diff --git a/config/models b/config/models index 5088aeb..a6a9365 100644 --- a/config/models +++ b/config/models @@ -40,18 +40,25 @@ Person UniquePersonEmail email VerifKey - ident URI - expires UTCTime Maybe - public PublicKey - sharer RemoteSharerId + ident URI + instance InstanceId + expires UTCTime Maybe + public PublicKey + sharer RemoteSharerId Maybe UniqueVerifKey ident RemoteSharer - ident URI + ident URI + instance InstanceId UniqueRemoteSharer ident +Instance + host Text + + UniqueInstance host + SshKey ident KyIdent person PersonId diff --git a/migrations/2019_02_03_verifkey.model b/migrations/2019_02_03_verifkey.model index 8ae8e16..79dbd9c 100644 --- a/migrations/2019_02_03_verifkey.model +++ b/migrations/2019_02_03_verifkey.model @@ -1,12 +1,19 @@ VerifKey - ident String - expires UTCTime Maybe - public ByteString - sharer RemoteSharerId + ident String + instance InstanceId + expires UTCTime Maybe + public ByteString + sharer RemoteSharerId Maybe UniqueVerifKey ident RemoteSharer - ident String + ident String + instance InstanceId UniqueRemoteSharer ident + +Instance + host Text + + UniqueInstance host diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index d5c5e92..82a822e 100644 --- a/src/Data/Aeson/Local.hs +++ b/src/Data/Aeson/Local.hs @@ -18,6 +18,7 @@ module Data.Aeson.Local , toEither , fromEither , frg + , parseHttpsURI' , parseHttpsURI , renderURI , (.=?) @@ -29,7 +30,6 @@ import Prelude import Control.Applicative ((<|>)) import Data.Aeson import Data.Aeson.Types (Parser) -import Data.Maybe (isJust) import Data.Text (Text) import Network.URI @@ -56,16 +56,22 @@ fromEither (Right y) = Right' y frg :: Text frg = "https://forgefed.angeley.es/ns#" -parseHttpsURI :: Text -> Parser URI -parseHttpsURI t = +parseHttpsURI' :: Text -> Either String URI +parseHttpsURI' t = case parseURI $ T.unpack t of - Nothing -> fail "Invalid absolute URI" + Nothing -> Left "Invalid absolute URI" Just u -> if uriScheme u == "https:" - then if isJust $ uriAuthority u - then return u - else fail "URI has empty authority" - else fail "URI scheme isn't https" + then case uriAuthority u of + Just a -> + if uriUserInfo a == "" && uriPort a == "" + then Right u + else Left "URI has userinfo or port" + Nothing -> Left "URI has empty authority" + else Left "URI scheme isn't https" + +parseHttpsURI :: Text -> Parser URI +parseHttpsURI = either fail return . parseHttpsURI' renderURI :: URI -> String renderURI u = uriToString id u "" diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index eddce07..17f84c9 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -22,7 +22,9 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Crypto.Error (CryptoFailable (..)) import Crypto.PubKey.Ed25519 (publicKey, signature, verify) +import Data.Maybe (fromJust) import Data.PEM (pemContent) +import Data.Text.Encoding (decodeUtf8') import Data.Time.Interval (TimeInterval, fromTimeUnit, toTimeUnit) import Data.Time.Units (Second, Minute, Day) import Database.Persist.Sql (ConnectionPool, runSqlPool) @@ -30,7 +32,7 @@ import Graphics.SVGFonts.ReadFont (PreparedFont) import Network.HTTP.Client (Manager, HttpException, requestFromURI, responseBody) import Network.HTTP.Simple (httpJSONEither, setRequestManager, addRequestHeader) import Network.HTTP.Types.Header (hHost) -import Network.URI (URI (uriFragment), parseURI) +import Network.URI (URI, uriAuthority, uriFragment, uriRegName, parseURI) import Text.Shakespeare.Text (textFile) import Text.Hamlet (hamletFile) --import Text.Jasmine (minifym) @@ -57,6 +59,7 @@ import qualified Network.HTTP.Signature as S (Algorithm (..)) import Web.ActivityPub +import Data.Aeson.Local (parseHttpsURI') import Text.Email.Local import Text.Jasmine.Local (discardm) @@ -560,7 +563,7 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger instance YesodHttpSig App where data HttpSigVerResult App = HttpSigVerResult (Either String URI) - httpSigVerHeaders = const [hRequestTarget, hHost] + httpSigVerHeaders = const [hRequestTarget, hHost, "ActivityPub-Actor"] httpSigVerSeconds = fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings where @@ -580,23 +583,41 @@ instance YesodHttpSig App where case signature sig of CryptoPassed s -> Right s CryptoFailed e -> Left "Parsing Ed25519 signature failed" - (mvkid, key, mexpires, uActor) <- do + muActorHeader <- do + bs <- lookupHeaders "ActivityPub-Actor" + case bs of + [] -> return Nothing + [b] -> fmap Just . ExceptT . pure $ do + t <- first displayException $ decodeUtf8' b + parseHttpsURI' t + _ -> throwE "Multiple ActivityPub-Actor headers" + (mvkid, key, mexpires, uActor, host, shared) <- do ments <- lift $ runDB $ do mvk <- getBy $ UniqueVerifKey u for mvk $ \ vk@(Entity _ verifkey) -> do - remote <- getJust $ verifKeySharer verifkey - return (vk, remote) + mremote <- traverse getJust $ verifKeySharer verifkey + return (vk, mremote) case ments of - Just (Entity vkid vk, remote) -> + Just (Entity vkid vk, mremote) -> do + (ua, s) <- + case mremote of + Just remote -> return (remoteSharerIdent remote, False) + Nothing -> + case muActorHeader of + Nothing -> throwE "Got a sig with an instance key, but actor header not specified!" + Just u -> return (u, True) + let uKey = verifKeyIdent vk return ( Just vkid , verifKeyPublic vk , verifKeyExpires vk - , remoteSharerIdent remote + , ua + , T.pack $ uriRegName $ fromJust $ uriAuthority uKey + , s ) Nothing -> do - (k, mexp, ua) <- fetchKey' u - return (Nothing, k, mexp, ua) + Fetched k mexp ua h s <- fetchKey' muActorHeader u + return (Nothing, k, mexp, ua, h, s) let verify' k = verify k input signature errSig = throwE "Ed25519 sig verification says not valid" errTime = throwE "Key expired" @@ -609,10 +630,17 @@ instance YesodHttpSig App where then return (not existsInDB, key, mexpires) else if existsInDB then do - (newKey, newExp, newActor) <- fetchKey' u - if newActor == uActor + Fetched newKey newExp newActor h s <- fetchKey' muActorHeader u + if shared == s then return () - else throwE "Key owner changed, we reject that" + else throwE "Key scope changed, we reject that" + if shared + then if h == host + then return () + else fail "BUG! We re-fetched a key and the host changed" + else if newActor == uActor + then return () + else throwE "Key owner changed, we reject that" if stillValid newExp then return () else errTime @@ -624,29 +652,51 @@ instance YesodHttpSig App where else errTime when write $ ExceptT $ runDB $ case mvkid of - Nothing -> do - ment <- getBy $ UniqueRemoteSharer uActor - case ment of - Nothing -> do - rsid <- insert $ RemoteSharer uActor - insert_ $ VerifKey u mexpires' key' rsid - return $ Right () - Just (Entity rsid rs) -> do - n <- count [VerifKeySharer ==. rsid] - if n < 2 - then do - insert_ $ VerifKey u mexpires' key' rsid + Nothing -> + if shared + then do + ment <- getBy $ UniqueInstance host + case ment of + Nothing -> do + iid <- insert $ Instance host + insert_ $ VerifKey u iid mexpires' key' Nothing return $ Right () - else return $ Left "We already store 2 keys" + Just (Entity iid _) -> do + n <- count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing] + if n < 2 + then do + insert_ $ VerifKey u iid mexpires' key' Nothing + return $ Right () + else return $ Left "We already store 2 keys" + else do + ment <- getBy $ UniqueRemoteSharer uActor + case ment of + Nothing -> do + iid <- do + ment2 <- getBy $ UniqueInstance host + case ment2 of + Nothing -> insert $ Instance host + Just (Entity i _) -> return i + rsid <- insert $ RemoteSharer uActor iid + insert_ $ VerifKey u iid mexpires' key' (Just rsid) + return $ Right () + Just (Entity rsid rs) -> do + n <- count [VerifKeySharer ==. Just rsid] + if n < 2 + then do + let iid = remoteSharerInstance rs + insert_ $ VerifKey u iid mexpires' key' (Just rsid) + return $ Right () + else return $ Left "We already store 2 keys" Just vkid -> do update vkid [VerifKeyExpires =. mexpires', VerifKeyPublic =. key'] return $ Right () return uActor where - fetchKey' u = do + fetchKey' mua uk = do manager <- getsYesod appHttpManager - ExceptT $ fetchKey manager (isJust malgo) u + ExceptT $ fetchKey manager (isJust malgo) mua uk instance YesodBreadcrumbs App where breadcrumb route = return $ case route of diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 75a122d..f7ba391 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -36,6 +36,7 @@ module Web.ActivityPub , APGetError (..) , httpGetAP , httpPostAP + , Fetched (..) , fetchKey ) where @@ -72,7 +73,7 @@ import Yesod.Core.Handler (ProvidedRep, provideRepType) import qualified Crypto.PubKey.Ed25519 as E (PublicKey, publicKey) import qualified Data.HashMap.Strict as M (lookup) -import qualified Data.Text as T (unpack) +import qualified Data.Text as T (pack, unpack) import qualified Data.Vector as V (fromList, toList) import Data.Aeson.Local @@ -361,57 +362,88 @@ httpPostAP manager uri headers sign value = where consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r } +-- | Result of GETing the keyId URI and processing the JSON document. +data Fetched = Fetched + { fetchedPublicKey :: E.PublicKey + -- ^ The Ed25519 public key corresponding to the URI we requested. + , fetchedKeyExpires :: Maybe UTCTime + -- ^ Optional expiration time declared for the key we received. + , fetchedActorId :: URI + -- ^ The @id URI of the actor for whom the key's signature applies. + , fetchedHost :: Text + -- ^ The domain name of the instance from which we got the key. + , fetchedKeyShared :: Bool + -- ^ Whether the key we received is shared. A shared key can sign + -- requests for any actor on the same instance, while a personal key is + -- only for one actor. Knowing whether the key is shared will allow us + -- when receiving more requests, whether to accept signatures made on + -- different actors, or allow only a single permanent actor for the key + -- we received. + } + fetchKey :: MonadIO m => Manager -> Bool + -> Maybe URI -> URI - -> m (Either String (E.PublicKey, Maybe UTCTime, URI)) -fetchKey manager sigAlgo u = runExceptT $ do + -> m (Either String Fetched) +fetchKey manager sigAlgo muActor uKey = runExceptT $ do let fetch :: (MonadIO m, FromJSON a) => URI -> ExceptT String m a fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u - obj <- fetch u - (actor, pkey, separate) <- + obj <- fetch uKey + let inztance = uKey { uriPath = "", uriQuery = "", uriFragment = "" } + authority = + case uriAuthority uKey of + Nothing -> error "BUG! We were supposed to verify URI authority is non-empty!" + Just a -> a + (actor, pkey, shared) <- case obj of Left' pkey -> do - if publicKeyId pkey == u + if publicKeyId pkey == uKey then return () else throwE "Public key's ID doesn't match the keyid URI" - let authority = - case uriAuthority u of - Nothing -> error "BUG! We were supposed to verify URI authority is non-empty!" - Just a -> a if uriAuthority (publicKeyOwner pkey) == Just authority then return () else throwE "Actor and key on different domains, we reject" - actor <- fetch $ publicKeyOwner pkey + uActor <- + if publicKeyShared pkey + then case muActor of + Nothing -> throwE "Key is shared but actor header not specified!" + Just u -> return u + else return $ publicKeyOwner pkey + actor <- fetch uActor let PublicKeySet k1 mk2 = actorPublicKeys actor - match (Left uri) = uri == u + match (Left uri) = uri == uKey match (Right _) = False if match k1 || maybe False match mk2 - then return (actor, pkey, True) + then return (actor, pkey, publicKeyShared pkey) else throwE "Actor publicKey has no URI matching pkey @id" Right' actor -> do - if actorId actor == u { uriFragment = "" } + if actorId actor == uKey { uriFragment = "" } then return () else throwE "Actor ID doesn't match the keyid URI we fetched" + case muActor of + Nothing -> return () + Just u -> + if actorId actor == u + then return () + else throwE "Key's owner doesn't match actor header" let PublicKeySet k1 mk2 = actorPublicKeys actor match (Left _) = Nothing match (Right pk) = - if publicKeyId pk == u + if publicKeyId pk == uKey then Just pk else Nothing case match k1 <|> (match =<< mk2) of Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID" - Just pk -> return (actor, pk, False) + Just pk -> + if publicKeyShared pk + then throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document" + else return (actor, pk, False) ExceptT . pure $ do - if publicKeyShared pkey - then do - if separate - then Right () - else Left "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document" - let inztance = u { uriPath = "", uriQuery = "", uriFragment = "" } - if publicKeyOwner pkey == inztance + if shared + then if publicKeyOwner pkey == inztance then Right () else Left "Key is shared but its owner isn't the top-level instance URI" else if publicKeyOwner pkey == actorId actor @@ -432,5 +464,11 @@ fetchKey manager sigAlgo u = runExceptT $ do then "Algo mismatch, Ed25519 in Sig but unsupported algo in actor" else "No algo in Sig, unsupported algo in actor" case E.publicKey $ pemContent $ publicKeyPem pkey of - CryptoPassed k -> Right (k, publicKeyExpires pkey, actorId actor) - CryptoFailed e -> Left "Parsing Ed25519 public key failed" + CryptoPassed k -> Right Fetched + { fetchedPublicKey = k + , fetchedKeyExpires = publicKeyExpires pkey + , fetchedActorId = actorId actor + , fetchedHost = T.pack $ uriRegName authority + , fetchedKeyShared = shared + } + CryptoFailed _ -> Left "Parsing Ed25519 public key failed"