diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index eaab436..7594908 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -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 () diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs new file mode 100644 index 0000000..01ca2b8 --- /dev/null +++ b/src/Vervis/Federation/Auth.hs @@ -0,0 +1,400 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index 9ff3b74..fe70188 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -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 diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 74c9a5a..7a09aac 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -14,7 +14,7 @@ -} module Vervis.Federation.Ticket - ( sharerOfferTicketRemoteF + ( sharerOfferTicketF ) where @@ -39,38 +39,37 @@ 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 - verifyNothingE (ticketLocal ticket) "Ticket with 'id'" - _published <- - fromMaybeE (ticketPublished ticket) "Ticket without 'published'" - verifyNothingE (ticketName ticket) "Ticket with 'name'" - verifyNothingE (ticketAssignedTo ticket) "Ticket with 'assignedTo'" - when (ticketIsResolved ticket) $ throwE "Ticket resolved" - (hProject, shrProject, prjProject) <- parseTarget uTarget - unless (null $ ticketDependedBy ticket) $ throwE "Ticket has rdeps" - let checkDep' = checkDep hProject shrProject prjProject - deps <- traverse checkDep' $ ticketDependsOn ticket - local <- hostIsLocal hProject - runDBExcept $ do - ibidRecip <- lift $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - p <- getValBy404 $ UniquePersonIdent sid - return $ personInbox p - when local $ checkTargetAndDeps shrProject prjProject deps - lift $ insertToInbox ibidRecip +sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do + verifyNothingE (ticketLocal ticket) "Ticket with 'id'" + _published <- + fromMaybeE (ticketPublished ticket) "Ticket without 'published'" + verifyNothingE (ticketName ticket) "Ticket with 'name'" + verifyNothingE (ticketAssignedTo ticket) "Ticket with 'assignedTo'" + when (ticketIsResolved ticket) $ throwE "Ticket resolved" + (hProject, shrProject, prjProject) <- parseTarget uTarget + unless (null $ ticketDependedBy ticket) $ throwE "Ticket has rdeps" + let checkDep' = checkDep hProject shrProject prjProject + deps <- traverse checkDep' $ ticketDependsOn ticket + local <- hostIsLocal hProject + runDBExcept $ do + ibidRecip <- lift $ do + sid <- getKeyBy404 $ UniqueSharer shrRecip + p <- getValBy404 $ UniquePersonIdent sid + return $ personInbox p + when local $ checkTargetAndDeps shrProject prjProject deps + lift $ insertToInbox ibidRecip where parseTarget u = do let (h, lu) = f2l u @@ -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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 9777929..7493b8b 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -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 () diff --git a/vervis.cabal b/vervis.cabal index 97dc0e6..013b5ff 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -126,6 +126,7 @@ library Vervis.Darcs Vervis.Discussion Vervis.Federation + Vervis.Federation.Auth Vervis.Federation.Discussion Vervis.Federation.Ticket Vervis.Field.Key