Refactor the types used in activity authentication and handle project recipient

- The data returned from activity authentication has nicer types now, and no
  mess of big tuples.
- Activity authentication code has its own module now, Vervis.Federation.Auth.
- The sharer inbox handler can now handle and store activities by a local
  project actor, forwarded from a remote actor. This isn't in use right now,
  but once projects start publishing Accept activities, or other things, it may
  be needed.
This commit is contained in:
fr33domlover 2019-06-16 21:39:50 +00:00
parent e1ae75b50c
commit 4d5fa0551f
6 changed files with 540 additions and 355 deletions

View file

@ -14,9 +14,7 @@
-}
module Vervis.Federation
( ActivityDetail (..)
, authenticateActivity
, handleSharerInbox
( handleSharerInbox
, handleProjectInbox
, fixRunningDeliveries
, retryOutboxDelivery
@ -95,6 +93,7 @@ import Yesod.Persist.Local
import Vervis.ActivityPub
import Vervis.ActorKey
import Vervis.Federation.Auth
import Vervis.Federation.Discussion
import Vervis.Federation.Ticket
import Vervis.Foundation
@ -103,286 +102,6 @@ import Vervis.Model.Ident
import Vervis.RemoteActorStore
import Vervis.Settings
data ActivityDetail = ActivityDetail
{ actdAuthorURI :: FedURI
, actdInstance :: InstanceId
, actdAuthorId :: RemoteActorId
-- , actdRawBody :: BL.ByteString
-- , actdSignKey :: KeyId
-- , actdDigest :: Digest SHA256
}
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 input (Signature signature) host luKey mluActorHeader = do
manager <- getsYesod appHttpManager
(inboxOrVkid, vkd) <- do
ments <- lift $ runDB $ do
mvk <- runMaybeT $ do
Entity iid _ <- MaybeT $ getBy $ UniqueInstance host
MaybeT $ getBy $ UniqueVerifKey iid luKey
for mvk $ \ vk@(Entity _ verifkey) -> do
mremote <- for (verifKeySharer verifkey) $ \ rsid ->
(rsid,) <$> getJust rsid
return (vk, mremote)
case ments of
Just (Entity vkid vk, mremote) -> do
(ua, s, rsid) <-
case mremote of
Just (rsid, rs) -> do
let sharer = remoteActorIdent rs
for_ mluActorHeader $ \ u ->
if sharer == u
then return ()
else throwE "Key's owner doesn't match actor header"
return (sharer, False, rsid)
Nothing -> do
ua <- case mluActorHeader of
Nothing -> throwE "Got a sig with an instance key, but actor header not specified!"
Just u -> return u
let iid = verifKeyInstance vk
rsid <- withHostLock' host $ keyListedByActorShared iid vkid host luKey ua
return (ua, True, rsid)
return
( Right (verifKeyInstance vk, vkid, rsid)
, VerifKeyDetail
{ vkdKeyId = luKey
, vkdKey = verifKeyPublic vk
, vkdExpires = verifKeyExpires vk
, vkdActorId = ua
, vkdShared = s
}
)
Nothing -> fetched2vkd luKey <$> fetchUnknownKey manager malgo host mluActorHeader luKey
let verify k = ExceptT . pure $ verifySignature k input signature
errSig1 = throwE "Fetched fresh key; Crypto sig verification says not valid"
errSig2 = throwE "Used key from DB; Crypto sig verification says not valid; fetched fresh key; still not valid"
errTime = throwE "Key expired"
now <- liftIO getCurrentTime
let stillValid Nothing = True
stillValid (Just expires) = expires > now
valid1 <- verify $ vkdKey vkd
(iid, rsid) <-
if valid1 && stillValid (vkdExpires vkd)
then case inboxOrVkid of
Left (mname, uinb) -> ExceptT $ withHostLock host $ runDB $ runExceptT $ addVerifKey host mname uinb vkd
Right (iid, _vkid, rsid) -> return (iid, rsid)
else case inboxOrVkid of
Left _ ->
if stillValid $ vkdExpires vkd
then errSig1
else errTime
Right (iid, vkid, rsid) -> do
let ua = vkdActorId vkd
(newKey, newExp) <-
if vkdShared vkd
then fetchKnownSharedKey manager malgo host ua luKey
else fetchKnownPersonalKey manager malgo host ua luKey
if stillValid newExp
then return ()
else errTime
valid2 <- verify newKey
if valid2
then do
lift $ runDB $ updateVerifKey vkid vkd
{ vkdKey = newKey
, vkdExpires = newExp
}
return (iid, rsid)
else errSig2
return ActivityDetail
{ actdAuthorURI = l2f host $ vkdActorId vkd
, actdInstance = iid
, actdAuthorId = rsid
-- , actdRawBody = body
-- , actdSignKey = keyid
-- , actdDigest = digest
}
where
fetched2vkd uk (Fetched k mexp ua mname uinb s) =
( Left (mname, uinb)
, VerifKeyDetail
{ vkdKeyId = uk
, vkdKey = k
, vkdExpires = mexp
, vkdActorId = ua
, vkdShared = s
}
)
updateVerifKey vkid vkd =
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 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 input signature hKey luKey (Just luAuthor)
authenticateActivity
:: UTCTime
-> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity)
authenticateActivity now = do
(ad, wv, body) <- do
verifyContentType
proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
let requires = [hRequestTarget, hHost, hDigest]
wants = [hActivityPubActor]
seconds =
let toSeconds :: TimeInterval -> Second
toSeconds = toTimeUnit
in fromIntegral $ toSeconds timeLimit
prepareToVerifyHttpSig requires wants seconds now
(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
return (detail, wvdoc, body)
let WithValue raw (Doc hActivity activity) = wv
uSender = actdAuthorURI ad
(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
, ">"
]
return $ Right ad
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_, body, raw, activity)
where
verifyContentType = do
ctypes <- lookupHeaders "Content-Type"
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\""
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
withExceptT T.pack $ verifyForwardedSig hAuthor luAuthor proof
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
prependError :: Monad m => Text -> ExceptT Text m a -> ExceptT Text m a
prependError t a = do
r <- lift $ runExceptT a
@ -405,14 +124,13 @@ parseTicket project luContext = do
handleSharerInbox
:: UTCTime
-> ShrIdent
-> Either PersonId InstanceId
-> Object
-> Activity
-> ActivityAuthentication
-> ActivityBody
-> ExceptT Text Handler Text
handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
handleSharerInbox _now shrRecip (ActivityAuthLocalPerson pidAuthor) body = do
(shrActivity, obiid) <- do
route <-
case decodeRouteLocal $ activityId activity of
case decodeRouteLocal $ activityId $ actbActivity body of
Nothing -> throwE "Local activity: Not a valid route"
Just r -> return r
case route of
@ -449,30 +167,76 @@ handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
"Activity already exists in inbox of /s/" <> recip
Just _ ->
return $ "Activity inserted to inbox of /s/" <> recip
handleSharerInbox now shrRecip (Right iidAuthor) raw activity =
case activitySpecific activity of
handleSharerInbox _now shrRecip (ActivityAuthLocalProject jidAuthor) body = do
(shrActivity, prjActivity, obiid) <- do
route <-
case decodeRouteLocal $ activityId $ actbActivity body of
Nothing -> throwE "Local activity: Not a valid route"
Just r -> return r
case route of
ProjectOutboxItemR shr prj obikhid ->
(shr,prj,) <$> decodeKeyHashidE obikhid "Local activity: ID is invalid hashid"
_ -> throwE "Local activity: Not an activity route"
runDBExcept $ do
Entity pidRecip personRecip <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniquePersonIdent sid
mobi <- lift $ get obiid
obi <- fromMaybeE mobi "Local activity: No such ID in DB"
mjidOutbox <-
lift $ getKeyBy $ UniqueProjectOutbox $ outboxItemOutbox obi
jidOutbox <-
fromMaybeE mjidOutbox "Local activity not in a project outbox"
j <- lift $ getJust jidOutbox
s <- lift $ getJust $ projectSharer j
unless (sharerIdent s == shrActivity) $
throwE "Local activity: ID invalid, hashid and author shr mismatch"
unless (projectIdent j == prjActivity) $
throwE "Local activity: ID invalid, hashid and author prj mismatch"
unless (jidAuthor == jidOutbox) $
throwE "Activity author in DB and in received JSON don't match"
lift $ do
ibiid <- insert $ InboxItem True
let ibid = personInbox personRecip
miblid <- insertUnique $ InboxItemLocal ibid obiid ibiid
let recip = shr2text shrRecip
case miblid of
Nothing -> do
delete ibiid
return $
"Activity already exists in inbox of /s/" <> recip
Just _ ->
return $ "Activity inserted to inbox of /s/" <> recip
handleSharerInbox now shrRecip (ActivityAuthRemote author) body =
case activitySpecific $ actbActivity body of
CreateActivity (Create note) ->
sharerCreateNoteRemoteF now shrRecip iidAuthor raw activity note
sharerCreateNoteF now shrRecip author body note
OfferActivity offer ->
sharerOfferTicketRemoteF
now shrRecip iidAuthor raw (activityId activity) offer
sharerOfferTicketF now shrRecip author body offer
_ -> return "Unsupported activity type"
handleProjectInbox
:: UTCTime
-> ShrIdent
-> PrjIdent
-> InstanceId
-> Text
-> RemoteActorId
-> BL.ByteString
-> Object
-> Activity
-> ActivityAuthentication
-> ActivityBody
-> ExceptT Text Handler Text
handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw activity =
case activitySpecific activity of
handleProjectInbox now shrRecip prjRecip auth body = do
remoteAuthor <-
case auth of
ActivityAuthLocalPerson pid ->
throwE $
"Project inbox got local forwarded activity by pid#" <>
T.pack (show $ fromSqlKey pid)
ActivityAuthLocalProject jid ->
throwE $
"Project inbox got local forwarded activity by jid#" <>
T.pack (show $ fromSqlKey jid)
ActivityAuthRemote ra -> return ra
case activitySpecific $ actbActivity body of
CreateActivity (Create note) ->
projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw activity (activityAudience activity) note
projectCreateNoteF now shrRecip prjRecip remoteAuthor body note
_ -> return "Unsupported activity type"
fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()

View file

@ -0,0 +1,400 @@
{- This file is part of Vervis.
-
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
module Vervis.Federation.Auth
( RemoteAuthor (..)
, ActivityAuthentication (..)
, ActivityBody (..)
, authenticateActivity
)
where
import Control.Applicative
import Control.Concurrent.MVar
import Control.Concurrent.STM.TVar
import Control.Exception hiding (Handler, try)
import Control.Monad
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Crypto.Hash
import Data.Aeson
import Data.Bifunctor
import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
import Data.Function
import Data.List (sort, deleteBy, nub, union, unionBy, partition)
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Maybe
import Data.Semigroup
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time.Clock
import Data.Time.Units
import Data.Traversable
import Data.Tuple
import Database.Persist hiding (deleteBy)
import Database.Persist.Sql hiding (deleteBy)
import Network.HTTP.Client
import Network.HTTP.Types.Header
import Network.HTTP.Types.URI
import Network.TLS hiding (SHA256)
import UnliftIO.Exception (try)
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
import Yesod.Persist.Core
import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI
import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T
import qualified Database.Esqueleto as E
import qualified Network.Wai as W
import Data.Time.Interval
import Network.HTTP.Signature hiding (requestHeaders)
import Yesod.HttpSignature
import Crypto.PublicVerifKey
import Database.Persist.JSON
import Network.FedURI
import Network.HTTP.Digest
import Web.ActivityPub hiding (Follow)
import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Control.Monad.Trans.Except.Local
import Data.Aeson.Local
import Data.Either.Local
import Data.List.Local
import Data.List.NonEmpty.Local
import Data.Maybe.Local
import Data.Tuple.Local
import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.ActivityPub
import Vervis.ActorKey
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.RemoteActorStore
import Vervis.Settings
data RemoteAuthor = RemoteAuthor
{ remoteAuthorURI :: FedURI
, remoteAuthorInstance :: InstanceId
, remoteAuthorId :: RemoteActorId
}
data ActivityAuthentication
= ActivityAuthLocalPerson PersonId
| ActivityAuthLocalProject ProjectId
| ActivityAuthRemote RemoteAuthor
data ActivityBody = ActivityBody
{ actbBL :: BL.ByteString
, actbObject :: Object
, actbActivity :: Activity
}
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 input (Signature signature) host luKey mluActorHeader = do
manager <- getsYesod appHttpManager
(inboxOrVkid, vkd) <- do
ments <- lift $ runDB $ do
mvk <- runMaybeT $ do
Entity iid _ <- MaybeT $ getBy $ UniqueInstance host
MaybeT $ getBy $ UniqueVerifKey iid luKey
for mvk $ \ vk@(Entity _ verifkey) -> do
mremote <- for (verifKeySharer verifkey) $ \ rsid ->
(rsid,) <$> getJust rsid
return (vk, mremote)
case ments of
Just (Entity vkid vk, mremote) -> do
(ua, s, rsid) <-
case mremote of
Just (rsid, rs) -> do
let sharer = remoteActorIdent rs
for_ mluActorHeader $ \ u ->
if sharer == u
then return ()
else throwE "Key's owner doesn't match actor header"
return (sharer, False, rsid)
Nothing -> do
ua <- case mluActorHeader of
Nothing -> throwE "Got a sig with an instance key, but actor header not specified!"
Just u -> return u
let iid = verifKeyInstance vk
rsid <- withHostLock' host $ keyListedByActorShared iid vkid host luKey ua
return (ua, True, rsid)
return
( Right (verifKeyInstance vk, vkid, rsid)
, VerifKeyDetail
{ vkdKeyId = luKey
, vkdKey = verifKeyPublic vk
, vkdExpires = verifKeyExpires vk
, vkdActorId = ua
, vkdShared = s
}
)
Nothing -> fetched2vkd luKey <$> fetchUnknownKey manager malgo host mluActorHeader luKey
let verify k = ExceptT . pure $ verifySignature k input signature
errSig1 = throwE "Fetched fresh key; Crypto sig verification says not valid"
errSig2 = throwE "Used key from DB; Crypto sig verification says not valid; fetched fresh key; still not valid"
errTime = throwE "Key expired"
now <- liftIO getCurrentTime
let stillValid Nothing = True
stillValid (Just expires) = expires > now
valid1 <- verify $ vkdKey vkd
(iid, rsid) <-
if valid1 && stillValid (vkdExpires vkd)
then case inboxOrVkid of
Left (mname, uinb) -> ExceptT $ withHostLock host $ runDB $ runExceptT $ addVerifKey host mname uinb vkd
Right (iid, _vkid, rsid) -> return (iid, rsid)
else case inboxOrVkid of
Left _ ->
if stillValid $ vkdExpires vkd
then errSig1
else errTime
Right (iid, vkid, rsid) -> do
let ua = vkdActorId vkd
(newKey, newExp) <-
if vkdShared vkd
then fetchKnownSharedKey manager malgo host ua luKey
else fetchKnownPersonalKey manager malgo host ua luKey
if stillValid newExp
then return ()
else errTime
valid2 <- verify newKey
if valid2
then do
lift $ runDB $ updateVerifKey vkid vkd
{ vkdKey = newKey
, vkdExpires = newExp
}
return (iid, rsid)
else errSig2
return RemoteAuthor
{ remoteAuthorURI = l2f host $ vkdActorId vkd
, remoteAuthorInstance = iid
, remoteAuthorId = rsid
-- , actdRawBody = body
-- , actdSignKey = keyid
-- , actdDigest = digest
}
where
fetched2vkd uk (Fetched k mexp ua mname uinb s) =
( Left (mname, uinb)
, VerifKeyDetail
{ vkdKeyId = uk
, vkdKey = k
, vkdExpires = mexp
, vkdActorId = ua
, vkdShared = s
}
)
updateVerifKey vkid vkd =
update vkid [VerifKeyExpires =. vkdExpires vkd, VerifKeyPublic =. vkdKey vkd]
withHostLock' h = ExceptT . withHostLock h . runExceptT
verifyActorSig :: Verification -> ExceptT String Handler RemoteAuthor
verifyActorSig (Verification malgo keyid input signature) = do
(host, luKey) <- parseKeyId keyid
checkHost host
mluActorHeader <- getActorHeader host
verifyActorSig' malgo 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 (Either PersonId ProjectId)
verifySelfSig luAuthor luKey input (Signature sig) = do
author <- 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 $ Left shr
ProjectR shr prj -> return $ Right (shr, prj)
_ -> throwE "Local author ID isn't an actor 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
mauthorId <- runMaybeT $ bitraverse getPerson getProject author
return $
case mauthorId of
Nothing -> Left "Local author: No such user/project"
Just id_ -> Right id_
where
getPerson shr = do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getKeyBy $ UniquePersonIdent sid
getProject (shr, prj) = do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getKeyBy $ UniqueProject prj sid
verifyForwardedSig :: Text -> LocalURI -> Verification -> ExceptT String Handler ActivityAuthentication
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 mkauth <$> verifySelfSig luAuthor luKey input signature
else ActivityAuthRemote <$> verifyActorSig' malgo input signature hKey luKey (Just luAuthor)
where
mkauth (Left pid) = ActivityAuthLocalPerson pid
mkauth (Right jid) = ActivityAuthLocalProject jid
authenticateActivity
:: UTCTime
-- -> ExceptT Text Handler (Either PersonId ActivityDetail, BL.ByteString, Object, Activity)
-> ExceptT Text Handler (ActivityAuthentication, ActivityBody)
authenticateActivity now = do
(ra, wv, body) <- do
verifyContentType
proof <- withExceptT (T.pack . displayException) $ ExceptT $ do
timeLimit <- getsYesod $ appHttpSigTimeLimit . appSettings
let requires = [hRequestTarget, hHost, hDigest]
wants = [hActivityPubActor]
seconds =
let toSeconds :: TimeInterval -> Second
toSeconds = toTimeUnit
in fromIntegral $ toSeconds timeLimit
prepareToVerifyHttpSig requires wants seconds now
(remoteAuthor, 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
return (remoteAuthor, wvdoc, body)
let WithValue raw (Doc hActivity activity) = wv
uSender = remoteAuthorURI ra
(hSender, luSender) = f2l uSender
auth <-
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
, ">"
]
return $ ActivityAuthRemote ra
else do
-- TODO CONTINUE
ma <- checkForward uSender hActivity (activityActor activity)
case ma of
Nothing -> throwE $ T.concat
[ "Activity host <", hActivity
, "> doesn't match signature key host <", hSender, ">"
]
Just a -> return a
return (auth, ActivityBody body raw activity)
where
verifyContentType = do
ctypes <- lookupHeaders "Content-Type"
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\""
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
withExceptT T.pack $ verifyForwardedSig hAuthor luAuthor proof
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

View file

@ -14,7 +14,7 @@
-}
module Vervis.Federation.Discussion
( sharerCreateNoteRemoteF
( sharerCreateNoteF
, projectCreateNoteF
)
where
@ -92,13 +92,21 @@ import Yesod.Persist.Local
import Vervis.ActivityPub
--import Vervis.ActorKey
import Vervis.Federation.Auth
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
--import Vervis.RemoteActorStore
import Vervis.Settings
sharerCreateNoteRemoteF now shrRecip iidSender raw activity (Note mluNote _ _ muParent muContext mpublished _ _) = do
sharerCreateNoteF
:: UTCTime
-> ShrIdent
-> RemoteAuthor
-> ActivityBody
-> Note
-> ExceptT Text Handler Text
sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext mpublished _ _) = do
_luNote <- fromMaybeE mluNote "Note without note id"
_published <- fromMaybeE mpublished "Note without 'published' field"
uContext <- fromMaybeE muContext "Note without context"
@ -162,9 +170,10 @@ sharerCreateNoteRemoteF now shrRecip iidSender raw activity (Note mluNote _ _ mu
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
insertToInbox ibidRecip = do
let luActivity = activityId activity
jsonObj = PersistJSON raw
ract = RemoteActivity iidSender luActivity jsonObj now
let iidAuthor = remoteAuthorInstance author
luActivity = activityId $ actbActivity body
jsonObj = PersistJSON $ actbObject body
ract = RemoteActivity iidAuthor luActivity jsonObj now
ractid <- either entityKey id <$> insertBy' ract
ibiid <- insert $ InboxItem True
mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
@ -181,7 +190,15 @@ data CreateNoteRecipColl
| CreateNoteRecipTicketTeam
deriving Eq
projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw activity audience (Note mluNote _ _ muParent muCtx mpub src content) = do
projectCreateNoteF
:: UTCTime
-> ShrIdent
-> PrjIdent
-> RemoteAuthor
-> ActivityBody
-> Note
-> ExceptT Text Handler Text
projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent muCtx mpub src content) = do
luNote <- fromMaybeE mluNote "Note without note id"
published <- fromMaybeE mpub "Note without 'published' field"
uContext <- fromMaybeE muCtx "Note without context"
@ -201,7 +218,9 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
else do
msig <- checkForward
hLocal <- getsYesod $ appInstanceHost . appSettings
let colls = findRelevantCollections hLocal num audience
let colls =
findRelevantCollections hLocal num $
activityAudience $ actbActivity body
mremotesHttp <- runDBExcept $ do
(sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent num mparent
lift $ join <$> do
@ -287,10 +306,12 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
Nothing -> return $ Right $ l2f hParent luParent
return (sid, fsidProject, ticketFollowers t, jid, ibid, did, meparent)
insertToDiscussion luNote published ibid did meparent fsid = do
let iidAuthor = remoteAuthorInstance author
raidAuthor = remoteAuthorId author
ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityInstance = iidSender
, remoteActivityIdent = activityId activity
, remoteActivityContent = PersistJSON raw
{ remoteActivityInstance = iidAuthor
, remoteActivityIdent = activityId $ actbActivity body
, remoteActivityContent = PersistJSON $ actbObject body
, remoteActivityReceived = now
}
mid <- insert Message
@ -304,8 +325,8 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
, messageRoot = did
}
mrmid <- insertUnique RemoteMessage
{ remoteMessageAuthor = raidSender
, remoteMessageInstance = iidSender
{ remoteMessageAuthor = raidAuthor
, remoteMessageInstance = iidAuthor
, remoteMessageIdent = luNote
, remoteMessageRest = mid
, remoteMessageCreate = ractid
@ -319,12 +340,13 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
delete mid
return Nothing
Just _ -> do
insertUnique_ $ RemoteFollow raidSender fsid False
insertUnique_ $ RemoteFollow raidAuthor fsid False
ibiid <- insert $ InboxItem False
insert_ $ InboxItemRemote ibid ractid ibiid
return $ Just (ractid, mid)
updateOrphans luNote did mid = do
let uNote = l2f hSender luNote
let hAuthor = furiHost $ remoteAuthorURI author
uNote = l2f hAuthor luNote
related <- selectOrphans uNote (E.==.)
for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do
logWarn $ T.concat
@ -391,7 +413,7 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
-> AppDB
[((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
deliverRemoteDB ractid jid sig recips = do
let body' = BL.toStrict body
let body' = BL.toStrict $ actbBL body
deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
fetchedDeliv <- for recips $ \ (i, rs) ->
(i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
@ -408,8 +430,9 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
-> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
-> Handler ()
deliverRemoteHttp sig fetched = do
let deliver h inbox = do
forwardActivity (l2f h inbox) sig (ProjectR shrRecip prjRecip) body
let deliver h inbox =
let sender = ProjectR shrRecip prjRecip
in forwardActivity (l2f h inbox) sig sender (actbBL body)
now <- liftIO getCurrentTime
traverse_ (fork . deliverFetched deliver now) fetched
where

View file

@ -14,7 +14,7 @@
-}
module Vervis.Federation.Ticket
( sharerOfferTicketRemoteF
( sharerOfferTicketF
)
where
@ -39,20 +39,19 @@ import Database.Persist.Local
import Yesod.Persist.Local
import Vervis.ActivityPub
import Vervis.Federation.Auth
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
sharerOfferTicketRemoteF
sharerOfferTicketF
:: UTCTime
-> ShrIdent
-> InstanceId
-> Object
-> LocalURI
-> RemoteAuthor
-> ActivityBody
-> Offer
-> ExceptT Text Handler Text
sharerOfferTicketRemoteF
now shrRecip iidAuthor raw luOffer (Offer ticket uTarget) = do
sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
verifyNothingE (ticketLocal ticket) "Ticket with 'id'"
_published <-
fromMaybeE (ticketPublished ticket) "Ticket without 'published'"
@ -112,7 +111,9 @@ sharerOfferTicketRemoteF
unless (isJust mt) $
throwE "Local dep: No such ticket number in DB"
insertToInbox ibidRecip = do
let jsonObj = PersistJSON raw
let iidAuthor = remoteAuthorInstance author
luOffer = activityId $ actbActivity body
jsonObj = PersistJSON $ actbObject body
ract = RemoteActivity iidAuthor luOffer jsonObj now
ractid <- either entityKey id <$> insertBy' ract
ibiid <- insert $ InboxItem True

View file

@ -113,6 +113,7 @@ import Yesod.Persist.Local
import Vervis.ActorKey
import Vervis.API
import Vervis.Federation
import Vervis.Federation.Auth
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
@ -256,9 +257,8 @@ postSharerInboxR shrRecip = do
contentTypes <- lookupHeaders "Content-Type"
now <- liftIO getCurrentTime
result <- runExceptT $ do
(id_, _body, raw, activity) <- authenticateActivity now
let id' = second actdInstance id_
(raw,) <$> handleSharerInbox now shrRecip id' raw activity
(auth, body) <- authenticateActivity now
(actbObject body,) <$> handleSharerInbox now shrRecip auth body
recordActivity now result contentTypes
case result of
Left _ -> sendResponseStatus badRequest400 ()
@ -285,13 +285,9 @@ postProjectInboxR shrRecip prjRecip = do
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
(auth, body) <- authenticateActivity now
(actbObject body,) <$>
handleProjectInbox now shrRecip prjRecip auth body
recordActivity now result contentTypes
case result of
Left _ -> sendResponseStatus badRequest400 ()

View file

@ -126,6 +126,7 @@ library
Vervis.Darcs
Vervis.Discussion
Vervis.Federation
Vervis.Federation.Auth
Vervis.Federation.Discussion
Vervis.Federation.Ticket
Vervis.Field.Key