sign and verify and follow

app/DB.hs

@@ -1,11 +1,22 @@
+
+-- needed because of a compiler bug with OverloadedRecordDot:
+-- <https://play.haskell.org/saved/Xq0ZFrQi>
+{-# language FieldSelectors #-}
+
 -- | Database interaction
-module DB where
+module DB
+  ( module DB
+  , DB.Int64
+  )
+where
 
 import Data.Text qualified as T
 import Database.Sqlite.Easy qualified as DB
 import Fedi
 import GHC.Stack (HasCallStack)
 import Text.RawString.QQ
+import Control.Monad.IO.Class (liftIO)
+import Data.Typeable
 
 -----------------------
 
@@ -16,7 +27,8 @@ data DB
   { getNotes :: IO [Note]
   , getNote :: DB.Int64 -> IO (Maybe Note)
   , insertNote :: NoteEntry -> IO (DB.Int64, Note)
-  , insertFollower :: FollowerEntry -> IO DB.Int64
+  , insertFollower ::
+      forall a. Typeable a => FollowerEntry -> (DB.Int64 -> IO a) -> IO a
   , deleteFollower :: FollowerEntry -> IO DB.Int64
   , getFollowers :: IO [Follower]
   }
@@ -61,7 +73,9 @@ mkDB connstr details = do
       , insertNote =
           \note -> DB.withPool pool (insertNoteToDb (actorUrl details) note)
       , insertFollower =
-          \follower -> DB.withPool pool (insertFollowerToDb follower)
+          \follower handle -> DB.withPool pool $ DB.transaction do
+            id' <- insertFollowerToDb follower
+            liftIO $ handle id'
       , deleteFollower =
           \follower -> DB.withPool pool (deleteFollowerFromDb follower)
       , getFollowers =
@@ -233,8 +247,8 @@ deleteFollowerSQL :: FollowerEntry -> (DB.SQL, [DB.SQLData])
 deleteFollowerSQL follower =
   ( [r|
       DELETE FROM follower
-      WHERE followId = ? AND actor = ?
-      RETURNING followId
+      WHERE follow_id = ? AND actor = ?
+      RETURNING follow_id
     |]
   ,
     [ DB.SQLText follower.followId

app/Main.hs

@@ -4,7 +4,6 @@ import DB
 import Data.Aeson qualified as A
 import Data.Functor ((<&>))
 import Data.SecureMem (secureMemFromByteString)
-import Data.String (fromString)
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
 import Data.Text.IO qualified as T

app/Routes.hs

@@ -1,11 +1,9 @@
 module Routes where
 
-import Control.Monad.IO.Class (liftIO)
 import DB
 import Data.Aeson qualified as A
 import Data.Functor ((<&>))
 import Data.Maybe (maybeToList)
-import Data.String (fromString)
 import Fedi qualified as Fedi
 import Html
 import Lucid qualified as H
@@ -140,20 +138,26 @@ handleInbox db detailsFile activity = do
         Just id'' -> do
           if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
             then do
-              liftIO do
-                insertId <- db.insertFollower FollowerEntry
-                  { actorId = fromString actor.unwrap
-                  , followId = fromString id''.unwrap
-                  }
-                (result :: A.Value) <- Fedi.sendPost
-                  details
-                  (id''.unwrap <> "/inbox")
-                  ( Fedi.makeAccept
-                    follow
-                    (Fedi.actorUrl details <> "/accepts/follows/" <> show insertId)
+              let
+                followerEntry = ( FollowerEntry
+                    { actorId = fromString actor.unwrap
+                    , followId = fromString id''.unwrap
+                    }
                   )
-                print result
-                pure $ Fedi.jsonLD "{}"
+                callback =
+                  ( \(insertId :: DB.Int64) -> do
+                    (result :: A.Value) <- Fedi.sendPost
+                      details
+                      (actor.unwrap <> "/inbox")
+                      ( Fedi.makeAccept
+                        follow
+                        (Fedi.actorUrl details <> "/accepts/follows/" <> show insertId)
+                      )
+                    print result
+                    pure $ Fedi.jsonLD "{}"
+                  )
+              liftIO do
+                insertFollower db followerEntry callback
             else Twain.next
         Nothing ->
           Twain.next

fedi.cabal

@@ -61,6 +61,9 @@ library
     , crypton
     , crypton-x509
     , cryptostore
+    , raw-strings-qq
+    , case-insensitive
+    , http-types
 
   hs-source-dirs: src
   default-language: GHC2021

src/Fedi/Crypto.hs

@@ -13,13 +13,19 @@ import Data.ByteString.Base64 qualified as Base64
 import Data.Base64.Types qualified as Base64
 import Data.Text qualified as T
 
+-- import Debug.Trace
+
 verifyPub :: MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool
 verifyPub pubkeypem sig message = do
+  -- traceShowM ("pubkeypem", pubkeypem)
+  -- traceShowM ("sig", sig)
+  -- traceShowM ("mssage", message)
+
   pubkey <-
     case Crypto.readPubKeyFileFromMemory pubkeypem of
       [Crypto.PubKeyRSA pubkey'] -> pure pubkey'
       _ -> throw "failed to read pubkey pem"
-  pure $ Crypto.verify (Just Crypto.SHA256) pubkey message sig
+  pure $ Crypto.verify (Just Crypto.SHA256) pubkey message (decodeBase64 sig)
 
 sign :: FilePath -> ByteString -> IO Signed
 sign privatePemFile message = do

src/Fedi/Requests.hs

@@ -68,7 +68,6 @@ 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 <-

src/Fedi/Signature/Check.hs

@@ -1,4 +1,5 @@
 {-# language RecordWildCards #-}
+{-# language ViewPatterns #-}
 
 module Fedi.Signature.Check
   ( module Fedi.Signature.Types
@@ -15,12 +16,15 @@ import Fedi.Helpers
 import Web.Twain qualified as Twain
 import Data.Text qualified as T
 import Network.Wai qualified as Wai
+import Network.HTTP.Types.URI qualified as HTTP
 import Control.Monad.IO.Class (liftIO)
 import Text.ParserCombinators.ReadP qualified as P
 import Data.Text.Encoding qualified as T
+import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as BSL
 import Fedi.Crypto
 import Fedi.Signature.Types
+import Data.CaseInsensitive qualified as CI
 
 -- * Check
 
@@ -29,7 +33,7 @@ checkSignatureAndParseBody :: Twain.ResponderM AnyActivity
 checkSignatureAndParseBody = do
   -- get info
   request <- Twain.request
-  liftIO $ print ("headers", Twain.requestHeaders request)
+  -- liftIO $ print ("headers", Twain.requestHeaders request)
   body <- liftIO (Wai.strictRequestBody request)
   sigheader <- parseSignature =<< Twain.header "Signature"
   digest <- Twain.header "Digest" >>=
@@ -38,28 +42,62 @@ checkSignatureAndParseBody = do
   let personPkid = person.otype.publicKey.pkid
   let personPublicKey = pemToBS person.otype.publicKey.publicKeyPem
 
+  signatureString <-
+    makeSignatureString request sigheader.headers
+
   -- check
   liftIO $
-    checkSignature personPkid personPublicKey sigheader digest (BSL.toStrict body)
+    checkSignature personPkid personPublicKey sigheader signatureString digest (BSL.toStrict body)
 
   -- parse the body and return it
   parseJson body
 
+makeSignatureString
+  :: forall m. MonadThrow m => Wai.Request -> [T.Text] -> m ByteString
+makeSignatureString request (map (T.encodeUtf8 . T.toLower) -> headers) = do
+  let
+    requestHeaders = Wai.requestHeaders request
+    method = T.encodeUtf8 $ T.toLower $ T.decodeUtf8 $ Wai.requestMethod request
+    path = "/" <> T.encodeUtf8 (T.intercalate "/" $ Wai.pathInfo request)
+      <> HTTP.renderQuery True (Wai.queryString request)
+    requestTarget = method <> " " <> path
+  let
+    mylookup :: ByteString -> m ByteString
+    mylookup header
+      | header == "(request-target)" =
+        pure $ header <> ": " <> requestTarget
+      | header == "host" = do
+        let result = lookup (CI.mk header) requestHeaders
+        case result of
+          Nothing -> throw $ "Missing header '" <> show header <> "'."
+          Just value -> pure $ header <> ": "
+            <> if ":443" `BS.isSuffixOf` value
+              then BS.dropEnd (BS.length ":443") value
+              else value
+      | otherwise = do
+        let result = lookup (CI.mk header) requestHeaders
+        case result of
+          Nothing -> throw $ "Missing header '" <> show header <> "'."
+          Just value -> pure $ header <> ": " <> value
+
+  BS.intercalate "\n" <$> traverse mylookup headers
+
 checkSignature
   :: MonadThrow m
-  => Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> m ()
-checkSignature personPkid personPublicKey sigheader _digest body = do
+  => Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> ByteString -> m ()
+checkSignature personPkid personPublicKey sigheader signatureString digest body = do
   -- check
   unless (personPkid == sigheader.keyId) $
     throw "public key mismatch with signature."
 
-  pub <- verifyPub personPublicKey sigheader.signature body
+  pub <- verifyPub personPublicKey sigheader.signature signatureString
   unless pub $
     throw "signature verification failed."
 
-  -- dig <- verifyDigest personPublicKey digest body
-  -- unless dig $
-  --   throw "digest verification failed."
+  let
+    mydigest = "SHA-256=" <> encodeBase64 (makeDigest body)
+  unless (mydigest == digest) $
+    throw "digest verification failed."
 
   -- todo: check date
 
@@ -77,9 +115,9 @@ parseSignature minput = do
       keyId <- lookup' KeyId components
       headers <- T.split (==' ') . T.pack <$> lookup' Headers components
       signature <-
-        ( decodeBase64
-        . fromString
+        ( fromString
         ) <$> lookup' Signature components
+      P.eof
       pure SignatureHeader{..}
     component = P.choice
       [ do
@@ -95,8 +133,12 @@ parseSignature minput = do
         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)
+        _ <- P.string "algorithm="
+        alg <- P.between (P.char '\"') (P.char '\"') (P.string "rsa-sha256")
+        pure (Algorithm, alg)
+      -- , do
+      --   key <- P.munch1 (/= '=')
+      --   _ <- P.char '='
+      --   value <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
+      --   pure (Other key, value)
       ]

src/Fedi/Signature/Sign.hs

@@ -29,6 +29,8 @@ signSignature details host requestTarget body = do
     components = []
     signatureString = makeSignatureString host requestTarget date digest
 
+  -- BS.putStr $ signatureString <> "\n"
+
   signed <- sign details.privatePem signatureString
 
   let

src/Fedi/Types.hs

@@ -270,8 +270,8 @@ instance (A.FromJSON a) => A.FromJSON (TypeActivity a) where
     atype <- A.parseJSON object
     flip (A.withObject "TypeActivity") object \value -> do
       actor <- value A..: "actor"
-      target <- value A..: "target"
-      origin <- value A..: "origin"
+      target <- value A..:? "target"
+      origin <- value A..:? "origin"
       pure TypeActivity {..}
 
 -- type Announce = Object (TypeActivity TypeAnnounce)