diff --git a/app/DB.hs b/app/DB.hs index 9c72b7c..54ea78b 100644 --- a/app/DB.hs +++ b/app/DB.hs @@ -1,22 +1,20 @@ - -- needed because of a compiler bug with OverloadedRecordDot: -- -{-# 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) diff --git a/app/Html.hs b/app/Html.hs index b42d9ae..50906c8 100644 --- 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++) { diff --git a/app/Main.hs b/app/Main.hs index ee791b6..8c31b82 100644 --- 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") diff --git a/app/Routes.hs b/app/Routes.hs index c165cdb..cce58cd 100644 --- 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 diff --git a/app/Routes/Inbox/Accept.hs b/app/Routes/Inbox/Accept.hs index 22e5e10..58568d3 100644 --- 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 diff --git a/app/Routes/Inbox/Follow.hs b/app/Routes/Inbox/Follow.hs index e42438c..f46dcad 100644 --- 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) ) diff --git a/src/Fedi.hs b/src/Fedi.hs index 82c63b4..350ed41 100644 --- 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 diff --git a/src/Fedi/Crypto.hs b/src/Fedi/Crypto.hs index e4ec554..a795de4 100644 --- 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) diff --git a/src/Fedi/Helpers.hs b/src/Fedi/Helpers.hs index c74d195..047f964 100644 --- 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} diff --git a/src/Fedi/Requests.hs b/src/Fedi/Requests.hs index 02b9f7e..fbfd9b3 100644 --- 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 diff --git a/src/Fedi/Routes.hs b/src/Fedi/Routes.hs index a2ee7f7..fc548f2 100644 --- 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] diff --git a/src/Fedi/Routes/Follow.hs b/src/Fedi/Routes/Follow.hs index 4144875..5ae4b0d 100644 --- 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) diff --git a/src/Fedi/Routes/Helpers.hs b/src/Fedi/Routes/Helpers.hs index 1222597..75b855a 100644 --- 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 = diff --git a/src/Fedi/Routes/Inbox.hs b/src/Fedi/Routes/Inbox.hs index b259247..8519a7c 100644 --- 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 diff --git a/src/Fedi/Routes/Notes.hs b/src/Fedi/Routes/Notes.hs index 404226d..54839ed 100644 --- 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 diff --git a/src/Fedi/Routes/Outbox.hs b/src/Fedi/Routes/Outbox.hs index e2ff05d..b07c1e5 100644 --- 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 diff --git a/src/Fedi/Routes/User.hs b/src/Fedi/Routes/User.hs index 012477e..dc56733 100644 --- 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 diff --git a/src/Fedi/Signature/Check.hs b/src/Fedi/Signature/Check.hs index ac40e51..1055451 100644 --- 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) + ] diff --git a/src/Fedi/Signature/Sign.hs b/src/Fedi/Signature/Sign.hs index 2b1e079..3bb2e66 100644 --- 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 diff --git a/src/Fedi/Signature/Types.hs b/src/Fedi/Signature/Types.hs index 0ecbe5f..990e724 100644 --- 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 diff --git a/src/Fedi/Types.hs b/src/Fedi/Types.hs index 5357c41..6e8800c 100644 --- 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 diff --git a/src/Fedi/Types/Helpers.hs b/src/Fedi/Types/Helpers.hs index 3427224..45f6adf 100644 --- 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 } diff --git a/src/Fedi/UserDetails.hs b/src/Fedi/UserDetails.hs index c82b435..e3c5813 100644 --- 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)