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,8 +293,9 @@ decodeNoteRow = \case
     ] ->
       let
         emptyNote = emptyUserNote $ T.unpack actor
-      in (noteid,
+      in
-        emptyNote
+        ( noteid
+        , emptyNote
             { id = Just $ ObjectId $ T.unpack noteidurl
             , published = Just $ read (T.unpack published)
             , attributedTo = Just $ LLink $ Link $ T.unpack actor
@@ -312,7 +314,8 @@ decodeNoteRow = \case
                         { id = Just $ ObjectId $ T.unpack noteidurl <> "/shares"
                         }
                   }
-          })
+            }
+        )
   row -> error $ "Couldn't decode row as Note: " <> show row
 
 decodeIntRow :: [DB.SQLData] -> DB.Int64

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
@@ -122,7 +122,8 @@ runServer port authMiddleware app = do
     ( Logger.logStdoutDev
         . Limit.requestSizeLimitMiddleware Limit.defaultRequestSizeLimitSettings
         . 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,11 +72,11 @@ 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 <-
+        liftIO db.getFollowers
           <&> map (\follower -> T.unpack follower.actorId)
       Fedi.handleFollowers details followers
   , -- Following
@@ -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,12 +135,15 @@ handleInbox db detailsFile activity = do
       handleInboxFollow details db activity follow
     Fedi.ActivityUndo
       ( Fedi.Object
-        { otype = Fedi.TypeActivity
+          { otype =
-          { atype = Fedi.TypeUndo
+            Fedi.TypeActivity
+              { atype =
+                Fedi.TypeUndo
                   { object = Fedi.ActivityFollow follow
                   }
               }
-        }) ->
+          }
+        ) ->
         handleInboxUnfollow details db activity follow
     _ -> do
       Log.logError $ "Unsupported activity: " <> Fedi.pShow activity

app/Routes/Inbox/Accept.hs

@@ -1,10 +1,10 @@
 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
@@ -19,10 +19,12 @@ acceptRequest details actor activity operation = do
     let
       callback =
         ( \(opid :: DB.Int64) -> do
-          result <- Fedi.sendPost
+            result <-
+              Fedi.sendPost
                 details
                 (actor.unwrap <> "/inbox")
-            ( Fedi.makeAccept Fedi.MkAccept
+                ( Fedi.makeAccept
+                    Fedi.MkAccept
                       { Fedi.acceptId =
                           Fedi.actorUrl details <> "/accepts/requests/" <> show opid
                       , Fedi.acceptingActorUrl = Fedi.Link $ Fedi.actorUrl details

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
@@ -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
 
@@ -64,9 +62,12 @@ handleInboxUnfollow details db activity follow = do
                   }
               )
             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,23 +1,25 @@
-{-# 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 $
+    "Verifying signature: "
+      <> pShow
         [ ("pubkeypem", pubkeypem)
         , ("sig", sig)
         , ("message", message)
@@ -43,13 +45,13 @@ sign privatePemFile message = do
       & either (throw . show) pure
 
   -- return
-  pure Signed{..}
+  pure Signed {..}
 
 newtype Signed
   = Signed
   { signedMessage :: ByteString
   }
-  deriving Show
+  deriving (Show)
 
 ppSigned :: Signed -> String
 ppSigned signed =

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)
@@ -39,7 +40,7 @@ sendPost details url payload = do
         ( scheme
             <> sigHeaders httpSignature
         )
-        (\request -> do
+        ( \request -> do
             Log.logDebug $ "Sending POST request: " <> pShow request
             pure request
         )
@@ -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
@@ -90,7 +90,7 @@ sendGet url = do
         ( scheme
             <> Req.header "ContentType" "application/activity+json"
         )
-        (\request -> do
+        ( \request -> do
             Log.logDebug $ "Sending GET request: " <> pShow request
             pure request
         )

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
 

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,12 +55,14 @@ 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 =
+      "/"
+        <> T.encodeUtf8 (T.intercalate "/" $ Wai.pathInfo request)
         <> HTTP.renderQuery True (Wai.queryString request)
     requestTarget = method <> " " <> path
   let
@@ -67,15 +71,20 @@ makeSignatureString request (map (T.encodeUtf8 . T.toLower) -> headers) = do
       | header == "(request-target)" =
           pure $ header <> ": " <> requestTarget
       | header == "host" = do
-        let result = lookup (CI.mk header) requestHeaders
+          let
+            result = lookup (CI.mk header) requestHeaders
           case result of
             Nothing -> throw $ "Missing header '" <> show header <> "'."
-          Just value -> pure $ 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
+          let
+            result = lookup (CI.mk header) requestHeaders
           case result of
             Nothing -> throw $ "Missing header '" <> show header <> "'."
             Just value -> pure $ header <> ": " <> value
@@ -83,7 +92,8 @@ makeSignatureString request (map (T.encodeUtf8 . T.toLower) -> headers) = do
   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,13 +123,14 @@ 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 =
+      P.choice
         [ do
             _ <- P.string "keyId="
             url <- P.between (P.char '\"') (P.char '\"') (P.munch1 (/= '\"'))

src/Fedi/Signature/Sign.hs

@@ -1,25 +1,25 @@
-{-# 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.getCurrentTime
       <&> Time.formatTime Time.defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
 
   let
@@ -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,12 +1,12 @@
-{-# 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
@@ -15,11 +15,12 @@ data HttpSignature
   , host :: String
   , 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)]
   }
-  deriving Show
+  deriving (Show)
 
 data Component
   = KeyId

src/Fedi/Types.hs

@@ -48,8 +48,7 @@ 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)
              ]
     ]
@@ -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

@@ -166,7 +166,8 @@ makeAccept accept =
     , otype =
         TypeActivity
           { actor = accept.acceptingActorUrl
-          , atype = TypeAccept
+          , atype =
+              TypeAccept
                 { object = accept.acceptedActivity
                 }
           , target = 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)