diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index ae1413c..acf00a6 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -18,6 +18,7 @@ module Vervis.Federation , fixRunningDeliveries , handleOutboxNote , retryOutboxDelivery + , authenticateActivity ) where @@ -32,7 +33,7 @@ import Control.Monad.Logger.CallStack import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader -import Data.Aeson (Object) +import Data.Aeson import Data.Bifunctor import Data.ByteString (ByteString) import Data.Either @@ -50,7 +51,6 @@ import Data.Tuple import Database.Persist hiding (deleteBy) import Database.Persist.Sql hiding (deleteBy) import Network.HTTP.Client -import Network.HTTP.Signature import Network.HTTP.Types.Header import Network.HTTP.Types.URI import Network.TLS @@ -65,6 +65,7 @@ import qualified Data.Text as T import qualified Database.Esqueleto as E import Network.HTTP.Signature +import Yesod.HttpSignature import Database.Persist.JSON import Network.FedURI @@ -75,6 +76,7 @@ import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite +import Data.Aeson.Local import Data.Either.Local import Data.List.Local import Data.List.NonEmpty.Local @@ -1310,3 +1312,49 @@ retryOutboxDelivery = do unless (and results) $ logError $ "Periodic UDL delivery error for host " <> h return True + +authenticateActivity + :: UTCTime + -> [ByteString] + -> ExceptT Text Handler (InstanceId, Object, Activity) +authenticateActivity now ctypes = do + verifyContentType + HttpSigVerResult result <- + ExceptT $ + first (T.pack . displayException) <$> + verifyRequestSignature now + ActivityDetail uSender iid _raid body _keyid _digest <- ExceptT $ pure $ first T.pack result + WithValue raw (Doc hActivity activity) <- + case eitherDecode' body of + Left s -> throwE $ "Parsing activity failed: " <> T.pack s + Right wv -> return wv + let (hSender, luSender) = f2l uSender + unless (hSender == hActivity) $ + throwE $ T.concat + [ "Activity host <", hActivity + , "> doesn't match signature key host <", hSender, ">" + ] + unless (activityActor activity == luSender) $ + throwE $ T.concat + [ "Activity's actor <" + , renderFedURI $ l2f hActivity $ activityActor activity + , "> != Signature key's actor <", renderFedURI uSender, ">" + ] + return (iid, raw, activity) + where + verifyContentType = + case ctypes of + [] -> throwE "Content-Type not specified" + [x] | x == typeAS -> return () + | x == typeAS2 -> return () + | otherwise -> + throwE $ "Not a recognized AP Content-Type: " <> + case decodeUtf8' x of + Left _ -> T.pack (show x) + Right t -> t + _ -> throwE "More than one Content-Type specified" + where + typeAS = "application/activity+json" + typeAS2 = + "application/ld+json; \ + \profile=\"https://www.w3.org/ns/activitystreams\"" diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index ef8391a..126899a 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -140,53 +140,14 @@ postSharerInboxR shrRecip = do unless federation badMethod contentTypes <- lookupHeaders "Content-Type" now <- liftIO getCurrentTime - result <- go now contentTypes + result <- runExceptT $ do + (iid, raw, activity) <- authenticateActivity now contentTypes + (raw,) <$> handleSharerInbox now shrRecip iid raw activity recordActivity now result contentTypes case result of Left _ -> sendResponseStatus badRequest400 () Right _ -> return () where - go now ctypes = runExceptT $ do - verifyContentType - HttpSigVerResult result <- - ExceptT $ - first (T.pack . displayException) <$> - verifyRequestSignature now - ActivityDetail uSender iid _raid body _keyid _digest <- ExceptT $ pure $ first T.pack result - WithValue raw (Doc hActivity activity) <- - case eitherDecode' body of - Left s -> throwE $ "Parsing activity failed: " <> T.pack s - Right wv -> return wv - let (hSender, luSender) = f2l uSender - unless (hSender == hActivity) $ - throwE $ T.concat - [ "Activity host <", hActivity - , "> doesn't match signature key host <", hSender, ">" - ] - unless (activityActor activity == luSender) $ - throwE $ T.concat - [ "Activity's actor <" - , renderFedURI $ l2f hActivity $ activityActor activity - , "> != Signature key's actor <", renderFedURI uSender, ">" - ] - (raw,) <$> handleSharerInbox now shrRecip iid raw activity - where - verifyContentType = - case ctypes of - [] -> throwE "Content-Type not specified" - [x] | x == typeAS -> return () - | x == typeAS2 -> return () - | otherwise -> - throwE $ "Not a recognized AP Content-Type: " <> - case decodeUtf8' x of - Left _ -> T.pack (show x) - Right t -> t - _ -> throwE "More than one Content-Type specified" - where - typeAS = "application/activity+json" - typeAS2 = - "application/ld+json; \ - \profile=\"https://www.w3.org/ns/activitystreams\"" recordActivity now result contentTypes = do macts <- getsYesod appActivities for_ macts $ \ (size, acts) ->