Put inbox activity auth code in a dedicated function in Vervis.Federation

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\""

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) ->