format

2024-11-08 00:28:15 +02:00 · 2024-11-08 00:28:15 +02:00 · 34590c8a66
commit 34590c8a66
parent 10d9a92b12
23 changed files with 329 additions and 307 deletions
--- a/app/DB.hs
+++ b/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,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 ::
-      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
+  , 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]
  }

@ -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,
-        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
@ -326,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)
--- a/app/Html.hs
+++ b/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++) {
--- a/app/Main.hs
+++ b/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")
--- a/app/Routes.hs
+++ b/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
-        <&> 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
@ -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
-          { atype = Fedi.TypeUndo
-            { object = Fedi.ActivityFollow follow
-            }
+          { otype =
+            Fedi.TypeActivity
+              { 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
--- a/app/Routes/Inbox/Accept.hs
+++ b/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.AnyActivity
-   -> ((Int64 -> IO ()) -> IO a)
-   -> IO ()
+  -> 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..."
@ -19,17 +19,19 @@ acceptRequest details actor activity operation = do
    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)
+            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
--- a/app/Routes/Inbox/Follow.hs
+++ b/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
-                , followId = fromString id''.unwrap
-                }
+                  { actorId = fromString actor.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
-                , followId = fromString id''.unwrap
-                }
+                  { actorId = fromString actor.unwrap
+                  , followId = fromString id''.unwrap
+                  }
              )
            operation sendAccept = do
-              deleteFollower db followerEntry
-                (\deletedId' -> do
-                    let deletedId = Fedi.fromMaybe 0 deletedId'
+              deleteFollower
+                db
+                followerEntry
+                ( \deletedId' -> do
+                    let
+                      deletedId = Fedi.fromMaybe 0 deletedId'
                    sendAccept deletedId
                      <* Log.logInfo ("Deleted follower: " <> Fedi.pShow deletedId)
                )
--- a/src/Fedi.hs
+++ b/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
--- a/src/Fedi/Crypto.hs
+++ b/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)
--- a/src/Fedi/Helpers.hs
+++ b/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}
--- a/src/Fedi/Requests.hs
+++ b/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
-          Log.logDebug $ "Sending POST request: " <> pShow request
-          pure request
+        ( \request -> do
+            Log.logDebug $ "Sending POST request: " <> pShow 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
-          Log.logDebug $ "Sending GET request: " <> pShow request
-          pure request
+        ( \request -> do
+            Log.logDebug $ "Sending GET request: " <> pShow request
+            pure request
        )
    Log.logInfo $ "Get Response: " <> pShow response
    pure $ Req.responseBody response
--- a/src/Fedi/Routes.hs
+++ b/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]
--- a/src/Fedi/Routes/Follow.hs
+++ b/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)
--- a/src/Fedi/Routes/Helpers.hs
+++ b/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 =
--- a/src/Fedi/Routes/Inbox.hs
+++ b/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

--- a/src/Fedi/Routes/Notes.hs
+++ b/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

--- a/src/Fedi/Routes/Outbox.hs
+++ b/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

--- a/src/Fedi/Routes/User.hs
+++ b/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

--- a/src/Fedi/Signature/Check.hs
+++ b/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)
+        ]
--- a/src/Fedi/Signature/Sign.hs
+++ b/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
--- a/src/Fedi/Signature/Types.hs
+++ b/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
--- a/src/Fedi/Types.hs
+++ b/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
--- a/src/Fedi/Types/Helpers.hs
+++ b/src/Fedi/Types/Helpers.hs
@ -154,10 +154,10 @@ emptyOrderedCollectionPage url =

 data MkAccept
  = MkAccept
-    { acceptId :: String
-    , acceptingActorUrl :: Link
-    , acceptedActivity :: AnyActivity
-    }
+  { acceptId :: String
+  , acceptingActorUrl :: Link
+  , acceptedActivity :: AnyActivity
+  }

 makeAccept :: MkAccept -> Object (TypeActivity TypeAccept)
 makeAccept accept =
@ -166,9 +166,10 @@ makeAccept accept =
    , otype =
        TypeActivity
          { actor = accept.acceptingActorUrl
-          , atype = TypeAccept
-            { object = accept.acceptedActivity
-            }
+          , atype =
+              TypeAccept
+                { object = accept.acceptedActivity
+                }
          , target = Nothing
          , origin = Nothing
          }
--- a/src/Fedi/UserDetails.hs
+++ b/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)