forge/Vervis
1
0
Fork 0
Code Pull requests Activity

In sharer inbox, accept forwarded activities, including ones of local users

Browse source
This commit is contained in:
fr33domlover 2019-05-01 23:13:22 +00:00
parent f789a773e4
commit 3d9438714b
3 changed files with 209 additions and 90 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

256
src/Vervis/Federation.hs
View file

@ -100,20 +100,20 @@ import Vervis.RemoteActorStore
import Vervis.Settings
data ActivityDetail = ActivityDetail
{ _actdAuthorURI :: FedURI
, _actdInstance :: InstanceId
, _actdAuthorId :: RemoteActorId
, _actdRawBody :: BL.ByteString
, _actdSignKey :: KeyId
, _actdDigest :: Digest SHA256
{ actdAuthorURI :: FedURI
, actdInstance :: InstanceId
-- , actdAuthorId :: RemoteActorId
-- , actdRawBody :: BL.ByteString
-- , actdSignKey :: KeyId
-- , actdDigest :: Digest SHA256
}
verifyActorSig :: Verification -> ExceptT String Handler ActivityDetail
verifyActorSig (Verification malgo (KeyId keyid) input (Signature signature)) = do
(host, luKey) <- f2l <$> parseKeyId keyid
checkHost host
(body, digest) <- verifyBodyDigest
mluActorHeader <- getActorHeader host
parseKeyId (KeyId k) =
case fmap f2l . parseFedURI =<< (first displayException . decodeUtf8') k of
Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e
Right u -> return u
verifyActorSig' malgo keyid input (Signature signature) host luKey mluActorHeader = do
manager <- getsYesod appHttpManager
(inboxOrVkid, vkd) <- do
ments <- lift $ runDB $ do
@ -192,44 +192,14 @@ verifyActorSig (Verification malgo (KeyId keyid) input (Signature signature)) =
else errSig2
return ActivityDetail
{ _actdAuthorURI = l2f host $ vkdActorId vkd
, _actdInstance = iid
, _actdAuthorId = rsid
, _actdRawBody = body
, _actdSignKey = KeyId keyid
, _actdDigest = digest
{ actdAuthorURI = l2f host $ vkdActorId vkd
, actdInstance = iid
-- , actdAuthorId = rsid
-- , actdRawBody = body
-- , actdSignKey = keyid
-- , actdDigest = digest
}
where
parseKeyId k =
case parseFedURI =<< (first displayException . decodeUtf8') k of
Left e -> throwE $ "keyId in Sig header isn't a valid FedURI: " ++ e
Right u -> return u
checkHost h = do
home <- getsYesod $ appInstanceHost . appSettings
when (h == home) $
throwE "Received HTTP signed request from the instance's host"
verifyBodyDigest = do
req <- waiRequest
let headers = W.requestHeaders req
digest <- case parseHttpBodyDigest SHA256 "SHA-256" headers of
Left s -> throwE $ "Parsing digest header failed: " ++ s
Right d -> return d
(digest', body) <- liftIO $ hashHttpBody SHA256 (W.requestBody req)
unless (digest == digest') $
throwE "Body digest verification failed"
return (body, digest)
getActorHeader host = do
bs <- lookupHeaders hActivityPubActor
case bs of
[] -> return Nothing
[b] -> fmap Just . ExceptT . pure $ do
t <- first displayException $ decodeUtf8' b
(h, lu) <- f2l <$> parseFedURI t
if h == host
then Right ()
else Left "Key and actor have different hosts"
Right lu
_ -> throwE "Multiple ActivityPub-Actor headers"
fetched2vkd uk (Fetched k mexp ua uinb s) =
( Left uinb
, VerifKeyDetail
@ -244,10 +214,78 @@ verifyActorSig (Verification malgo (KeyId keyid) input (Signature signature)) =
update vkid [VerifKeyExpires =. vkdExpires vkd, VerifKeyPublic =. vkdKey vkd]
withHostLock' h = ExceptT . withHostLock h . runExceptT
verifyActorSig :: Verification -> ExceptT String Handler ActivityDetail
verifyActorSig (Verification malgo keyid input signature) = do
(host, luKey) <- parseKeyId keyid
checkHost host
mluActorHeader <- getActorHeader host
verifyActorSig' malgo keyid input signature host luKey mluActorHeader
where
checkHost h = do
home <- getsYesod $ appInstanceHost . appSettings
when (h == home) $
throwE "Received HTTP signed request from the instance's host"
getActorHeader host = do
bs <- lookupHeaders hActivityPubActor
case bs of
[] -> return Nothing
[b] -> fmap Just . ExceptT . pure $ do
t <- first displayException $ decodeUtf8' b
(h, lu) <- f2l <$> parseFedURI t
if h == host
then Right ()
else Left "Key and actor have different hosts"
Right lu
_ -> throwE "Multiple ActivityPub-Actor headers"
verifySelfSig :: LocalURI -> LocalURI -> ByteString -> Signature -> ExceptT String Handler PersonId
verifySelfSig luAuthor luKey input (Signature sig) = do
shrAuthor <- do
route <-
case decodeRouteLocal luAuthor of
Nothing -> throwE "Local author ID isn't a valid route"
Just r -> return r
case route of
SharerR shr -> return shr
_ -> throwE "Local author ID isn't a user route"
akey <- do
route <-
case decodeRouteLocal luKey of
Nothing -> throwE "Local key ID isn't a valid route"
Just r -> return r
(akey1, akey2, _) <- liftIO . readTVarIO =<< getsYesod appActorKeys
case route of
ActorKey1R -> return akey1
ActorKey2R -> return akey2
_ -> throwE "Local key ID isn't an actor key route"
valid <-
ExceptT . pure $ verifySignature (actorKeyPublicBin akey) input sig
unless valid $
throwE "Self sig verification says not valid"
ExceptT $ runDB $ do
mpid <- runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shrAuthor
MaybeT $ getKeyBy $ UniquePersonIdent sid
return $
case mpid of
Nothing -> Left "Local author: No such user"
Just pid -> Right pid
verifyForwardedSig :: Text -> LocalURI -> Verification -> ExceptT String Handler (Either PersonId ActivityDetail)
verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) = do
(hKey, luKey) <- parseKeyId keyid
unless (hAuthor == hKey) $
throwE "Author and forwarded sig key on different hosts"
local <- hostIsLocal hKey
if local
then Left <$> verifySelfSig luAuthor luKey input signature
else Right <$> verifyActorSig' malgo keyid input signature hKey luKey (Just luAuthor)
authenticateActivity
:: UTCTime
-> ExceptT Text Handler (InstanceId, Object, Activity)
-> ExceptT Text Handler (Either PersonId InstanceId, Object, Activity)
authenticateActivity now = do
(ad, wv) <- do
verifyContentType
proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
@ -258,25 +296,38 @@ authenticateActivity now = do
toSeconds = toTimeUnit
in fromIntegral $ toSeconds timeLimit
prepareToVerifyHttpSig requires wants seconds now
ActivityDetail uSender iid _raid body _keyid _digest <-
withExceptT T.pack $ verifyActorSig proof
WithValue raw (Doc hActivity activity) <-
(detail, body) <-
withExceptT T.pack $
(,) <$> verifyActorSig proof
<*> verifyBodyDigest
wvdoc <-
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, ">"
]
return (detail, wvdoc)
let ActivityDetail uSender iid = ad
WithValue raw (Doc hActivity activity) = wv
(hSender, luSender) = f2l uSender
id_ <-
if hSender == hActivity
then do
unless (activityActor activity == luSender) $
throwE $ T.concat
[ "Activity's actor <"
, renderFedURI $ l2f hActivity $ activityActor activity
, "> != Signature key's actor <", renderFedURI uSender, ">"
, "> != Signature key's actor <", renderFedURI uSender
, ">"
]
return (iid, raw, activity)
return $ Right iid
else do
mi <- checkForward uSender hActivity (activityActor activity)
case mi of
Nothing -> throwE $ T.concat
[ "Activity host <", hActivity
, "> doesn't match signature key host <", hSender, ">"
]
Just i -> return i
return (id_, raw, activity)
where
verifyContentType = do
ctypes <- lookupHeaders "Content-Type"
@ -295,6 +346,39 @@ authenticateActivity now = do
typeAS2 =
"application/ld+json; \
\profile=\"https://www.w3.org/ns/activitystreams\""
verifyBodyDigest = do
req <- waiRequest
let headers = W.requestHeaders req
digest <- case parseHttpBodyDigest SHA256 "SHA-256" headers of
Left s -> throwE $ "Parsing digest header failed: " ++ s
Right d -> return d
(digest', body) <- liftIO $ hashHttpBody SHA256 (W.requestBody req)
unless (digest == digest') $
throwE "Body digest verification failed"
return body
checkForward uSender hAuthor luAuthor = do
let hSig = hForwardedSignature
msig <- lookupHeader hSig
for msig $ \ _ -> do
uForwarder <- parseForwarderHeader
unless (uForwarder == uSender) $
throwE "Signed forwarder doesn't match the sender"
proof <- withExceptT (T.pack . displayException) $ ExceptT $
let requires = [hDigest, hActivityPubForwarder]
in prepareToVerifyHttpSigWith hSig False requires [] Nothing
result <- withExceptT T.pack $ verifyForwardedSig hAuthor luAuthor proof
return $ second actdInstance result
where
parseForwarderHeader = do
fwds <- lookupHeaders hActivityPubForwarder
fwd <-
case fwds of
[] -> throwE "ActivityPub-Forwarder header missing"
[x] -> return x
_ -> throwE "Multiple ActivityPub-Forwarder"
case parseFedURI =<< (first displayException . decodeUtf8') fwd of
Left e -> throwE $ "ActivityPub-Forwarder isn't a valid FedURI: " <> T.pack e
Right u -> return u
hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool
hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings
@ -416,11 +500,42 @@ getLocalParentMessageId did shr lmid = do
handleSharerInbox
:: UTCTime
-> ShrIdent
-> InstanceId
-> Either PersonId InstanceId
-> Object
-> Activity
-> ExceptT Text Handler Text
handleSharerInbox now shrRecip iidSender raw activity =
handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
(shrActivity, obid) <- do
route <-
case decodeRouteLocal $ activityId activity of
Nothing -> throwE "Local activity: Not a valid route"
Just r -> return r
case route of
OutboxItemR shr obkhid ->
(shr,) <$> decodeKeyHashidE obkhid "Local activity: ID is invalid hashid"
_ -> throwE "Local activity: Not an activity route"
runDBExcept $ do
pidRecip <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getKeyBy404 $ UniquePersonIdent sid
mob <- lift $ get obid
ob <- fromMaybeE mob "Local activity: No such ID in DB"
let pidOutbox = outboxItemPerson ob
p <- lift $ getJust pidOutbox
s <- lift $ getJust $ personIdent p
unless (sharerIdent s == shrActivity) $
throwE "Local activity: ID invalid, hashid and author mismatch"
unless (pidAuthor == pidOutbox) $
throwE "Activity author in DB and in received JSON don't match"
if pidRecip == pidAuthor
then return "Received activity authored by self, ignoring"
else do
miblid <- lift $ insertUnique $ InboxItemLocal pidRecip obid
let recip = shr2text shrRecip
return $ case miblid of
Nothing -> "Activity already exists in inbox of /s/" <> recip
Just _ -> "Activity inserted to inbox of /s/" <> recip
handleSharerInbox now shrRecip (Right iidSender) raw activity =
case activitySpecific activity of
CreateActivity (Create note) -> handleNote note
_ -> return "Unsupported activity type"
@ -558,14 +673,6 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender raw activi
-> Just LocalTicketTeam
_ -> Nothing
recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
runDBExcept action = do
result <-
lift $ try $ runDB $ either abort return =<< runExceptT action
case result of
Left (FedError t) -> throwE t
Right r -> return r
where
abort = liftIO . throwIO . FedError
getContextAndParent num mparent = do
mt <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
@ -703,6 +810,15 @@ newtype FedError = FedError Text deriving Show
instance Exception FedError
runDBExcept action = do
result <-
lift $ try $ runDB $ either abort return =<< runExceptT action
case result of
Left (FedError t) -> throwE t
Right r -> return r
where
abort = liftIO . throwIO . FedError
deliverHttp
:: (MonadSite m, SiteEnv m ~ App)
=> Doc Activity

4
src/Vervis/Handler/Inbox.hs
View file

@ -141,8 +141,8 @@ postSharerInboxR shrRecip = do
contentTypes <- lookupHeaders "Content-Type"
now <- liftIO getCurrentTime
result <- runExceptT $ do
(iid, raw, activity) <- authenticateActivity now
(raw,) <$> handleSharerInbox now shrRecip iid raw activity
(id_, raw, activity) <- authenticateActivity now
(raw,) <$> handleSharerInbox now shrRecip id_ raw activity
recordActivity now result contentTypes
case result of
Left _ -> sendResponseStatus badRequest400 ()

3
src/Web/ActivityPub.hs
View file

@ -50,6 +50,9 @@ module Web.ActivityPub
, APGetError (..)
, httpGetAP
, APPostError (..)
, hActivityPubForwarder
, hForwardingSignature
, hForwardedSignature
, httpPostAP
, Fetched (..)
, fetchAPID