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 module Vervis.Federation
( ActivityDetail (..) ( handleSharerInbox
, authenticateActivity
, handleSharerInbox
, handleProjectInbox , handleProjectInbox
, fixRunningDeliveries , fixRunningDeliveries
, retryOutboxDelivery , retryOutboxDelivery
@ -95,6 +93,7 @@ import Yesod.Persist.Local
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.Federation.Auth
import Vervis.Federation.Discussion import Vervis.Federation.Discussion
import Vervis.Federation.Ticket import Vervis.Federation.Ticket
import Vervis.Foundation import Vervis.Foundation
@ -103,286 +102,6 @@ import Vervis.Model.Ident
import Vervis.RemoteActorStore import Vervis.RemoteActorStore
import Vervis.Settings 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 :: Monad m => Text -> ExceptT Text m a -> ExceptT Text m a
prependError t a = do prependError t a = do
r <- lift $ runExceptT a r <- lift $ runExceptT a
@ -405,14 +124,13 @@ parseTicket project luContext = do
handleSharerInbox handleSharerInbox
:: UTCTime :: UTCTime
-> ShrIdent -> ShrIdent
-> Either PersonId InstanceId -> ActivityAuthentication
-> Object -> ActivityBody
-> Activity
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do handleSharerInbox _now shrRecip (ActivityAuthLocalPerson pidAuthor) body = do
(shrActivity, obiid) <- do (shrActivity, obiid) <- do
route <- route <-
case decodeRouteLocal $ activityId activity of case decodeRouteLocal $ activityId $ actbActivity body of
Nothing -> throwE "Local activity: Not a valid route" Nothing -> throwE "Local activity: Not a valid route"
Just r -> return r Just r -> return r
case route of case route of
@ -449,30 +167,76 @@ handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
"Activity already exists in inbox of /s/" <> recip "Activity already exists in inbox of /s/" <> recip
Just _ -> Just _ ->
return $ "Activity inserted to inbox of /s/" <> recip return $ "Activity inserted to inbox of /s/" <> recip
handleSharerInbox now shrRecip (Right iidAuthor) raw activity = handleSharerInbox _now shrRecip (ActivityAuthLocalProject jidAuthor) body = do
case activitySpecific activity of (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) -> CreateActivity (Create note) ->
sharerCreateNoteRemoteF now shrRecip iidAuthor raw activity note sharerCreateNoteF now shrRecip author body note
OfferActivity offer -> OfferActivity offer ->
sharerOfferTicketRemoteF sharerOfferTicketF now shrRecip author body offer
now shrRecip iidAuthor raw (activityId activity) offer
_ -> return "Unsupported activity type" _ -> return "Unsupported activity type"
handleProjectInbox handleProjectInbox
:: UTCTime :: UTCTime
-> ShrIdent -> ShrIdent
-> PrjIdent -> PrjIdent
-> InstanceId -> ActivityAuthentication
-> Text -> ActivityBody
-> RemoteActorId
-> BL.ByteString
-> Object
-> Activity
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw activity = handleProjectInbox now shrRecip prjRecip auth body = do
case activitySpecific activity of 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) -> 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" _ -> return "Unsupported activity type"
fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m () 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 module Vervis.Federation.Discussion
( sharerCreateNoteRemoteF ( sharerCreateNoteF
, projectCreateNoteF , projectCreateNoteF
) )
where where
@ -92,13 +92,21 @@ import Yesod.Persist.Local
import Vervis.ActivityPub import Vervis.ActivityPub
--import Vervis.ActorKey --import Vervis.ActorKey
import Vervis.Federation.Auth
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
--import Vervis.RemoteActorStore --import Vervis.RemoteActorStore
import Vervis.Settings 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" _luNote <- fromMaybeE mluNote "Note without note id"
_published <- fromMaybeE mpublished "Note without 'published' field" _published <- fromMaybeE mpublished "Note without 'published' field"
uContext <- fromMaybeE muContext "Note without context" uContext <- fromMaybeE muContext "Note without context"
@ -162,9 +170,10 @@ sharerCreateNoteRemoteF now shrRecip iidSender raw activity (Note mluNote _ _ mu
unless (messageRoot m == did) $ unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion" throwE "Remote parent belongs to a different discussion"
insertToInbox ibidRecip = do insertToInbox ibidRecip = do
let luActivity = activityId activity let iidAuthor = remoteAuthorInstance author
jsonObj = PersistJSON raw luActivity = activityId $ actbActivity body
ract = RemoteActivity iidSender luActivity jsonObj now jsonObj = PersistJSON $ actbObject body
ract = RemoteActivity iidAuthor luActivity jsonObj now
ractid <- either entityKey id <$> insertBy' ract ractid <- either entityKey id <$> insertBy' ract
ibiid <- insert $ InboxItem True ibiid <- insert $ InboxItem True
mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
@ -181,7 +190,15 @@ data CreateNoteRecipColl
| CreateNoteRecipTicketTeam | CreateNoteRecipTicketTeam
deriving Eq 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" luNote <- fromMaybeE mluNote "Note without note id"
published <- fromMaybeE mpub "Note without 'published' field" published <- fromMaybeE mpub "Note without 'published' field"
uContext <- fromMaybeE muCtx "Note without context" uContext <- fromMaybeE muCtx "Note without context"
@ -201,7 +218,9 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
else do else do
msig <- checkForward msig <- checkForward
hLocal <- getsYesod $ appInstanceHost . appSettings hLocal <- getsYesod $ appInstanceHost . appSettings
let colls = findRelevantCollections hLocal num audience let colls =
findRelevantCollections hLocal num $
activityAudience $ actbActivity body
mremotesHttp <- runDBExcept $ do mremotesHttp <- runDBExcept $ do
(sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent num mparent (sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent num mparent
lift $ join <$> do lift $ join <$> do
@ -287,10 +306,12 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
Nothing -> return $ Right $ l2f hParent luParent Nothing -> return $ Right $ l2f hParent luParent
return (sid, fsidProject, ticketFollowers t, jid, ibid, did, meparent) return (sid, fsidProject, ticketFollowers t, jid, ibid, did, meparent)
insertToDiscussion luNote published ibid did meparent fsid = do insertToDiscussion luNote published ibid did meparent fsid = do
let iidAuthor = remoteAuthorInstance author
raidAuthor = remoteAuthorId author
ractid <- either entityKey id <$> insertBy' RemoteActivity ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityInstance = iidSender { remoteActivityInstance = iidAuthor
, remoteActivityIdent = activityId activity , remoteActivityIdent = activityId $ actbActivity body
, remoteActivityContent = PersistJSON raw , remoteActivityContent = PersistJSON $ actbObject body
, remoteActivityReceived = now , remoteActivityReceived = now
} }
mid <- insert Message mid <- insert Message
@ -304,8 +325,8 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
, messageRoot = did , messageRoot = did
} }
mrmid <- insertUnique RemoteMessage mrmid <- insertUnique RemoteMessage
{ remoteMessageAuthor = raidSender { remoteMessageAuthor = raidAuthor
, remoteMessageInstance = iidSender , remoteMessageInstance = iidAuthor
, remoteMessageIdent = luNote , remoteMessageIdent = luNote
, remoteMessageRest = mid , remoteMessageRest = mid
, remoteMessageCreate = ractid , remoteMessageCreate = ractid
@ -319,12 +340,13 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
delete mid delete mid
return Nothing return Nothing
Just _ -> do Just _ -> do
insertUnique_ $ RemoteFollow raidSender fsid False insertUnique_ $ RemoteFollow raidAuthor fsid False
ibiid <- insert $ InboxItem False ibiid <- insert $ InboxItem False
insert_ $ InboxItemRemote ibid ractid ibiid insert_ $ InboxItemRemote ibid ractid ibiid
return $ Just (ractid, mid) return $ Just (ractid, mid)
updateOrphans luNote did mid = do updateOrphans luNote did mid = do
let uNote = l2f hSender luNote let hAuthor = furiHost $ remoteAuthorURI author
uNote = l2f hAuthor luNote
related <- selectOrphans uNote (E.==.) related <- selectOrphans uNote (E.==.)
for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do
logWarn $ T.concat logWarn $ T.concat
@ -391,7 +413,7 @@ projectCreateNoteF now shrRecip prjRecip iidSender hSender raidSender body raw a
-> AppDB -> AppDB
[((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))] [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
deliverRemoteDB ractid jid sig recips = do 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 deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
fetchedDeliv <- for recips $ \ (i, rs) -> fetchedDeliv <- for recips $ \ (i, rs) ->
(i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) 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))] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
-> Handler () -> Handler ()
deliverRemoteHttp sig fetched = do deliverRemoteHttp sig fetched = do
let deliver h inbox = do let deliver h inbox =
forwardActivity (l2f h inbox) sig (ProjectR shrRecip prjRecip) body let sender = ProjectR shrRecip prjRecip
in forwardActivity (l2f h inbox) sig sender (actbBL body)
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
traverse_ (fork . deliverFetched deliver now) fetched traverse_ (fork . deliverFetched deliver now) fetched
where where

View file

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

View file

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

View file

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