Plug the project inbox handler code into the actual POST handler function
This commit is contained in:
parent
b0a26722d3
commit
5770c62692
2 changed files with 51 additions and 32 deletions
|
@ -14,7 +14,8 @@
|
||||||
-}
|
-}
|
||||||
|
|
||||||
module Vervis.Federation
|
module Vervis.Federation
|
||||||
( authenticateActivity
|
( ActivityDetail (..)
|
||||||
|
, authenticateActivity
|
||||||
, handleSharerInbox
|
, handleSharerInbox
|
||||||
, handleProjectInbox
|
, handleProjectInbox
|
||||||
, fixRunningDeliveries
|
, fixRunningDeliveries
|
||||||
|
@ -103,7 +104,7 @@ import Vervis.Settings
|
||||||
data ActivityDetail = ActivityDetail
|
data ActivityDetail = ActivityDetail
|
||||||
{ actdAuthorURI :: FedURI
|
{ actdAuthorURI :: FedURI
|
||||||
, actdInstance :: InstanceId
|
, actdInstance :: InstanceId
|
||||||
-- , actdAuthorId :: RemoteActorId
|
, actdAuthorId :: RemoteActorId
|
||||||
-- , actdRawBody :: BL.ByteString
|
-- , actdRawBody :: BL.ByteString
|
||||||
-- , actdSignKey :: KeyId
|
-- , actdSignKey :: KeyId
|
||||||
-- , actdDigest :: Digest SHA256
|
-- , actdDigest :: Digest SHA256
|
||||||
|
@ -114,7 +115,7 @@ parseKeyId (KeyId k) =
|
||||||
Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e
|
Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e
|
||||||
Right u -> return u
|
Right u -> return u
|
||||||
|
|
||||||
verifyActorSig' malgo keyid input (Signature signature) host luKey mluActorHeader = do
|
verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
|
||||||
manager <- getsYesod appHttpManager
|
manager <- getsYesod appHttpManager
|
||||||
(inboxOrVkid, vkd) <- do
|
(inboxOrVkid, vkd) <- do
|
||||||
ments <- lift $ runDB $ do
|
ments <- lift $ runDB $ do
|
||||||
|
@ -195,7 +196,7 @@ verifyActorSig' malgo keyid input (Signature signature) host luKey mluActorHeade
|
||||||
return ActivityDetail
|
return ActivityDetail
|
||||||
{ actdAuthorURI = l2f host $ vkdActorId vkd
|
{ actdAuthorURI = l2f host $ vkdActorId vkd
|
||||||
, actdInstance = iid
|
, actdInstance = iid
|
||||||
-- , actdAuthorId = rsid
|
, actdAuthorId = rsid
|
||||||
-- , actdRawBody = body
|
-- , actdRawBody = body
|
||||||
-- , actdSignKey = keyid
|
-- , actdSignKey = keyid
|
||||||
-- , actdDigest = digest
|
-- , actdDigest = digest
|
||||||
|
@ -220,7 +221,7 @@ verifyActorSig (Verification malgo keyid input signature) = do
|
||||||
(host, luKey) <- parseKeyId keyid
|
(host, luKey) <- parseKeyId keyid
|
||||||
checkHost host
|
checkHost host
|
||||||
mluActorHeader <- getActorHeader host
|
mluActorHeader <- getActorHeader host
|
||||||
verifyActorSig' malgo keyid input signature host luKey mluActorHeader
|
verifyActorSig' malgo input signature host luKey mluActorHeader
|
||||||
where
|
where
|
||||||
checkHost h = do
|
checkHost h = do
|
||||||
home <- getsYesod $ appInstanceHost . appSettings
|
home <- getsYesod $ appInstanceHost . appSettings
|
||||||
|
@ -280,13 +281,13 @@ verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) =
|
||||||
local <- hostIsLocal hKey
|
local <- hostIsLocal hKey
|
||||||
if local
|
if local
|
||||||
then Left <$> verifySelfSig luAuthor luKey input signature
|
then Left <$> verifySelfSig luAuthor luKey input signature
|
||||||
else Right <$> verifyActorSig' malgo keyid input signature hKey luKey (Just luAuthor)
|
else Right <$> verifyActorSig' malgo input signature hKey luKey (Just luAuthor)
|
||||||
|
|
||||||
authenticateActivity
|
authenticateActivity
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> ExceptT Text Handler (Either PersonId InstanceId, Object, Activity)
|
-> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity)
|
||||||
authenticateActivity now = do
|
authenticateActivity now = do
|
||||||
(ad, wv) <- do
|
(ad, wv, body) <- do
|
||||||
verifyContentType
|
verifyContentType
|
||||||
proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
|
proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
|
||||||
timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
|
timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
|
||||||
|
@ -305,9 +306,9 @@ authenticateActivity now = do
|
||||||
case eitherDecode' body of
|
case eitherDecode' body of
|
||||||
Left s -> throwE $ "Parsing activity failed: " <> T.pack s
|
Left s -> throwE $ "Parsing activity failed: " <> T.pack s
|
||||||
Right wv -> return wv
|
Right wv -> return wv
|
||||||
return (detail, wvdoc)
|
return (detail, wvdoc, body)
|
||||||
let ActivityDetail uSender iid = ad
|
let WithValue raw (Doc hActivity activity) = wv
|
||||||
WithValue raw (Doc hActivity activity) = wv
|
uSender = actdAuthorURI ad
|
||||||
(hSender, luSender) = f2l uSender
|
(hSender, luSender) = f2l uSender
|
||||||
id_ <-
|
id_ <-
|
||||||
if hSender == hActivity
|
if hSender == hActivity
|
||||||
|
@ -319,7 +320,7 @@ authenticateActivity now = do
|
||||||
, "> != Signature key's actor <", renderFedURI uSender
|
, "> != Signature key's actor <", renderFedURI uSender
|
||||||
, ">"
|
, ">"
|
||||||
]
|
]
|
||||||
return $ Right iid
|
return $ Right ad
|
||||||
else do
|
else do
|
||||||
mi <- checkForward uSender hActivity (activityActor activity)
|
mi <- checkForward uSender hActivity (activityActor activity)
|
||||||
case mi of
|
case mi of
|
||||||
|
@ -328,7 +329,7 @@ authenticateActivity now = do
|
||||||
, "> doesn't match signature key host <", hSender, ">"
|
, "> doesn't match signature key host <", hSender, ">"
|
||||||
]
|
]
|
||||||
Just i -> return i
|
Just i -> return i
|
||||||
return (id_, raw, activity)
|
return (id_, body, raw, activity)
|
||||||
where
|
where
|
||||||
verifyContentType = do
|
verifyContentType = do
|
||||||
ctypes <- lookupHeaders "Content-Type"
|
ctypes <- lookupHeaders "Content-Type"
|
||||||
|
@ -367,8 +368,7 @@ authenticateActivity now = do
|
||||||
proof <- withExceptT (T.pack . displayException) $ ExceptT $
|
proof <- withExceptT (T.pack . displayException) $ ExceptT $
|
||||||
let requires = [hDigest, hActivityPubForwarder]
|
let requires = [hDigest, hActivityPubForwarder]
|
||||||
in prepareToVerifyHttpSigWith hSig False requires [] Nothing
|
in prepareToVerifyHttpSigWith hSig False requires [] Nothing
|
||||||
result <- withExceptT T.pack $ verifyForwardedSig hAuthor luAuthor proof
|
withExceptT T.pack $ verifyForwardedSig hAuthor luAuthor proof
|
||||||
return $ second actdInstance result
|
|
||||||
where
|
where
|
||||||
parseForwarderHeader = do
|
parseForwarderHeader = do
|
||||||
fwds <- lookupHeaders hActivityPubForwarder
|
fwds <- lookupHeaders hActivityPubForwarder
|
||||||
|
@ -1438,6 +1438,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
|
||||||
Left pid -> return pid
|
Left pid -> return pid
|
||||||
Right _gid -> throwE "Local Note addresses a local group"
|
Right _gid -> throwE "Local Note addresses a local group"
|
||||||
|
|
||||||
|
{-
|
||||||
-- Deliver to a local sharer, if they exist as a user account
|
-- Deliver to a local sharer, if they exist as a user account
|
||||||
deliverToLocalSharer :: OutboxItemId -> ShrIdent -> ExceptT Text AppDB ()
|
deliverToLocalSharer :: OutboxItemId -> ShrIdent -> ExceptT Text AppDB ()
|
||||||
deliverToLocalSharer obid shr = do
|
deliverToLocalSharer obid shr = do
|
||||||
|
@ -1452,6 +1453,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
|
||||||
case id_ of
|
case id_ of
|
||||||
Left pid -> lift $ insert_ $ InboxItemLocal pid obid
|
Left pid -> lift $ insert_ $ InboxItemLocal pid obid
|
||||||
Right _gid -> throwE "Local Note addresses a local group"
|
Right _gid -> throwE "Local Note addresses a local group"
|
||||||
|
-}
|
||||||
|
|
||||||
deliverRemoteDB
|
deliverRemoteDB
|
||||||
:: Text
|
:: Text
|
||||||
|
|
|
@ -141,14 +141,15 @@ postSharerInboxR shrRecip = do
|
||||||
contentTypes <- lookupHeaders "Content-Type"
|
contentTypes <- lookupHeaders "Content-Type"
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
result <- runExceptT $ do
|
result <- runExceptT $ do
|
||||||
(id_, raw, activity) <- authenticateActivity now
|
(id_, _body, raw, activity) <- authenticateActivity now
|
||||||
(raw,) <$> handleSharerInbox now shrRecip id_ raw activity
|
let id' = second actdInstance id_
|
||||||
|
(raw,) <$> handleSharerInbox now shrRecip id' raw activity
|
||||||
recordActivity now result contentTypes
|
recordActivity now result contentTypes
|
||||||
case result of
|
case result of
|
||||||
Left _ -> sendResponseStatus badRequest400 ()
|
Left _ -> sendResponseStatus badRequest400 ()
|
||||||
Right _ -> return ()
|
Right _ -> return ()
|
||||||
where
|
|
||||||
recordActivity now result contentTypes = do
|
recordActivity now result contentTypes = do
|
||||||
macts <- getsYesod appActivities
|
macts <- getsYesod appActivities
|
||||||
for_ macts $ \ (size, acts) ->
|
for_ macts $ \ (size, acts) ->
|
||||||
liftIO $ atomically $ modifyTVar' acts $ \ vec ->
|
liftIO $ atomically $ modifyTVar' acts $ \ vec ->
|
||||||
|
@ -163,7 +164,23 @@ postSharerInboxR shrRecip = do
|
||||||
else vec'
|
else vec'
|
||||||
|
|
||||||
postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
|
postProjectInboxR :: ShrIdent -> PrjIdent -> Handler ()
|
||||||
postProjectInboxR _ _ = error "TODO implement postProjectInboxR"
|
postProjectInboxR shrRecip prjRecip = do
|
||||||
|
federation <- getsYesod $ appFederation . appSettings
|
||||||
|
unless federation badMethod
|
||||||
|
contentTypes <- lookupHeaders "Content-Type"
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
|
result <- runExceptT $ do
|
||||||
|
(id_, body, raw, activity) <- authenticateActivity now
|
||||||
|
ActivityDetail uAuthor iidAuthor raidAuthor <-
|
||||||
|
case id_ of
|
||||||
|
Left _pid -> throwE "Project inbox got local forwarded activity"
|
||||||
|
Right d -> return d
|
||||||
|
let hAuthor = furiHost uAuthor
|
||||||
|
(raw,) <$> handleProjectInbox now shrRecip prjRecip iidAuthor hAuthor raidAuthor body raw activity
|
||||||
|
recordActivity now result contentTypes
|
||||||
|
case result of
|
||||||
|
Left _ -> sendResponseStatus badRequest400 ()
|
||||||
|
Right _ -> return ()
|
||||||
|
|
||||||
{-
|
{-
|
||||||
jsonField :: (FromJSON a, ToJSON a) => Field Handler a
|
jsonField :: (FromJSON a, ToJSON a) => Field Handler a
|
||||||
|
|
Loading…
Reference in a new issue