format

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 (
-  ( module DB
+  module DB,
-  , DB.Int64
+  DB.Int64,
-  )
+) where
-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,12 +25,14 @@ data DB
   { getNotes :: IO [Note]
   , getNote :: DB.Int64 -> IO (Maybe Note)
   , insertNote :: NoteEntry -> IO (DB.Int64, Note)
-  , -- | We use a callback so we can revert if the operation fails.
+  , insertFollower
-    insertFollower ::
+      :: forall a
-      forall a. Typeable a => FollowerEntry -> (DB.Int64 -> IO a) -> IO a
+       . (Typeable a) => FollowerEntry -> (DB.Int64 -> IO a) -> IO a
-  , -- | We use a callback so we can revert if the operation fails.
+  -- ^ We use a callback so we can revert if the operation fails.
-    deleteFollower ::
+  , deleteFollower
-      forall a. Typeable a => FollowerEntry -> (Maybe DB.Int64 -> IO a) -> IO a
+      :: 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]
   }
 
@@ -45,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
@@ -60,7 +60,7 @@ data Follower
   , followId :: T.Text
   , actorId :: T.Text
   }
-  deriving Show
+  deriving (Show)
 
 -----------------------
 
@@ -275,6 +275,7 @@ getFollowersSQL url =
     |]
   , [DB.SQLText $ T.pack url]
   )
+
 -----------------------
 
 -- ** Decode row
@@ -292,27 +293,29 @@ decodeNoteRow = \case
     ] ->
       let
         emptyNote = emptyUserNote $ T.unpack actor
-      in (noteid,
+      in
-        emptyNote
+        ( noteid
-          { id = Just $ ObjectId $ T.unpack noteidurl
+        , emptyNote
-          , published = Just $ read (T.unpack published)
+            { id = Just $ ObjectId $ T.unpack noteidurl
-          , attributedTo = Just $ LLink $ Link $ T.unpack actor
+            , published = Just $ read (T.unpack published)
-          , inReplyTo = LLink . Link <$> inReplyTo
+            , attributedTo = Just $ LLink $ Link $ T.unpack actor
-          , content = Just content
+            , inReplyTo = LLink . Link <$> inReplyTo
-          , url = url
+            , content = Just content
-          , name = StringName <$> name
+            , url = url
-          , otype =
+            , name = StringName <$> name
-              emptyNote.otype
+            , otype =
-                { likes =
+                emptyNote.otype
-                    emptyNote.otype.likes
+                  { likes =
-                      { id = Just $ ObjectId $ T.unpack noteidurl <> "/likes"
+                      emptyNote.otype.likes
-                      }
+                        { id = Just $ ObjectId $ T.unpack noteidurl <> "/likes"
-                , shares =
+                        }
-                    emptyNote.otype.shares
+                  , shares =
-                      { id = Just $ ObjectId $ T.unpack noteidurl <> "/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
@@ -326,11 +329,11 @@ decodeFollowerRow = \case
     , DB.SQLText follower_id
     , DB.SQLText actor
     ] ->
-    Follower
+      Follower
-      { myid = myid
+        { myid = myid
-      , followId = follower_id
+        , followId = follower_id
-      , actorId = actor
+        , 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
+        . Limit.requestSizeLimitMiddleware Limit.defaultRequestSizeLimitSettings
-    . auth
+        . auth
-    ) app
+    )
+      app
 
 matchAdmin :: [T.Text] -> Bool
 matchAdmin = any (== "admin")

app/Routes.hs

@@ -1,18 +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
-import Routes.Inbox.Follow
 
 routes :: DB -> FilePath -> [Twain.Middleware]
 routes db detailsFile =
@@ -47,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
@@ -74,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
+      followers <-
-        <&> map (\follower -> T.unpack follower.actorId)
+        liftIO db.getFollowers
+          <&> map (\follower -> T.unpack follower.actorId)
       Fedi.handleFollowers details followers
   , -- Following
     Twain.get (Fedi.matchFollowing $ unsafePerformIO $ fetchUserDetails detailsFile) do
@@ -89,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
@@ -137,13 +135,16 @@ handleInbox db detailsFile activity = do
       handleInboxFollow details db activity follow
     Fedi.ActivityUndo
       ( Fedi.Object
-        { otype = Fedi.TypeActivity
+          { otype =
-          { atype = Fedi.TypeUndo
+            Fedi.TypeActivity
-            { object = Fedi.ActivityFollow follow
+              { atype =
-            }
+                Fedi.TypeUndo
+                  { object = Fedi.ActivityFollow follow
+                  }
+              }
           }
-        }) ->
+        ) ->
-      handleInboxUnfollow details db activity follow
+        handleInboxUnfollow details db activity follow
     _ -> do
       Log.logError $ "Unsupported activity: " <> Fedi.pShow activity
       Twain.next

app/Routes/Inbox/Accept.hs

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

app/Routes/Inbox/Follow.hs

@@ -1,10 +1,10 @@
 module Routes.Inbox.Follow where
 
+import Control.Logger.Simple qualified as Log
 import DB
 import Fedi qualified as Fedi
-import Web.Twain qualified as Twain
-import Control.Logger.Simple qualified as Log
 import Routes.Inbox.Accept
+import Web.Twain qualified as Twain
 
 handleInboxFollow
   :: Fedi.UserDetails
@@ -24,9 +24,9 @@ handleInboxFollow details db activity follow = do
           let
             followerEntry =
               ( FollowerEntry
-                { actorId = fromString actor.unwrap
+                  { actorId = fromString actor.unwrap
-                , followId = fromString id''.unwrap
+                  , followId = fromString id''.unwrap
-                }
+                  }
               )
             operation sendAccept = do
               insertFollower db followerEntry sendAccept
@@ -35,9 +35,7 @@ handleInboxFollow details db activity follow = do
           liftIO $ acceptRequest details actor activity operation
 
           pure $ Twain.text ""
-
         else Twain.next
-
     Nothing ->
       Twain.next
 
@@ -59,14 +57,17 @@ handleInboxUnfollow details db activity follow = do
           let
             followerEntry =
               ( FollowerEntry
-                { actorId = fromString actor.unwrap
+                  { actorId = fromString actor.unwrap
-                , followId = fromString id''.unwrap
+                  , followId = fromString id''.unwrap
-                }
+                  }
               )
             operation sendAccept = do
-              deleteFollower db followerEntry
+              deleteFollower
-                (\deletedId' -> do
+                db
-                    let deletedId = Fedi.fromMaybe 0 deletedId'
+                followerEntry
+                ( \deletedId' -> do
+                    let
+                      deletedId = Fedi.fromMaybe 0 deletedId'
                     sendAccept deletedId
                       <* Log.logInfo ("Deleted follower: " <> Fedi.pShow deletedId)
                 )

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
+  Log.logDebug $
-    [ ("pubkeypem", pubkeypem)
+    "Verifying signature: "
-    , ("sig", sig)
+      <> pShow
-    , ("message", message)
+        [ ("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
+  { signedMessage :: ByteString
-    }
+  }
-  deriving Show
+  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 Fedi.Helpers (
-  ( module Export
+  module Export,
-  , module Fedi.Helpers
+  module Fedi.Helpers,
-  )
+) where
-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.Time as Export (UTCTime)
-import Data.Aeson.Encode.Pretty qualified as AP
+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,20 +1,20 @@
-{-# 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
@@ -24,7 +24,8 @@ sendPost details url payload = do
   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 $ "Post http signature: " <> pShow httpSignature
   Log.logDebug $ "Post http signature headers: " <> pShow (makeSigHeaders httpSignature)
@@ -37,11 +38,11 @@ sendPost details url payload = do
         (Req.ReqBodyBs encoded)
         Req.bsResponse
         ( scheme
-          <> sigHeaders httpSignature
+            <> sigHeaders httpSignature
         )
-        (\request -> do
+        ( \request -> do
-          Log.logDebug $ "Sending POST request: " <> pShow request
+            Log.logDebug $ "Sending POST request: " <> pShow request
-          pure request
+            pure request
         )
     Log.logInfo $ "Post Response: " <> pShow response
     pure $ Req.responseBody response
@@ -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
@@ -88,11 +88,11 @@ sendGet url = do
         Req.NoReqBody
         Req.jsonResponse
         ( scheme
-          <> Req.header "ContentType" "application/activity+json"
+            <> Req.header "ContentType" "application/activity+json"
         )
-        (\request -> do
+        ( \request -> do
-          Log.logDebug $ "Sending GET request: " <> pShow request
+            Log.logDebug $ "Sending GET request: " <> pShow request
-          pure request
+            pure request
         )
     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 Fedi.Routes
+  module Fedi.Routes,
-  , module Export
+  module Export,
-  )
+) where
-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"
+        { id = Just $ ObjectId $ actorUrl details <> "/following"
-      , summary = Just $ fromString $ details.username <> " is 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 Control.Logger.Simple qualified as Log
-import Fedi.Types
+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 Prelude hiding (error)
-import Fedi.Signature.Check
-import Control.Logger.Simple qualified as Log
 
 -- * 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 RecordWildCards #-}
-{-# language ViewPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
 
-module Fedi.Signature.Check
+module Fedi.Signature.Check (
-  ( module Fedi.Signature.Types
+  module Fedi.Signature.Types,
-  , module Fedi.Signature.Check
+  module Fedi.Signature.Check,
-  )
+) where
-where
 
-import Prelude hiding (error)
+import Control.Monad.IO.Class
-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 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" >>=
+  digest <-
-    maybe (throw "missing header Digest") (pure . T.encodeUtf8)
+    Twain.header "Digest"
+      >>= maybe (throw "missing header Digest") (pure . T.encodeUtf8)
   (person :: Person) <- liftIO $ sendGet sigheader.keyId
-  let personPkid = person.otype.publicKey.pkid
+  let
-  let personPublicKey = pemToBS person.otype.publicKey.publicKeyPem
+    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)
+    path =
-      <> HTTP.renderQuery True (Wai.queryString request)
+      "/"
+        <> 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
+          let
-        case result of
+            result = lookup (CI.mk header) requestHeaders
-          Nothing -> throw $ "Missing header '" <> show header <> "'."
+          case result of
-          Just value -> pure $ header <> ": "
+            Nothing -> throw $ "Missing header '" <> show header <> "'."
-            <> if ":443" `BS.isSuffixOf` value
+            Just value ->
-              then BS.dropEnd (BS.length ":443") value
+              pure $
-              else value
+                header
+                  <> ": "
+                  <> if ":443" `BS.isSuffixOf` value
+                    then BS.dropEnd (BS.length ":443") value
+                    else value
       | otherwise = do
-        let result = lookup (CI.mk header) requestHeaders
+          let
-        case result of
+            result = lookup (CI.mk header) requestHeaders
-          Nothing -> throw $ "Missing header '" <> show header <> "'."
+          case result of
-          Just value -> pure $ header <> ": " <> value
+            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
+        (fromString)
-        ) <$> lookup' Signature components
+          <$> lookup' Signature components
       P.eof
-      pure SignatureHeader{..}
+      pure SignatureHeader {..}
-    component = P.choice
+    component =
-      [ do
+      P.choice
-        _ <- P.string "keyId="
+        [ do
-        url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
+            _ <- P.string "keyId="
-        pure (KeyId, url)
+            url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
-      , do
+            pure (KeyId, url)
-        _ <- P.string "headers="
+        , do
-        url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
+            _ <- P.string "headers="
-        pure (Headers, url)
+            url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
-      , do
+            pure (Headers, url)
-        _ <- P.string "signature="
+        , do
-        url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
+            _ <- P.string "signature="
-        pure (Signature, url)
+            url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
-      , do
+            pure (Signature, url)
-        _ <- P.string "algorithm="
+        , do
-        alg <- P.between (P.char '\"') (P.char '\"') (P.string "rsa-sha256")
+            _ <- P.string "algorithm="
-        pure (Algorithm, alg)
+            alg <- P.between (P.char '\"') (P.char '\"') (P.string "rsa-sha256")
-      -- , do
+            pure (Algorithm, alg)
-      --   key <- P.munch1 (/= '=')
+            -- , do
-      --   _ <- P.char '='
+            --   key <- P.munch1 (/= '=')
-      --   value <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))
+            --   _ <- P.char '='
-      --   pure (Other key, value)
+            --   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.Sign (
-  ( module Fedi.Signature.Types
+  module Fedi.Signature.Types,
-  , module Fedi.Signature.Sign
+  module Fedi.Signature.Sign,
-  )
+) where
-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
+  date <-
-    <&> Time.formatTime Time.defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
+    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 Data.ByteString qualified as BS
-import Fedi.UserDetails
 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
+  { signatureHeader :: SignatureHeader
-    , date :: String
+  , date :: String
-    , host :: String
+  , host :: String
-    , digest :: ByteString
+  , digest :: ByteString
-    }
+  }
-  deriving Show
+  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
-      keyId :: Url
+  -- ^ Where to get the public key for this actor
-    , -- | Which headers have been sent
+  , headers :: [T.Text]
-      headers :: [T.Text]
+  -- ^ Which headers have been sent
-    , -- | Contains the signature
+  , signature :: ByteString
-      signature :: ByteString
+  -- ^ Contains the signature
-    , components :: [(Component, String)]
+  , components :: [(Component, String)]
-    }
+  }
-  deriving Show
+  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..=
+        A..= [ ("https://www.w3.org/ns/activitystreams" :: String)
-        [ ("https://www.w3.org/ns/activitystreams" :: String)
+             , ("https://w3id.org/security/v1" :: 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

@@ -154,10 +154,10 @@ emptyOrderedCollectionPage url =
 
 data MkAccept
   = MkAccept
-    { acceptId :: String
+  { acceptId :: String
-    , acceptingActorUrl :: Link
+  , acceptingActorUrl :: Link
-    , acceptedActivity :: AnyActivity
+  , acceptedActivity :: AnyActivity
-    }
+  }
 
 makeAccept :: MkAccept -> Object (TypeActivity TypeAccept)
 makeAccept accept =
@@ -166,9 +166,10 @@ makeAccept accept =
     , otype =
         TypeActivity
           { actor = accept.acceptingActorUrl
-          , atype = TypeAccept
+          , atype =
-            { object = accept.acceptedActivity
+              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)