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,7 @@ library
     , crypton
     , crypton-x509
     , cryptostore
+    , raw-strings-qq
     , case-insensitive
     , http-types
 

src/Fedi/Crypto.hs

@@ -13,8 +13,14 @@ 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'

src/Fedi/Signature/Check.hs

@@ -33,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" >>=
@@ -58,7 +58,7 @@ 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)
+    path = "/" <> T.encodeUtf8 (T.intercalate "/" $ Wai.pathInfo request)
       <> HTTP.renderQuery True (Wai.queryString request)
     requestTarget = method <> " " <> path
   let
@@ -115,8 +115,7 @@ 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{..}

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)