Refactor HTTP sig verification DB update code

src/Vervis/Foundation.hs

@@ -603,7 +603,20 @@ actorRoom rsid =
         (count [VerifKeySharedUsageUser ==. rsid])
         (count [VerifKeySharer ==. Just rsid])
 
-keyListedByActor'
+-- | Given a shared key we have in our DB, verify that the given actor lists
+-- this key, and update the DB accordingly.
+--
+--   * If we know the actor and we have a record that it lists the key, return
+--     success, otherwise no action
+--   * If we know the actor but we don't have a record of usage, fetch the
+--     actor and verify usage. If the actor already has 2 known keys, return
+--     error, otherwise store usage in DB.
+--   * If we don't know the actor, fetch actor, verify usage, store actor and
+--     usage in DB.
+--
+-- If we get success, that means the actor lists the key, and both the actor
+-- and the usage exist in our DB now.
+keyListedByActorShared
     :: Manager
     -> InstanceId
     -> VerifKeyId
@@ -611,7 +624,7 @@ keyListedByActor'
     -> LocalURI
     -> LocalURI
     -> Handler (Either String ())
-keyListedByActor' manager iid vkid host luKey luActor = do
+keyListedByActorShared manager iid vkid host luKey luActor = do
     mresult <- do
         ments <- runDB $ do
             mrs <- getBy $ UniqueRemoteSharer iid luActor
@@ -640,92 +653,15 @@ keyListedByActor' manager iid vkid host luKey luActor = do
                         return $ Right ()
                     else return $ Left "Actor already has at least 2 keys"
 
-data AddVerifKey = AddVerifKey
-    { addvkHost       :: Text
-    , addvkKeyId      :: LocalURI
-    , addvkExpires    :: Maybe UTCTime
-    , addvkKey        :: PublicKey
-    , addvkActorId    :: LocalURI
-    , addvkActorInbox :: LocalURI
-    }
-
-addSharedKey :: AddVerifKey -> AppDB (Maybe String)
-addSharedKey (AddVerifKey host luKey mexpires key luActor luInbox) = do
-    (iid, rsid, inew) <- instanceAndActor host luActor luInbox
-    room <-
-        case inew of
-            Nothing -> pure True
-            Just rsnew -> do
-                iRoom <- instanceRoom iid
-                if iRoom
-                    then if rsnew
-                            then pure True
-                            else actorRoom rsid
-                    else return False
-    if room
-        then do
-            vkid <- insert $ VerifKey luKey iid mexpires key Nothing
-            insert_ $ VerifKeySharedUsage vkid rsid
-            return Nothing
-        else return $ Just "We already store 2 keys"
-    where
-    instanceRoom iid =
-        (< 2) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
-
-addPersonalKey :: AddVerifKey -> AppDB (Maybe String)
-addPersonalKey (AddVerifKey host luKey mexpires key luActor luInbox) = do
-    (iid, rsid, inew) <- instanceAndActor host luActor luInbox
-    room <-
-        if inew == Just False
-            then actorRoom rsid
-            else pure True
-    if room
-        then do
-            insert_ $ VerifKey luKey iid mexpires key (Just rsid)
-            return Nothing
-        else return $ Just "We already store 2 keys"
-
-data UpdateVerifKey = UpdateVerifKey
-    { updvkId      :: VerifKeyId
-    , updvkExpires :: Maybe UTCTime
-    , updvkKey     :: PublicKey
-    }
-
-updateVerifKey :: UpdateVerifKey -> AppDB (Maybe String)
-updateVerifKey (UpdateVerifKey vkid mexpires key) = do
-    update vkid [VerifKeyExpires =. mexpires, VerifKeyPublic =. key]
-    return Nothing
-
-data VerifKeyUpdate
-    = VKUAddSharedKey AddVerifKey
-    | VKUAddPersonalKey AddVerifKey
-    | VKUUpdateKey UpdateVerifKey
-
-updateVerifKeyInDB :: VerifKeyUpdate -> AppDB (Maybe String)
-updateVerifKeyInDB (VKUAddSharedKey avk)   = addSharedKey avk
-updateVerifKeyInDB (VKUAddPersonalKey avk) = addPersonalKey avk
-updateVerifKeyInDB (VKUUpdateKey uvk)      = updateVerifKey uvk
-
 data VerifKeyDetail = VerifKeyDetail
     { vkdKeyId     :: LocalURI
-    , vkdInboxOrId :: Either LocalURI VerifKeyId
+    -- , vkdInboxOrId :: Either LocalURI VerifKeyId
     , vkdKey       :: PublicKey
     , vkdExpires   :: Maybe UTCTime
     , vkdActorId   :: LocalURI
     , vkdShared    :: Bool
     }
 
-makeVerifKeyUpdate :: Text -> VerifKeyDetail -> VerifKeyUpdate
-makeVerifKeyUpdate
-    host (VerifKeyDetail luKey iori key mexpires luActor shared) =
-        case iori of
-            Left luInbox ->
-                let avk = AddVerifKey host luKey mexpires key luActor luInbox
-                in  if shared
-                        then VKUAddSharedKey avk
-                        else VKUAddPersonalKey avk
-            Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key
-
 instance YesodHttpSig App where
     data HttpSigVerResult App = HttpSigVerResult (Either String FedURI)
     httpSigVerHeaders = const [hRequestTarget, hHost, hActivityPubActor]
@@ -735,32 +671,11 @@ instance YesodHttpSig App where
         toSeconds :: TimeInterval -> Second
         toSeconds = toTimeUnit
     httpVerifySig (Verification malgo (KeyId keyid) input (Signature sig)) = fmap HttpSigVerResult $ runExceptT $ do
-        ExceptT . pure $ case malgo of
+        verifySigAlgo malgo
-            Nothing -> Right ()
+        (host, luKey) <- f2l <$> parseKeyId keyid
-            Just algo ->
+        signature <- parseSig sig
-                case algo of
+        mluActorHeader <- getActorHeader host
-                    S.AlgorithmEd25519 -> Right ()
+        (inboxOrVkid, vkd) <- do
-                    S.AlgorithmOther _ -> Left "Unsupported algo in Sig header"
-        (host, luKey) <- ExceptT . pure $ case parseFedURI =<< (first displayException . decodeUtf8') keyid of
-            Left e -> Left $ "keyId in Sig header isn't a valid FedURI: " ++ e
-            Right uri -> Right $ f2l uri
-        signature <- ExceptT . pure $ do
-            case signature sig of
-                CryptoPassed s -> Right s
-                CryptoFailed e -> Left "Parsing Ed25519 signature failed"
-        mluActorHeader <- 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"
-        vkd <- do
             ments <- lift $ runDB $ do
                 mvk <- runMaybeT $ do
                     Entity iid _ <- MaybeT $ getBy $ UniqueInstance host
@@ -785,68 +700,133 @@ instance YesodHttpSig App where
                                     Just u -> return u
                                 manager <- getsYesod appHttpManager
                                 let iid = verifKeyInstance vk
-                                ExceptT $
+                                ExceptT $ keyListedByActorShared manager iid vkid host luKey ua
-                                    keyListedByActor' manager iid vkid host luKey ua
                                 return (ua, True)
-                    return VerifKeyDetail
+                    return
-                        { vkdKeyId     = luKey
+                        ( Right vkid
-                        , vkdInboxOrId = Right vkid
+                        , VerifKeyDetail
-                        , vkdKey       = verifKeyPublic vk
+                            { vkdKeyId     = luKey
-                        , vkdExpires   = verifKeyExpires vk
+                            , vkdKey       = verifKeyPublic vk
-                        , vkdActorId   = ua
+                            , vkdExpires   = verifKeyExpires vk
-                        , vkdShared    = s
+                            , vkdActorId   = ua
-                        }
+                            , vkdShared    = s
+                            }
+                        )
                 Nothing -> fetched2vkd luKey <$> fetchKey' 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
+            -- existsInDB = isRight $ vkdInboxOrId vkd
         now <- liftIO getCurrentTime
         let stillValid Nothing        = True
             stillValid (Just expires) = expires > now
 
-        mvkd <-
+        if verify' (vkdKey vkd) && stillValid (vkdExpires vkd)
-            if verify' (vkdKey vkd) && stillValid (vkdExpires vkd)
+            then case inboxOrVkid of
-                then return $ if existsInDB
+                Left uinb -> ExceptT $ runDB $ addVerifKey host uinb vkd
-                                then Nothing
+                Right _vkid -> return ()
-                                else Just vkd
+            else case inboxOrVkid of
-                else if existsInDB
+                Left _uinb ->
-                    then do
+                    if stillValid $ vkdExpires vkd
-                        Fetched newKey newExp newActor _newInbox s <- fetchKey' host mluActorHeader luKey
+                        then errSig
-                        if vkdShared vkd == s
+                        else errTime
+                Right vkid -> do
+                    Fetched newKey newExp newActor _newInbox s <- fetchKey' host mluActorHeader luKey
+                    if vkdShared vkd == s
+                        then return ()
+                        else throwE "Key scope changed, we reject that"
+                    unless (vkdShared vkd) $
+                        if newActor == vkdActorId vkd
                             then return ()
-                            else throwE "Key scope changed, we reject that"
+                            else throwE "Key owner changed, we reject that"
-                        unless (vkdShared vkd) $
+                    if stillValid newExp
-                            if newActor == vkdActorId vkd
+                        then return ()
-                                then return ()
+                        else errTime
-                                else throwE "Key owner changed, we reject that"
+                    if verify' newKey
-                        if stillValid newExp
+                        then lift $ runDB $ updateVerifKey vkid vkd
-                            then return ()
+                                { vkdKey     = newKey
-                            else errTime
+                                , vkdExpires = newExp
-                        if verify' newKey
+                                }
-                            then return $ Just vkd
+                        else errSig
-                                    { vkdKey     = newKey
-                                    , vkdExpires = newExp
-                                    }
-                            else errSig
-                    else if stillValid $ vkdExpires vkd
-                            then errSig
-                            else errTime
 
-        for_ mvkd $ ExceptT . fmap (maybe (Right ()) Left) . runDB .  updateVerifKeyInDB . makeVerifKeyUpdate host
         return $ l2f host $ vkdActorId vkd
         where
+        verifySigAlgo = traverse_ $ \ algo ->
+            case algo of
+                S.AlgorithmEd25519 -> return ()
+                S.AlgorithmOther _ -> throwE "Unsupported algo in Sig header"
+        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
+        parseSig b =
+            case signature b of
+                CryptoPassed s -> return s
+                CryptoFailed e -> throwE "Parsing Ed25519 signature failed"
+        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"
         fetchKey' h mua uk = do
             manager <- getsYesod appHttpManager
             ExceptT $ fetchKey manager (isJust malgo) h mua uk
-        fetched2vkd uk (Fetched k mexp ua uinb s) = VerifKeyDetail
+        fetched2vkd uk (Fetched k mexp ua uinb s) =
-            { vkdKeyId     = uk
+            ( Left uinb
-            , vkdInboxOrId = Left uinb
+            , VerifKeyDetail
-            , vkdKey       = k
+                { vkdKeyId     = uk
-            , vkdExpires   = mexp
+                , vkdKey       = k
-            , vkdActorId   = ua
+                , vkdExpires   = mexp
-            , vkdShared    = s
+                , vkdActorId   = ua
-            }
+                , vkdShared    = s
+                }
+            )
+        addVerifKey h uinb vkd =
+            if vkdShared vkd
+                then addSharedKey h uinb vkd
+                else addPersonalKey h uinb vkd
+            where
+            addSharedKey host luInbox (VerifKeyDetail luKey key mexpires luActor _) = do
+                (iid, rsid, inew) <- instanceAndActor host luActor luInbox
+                room <-
+                    case inew of
+                        Nothing -> pure True
+                        Just rsnew -> do
+                            iRoom <- instanceRoom iid
+                            if iRoom
+                                then if rsnew
+                                        then pure True
+                                        else actorRoom rsid
+                                else return False
+                if room
+                    then do
+                        vkid <- insert $ VerifKey luKey iid mexpires key Nothing
+                        insert_ $ VerifKeySharedUsage vkid rsid
+                        return $ Right ()
+                    else return $ Left "We already store 2 keys"
+                where
+                instanceRoom iid =
+                    (< 2) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
+            addPersonalKey host luInbox (VerifKeyDetail luKey key mexpires luActor _) = do
+                (iid, rsid, inew) <- instanceAndActor host luActor luInbox
+                room <-
+                    if inew == Just False
+                        then actorRoom rsid
+                        else pure True
+                if room
+                    then do
+                        insert_ $ VerifKey luKey iid mexpires key (Just rsid)
+                        return $ Right ()
+                    else return $ Left "We already store 2 keys"
+        updateVerifKey vkid vkd =
+            update vkid [VerifKeyExpires =. vkdExpires vkd, VerifKeyPublic =. vkdKey vkd]
 
 instance YesodBreadcrumbs App where
     breadcrumb route = return $ case route of

src/Web/ActivityPub.hs

@@ -545,23 +545,34 @@ fetchKey
     -> m (Either String Fetched)
 fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
     obj <- fetchAPIDOrH manager publicKeyId host luKey
-    (actor, pkey) <-
+    (pem, mkFetched, malgo) <-
         case obj of
             Left pkey -> do
-                luActor <-
+                (oi, luActor) <-
                     case publicKeyOwner pkey of
                         OwnerInstance ->
                             case mluActor of
                                 Nothing -> throwE "Key is shared but actor header not specified!"
-                                Just u  -> return u
+                                Just u  -> return (True, u)
                         OwnerActor owner -> do
                             for_ mluActor $ \ lu ->
                                 if owner == lu
                                     then return ()
                                     else throwE "Key's owner doesn't match actor header"
-                            return owner
+                            return (False, owner)
-                actor <- ExceptT $ keyListedByActor manager host luKey luActor
+                inbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
-                return (actor, pkey)
+                return
+                    ( publicKeyPem pkey
+                    , \ k ->
+                        Fetched
+                            { fetchedPublicKey  = k
+                            , fetchedKeyExpires = publicKeyExpires pkey
+                            , fetchedActorId    = luActor
+                            , fetchedActorInbox = inbox
+                            , fetchedKeyShared  = oi
+                            }
+                    , publicKeyAlgo pkey
+                    )
             Right actor -> do
                 if actorId actor == luKey { luriFragment = "" }
                     then return ()
@@ -581,15 +592,24 @@ fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
                     Just pk ->
                         case publicKeyOwner pk of
                             OwnerInstance -> throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document"
-                            OwnerActor _ -> return (actor, pk)
+                            OwnerActor owner -> do
+                                if owner == actorId actor
+                                    then return ()
+                                    else throwE "Actor's publicKey's owner doesn't match the actor's ID"
+                                return
+                                    ( publicKeyPem pk
+                                    , \ k ->
+                                        Fetched
+                                            { fetchedPublicKey  = k
+                                            , fetchedKeyExpires = publicKeyExpires pk
+                                            , fetchedActorId    = owner
+                                            , fetchedActorInbox = actorInbox actor
+                                            , fetchedKeyShared  = False
+                                            }
+                                    , publicKeyAlgo pk
+                                    )
     ExceptT . pure $ do
-        case publicKeyOwner pkey of
+        case malgo of
-            OwnerInstance -> Right ()
-            OwnerActor owner ->
-                if owner == actorId actor
-                    then Right ()
-                    else Left "Actor's publicKey's owner doesn't match the actor's ID"
-        case publicKeyAlgo pkey of
             Nothing ->
                 Left $
                 if sigAlgo
@@ -603,12 +623,6 @@ fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
                         if sigAlgo
                             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
+        case E.publicKey $ pemContent pem of
-            CryptoPassed k -> Right Fetched
+            CryptoPassed k -> Right $ mkFetched k
-                { fetchedPublicKey  = k
-                , fetchedKeyExpires = publicKeyExpires pkey
-                , fetchedActorId    = actorId actor
-                , fetchedActorInbox = actorInbox actor
-                , fetchedKeyShared  = ownerShared $ publicKeyOwner pkey
-                }
             CryptoFailed _ -> Left "Parsing Ed25519 public key failed"