Put inbox activity auth code in a dedicated function in Vervis.Federation
This commit is contained in:
fr33domlover
parent
9d5399d636
commit
342467297a
2 changed files with 53 additions and 44 deletions
|
|
@ -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\""
|
||||
|
|
|
|||
|
|
@ -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) ->
|
||||
|
|
|
|||
Loading…
Reference in a new issue