Support for instance-scope keys when verifying HTTP signature

config/models

@@ -40,18 +40,25 @@ Person
     UniquePersonEmail email
 
 VerifKey
-    ident   URI
+    ident    URI
-    expires UTCTime Maybe
+    instance InstanceId
-    public  PublicKey
+    expires  UTCTime Maybe
-    sharer  RemoteSharerId
+    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

migrations/2019_02_03_verifkey.model

@@ -1,12 +1,19 @@
 VerifKey
-    ident   String
+    ident    String
-    expires UTCTime Maybe
+    instance InstanceId
-    public  ByteString
+    expires  UTCTime Maybe
-    sharer  RemoteSharerId
+    public   ByteString
+    sharer   RemoteSharerId Maybe
 
     UniqueVerifKey ident
 
 RemoteSharer
-    ident String
+    ident    String
+    instance InstanceId
 
     UniqueRemoteSharer ident
+
+Instance
+    host Text
+
+    UniqueInstance host

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' :: Text -> Either String URI
-parseHttpsURI t =
+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 case uriAuthority u of
-                        then return u
+                        Just a ->
-                        else fail "URI has empty authority"
+                            if uriUserInfo a == "" && uriPort a == ""
-                else fail "URI scheme isn't https"
+                                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 ""

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
+                    mremote <- traverse getJust $ verifKeySharer verifkey
-                    return (vk, remote)
+                    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
+                    Fetched k mexp ua h s <- fetchKey' muActorHeader u
-                    return (Nothing, k, mexp, ua)
+                    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
+                        Fetched newKey newExp newActor h s <- fetchKey' muActorHeader u
-                        if newActor == uActor
+                        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
+                Nothing ->
-                    ment <- getBy $ UniqueRemoteSharer uActor
+                    if shared
-                    case ment of
+                        then do
-                        Nothing -> do
+                            ment <- getBy $ UniqueInstance host
-                            rsid <- insert $ RemoteSharer uActor
+                            case ment of
-                            insert_ $ VerifKey u mexpires' key' rsid
+                                Nothing -> do
-                            return $ Right ()
+                                    iid <- insert $ Instance host
-                        Just (Entity rsid rs) -> do
+                                    insert_ $ VerifKey u iid mexpires' key' Nothing
-                            n <- count [VerifKeySharer ==. rsid]
-                            if n < 2
-                                then do
-                                    insert_ $ VerifKey u mexpires' key' rsid
                                     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

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))
+    -> m (Either String Fetched)
-fetchKey manager sigAlgo u = runExceptT $ do
+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
+    obj <- fetch uKey
-    (actor, pkey, separate) <-
+    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
+        if shared
-            then do
+            then if publicKeyOwner pkey == inztance
-                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
                     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)
+            CryptoPassed k -> Right Fetched
-            CryptoFailed e -> Left "Parsing Ed25519 public key failed"
+                { fetchedPublicKey  = k
+                , fetchedKeyExpires = publicKeyExpires pkey
+                , fetchedActorId    = actorId actor
+                , fetchedHost       = T.pack $ uriRegName authority
+                , fetchedKeyShared  = shared
+                }
+            CryptoFailed _ -> Left "Parsing Ed25519 public key failed"