diff --git a/app/DB.hs b/app/DB.hs index 497f00b..434a1bf 100644 --- a/app/DB.hs +++ b/app/DB.hs @@ -1,11 +1,22 @@ + +-- needed because of a compiler bug with OverloadedRecordDot: +-- +{-# 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 diff --git a/app/Main.hs b/app/Main.hs index 3e87c31..33e0c90 100644 --- a/app/Main.hs +++ b/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 diff --git a/app/Routes.hs b/app/Routes.hs index dae51b5..4d5d134 100644 --- a/app/Routes.hs +++ b/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 diff --git a/fedi.cabal b/fedi.cabal index d2f8fcc..8d6fb15 100644 --- a/fedi.cabal +++ b/fedi.cabal @@ -61,6 +61,7 @@ library , crypton , crypton-x509 , cryptostore + , raw-strings-qq , case-insensitive , http-types diff --git a/src/Fedi/Crypto.hs b/src/Fedi/Crypto.hs index bcd24b0..5c4e3ad 100644 --- a/src/Fedi/Crypto.hs +++ b/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' diff --git a/src/Fedi/Signature/Check.hs b/src/Fedi/Signature/Check.hs index ab829c2..5f3d491 100644 --- a/src/Fedi/Signature/Check.hs +++ b/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{..} diff --git a/src/Fedi/Signature/Sign.hs b/src/Fedi/Signature/Sign.hs index a6df4d0..9f0c663 100644 --- a/src/Fedi/Signature/Sign.hs +++ b/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 diff --git a/src/Fedi/Types.hs b/src/Fedi/Types.hs index 1646573..5357c41 100644 --- a/src/Fedi/Types.hs +++ b/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)