diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index acf00a6..c0980c0 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -14,11 +14,12 @@ -} module Vervis.Federation - ( handleSharerInbox + ( authenticateActivity + , handleSharerInbox + , handleProjectInbox , fixRunningDeliveries , handleOutboxNote , retryOutboxDelivery - , authenticateActivity ) where @@ -33,6 +34,7 @@ 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.ByteString (ByteString) @@ -46,6 +48,7 @@ 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) @@ -53,22 +56,27 @@ import Database.Persist.Sql hiding (deleteBy) import Network.HTTP.Client import Network.HTTP.Types.Header import Network.HTTP.Types.URI -import Network.TLS +import Network.TLS hiding (SHA256) import UnliftIO.Exception (try) import Yesod.Core hiding (logError, logWarn, logInfo) import Yesod.Persist.Core +import qualified Data.ByteString.Lazy as BL 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 Network.HTTP.Signature +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 @@ -91,6 +99,203 @@ 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 + } + +verifyActorSig :: Verification -> ExceptT String Handler ActivityDetail +verifyActorSig (Verification malgo (KeyId keyid) input (Signature signature)) = do + (host, luKey) <- f2l <$> parseKeyId keyid + checkHost host + (body, digest) <- verifyBodyDigest + mluActorHeader <- getActorHeader host + 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 uinb -> ExceptT $ withHostLock host $ runDB $ runExceptT $ addVerifKey host uinb vkd + Right (iid, _vkid, rsid) -> return (iid, rsid) + else case inboxOrVkid of + Left _uinb -> + 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 keyid + , _actdDigest = digest + } + where + parseKeyId k = + case parseFedURI =<< (first displayException . decodeUtf8') k of + Left e -> throwE $ "keyId in Sig header isn't a valid FedURI: " ++ e + Right u -> return u + checkHost h = do + home <- getsYesod $ appInstanceHost . appSettings + when (h == home) $ + throwE "Received HTTP signed request from the instance's host" + verifyBodyDigest = do + req <- waiRequest + let headers = W.requestHeaders req + digest <- case parseHttpBodyDigest SHA256 "SHA-256" headers of + Left s -> throwE $ "Parsing digest header failed: " ++ s + Right d -> return d + (digest', body) <- liftIO $ hashHttpBody SHA256 (W.requestBody req) + unless (digest == digest') $ + throwE "Body digest verification failed" + return (body, digest) + getActorHeader host = do + bs <- lookupHeaders hActivityPubActor + case bs of + [] -> return Nothing + [b] -> fmap Just . ExceptT . pure $ do + t <- first displayException $ decodeUtf8' b + (h, lu) <- f2l <$> parseFedURI t + if h == host + then Right () + else Left "Key and actor have different hosts" + Right lu + _ -> throwE "Multiple ActivityPub-Actor headers" + fetched2vkd uk (Fetched k mexp ua uinb s) = + ( Left uinb + , VerifKeyDetail + { 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 + +authenticateActivity + :: UTCTime + -> ExceptT Text Handler (InstanceId, Object, Activity) +authenticateActivity now = 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 + ActivityDetail uSender iid _raid body _keyid _digest <- + withExceptT T.pack $ verifyActorSig proof + WithValue raw (Doc hActivity activity) <- + case eitherDecode' body of + Left s -> throwE $ "Parsing activity failed: " <> T.pack s + Right wv -> return wv + let (hSender, luSender) = f2l uSender + unless (hSender == hActivity) $ + throwE $ T.concat + [ "Activity host <", hActivity + , "> doesn't match signature key host <", hSender, ">" + ] + unless (activityActor activity == luSender) $ + throwE $ T.concat + [ "Activity's actor <" + , renderFedURI $ l2f hActivity $ activityActor activity + , "> != Signature key's actor <", renderFedURI uSender, ">" + ] + return (iid, 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\"" + hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings @@ -1312,49 +1517,3 @@ retryOutboxDelivery = do unless (and results) $ logError $ "Periodic UDL delivery error for host " <> h return True - -authenticateActivity - :: UTCTime - -> [ByteString] - -> ExceptT Text Handler (InstanceId, Object, Activity) -authenticateActivity now ctypes = do - verifyContentType - HttpSigVerResult result <- - ExceptT $ - first (T.pack . displayException) <$> - verifyRequestSignature now - ActivityDetail uSender iid _raid body _keyid _digest <- ExceptT $ pure $ first T.pack result - WithValue raw (Doc hActivity activity) <- - case eitherDecode' body of - Left s -> throwE $ "Parsing activity failed: " <> T.pack s - Right wv -> return wv - let (hSender, luSender) = f2l uSender - unless (hSender == hActivity) $ - throwE $ T.concat - [ "Activity host <", hActivity - , "> doesn't match signature key host <", hSender, ">" - ] - unless (activityActor activity == luSender) $ - throwE $ T.concat - [ "Activity's actor <" - , renderFedURI $ l2f hActivity $ activityActor activity - , "> != Signature key's actor <", renderFedURI uSender, ">" - ] - return (iid, raw, activity) - where - verifyContentType = - 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\"" diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 0ed9d0d..a7edc76 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -64,7 +64,6 @@ import Network.HTTP.Digest import Network.HTTP.Signature hiding (Algorithm (..), requestHeaders) import Yesod.Auth.Unverified import Yesod.Auth.Unverified.Creds -import Yesod.HttpSignature (YesodHttpSig (..)) import Yesod.Mail.Send import qualified Network.HTTP.Signature as S (Algorithm (..)) @@ -657,167 +656,6 @@ instance YesodActivityPub App where else (renderUrl ActorKey2R, akey2) return (KeyId $ encodeUtf8 keyID, actorKeySign akey) -data ActorDetail = ActorDetail - { actorDetailId :: FedURI - , actorDetailInstance :: InstanceId - , actorDetailSharer :: RemoteActorId - } - -data ActivityDetail = ActivityDetail - { _actdAuthorURI :: FedURI - , _actdInstance :: InstanceId - , _actdAuthorId :: RemoteActorId - , _actdRawBody :: BL.ByteString - , _actdSignKey :: KeyId - , _actdDigest :: Digest SHA256 - } - -instance YesodHttpSig App where - data HttpSigVerResult App = HttpSigVerResult (Either String ActivityDetail) - httpSigVerRequiredHeaders = const [hRequestTarget, hHost, hDigest] - httpSigVerWantedHeaders = const [hActivityPubActor] - httpSigVerSeconds = - fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings - where - toSeconds :: TimeInterval -> Second - toSeconds = toTimeUnit - httpVerifySig (Verification malgo (KeyId keyid) input (Signature signature)) = fmap HttpSigVerResult $ runExceptT $ do - (host, luKey) <- f2l <$> parseKeyId keyid - checkHost host - (body, digest) <- verifyBodyDigest - mluActorHeader <- getActorHeader host - 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 uinb -> ExceptT $ withHostLock host $ runDB $ runExceptT $ addVerifKey host uinb vkd - Right (iid, _vkid, rsid) -> return (iid, rsid) - else case inboxOrVkid of - Left _uinb -> - 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 keyid - , _actdDigest = digest - } - where - parseKeyId k = - case parseFedURI =<< (first displayException . decodeUtf8') k of - Left e -> throwE $ "keyId in Sig header isn't a valid FedURI: " ++ e - Right u -> return u - checkHost h = do - home <- getsYesod $ appInstanceHost . appSettings - when (h == home) $ - throwE "Received HTTP signed request from the instance's host" - where - isAsciiLetter c = isAsciiLower c || isAsciiUpper c - verifyBodyDigest = do - req <- waiRequest - let headers = 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 (requestBody req) - unless (digest == digest') $ - throwE "Body digest verification failed" - return (body, digest) - getActorHeader host = do - bs <- lookupHeaders hActivityPubActor - case bs of - [] -> return Nothing - [b] -> fmap Just . ExceptT . pure $ do - t <- first displayException $ decodeUtf8' b - (h, lu) <- f2l <$> parseFedURI t - if h == host - then Right () - else Left "Key and actor have different hosts" - Right lu - _ -> throwE "Multiple ActivityPub-Actor headers" - fetched2vkd uk (Fetched k mexp ua uinb s) = - ( Left uinb - , VerifKeyDetail - { 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 - instance YesodBreadcrumbs App where breadcrumb route = return $ case route of StaticR _ -> ("", Nothing) diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 126899a..780cda8 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -141,7 +141,7 @@ postSharerInboxR shrRecip = do contentTypes <- lookupHeaders "Content-Type" now <- liftIO getCurrentTime result <- runExceptT $ do - (iid, raw, activity) <- authenticateActivity now contentTypes + (iid, raw, activity) <- authenticateActivity now (raw,) <$> handleSharerInbox now shrRecip iid raw activity recordActivity now result contentTypes case result of