Use the DB for checking key usage by actors

* When we refetch a personal key, we never need to separately fetch the actor
* When we refetch a shared key, check usage in DB and insert usage to DB

src/Vervis/Foundation.hs

@@ -623,10 +623,10 @@ keyListedByActorShared
     -> Text
     -> LocalURI
     -> LocalURI
-    -> Handler (Either String ())
+    -> ExceptT String Handler ()
 keyListedByActorShared manager iid vkid host luKey luActor = do
     mresult <- do
-        ments <- runDB $ do
+        ments <- lift $ runDB $ do
             mrs <- getBy $ UniqueRemoteSharer iid luActor
             for mrs $ \ (Entity rsid _) ->
                 (rsid,) . isJust <$>
@@ -638,7 +638,7 @@ keyListedByActorShared manager iid vkid host luKey luActor = do
                     if used
                         then Nothing
                         else Just $ Just rsid
-    runExceptT $ for_ mresult $ \ mrsid -> do
+    for_ mresult $ \ mrsid -> do
         luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
         ExceptT $ runDB $ case mrsid of
             Nothing -> do
@@ -655,7 +655,6 @@ keyListedByActorShared manager iid vkid host luKey luActor = do
 
 data VerifKeyDetail = VerifKeyDetail
     { vkdKeyId     :: LocalURI
-    -- , vkdInboxOrId :: Either LocalURI VerifKeyId
     , vkdKey       :: PublicKey
     , vkdExpires   :: Maybe UTCTime
     , vkdActorId   :: LocalURI
@@ -675,6 +674,8 @@ instance YesodHttpSig App where
         (host, luKey) <- f2l <$> parseKeyId keyid
         signature <- parseSig sig
         mluActorHeader <- getActorHeader host
+        let sigAlgo = isJust malgo
+        manager <- getsYesod appHttpManager
         (inboxOrVkid, vkd) <- do
             ments <- lift $ runDB $ do
                 mvk <- runMaybeT $ do
@@ -700,10 +701,10 @@ instance YesodHttpSig App where
                                     Just u -> return u
                                 manager <- getsYesod appHttpManager
                                 let iid = verifKeyInstance vk
-                                ExceptT $ keyListedByActorShared manager iid vkid host luKey ua
+                                keyListedByActorShared manager iid vkid host luKey ua
                                 return (ua, True)
                     return
-                        ( Right vkid
+                        ( Right (verifKeyInstance vk, vkid)
                         , VerifKeyDetail
                             { vkdKeyId     = luKey
                             , vkdKey       = verifKeyPublic vk
@@ -712,11 +713,10 @@ instance YesodHttpSig App where
                             , vkdShared    = s
                             }
                         )
-                Nothing -> fetched2vkd luKey <$> fetchKey' host mluActorHeader luKey
+                Nothing -> fetched2vkd luKey <$> fetchUnknownKey manager sigAlgo host mluActorHeader luKey
         let verify' k = verify k input signature
             errSig = throwE "Ed25519 sig verification says not valid"
             errTime = throwE "Key expired"
-            -- existsInDB = isRight $ vkdInboxOrId vkd
         now <- liftIO getCurrentTime
         let stillValid Nothing        = True
             stillValid (Just expires) = expires > now
@@ -724,21 +724,19 @@ instance YesodHttpSig App where
         if verify' (vkdKey vkd) && stillValid (vkdExpires vkd)
             then case inboxOrVkid of
                 Left uinb -> ExceptT $ runDB $ addVerifKey host uinb vkd
-                Right _vkid -> return ()
+                Right _ids -> return ()
             else case inboxOrVkid of
                 Left _uinb ->
                     if stillValid $ vkdExpires vkd
                         then errSig
                         else errTime
-                Right vkid -> do
+                Right (iid, vkid) -> do
-                    Fetched newKey newExp newActor _newInbox s <- fetchKey' host mluActorHeader luKey
+                    let ua = vkdActorId vkd
-                    if vkdShared vkd == s
+                        listed = keyListedByActorShared manager iid vkid host luKey ua
-                        then return ()
+                    (newKey, newExp) <-
-                        else throwE "Key scope changed, we reject that"
+                        if vkdShared vkd
-                    unless (vkdShared vkd) $
+                            then fetchKnownSharedKey manager listed sigAlgo host ua luKey
-                        if newActor == vkdActorId vkd
+                            else fetchKnownPersonalKey manager sigAlgo host ua luKey
-                            then return ()
-                            else throwE "Key owner changed, we reject that"
                     if stillValid newExp
                         then return ()
                         else errTime
@@ -775,9 +773,6 @@ instance YesodHttpSig App where
                         else Left "Key and actor have different hosts"
                     Right lu
                 _ -> throwE "Multiple ActivityPub-Actor headers"
-        fetchKey' h mua uk = do
-            manager <- getsYesod appHttpManager
-            ExceptT $ fetchKey manager (isJust malgo) h mua uk
         fetched2vkd uk (Fetched k mexp ua uinb s) =
             ( Left uinb
             , VerifKeyDetail

src/Web/ActivityPub.hs

@@ -47,7 +47,9 @@ module Web.ActivityPub
     , Fetched (..)
     , fetchAPID
     , keyListedByActor
-    , fetchKey
+    , fetchUnknownKey
+    , fetchKnownPersonalKey
+    , fetchKnownSharedKey
     )
 where
 
@@ -485,12 +487,14 @@ data Fetched = Fetched
 fetchAP :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT String m a
 fetchAP m u = ExceptT $ bimap displayException responseBody <$> httpGetAP m u
 
+{-
 fetchAPH :: (MonadIO m, ActivityPub a) => Manager -> Text -> LocalURI -> ExceptT String m a
 fetchAPH m h lu = do
     Doc h' v <- fetchAP m $ l2f h lu
     if h == h'
         then return v
         else throwE "Object @id URI's host doesn't match the URI we fetched"
+-}
 
 fetchAPID :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either String a)
 fetchAPID m getId h lu = runExceptT $ do
@@ -535,15 +539,53 @@ keyListedByActor manager host luKey luActor = runExceptT $ do
             match (Right _)  = False
         in  match k1 || maybe False match mk2
 
-fetchKey
+matchKeyObj luKey (PublicKeySet k1 mk2) =
+    let match' = match luKey
+    in  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 pk
+    where
+    match _   (Left _)   = Nothing
+    match luk (Right pk) =
+        if publicKeyId pk == luk
+            then Just pk
+            else Nothing
+
+verifyAlgo sigAlgo Nothing =
+    Left $
+    if sigAlgo
+        then "Algo mismatch, Ed25519 in Sig but none in actor"
+        else "Algo not given in Sig nor actor"
+verifyAlgo sigAlgo (Just algo) =
+    case algo of
+        AlgorithmEd25519 -> Right ()
+        AlgorithmOther _ ->
+            Left $
+            if sigAlgo
+                then "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
+                else "No algo in Sig, unsupported algo in actor"
+
+parseKey pem =
+    case E.publicKey $ pemContent pem of
+        CryptoPassed k -> Right k
+        CryptoFailed _ -> Left "Parsing Ed25519 public key failed"
+
+-- | Fetch a key we don't have cached locally.
+fetchUnknownKey
     :: MonadIO m
     => Manager
+    -- ^ Manager for making HTTP requests
     -> Bool
+    -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
+    -- signature header
     -> Text
+    -- ^ Instance host
     -> Maybe LocalURI
+    -- ^ Actor URI possibly provided in the HTTP request's actor header
     -> LocalURI
-    -> m (Either String Fetched)
+    -- ^ Key URI provided in HTTP signature header
-fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
+    -> ExceptT String m Fetched
+fetchUnknownKey manager sigAlgo host mluActor luKey = do
     obj <- fetchAPIDOrH manager publicKeyId host luKey
     (pem, mkFetched, malgo) <-
         case obj of
@@ -603,32 +645,81 @@ fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
     ExceptT . pure $ do
         verifyAlgo sigAlgo malgo
         mkFetched <$> parseKey pem
-    where
+
-    matchKeyObj luKey (PublicKeySet k1 mk2) =
+keyDetail pk = (publicKeyPem pk, publicKeyExpires pk, publicKeyAlgo pk)
-        let match' = match luKey
+
-        in  case match' k1 <|> (match' =<< mk2) of
+-- | Fetch a personal key we already have cached locally, but we'd like to
-                Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
+-- refresh the local copy by fetching the key again from the server.
-                Just pk -> return pk
+fetchKnownPersonalKey
-        where
+    :: MonadIO m
-        match _   (Left _)   = Nothing
+    => Manager
-        match luk (Right pk) =
+    -- ^ Manager for making HTTP requests
-            if publicKeyId pk == luk
+    -> Bool
-                then Just pk
+    -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
-                else Nothing
+    -- signature header
-    verifyAlgo sigAlgo Nothing =
+    -> Text
-        Left $
+    -- ^ Instance host
-        if sigAlgo
+    -> LocalURI
-            then "Algo mismatch, Ed25519 in Sig but none in actor"
+    -- ^ Key owner actor ID URI
-            else "Algo not given in Sig nor actor"
+    -> LocalURI
-    verifyAlgo sigAlgo (Just algo) =
+    -- ^ Key URI
-        case algo of
+    -> ExceptT String m (E.PublicKey, Maybe UTCTime)
-            AlgorithmEd25519 -> Right ()
+fetchKnownPersonalKey manager sigAlgo host luOwner luKey = do
-            AlgorithmOther _ ->
+    obj <- fetchAPIDOrH manager publicKeyId host luKey
-                Left $
+    (pem, mexpires, malgo) <-
-                if sigAlgo
+        case obj of
-                    then "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
+            Left pkey -> do
-                    else "No algo in Sig, unsupported algo in actor"
+                case publicKeyOwner pkey of
-    parseKey pem =
+                    OwnerInstance -> throwE "Personal key became shared"
-        case E.publicKey $ pemContent pem of
+                    OwnerActor owner ->
-            CryptoPassed k -> Right k
+                        when (luOwner /= owner) $ throwE "Key owner changed"
-            CryptoFailed _ -> Left "Parsing Ed25519 public key failed"
+                return $ keyDetail pkey
+            Right actor -> do
+                when (actorId actor /= luKey { luriFragment = "" }) $
+                    throwE "Actor ID doesn't match the keyid URI we fetched"
+                when (actorId actor /= luOwner) $
+                    throwE "Key owner changed"
+                pk <- matchKeyObj luKey $ actorPublicKeys actor
+                case publicKeyOwner pk of
+                    OwnerInstance -> throwE "Personal key became shared"
+                    OwnerActor owner ->
+                        when (owner /= luOwner) $
+                            throwE "Actor's publicKey's owner doesn't match the actor's ID"
+                return $ keyDetail pk
+    ExceptT . pure $ do
+        verifyAlgo sigAlgo malgo
+        (, mexpires) <$> parseKey pem
+
+-- | Fetch a shared key we already have cached locally, but we'd like to
+-- refresh the local copy by fetching the key again from the server.
+fetchKnownSharedKey
+    :: MonadIO m
+    => Manager
+    -- ^ Manager for making HTTP requests
+    -> ExceptT String m ()
+    -- ^ Action which checks whether the actor from HTTP actor header lists the
+    -- key, potentually updating our local cache if needed.
+    -> Bool
+    -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
+    -- signature header
+    -> Text
+    -- ^ Instance host
+    -> LocalURI
+    -- ^ Actor ID from HTTP actor header
+    -> LocalURI
+    -- ^ Key URI
+    -> ExceptT String m (E.PublicKey, Maybe UTCTime)
+fetchKnownSharedKey manager listed sigAlgo host luActor luKey = do
+    obj <- fetchAPIDOrH manager publicKeyId host luKey
+    pkey <-
+        case obj :: Either PublicKey Actor of
+            Left pk -> return pk
+            Right _actor -> throwE "Expected stand-alone key, got embedded key"
+    case publicKeyOwner pkey of
+        OwnerInstance -> return ()
+        OwnerActor _owner -> throwE "Shared key became personal"
+    listed
+    let (pem, mexpires, malgo) = keyDetail pkey
+    ExceptT . pure $ do
+        verifyAlgo sigAlgo malgo
+        (, mexpires) <$> parseKey pem