not yet working but progress

fedi.cabal

@@ -52,6 +52,7 @@ library
     , wai
     , exceptions
     , req
+    , modern-uri
     , base64
     , crypton
     , crypton-x509

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

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)
       ]