format

Dockerfile

@@ -0,0 +1,14 @@
+FROM hasufell/alpine-haskell:3.16 AS build
+
+RUN cabal update
+
+COPY . /app/
+
+WORKDIR /app
+
+RUN cabal update
+RUN cabal build exe:fedi --enable-executable-static
+RUN strip `cabal list-bin fedi`
+
+FROM scratch AS artifact
+COPY --from=build /app/dist-newstyle/build/x86_64-linux/*/*/x/*/build/*/fedi .

Makefile

@@ -0,0 +1,26 @@
+.PHONY: format
+format:
+	find ./src -type f -name "*.hs" -exec sh -c 'fourmolu -i {}' \;
+	find ./app -type f -name "*.hs" -exec sh -c 'fourmolu -i {}' \;
+	# find ./test -type f -name "*.hs" -exec sh -c 'fourmolu -i {}' \;
+
+.PHONY: clean
+clean:
+	rm -rf ./newdist ./out ./dist-newstyle
+
+.PHONY: build
+build: fedi.cabal cabal.project
+	cabal build all --enable-tests --enable-benchmarks
+
+.PHONY: serve
+serve:
+	FEDI_DETAILS="test/public/details.json" cabal run fedi -- serve
+
+.PHONY: insert
+insert:
+	FEDI_DETAILS="test/public/details.json" cabal run fedi -- insert note.html
+
+.PHONY: docker
+docker: fedi.cabal cabal.project clean
+	DOCKER_BUILDKIT=1 docker build -o ./out/ .
+	file out/fedi

app/DB.hs

@@ -1,22 +1,20 @@
-
 -- needed because of a compiler bug with OverloadedRecordDot:
 -- <https://play.haskell.org/saved/Xq0ZFrQi>
-{-# language FieldSelectors #-}
+{-# LANGUAGE FieldSelectors #-}
 
 -- | Database interaction
-module DB
-  ( module DB
-  , DB.Int64
-  )
-where
+module DB (
+  module DB,
+  DB.Int64,
+) where
 
+import Control.Monad.IO.Class (liftIO)
 import Data.Text qualified as T
+import Data.Typeable
 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
 
 -----------------------
 
@@ -27,9 +25,14 @@ data DB
   { getNotes :: IO [Note]
   , getNote :: DB.Int64 -> IO (Maybe Note)
   , insertNote :: NoteEntry -> IO (DB.Int64, Note)
-  , insertFollower ::
-      forall a. Typeable a => FollowerEntry -> (DB.Int64 -> IO a) -> IO a
-  , deleteFollower :: FollowerEntry -> IO (Maybe DB.Int64)
+  , insertFollower
+      :: forall a
+       . (Typeable a) => FollowerEntry -> (DB.Int64 -> IO a) -> IO a
+  -- ^ We use a callback so we can revert if the operation fails.
+  , deleteFollower
+      :: forall a
+       . (Typeable a) => FollowerEntry -> (Maybe DB.Int64 -> IO a) -> IO a
+  -- ^ We use a callback so we can revert if the operation fails.
   , getFollowers :: IO [Follower]
   }
 
@@ -42,14 +45,14 @@ data NoteEntry
   , name :: Maybe String
   , url :: Maybe Url
   }
-  deriving Show
+  deriving (Show)
 
 data FollowerEntry
   = FollowerEntry
   { followId :: T.Text
   , actorId :: T.Text
   }
-  deriving Show
+  deriving (Show)
 
 data Follower
   = Follower
@@ -57,7 +60,7 @@ data Follower
   , followId :: T.Text
   , actorId :: T.Text
   }
-  deriving Show
+  deriving (Show)
 
 -----------------------
 
@@ -80,7 +83,9 @@ mkDB connstr details = do
             id' <- insertFollowerToDb follower
             liftIO $ handle id'
       , deleteFollower =
-          \follower -> DB.withPool pool (deleteFollowerFromDb follower)
+          \follower handle -> DB.withPool pool $ DB.transaction do
+            id' <- deleteFollowerFromDb follower
+            liftIO $ handle id'
       , getFollowers =
           DB.withPool pool (getFollowersFromDb $ actorUrl details)
       }
@@ -270,6 +275,7 @@ getFollowersSQL url =
     |]
   , [DB.SQLText $ T.pack url]
   )
+
 -----------------------
 
 -- ** Decode row
@@ -287,27 +293,29 @@ decodeNoteRow = \case
     ] ->
       let
         emptyNote = emptyUserNote $ T.unpack actor
-      in (noteid,
-        emptyNote
-          { id = Just $ ObjectId $ T.unpack noteidurl
-          , published = Just $ read (T.unpack published)
-          , attributedTo = Just $ LLink $ Link $ T.unpack actor
-          , inReplyTo = LLink . Link <$> inReplyTo
-          , content = Just content
-          , url = url
-          , name = StringName <$> name
-          , otype =
-              emptyNote.otype
-                { likes =
-                    emptyNote.otype.likes
-                      { id = Just $ ObjectId $ T.unpack noteidurl <> "/likes"
-                      }
-                , shares =
-                    emptyNote.otype.shares
-                      { id = Just $ ObjectId $ T.unpack noteidurl <> "/shares"
-                      }
-                }
-          })
+      in
+        ( noteid
+        , emptyNote
+            { id = Just $ ObjectId $ T.unpack noteidurl
+            , published = Just $ read (T.unpack published)
+            , attributedTo = Just $ LLink $ Link $ T.unpack actor
+            , inReplyTo = LLink . Link <$> inReplyTo
+            , content = Just content
+            , url = url
+            , name = StringName <$> name
+            , otype =
+                emptyNote.otype
+                  { likes =
+                      emptyNote.otype.likes
+                        { id = Just $ ObjectId $ T.unpack noteidurl <> "/likes"
+                        }
+                  , shares =
+                      emptyNote.otype.shares
+                        { id = Just $ ObjectId $ T.unpack noteidurl <> "/shares"
+                        }
+                  }
+            }
+        )
   row -> error $ "Couldn't decode row as Note: " <> show row
 
 decodeIntRow :: [DB.SQLData] -> DB.Int64
@@ -321,11 +329,11 @@ decodeFollowerRow = \case
     , DB.SQLText follower_id
     , DB.SQLText actor
     ] ->
-    Follower
-      { myid = myid
-      , followId = follower_id
-      , actorId = actor
-      }
+      Follower
+        { myid = myid
+        , followId = follower_id
+        , actorId = actor
+        }
   row -> error $ "Couldn't decode row as Follower: " <> show row
 
 nullableString :: DB.SQLData -> Maybe (Maybe String)

app/Html.hs

@@ -58,7 +58,8 @@ notesHtml notes = do
 -- | A single post as HTML.
 noteHtml :: Fedi.Note -> Html
 noteHtml note = do
-  let noteid = T.pack (maybe "" (\i -> i.unwrap) note.id)
+  let
+    noteid = T.pack (maybe "" (\i -> i.unwrap) note.id)
   H.div_ [H.class_ "note"] $ do
     H.div_ [H.class_ "note-header"] $ do
       case note.name of
@@ -133,7 +134,8 @@ newNoteHtml details = do
     )
 
 localDateJs :: String
-localDateJs = [r|
+localDateJs =
+  [r|
 let collection = document.querySelectorAll(".note-date-published");
 
 for (let i = 0; i < collection.length; i++) {

app/Main.hs

@@ -1,5 +1,6 @@
 module Main where
 
+import Control.Logger.Simple qualified as Log
 import DB
 import Data.Aeson qualified as A
 import Data.Functor ((<&>))
@@ -16,7 +17,6 @@ import Network.Wai.Middleware.Routed qualified as Wai
 import Routes
 import System.Environment (getArgs, lookupEnv)
 import Web.Twain qualified as Twain
-import Control.Logger.Simple qualified as Log
 
 data Command
   = Serve
@@ -120,9 +120,10 @@ runServer port authMiddleware app = do
   auth <- Wai.routedMiddleware matchAdmin <$> pure authMiddleware
   run port $
     ( Logger.logStdoutDev
-    . Limit.requestSizeLimitMiddleware Limit.defaultRequestSizeLimitSettings
-    . auth
-    ) app
+        . Limit.requestSizeLimitMiddleware Limit.defaultRequestSizeLimitSettings
+        . auth
+    )
+      app
 
 matchAdmin :: [T.Text] -> Bool
 matchAdmin = any (== "admin")

app/Routes.hs

@@ -1,17 +1,18 @@
 module Routes where
 
+import Control.Concurrent.Async qualified as Async
+import Control.Logger.Simple qualified as Log
 import DB
 import Data.Aeson qualified as A
 import Data.Functor ((<&>))
 import Data.Maybe (maybeToList)
+import Data.Text qualified as T
 import Fedi qualified as Fedi
 import Html
 import Lucid qualified as H
+import Routes.Inbox.Follow
 import System.IO.Unsafe (unsafePerformIO)
 import Web.Twain qualified as Twain
-import Data.Text qualified as T
-import Control.Concurrent.Async qualified as Async
-import Control.Logger.Simple qualified as Log
 
 routes :: DB -> FilePath -> [Twain.Middleware]
 routes db detailsFile =
@@ -46,12 +47,10 @@ routes db detailsFile =
       notes <- map noteToCreate <$> liftIO db.getNotes
 
       Fedi.handleCreateNote details notes
-
   , -- Match inbox
     Twain.post (Fedi.matchInbox $ unsafePerformIO $ fetchUserDetails detailsFile) do
       Log.logTrace "Inbox"
       Fedi.handleInbox (handleInbox db detailsFile)
-
   , -- Match Create object
     Twain.get (Fedi.matchCreateNote $ unsafePerformIO $ fetchUserDetails detailsFile) do
       details <- liftIO $ fetchUserDetails detailsFile
@@ -73,12 +72,12 @@ routes db detailsFile =
             Nothing -> Twain.next
             Just thenote ->
               Twain.send $ Twain.html $ H.renderBS $ actorPage details [thenote]
-
   , -- Followers
     Twain.get (Fedi.matchFollowers $ unsafePerformIO $ fetchUserDetails detailsFile) do
       details <- liftIO $ fetchUserDetails detailsFile
-      followers <- liftIO db.getFollowers
-        <&> map (\follower -> T.unpack follower.actorId)
+      followers <-
+        liftIO db.getFollowers
+          <&> map (\follower -> T.unpack follower.actorId)
       Fedi.handleFollowers details followers
   , -- Following
     Twain.get (Fedi.matchFollowing $ unsafePerformIO $ fetchUserDetails detailsFile) do
@@ -88,8 +87,8 @@ routes db detailsFile =
     Twain.get Fedi.matchWebfinger do
       details <- liftIO $ fetchUserDetails detailsFile
       Fedi.handleWebfinger details
-  --------------------------------------------------------------------------------------------
-  , -- Admin page
+  , --------------------------------------------------------------------------------------------
+    -- Admin page
     Twain.get (fromString $ "/" <> (unsafePerformIO $ fetchUserDetails detailsFile).username <> "/admin") do
       details <- liftIO $ fetchUserDetails detailsFile
       notes <- liftIO db.getNotes
@@ -130,67 +129,22 @@ noteToCreate note = Fedi.makeCreateNote note
 handleInbox :: DB -> FilePath -> Fedi.AnyActivity -> Twain.ResponderM Twain.Response
 handleInbox db detailsFile activity = do
   details <- liftIO $ fetchUserDetails detailsFile
-  Log.logDebug (Fedi.pJson activity)
+  Log.logDebug $ "Inbox request: " <> Fedi.pJson activity
   case activity of
-    Fedi.ActivityFollow follow -> do
-      let
-        id' = follow.id
-        actor = follow.otype.actor
-        object = follow.otype.atype.object
-      case id' of
-        Just id'' -> do
-          if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
-            then do
-              let
-                followerEntry = ( FollowerEntry
-                    { actorId = fromString actor.unwrap
-                    , followId = fromString id''.unwrap
-                    }
-                  )
-                callback =
-                  ( \(insertId :: DB.Int64) -> do
-                    result <- Fedi.sendPost
-                      details
-                      (actor.unwrap <> "/inbox")
-                      ( Fedi.makeAccept
-                        follow
-                        (Fedi.actorUrl details <> "/accepts/follows/" <> show insertId)
-                      )
-                    Log.logDebug (Fedi.pShow result)
-                    pure $ Twain.text ""
-                  )
-              liftIO do
-                insertFollower db followerEntry callback
-                  <* Log.logInfo ("New follower: " <> Fedi.pShow followerEntry)
-            else Twain.next
-        Nothing ->
-          Twain.next
+    Fedi.ActivityFollow follow ->
+      handleInboxFollow details db activity follow
     Fedi.ActivityUndo
       ( Fedi.Object
-        { otype = Fedi.TypeActivity
-          { atype = Fedi.TypeUndo
-            { object = Fedi.ActivityFollow follow
-            }
-          }
-        }) -> do
-      let
-        id' = follow.id
-        actor = follow.otype.actor
-        object = follow.otype.atype.object
-      case id' of
-        Just id'' -> do
-          if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
-            then do
-              liftIO do
-                deletedId <- db.deleteFollower FollowerEntry
-                  { actorId = fromString actor.unwrap
-                  , followId = fromString id''.unwrap
+          { otype =
+            Fedi.TypeActivity
+              { atype =
+                Fedi.TypeUndo
+                  { object = Fedi.ActivityFollow follow
                   }
-                Log.logInfo ("deleted follower: " <> Fedi.pShow deletedId)
-                pure $ Twain.text ""
-            else Twain.next
-        Nothing ->
-          Twain.next
+              }
+          }
+        ) ->
+        handleInboxUnfollow details db activity follow
     _ -> do
       Log.logError $ "Unsupported activity: " <> Fedi.pShow activity
       Twain.next

app/Routes/Inbox/Accept.hs

@@ -0,0 +1,38 @@
+module Routes.Inbox.Accept where
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async qualified as Async
+import Control.Logger.Simple qualified as Log
+import DB
+import Fedi qualified as Fedi
+
+acceptRequest
+  :: Fedi.UserDetails
+  -> Fedi.Link
+  -> Fedi.AnyActivity
+  -> ((Int64 -> IO ()) -> IO a)
+  -> IO ()
+acceptRequest details actor activity operation = do
+  _ <- liftIO $ Async.async do
+    Log.logDebug "Waiting 10 seconds before accepting follow..."
+    threadDelay 10000000 -- 10 seconds
+    let
+      callback =
+        ( \(opid :: DB.Int64) -> do
+            result <-
+              Fedi.sendPost
+                details
+                (actor.unwrap <> "/inbox")
+                ( Fedi.makeAccept
+                    Fedi.MkAccept
+                      { Fedi.acceptId =
+                          Fedi.actorUrl details <> "/accepts/requests/" <> show opid
+                      , Fedi.acceptingActorUrl = Fedi.Link $ Fedi.actorUrl details
+                      , Fedi.acceptedActivity = activity
+                      }
+                )
+            Log.logDebug (Fedi.pShow result)
+        )
+    do
+      operation callback
+  pure ()

app/Routes/Inbox/Follow.hs

@@ -0,0 +1,80 @@
+module Routes.Inbox.Follow where
+
+import Control.Logger.Simple qualified as Log
+import DB
+import Fedi qualified as Fedi
+import Routes.Inbox.Accept
+import Web.Twain qualified as Twain
+
+handleInboxFollow
+  :: Fedi.UserDetails
+  -> DB
+  -> Fedi.AnyActivity
+  -> Fedi.Follow
+  -> Twain.ResponderM Twain.Response
+handleInboxFollow details db activity follow = do
+  let
+    id' = follow.id
+    actor = follow.otype.actor
+    object = follow.otype.atype.object
+  case id' of
+    Just id'' -> do
+      if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
+        then do
+          let
+            followerEntry =
+              ( FollowerEntry
+                  { actorId = fromString actor.unwrap
+                  , followId = fromString id''.unwrap
+                  }
+              )
+            operation sendAccept = do
+              insertFollower db followerEntry sendAccept
+                <* Log.logInfo ("New follower: " <> Fedi.pShow followerEntry)
+
+          liftIO $ acceptRequest details actor activity operation
+
+          pure $ Twain.text ""
+        else Twain.next
+    Nothing ->
+      Twain.next
+
+handleInboxUnfollow
+  :: Fedi.UserDetails
+  -> DB
+  -> Fedi.AnyActivity
+  -> Fedi.Follow
+  -> Twain.ResponderM Twain.Response
+handleInboxUnfollow details db activity follow = do
+  let
+    id' = follow.id
+    actor = follow.otype.actor
+    object = follow.otype.atype.object
+  case id' of
+    Just id'' -> do
+      if object == Fedi.LLink (Fedi.Link $ Fedi.actorUrl details)
+        then do
+          let
+            followerEntry =
+              ( FollowerEntry
+                  { actorId = fromString actor.unwrap
+                  , followId = fromString id''.unwrap
+                  }
+              )
+            operation sendAccept = do
+              deleteFollower
+                db
+                followerEntry
+                ( \deletedId' -> do
+                    let
+                      deletedId = Fedi.fromMaybe 0 deletedId'
+                    sendAccept deletedId
+                      <* Log.logInfo ("Deleted follower: " <> Fedi.pShow deletedId)
+                )
+
+          liftIO $ acceptRequest details actor activity operation
+
+          pure $ Twain.text ""
+        else Twain.next
+    Nothing ->
+      Twain.next

fedi.cabal

@@ -91,6 +91,8 @@ executable fedi
     Html
     Css
     Routes
+    Routes.Inbox.Follow
+    Routes.Inbox.Accept
   -- other-extensions:
   build-depends:
       aeson

src/Fedi.hs

@@ -2,9 +2,9 @@ module Fedi (module Export) where
 
 import Fedi.Crypto as Export
 import Fedi.Helpers as Export
+import Fedi.Requests as Export
 import Fedi.Routes as Export
 import Fedi.Types as Export
 import Fedi.Types.Helpers as Export
 import Fedi.UserDetails as Export
 import Fedi.Webfinger as Export
-import Fedi.Requests as Export

src/Fedi/Crypto.hs

@@ -1,27 +1,29 @@
-{-# language RecordWildCards #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Fedi.Crypto where
 
-import Crypto.Hash qualified as Crypto
-import Data.ByteArray qualified as BA
-import Crypto.PubKey.RSA.PKCS15 qualified as Crypto
-import Crypto.Store.X509 qualified as Crypto
-import Crypto.Store.PKCS8 qualified as Crypto
-import Data.X509 qualified as Crypto
-import Fedi.Helpers
-import Data.ByteString.Base64 qualified as Base64
-import Data.Base64.Types qualified as Base64
-import Data.Text qualified as T
 import Control.Logger.Simple qualified as Log
 import Control.Monad.IO.Class
+import Crypto.Hash qualified as Crypto
+import Crypto.PubKey.RSA.PKCS15 qualified as Crypto
+import Crypto.Store.PKCS8 qualified as Crypto
+import Crypto.Store.X509 qualified as Crypto
+import Data.Base64.Types qualified as Base64
+import Data.ByteArray qualified as BA
+import Data.ByteString.Base64 qualified as Base64
+import Data.Text qualified as T
+import Data.X509 qualified as Crypto
+import Fedi.Helpers
 
-verifyPub :: MonadIO m => MonadThrow m => ByteString -> ByteString -> ByteString -> m Bool
+verifyPub :: (MonadIO m) => (MonadThrow m) => ByteString -> ByteString -> ByteString -> m Bool
 verifyPub pubkeypem sig message = do
-  Log.logDebug $ "Verifying signature: " <> pShow
-    [ ("pubkeypem", pubkeypem)
-    , ("sig", sig)
-    , ("message", message)
-    ]
+  Log.logDebug $
+    "Verifying signature: "
+      <> pShow
+        [ ("pubkeypem", pubkeypem)
+        , ("sig", sig)
+        , ("message", message)
+        ]
 
   pubkey <-
     case Crypto.readPubKeyFileFromMemory pubkeypem of
@@ -43,13 +45,13 @@ sign privatePemFile message = do
       & either (throw . show) pure
 
   -- return
-  pure Signed{..}
+  pure Signed {..}
 
 newtype Signed
   = Signed
-    { signedMessage :: ByteString
-    }
-  deriving Show
+  { signedMessage :: ByteString
+  }
+  deriving (Show)
 
 ppSigned :: Signed -> String
 ppSigned signed =
@@ -70,4 +72,4 @@ decodeBase64 = Base64.decodeBase64Lenient
 
 makeDigest :: ByteString -> ByteString
 makeDigest message =
-   BA.convert (Crypto.hash message :: Crypto.Digest Crypto.SHA256)
+  BA.convert (Crypto.hash message :: Crypto.Digest Crypto.SHA256)

src/Fedi/Helpers.hs

@@ -1,40 +1,39 @@
-module Fedi.Helpers
-  ( module Export
-  , module Fedi.Helpers
-  )
-where
+module Fedi.Helpers (
+  module Export,
+  module Fedi.Helpers,
+) where
 
-import Fedi.UserDetails
+import Control.Monad as Export
+import Control.Monad.Catch as Export (Exception, MonadThrow, throwM)
+import Data.Aeson qualified as A
+import Data.Aeson.Encode.Pretty qualified as AP
+import Data.ByteString as Export (ByteString)
 import Data.Foldable as Export
+import Data.Function as Export
+import Data.Functor as Export
 import Data.Maybe as Export (fromMaybe, listToMaybe, maybeToList)
 import Data.String as Export (fromString)
 import Data.Text as Export (Text)
-import Data.ByteString as Export (ByteString)
-import Data.Time as Export (UTCTime)
-import Data.Traversable as Export
-import GHC.Generics as Export (Generic)
-import Control.Monad as Export
-import Data.Functor as Export
-import Data.Function as Export
-import Control.Monad.Catch as Export (throwM, Exception, MonadThrow)
-import Text.Pretty.Simple qualified as PS
 import Data.Text.Lazy qualified as TL
 import Data.Text.Lazy.Encoding qualified as TL
-import Data.Aeson qualified as A
-import Data.Aeson.Encode.Pretty qualified as AP
+import Data.Time as Export (UTCTime)
+import Data.Traversable as Export
+import Fedi.UserDetails
+import GHC.Generics as Export (Generic)
+import Text.Pretty.Simple qualified as PS
 
 data Error
   = Error String
   deriving (Show, Exception)
 
-throw :: MonadThrow m => String -> m a
+throw :: (MonadThrow m) => String -> m a
 throw = throwM . Error
 
-pShow :: Show a => a -> Text
+pShow :: (Show a) => a -> Text
 pShow = TL.toStrict . PS.pShow
 
-pJson :: A.ToJSON a => a -> Text
+pJson :: (A.ToJSON a) => a -> Text
 pJson =
   TL.toStrict
     . TL.decodeUtf8
-    . AP.encodePretty' AP.defConfig { AP.confIndent = AP.Spaces 2 }
+    . AP.encodePretty' AP.defConfig {AP.confIndent = AP.Spaces 2}

src/Fedi/Requests.hs

@@ -1,33 +1,34 @@
-{-# language DataKinds #-}
+{-# LANGUAGE DataKinds #-}
 
 module Fedi.Requests where
 
-import Data.List (intercalate)
-import Data.Aeson qualified as A
-import Fedi.Helpers
-import Fedi.UserDetails
-import Fedi.Signature.Sign
-import Network.HTTP.Req qualified as Req
-import Data.ByteString.Lazy qualified as BSL
-import Text.URI qualified as URI
-import Data.Text qualified as T
 import Control.Logger.Simple qualified as Log
+import Data.Aeson qualified as A
+import Data.ByteString.Lazy qualified as BSL
+import Data.List (intercalate)
+import Data.Text qualified as T
+import Fedi.Helpers
+import Fedi.Signature.Sign
+import Fedi.UserDetails
+import Network.HTTP.Req qualified as Req
+import Text.URI qualified as URI
 
 sendPost
-  :: A.ToJSON input
+  :: (A.ToJSON input)
   => UserDetails
   -> String
   -> input
   -> IO ByteString
 sendPost details url payload = do
   uri <- URI.mkURI $ fromString url
-  Log.logDebug "To: " <> fromString url
-  Log.logDebug "Sending: " <> pJson payload
+  Log.logDebug $ "Post To: " <> fromString url
+  Log.logDebug $ "Post Sending: " <> pJson payload
 
-  let encoded = BSL.toStrict $ A.encode payload
+  let
+    encoded = BSL.toStrict $ A.encode payload
   httpSignature <- makeHttpSignature details uri encoded
-  Log.logDebug $ "http signature: " <> pShow httpSignature
-  Log.logDebug $ "http signature headers: " <> pShow (makeSigHeaders httpSignature)
+  Log.logDebug $ "Post http signature: " <> pShow httpSignature
+  Log.logDebug $ "Post http signature headers: " <> pShow (makeSigHeaders httpSignature)
   (url', scheme) <- maybe (throw "couldn't parse uri") pure (Req.useHttpsURI uri)
   Req.runReq Req.defaultHttpConfig do
     response <-
@@ -37,13 +38,13 @@ sendPost details url payload = do
         (Req.ReqBodyBs encoded)
         Req.bsResponse
         ( scheme
-          <> sigHeaders httpSignature
+            <> sigHeaders httpSignature
         )
-        (\request -> do
-          Log.logDebug $ "Sending POST request: " <> pShow request
-          pure request
+        ( \request -> do
+            Log.logDebug $ "Sending POST request: " <> pShow request
+            pure request
         )
-    Log.logInfo $ "Response: " <> pShow response
+    Log.logInfo $ "Post Response: " <> pShow response
     pure $ Req.responseBody response
 
 makeHttpSignature :: UserDetails -> URI.URI -> ByteString -> IO HttpSignature
@@ -60,7 +61,6 @@ makeHttpSignature details uri encoded = do
       Nothing -> "/"
   signSignature details host ("post " <> path) encoded
 
-
 sigHeaders :: HttpSignature -> Req.Option scheme
 sigHeaders =
   foldMap (uncurry Req.header) . makeSigHeaders
@@ -75,23 +75,24 @@ makeSigHeaders httpSignature =
   , ("Signature", toSignature httpSignature.signatureHeader)
   ]
 
-sendGet :: (A.FromJSON a) => String -> IO a
+sendGet :: (Show a, 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)
 
   Req.runReq Req.defaultHttpConfig do
-    r <-
+    response <-
       Req.reqCb
         Req.GET
         url'
         Req.NoReqBody
         Req.jsonResponse
         ( scheme
-          <> Req.header "ContentType" "application/activity+json"
+            <> Req.header "ContentType" "application/activity+json"
         )
-        (\request -> do
-          Log.logDebug $ "Sending GET request: " <> pShow request
-          pure request
+        ( \request -> do
+            Log.logDebug $ "Sending GET request: " <> pShow request
+            pure request
         )
-    pure $ Req.responseBody r
+    Log.logInfo $ "Get Response: " <> pShow response
+    pure $ Req.responseBody response

src/Fedi/Routes.hs

@@ -1,19 +1,17 @@
-module Fedi.Routes
-  ( module Fedi.Routes
-  , module Export
-  )
-where
+module Fedi.Routes (
+  module Fedi.Routes,
+  module Export,
+) where
 
+import Fedi.Routes.Follow as Export
+import Fedi.Routes.Helpers as Export
+import Fedi.Routes.Inbox as Export
+import Fedi.Routes.Notes as Export
+import Fedi.Routes.Outbox as Export
+import Fedi.Routes.User as Export
 import Fedi.UserDetails
 import Web.Twain qualified as Twain
 
-import Fedi.Routes.Helpers as Export
-import Fedi.Routes.User as Export
-import Fedi.Routes.Inbox as Export
-import Fedi.Routes.Outbox as Export
-import Fedi.Routes.Notes as Export
-import Fedi.Routes.Follow as Export
-
 -- * Routes
 
 routes :: UserDetails -> [Twain.Middleware]

src/Fedi/Routes/Follow.hs

@@ -2,10 +2,10 @@ module Fedi.Routes.Follow where
 
 import Data.Aeson qualified as A
 import Fedi.Helpers
+import Fedi.Routes.Helpers
 import Fedi.Types
 import Fedi.Types.Helpers
 import Fedi.UserDetails
-import Fedi.Routes.Helpers
 import Web.Twain qualified as Twain
 import Web.Twain.Types qualified as Twain
 
@@ -79,7 +79,7 @@ handleFollowing details = do
     collection :: Collection ()
     collection =
       emptyUnorderedCollection
-      { id = Just $ ObjectId $ actorUrl details <> "/following"
-      , summary = Just $ fromString $ details.username <> " is following"
-      }
+        { id = Just $ ObjectId $ actorUrl details <> "/following"
+        , summary = Just $ fromString $ details.username <> " is following"
+        }
   Twain.send $ jsonLD (A.encode collection)

src/Fedi/Routes/Helpers.hs

@@ -1,10 +1,10 @@
 module Fedi.Routes.Helpers where
 
+import Control.Monad.Catch (throwM)
 import Data.Aeson qualified as A
 import Data.ByteString qualified as BS
 import Data.ByteString.Lazy qualified as BSL
 import Web.Twain qualified as Twain
-import Control.Monad.Catch (throwM)
 
 jsonLD :: BSL.ByteString -> Twain.Response
 jsonLD =

src/Fedi/Routes/Inbox.hs

@@ -1,14 +1,14 @@
 module Fedi.Routes.Inbox where
 
-import Prelude hiding (error)
-import Fedi.Types
+import Control.Logger.Simple qualified as Log
+import Control.Monad.Catch (SomeException, catch, displayException)
 import Fedi.Helpers
+import Fedi.Signature.Check
+import Fedi.Types
 import Fedi.UserDetails
 import Web.Twain qualified as Twain
 import Web.Twain.Types qualified as Twain
-import Control.Monad.Catch (catch, displayException, SomeException)
-import Fedi.Signature.Check
-import Control.Logger.Simple qualified as Log
+import Prelude hiding (error)
 
 -- * Inbox
 

src/Fedi/Routes/Notes.hs

@@ -1,9 +1,9 @@
 module Fedi.Routes.Notes where
 
 import Data.Aeson qualified as A
+import Fedi.Routes.Helpers
 import Fedi.Types
 import Fedi.UserDetails
-import Fedi.Routes.Helpers
 import Web.Twain qualified as Twain
 import Web.Twain.Types qualified as Twain
 

src/Fedi/Routes/Outbox.hs

@@ -2,10 +2,10 @@ module Fedi.Routes.Outbox where
 
 import Data.Aeson qualified as A
 import Fedi.Helpers
+import Fedi.Routes.Helpers
 import Fedi.Types
 import Fedi.Types.Helpers
 import Fedi.UserDetails
-import Fedi.Routes.Helpers
 import Web.Twain qualified as Twain
 import Web.Twain.Types qualified as Twain
 

src/Fedi/Routes/User.hs

@@ -2,10 +2,10 @@ module Fedi.Routes.User where
 
 import Data.Aeson qualified as A
 import Fedi.Helpers
+import Fedi.Routes.Helpers
+import Fedi.Types.Helpers
 import Fedi.UserDetails
 import Fedi.Webfinger
-import Fedi.Types.Helpers
-import Fedi.Routes.Helpers
 import Web.Twain qualified as Twain
 import Web.Twain.Types qualified as Twain
 

src/Fedi/Signature/Check.hs

@@ -1,30 +1,29 @@
-{-# language RecordWildCards #-}
-{-# language ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
 
-module Fedi.Signature.Check
-  ( module Fedi.Signature.Types
-  , module Fedi.Signature.Check
-  )
-where
+module Fedi.Signature.Check (
+  module Fedi.Signature.Types,
+  module Fedi.Signature.Check,
+) where
 
-import Prelude hiding (error)
-import Fedi.Types
-import Fedi.UserDetails
-import Fedi.Requests
-import Fedi.Routes.Helpers
-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 Text.ParserCombinators.ReadP qualified as P
-import Data.Text.Encoding qualified as T
+import Control.Monad.IO.Class
 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
-import Control.Monad.IO.Class
+import Data.Text qualified as T
+import Data.Text.Encoding qualified as T
+import Fedi.Crypto
+import Fedi.Helpers
+import Fedi.Requests
+import Fedi.Routes.Helpers
+import Fedi.Signature.Types
+import Fedi.Types
+import Fedi.UserDetails
+import Network.HTTP.Types.URI qualified as HTTP
+import Network.Wai qualified as Wai
+import Text.ParserCombinators.ReadP qualified as P
+import Web.Twain qualified as Twain
+import Prelude hiding (error)
 
 -- * Check
 
@@ -36,11 +35,14 @@ checkSignatureAndParseBody = do
   -- liftIO $ print ("headers", Twain.requestHeaders request)
   body <- liftIO (Wai.strictRequestBody request)
   sigheader <- parseSignature =<< Twain.header "Signature"
-  digest <- Twain.header "Digest" >>=
-    maybe (throw "missing header Digest") (pure . T.encodeUtf8)
+  digest <-
+    Twain.header "Digest"
+      >>= maybe (throw "missing header Digest") (pure . T.encodeUtf8)
   (person :: Person) <- liftIO $ sendGet sigheader.keyId
-  let personPkid = person.otype.publicKey.pkid
-  let personPublicKey = pemToBS person.otype.publicKey.publicKeyPem
+  let
+    personPkid = person.otype.publicKey.pkid
+  let
+    personPublicKey = pemToBS person.otype.publicKey.publicKeyPem
 
   signatureString <-
     makeSignatureString request sigheader.headers
@@ -53,37 +55,45 @@ checkSignatureAndParseBody = do
   parseJson body
 
 makeSignatureString
-  :: forall m. MonadThrow m => Wai.Request -> [T.Text] -> m ByteString
+  :: 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)
+    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
+          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
+          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
+          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
-  :: MonadIO m => MonadThrow m
+  :: (MonadIO m)
+  => (MonadThrow m)
   => Url -> ByteString -> SignatureHeader -> ByteString -> ByteString -> ByteString -> m ()
 checkSignature personPkid personPublicKey sigheader signatureString digest body = do
   -- check
@@ -99,9 +109,9 @@ checkSignature personPkid personPublicKey sigheader signatureString digest body
   unless (mydigest == digest) $
     throw "digest verification failed."
 
-  -- todo: check date
+-- todo: check date
 
-parseSignature :: MonadThrow m => Maybe T.Text -> m SignatureHeader
+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
@@ -113,32 +123,33 @@ parseSignature minput = do
     parser = do
       components <- component `P.sepBy` P.char ','
       keyId <- lookup' KeyId components
-      headers <- T.split (==' ') . T.pack <$> lookup' Headers components
+      headers <- T.split (== ' ') . T.pack <$> lookup' Headers components
       signature <-
-        ( fromString
-        ) <$> lookup' Signature components
+        (fromString)
+          <$> lookup' Signature components
       P.eof
-      pure SignatureHeader{..}
-    component = P.choice
-      [ do
-        _ <- P.string "keyId="
-        url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
-        pure (KeyId, url)
-      , do
-        _ <- P.string "headers="
-        url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
-        pure (Headers, url)
-      , do
-        _ <- P.string "signature="
-        url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
-        pure (Signature, url)
-      , do
-        _ <- 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)
-      ]
+      pure SignatureHeader {..}
+    component =
+      P.choice
+        [ do
+            _ <- P.string "keyId="
+            url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
+            pure (KeyId, url)
+        , do
+            _ <- P.string "headers="
+            url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
+            pure (Headers, url)
+        , do
+            _ <- P.string "signature="
+            url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
+            pure (Signature, url)
+        , do
+            _ <- 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

@@ -1,26 +1,26 @@
-{-# language RecordWildCards #-}
+{-# LANGUAGE RecordWildCards #-}
 
-module Fedi.Signature.Sign
-  ( module Fedi.Signature.Types
-  , module Fedi.Signature.Sign
-  )
-where
+module Fedi.Signature.Sign (
+  module Fedi.Signature.Types,
+  module Fedi.Signature.Sign,
+) where
 
-import Prelude hiding (error)
-import Fedi.UserDetails
-import Fedi.Helpers
 import Data.ByteString qualified as BS
-import Fedi.Crypto
 import Data.Time qualified as Time
+import Fedi.Crypto
+import Fedi.Helpers
 import Fedi.Signature.Types
+import Fedi.UserDetails
+import Prelude hiding (error)
 
 -- * Sign
 
 signSignature
   :: UserDetails -> String -> String -> ByteString -> IO HttpSignature
 signSignature details host requestTarget body = do
-  date <- Time.getCurrentTime
-    <&> Time.formatTime Time.defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
+  date <-
+    Time.getCurrentTime
+      <&> Time.formatTime Time.defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
 
   let
     digest = "SHA-256=" <> encodeBase64 (makeDigest body)
@@ -35,14 +35,15 @@ signSignature details host requestTarget body = do
 
   let
     signature = encodeBase64 signed.signedMessage
-    signatureHeader = SignatureHeader{..}
+    signatureHeader = SignatureHeader {..}
 
-  pure HttpSignature{..}
+  pure HttpSignature {..}
 
 makeSignatureString
   :: String -> String -> String -> ByteString -> ByteString
 makeSignatureString host requestTarget date digest =
-  BS.intercalate "\n"
+  BS.intercalate
+    "\n"
     [ "(request-target): " <> fromString requestTarget
     , "host: " <> fromString host
     , "date: " <> fromString date

src/Fedi/Signature/Types.hs

@@ -1,25 +1,26 @@
-{-# language RecordWildCards #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module Fedi.Signature.Types where
 
-import Prelude hiding (error)
-import Fedi.UserDetails
+import Data.ByteString qualified as BS
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
-import Data.ByteString qualified as BS
+import Fedi.UserDetails
+import Prelude hiding (error)
 
 data HttpSignature
   = HttpSignature
-    { signatureHeader :: SignatureHeader
-    , date :: String
-    , host :: String
-    , digest :: ByteString
-    }
-  deriving Show
+  { signatureHeader :: SignatureHeader
+  , date :: String
+  , host :: String
+  , digest :: ByteString
+  }
+  deriving (Show)
 
 toSignature :: SignatureHeader -> ByteString
 toSignature sig =
-  BS.intercalate ","
+  BS.intercalate
+    ","
     [ "keyId=\"" <> fromString sig.keyId <> "\""
     , "headers=\"" <> BS.intercalate " " (map T.encodeUtf8 sig.headers) <> "\""
     , "signature=\"" <> sig.signature <> "\""
@@ -28,15 +29,15 @@ toSignature sig =
 
 data SignatureHeader
   = SignatureHeader
-    { -- | Where to get the public key for this actor
-      keyId :: Url
-    , -- | Which headers have been sent
-      headers :: [T.Text]
-    , -- | Contains the signature
-      signature :: ByteString
-    , components :: [(Component, String)]
-    }
-  deriving Show
+  { keyId :: Url
+  -- ^ Where to get the public key for this actor
+  , headers :: [T.Text]
+  -- ^ Which headers have been sent
+  , signature :: ByteString
+  -- ^ Contains the signature
+  , components :: [(Component, String)]
+  }
+  deriving (Show)
 
 data Component
   = KeyId

src/Fedi/Types.hs

@@ -48,10 +48,9 @@ instance (ToObject a) => A.ToJSON (Object a) where
 instance (ToObject a) => ToObject (Object a) where
   toObject object =
     [ "@context"
-        A..=
-        [ ("https://www.w3.org/ns/activitystreams" :: String)
-        , ("https://w3id.org/security/v1" :: String)
-        ]
+        A..= [ ("https://www.w3.org/ns/activitystreams" :: String)
+             , ("https://w3id.org/security/v1" :: String)
+             ]
     ]
       <> toObject object.otype
       <> [ assignment
@@ -348,7 +347,6 @@ instance A.FromJSON TypeUndo where
       object <- value A..: "object"
       pure TypeUndo {..}
 
-
 --
 type Like = Object (TypeActivity TypeLike)
 
@@ -539,6 +537,7 @@ type Outbox = OrderedCollection AnyActivity
 type OutboxPage = OrderedCollectionPage AnyActivity
 
 type Followers = OrderedCollection Url
+
 type FollowersPage = OrderedCollectionPage Url
 
 data CollectionType t

src/Fedi/Types/Helpers.hs

@@ -152,16 +152,24 @@ emptyOrderedCollectionPage url =
           }
     }
 
-makeAccept :: Follow -> Url -> Accept
-makeAccept theirFollow myfollowId =
+data MkAccept
+  = MkAccept
+  { acceptId :: String
+  , acceptingActorUrl :: Link
+  , acceptedActivity :: AnyActivity
+  }
+
+makeAccept :: MkAccept -> Object (TypeActivity TypeAccept)
+makeAccept accept =
   emptyObject
-    { id = Just $ ObjectId myfollowId
+    { id = Just $ ObjectId accept.acceptId
     , otype =
         TypeActivity
-          { actor = theirFollow.otype.actor
-          , atype = TypeAccept
-            { object = ActivityFollow theirFollow
-            }
+          { actor = accept.acceptingActorUrl
+          , atype =
+              TypeAccept
+                { object = accept.acceptedActivity
+                }
           , target = Nothing
           , origin = Nothing
           }

src/Fedi/UserDetails.hs

@@ -4,11 +4,11 @@ module Fedi.UserDetails (
 ) where
 
 import Data.Aeson qualified as A
+import Data.ByteString as Export (ByteString)
 import Data.Foldable as Export
 import Data.Maybe as Export (fromMaybe, listToMaybe, maybeToList)
 import Data.String as Export (fromString)
 import Data.Text as Export (Text)
-import Data.ByteString as Export (ByteString)
 import Data.Text qualified as T
 import Data.Text.Encoding qualified as T
 import Data.Time as Export (UTCTime)

todo.org

@@ -0,0 +1,11 @@
+* Fedi
+** DONE Outbox of notes
+** DONE Inbox
+** DONE Publish
+** DONE HTTP Signatures
+** DONE Follow me / Unfollow me
+** TODO Test http signature
+** TODO Test outbox
+** TODO Test inbox + follow
+** TODO Like my note
+** TODO Reply to notes