From 749da0081e700176e7f32391fbf30fcda9ed602c Mon Sep 17 00:00:00 2001
From: me <me@alloca.space>
Date: Tue, 17 Dec 2024 10:46:59 +0200
Subject: [PATCH] not yet working but progress
---
fedi.cabal | 1 +
src/Fedi/Requests.hs | 19 +++++++++++++++----
src/Fedi/Routes/Inbox.hs | 31 ++++++++++++++++++++-----------
3 files changed, 36 insertions(+), 15 deletions(-)
diff --git a/fedi.cabal b/fedi.cabal
index c907fc6..abc0b9b 100644
--- a/fedi.cabal
+++ b/fedi.cabal
@@ -52,6 +52,7 @@ library
, wai
, exceptions
, req
+ , modern-uri
, base64
, crypton
, crypton-x509
diff --git a/src/Fedi/Requests.hs b/src/Fedi/Requests.hs
index d8e38bf..320c21a 100644
--- a/src/Fedi/Requests.hs
+++ b/src/Fedi/Requests.hs
@@ -3,10 +3,12 @@
module Fedi.Requests where
import Data.Aeson qualified as A
+import Fedi.Helpers
import Fedi.UserDetails
import Fedi.Crypto
import Network.HTTP.Req qualified as Req
import Data.ByteString.Lazy qualified as BSL
+import Text.URI qualified as URI
sendPost
:: (A.FromJSON output, A.ToJSON input)
@@ -17,15 +19,19 @@ sendPost
sendPost details url payload = do
let encoded = BSL.toStrict $ A.encode payload
signed <- sign details encoded
+ uri <- URI.mkURI $ fromString url
+ (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri)
+ print ("url", url')
Req.runReq Req.defaultHttpConfig do
r <-
Req.req
Req.POST
- (Req.https $ fromString url)
+ url'
(Req.ReqBodyBs encoded)
Req.jsonResponse
- ( Req.header "ContentType" "application/activity+json"
+ ( scheme
+ <> Req.header "ContentType" "application/activity+json"
<> Req.header "Digest" signed.signedDigest
<> Req.header "Signature" signed.signedMessage
)
@@ -33,13 +39,18 @@ sendPost details url payload = do
sendGet :: (A.FromJSON a) => String -> IO a
sendGet url = do
+ uri <- URI.mkURI $ fromString url
+ (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri)
+ print ("url", url')
+
Req.runReq Req.defaultHttpConfig do
r <-
Req.req
Req.GET
- (Req.https $ fromString url)
+ url'
Req.NoReqBody
Req.jsonResponse
- ( Req.header "ContentType" "application/activity+json"
+ ( scheme
+ <> Req.header "ContentType" "application/activity+json"
)
pure $ Req.responseBody r
diff --git a/src/Fedi/Routes/Inbox.hs b/src/Fedi/Routes/Inbox.hs
index fe32574..2140c99 100644
--- a/src/Fedi/Routes/Inbox.hs
+++ b/src/Fedi/Routes/Inbox.hs
@@ -12,10 +12,10 @@ import Web.Twain.Types qualified as Twain
import Data.Text qualified as T
import Network.Wai qualified as Wai
import Control.Monad.IO.Class (liftIO)
-import Control.Monad.Catch (catch)
+import Control.Monad.Catch (catch, displayException, SomeException)
import Text.ParserCombinators.ReadP qualified as P
import Data.Text.Encoding qualified as T
-import Data.Text.Encoding.Base64 qualified as Base64
+import Data.ByteString.Base64 qualified as Base64
import Data.ByteString.Lazy qualified as BSL
import Fedi.Crypto
@@ -32,16 +32,18 @@ handleInbox handle = do
activity <- checkSignatureAndParseBody
response <- handle activity
Twain.send response
- handler `catch` \(Error e) -> do
- liftIO $ print e
- Twain.send $ Twain.status Twain.status500 $ Twain.text (T.pack e)
+ handler `catch` \(e :: SomeException) -> do
+ liftIO $ putStrLn (displayException e)
+ Twain.send $
+ Twain.status Twain.status500 $
+ Twain.text "Internal Server Error 500"
-- | Check the signature of the sender and parse the body of the request.
checkSignatureAndParseBody :: Twain.ResponderM AnyActivity
checkSignatureAndParseBody = do
-- get info
request <- Twain.request
- liftIO $ print $ Twain.requestHeaders request
+ liftIO $ print ("headers", Twain.requestHeaders request)
body <- liftIO (Wai.strictRequestBody request)
sigheader <- parseSignature =<< Twain.header "Signature"
digest <- Twain.header "Digest" >>=
@@ -82,20 +84,23 @@ data SignatureHeader
headers :: [T.Text]
, -- | Contains the signature
signature :: ByteString
+ , components :: [(Component, String)]
}
+ deriving Show
data Component
= KeyId
| Headers
| Signature
- deriving Eq
+ | Other String
+ deriving (Eq, Show)
parseSignature :: MonadThrow m => Maybe T.Text -> m SignatureHeader
parseSignature minput = do
input <- maybe (throw "no signature.") (pure . T.unpack) minput
case P.readP_to_S parser input of
[(sig, "")] -> pure sig
- _ -> throw "error parsing signature."
+ xs -> throw $ "error parsing signature: " <> show xs
where
lookup' a b =
maybe (fail "error parsing signature") pure $ lookup a b
@@ -104,9 +109,8 @@ parseSignature minput = do
keyId <- lookup' KeyId components
headers <- T.split (==' ') . T.pack <$> lookup' Headers components
signature <-
- ( T.encodeUtf8
- . Base64.decodeBase64Lenient
- . T.pack
+ ( Base64.decodeBase64Lenient
+ . fromString
) <$> lookup' Signature components
pure SignatureHeader{..}
component = P.choice
@@ -122,4 +126,9 @@ parseSignature minput = do
_ <- P.string "signature="
url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
pure (Signature, url)
+ , do
+ key <- P.munch1 (/= '=')
+ _ <- P.char '='
+ value <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
+ pure (Other key, value)
]