Make the verification key update logic clearer

src/Vervis/Foundation.hs

@@ -21,7 +21,7 @@ import Control.Monad.Logger.CallStack (logWarn)
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Crypto.Error (CryptoFailable (..))
-import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
+import Crypto.PubKey.Ed25519 (PublicKey, publicKey, signature, verify)
 import Data.Either (isRight)
 import Data.Maybe (fromJust)
 import Data.PEM (pemContent)
@@ -59,7 +59,7 @@ import Yesod.Mail.Send
 import qualified Network.HTTP.Signature as S (Algorithm (..))
 
 import Network.FedURI
-import Web.ActivityPub
+import Web.ActivityPub hiding (PublicKey)
 
 import Text.Email.Local
 import Text.Jasmine.Local (discardm)
@@ -564,6 +564,100 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
 -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
 
+data AddVerifKey = AddVerifKey
+    { addvkHost    :: Text
+    , addvkKeyId   :: FedURI
+    , addvkExpires :: Maybe UTCTime
+    , addvkKey     :: PublicKey
+    }
+
+addSharedKey :: AddVerifKey -> AppDB (Maybe String)
+addSharedKey (AddVerifKey host uKey mexpires key) = do
+    (iid, new) <- idAndNew <$> insertBy (Instance host)
+    room <-
+        if new
+            then pure True
+            else
+                (< 2) <$>
+                count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
+    if room
+        then do
+            insert_ $ VerifKey uKey iid mexpires key Nothing
+            return Nothing
+        else return $ Just "We already store 2 keys"
+    where
+    idAndNew (Left (Entity iid _)) = (iid, False)
+    idAndNew (Right iid)           = (iid, True)
+
+data AddPersonalKey = AddPersonalKey
+    { addpkKey        :: AddVerifKey
+    , addpkActorId    :: FedURI
+    , addpkActorInbox :: FedURI
+    }
+
+addPersonalKey :: AddPersonalKey -> AppDB (Maybe String)
+addPersonalKey (AddPersonalKey avk uActor uInbox) = do
+    let AddVerifKey host uKey mexpires key = avk
+    (iid, rsid, new) <- do
+        mrs <- getBy $ UniqueRemoteSharer uActor
+        case mrs of
+            Nothing -> do
+                iid <- either entityKey id <$> insertBy (Instance host)
+                rsid <- insert $ RemoteSharer uActor iid uInbox
+                return (iid, rsid, True)
+            Just (Entity rsid rs) ->
+                return (remoteSharerInstance rs, rsid, False)
+    room <-
+        if new
+            then pure True
+            else (< 2) <$> count [VerifKeySharer ==. Just rsid]
+    if room
+        then do
+            insert_ $ VerifKey uKey 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 AddPersonalKey
+    | VKUUpdateKey UpdateVerifKey
+
+updateVerifKeyInDB :: VerifKeyUpdate -> AppDB (Maybe String)
+updateVerifKeyInDB (VKUAddSharedKey avk)   = addSharedKey avk
+updateVerifKeyInDB (VKUAddPersonalKey apk) = addPersonalKey apk
+updateVerifKeyInDB (VKUUpdateKey uvk)      = updateVerifKey uvk
+
+data VerifKeyDetail = VerifKeyDetail
+    { vkdKeyId     :: FedURI
+    , vkdInboxOrId :: Either FedURI VerifKeyId
+    , vkdKey       :: PublicKey
+    , vkdExpires   :: Maybe UTCTime
+    , vkdActorId   :: FedURI
+    , vkdHost      :: Text
+    , vkdShared    :: Bool
+    }
+
+makeVerifKeyUpdate :: VerifKeyDetail -> VerifKeyUpdate
+makeVerifKeyUpdate (VerifKeyDetail uKey iori key mexpires uActor host shared) =
+    case iori of
+        Left uInbox ->
+            let avk = AddVerifKey host uKey mexpires key
+            in  if shared
+                    then VKUAddSharedKey avk
+                    else VKUAddPersonalKey $ AddPersonalKey avk uActor uInbox
+        Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key
+
 instance YesodHttpSig App where
     data HttpSigVerResult App = HttpSigVerResult (Either String FedURI)
     httpSigVerHeaders = const [hRequestTarget, hHost, hActivityPubActor]
@@ -579,7 +673,7 @@ instance YesodHttpSig App where
                 case algo of
                     S.AlgorithmEd25519 -> Right ()
                     S.AlgorithmOther _ -> Left "Unsupported algo in Sig header"
-        u <- ExceptT . pure $ case parseFedURI =<< (first displayException . decodeUtf8') keyid of
+        uKey <- 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 uri
         signature <- ExceptT . pure $ do
@@ -594,9 +688,10 @@ instance YesodHttpSig App where
                     t <- first displayException $ decodeUtf8' b
                     parseFedURI t
                 _ -> throwE "Multiple ActivityPub-Actor headers"
-        (inboxOrVkid, key, mexpires, uActor, host, shared) <- do
+        --(inboxOrVkid, key, mexpires, uActor, host, shared) <- do
+        vkd <- do
             ments <- lift $ runDB $ do
-                mvk <- getBy $ UniqueVerifKey u
+                mvk <- getBy $ UniqueVerifKey uKey
                 for mvk $ \ vk@(Entity _ verifkey) -> do
                     mremote <- traverse getJust $ verifKeySharer verifkey
                     return (vk, mremote)
@@ -609,93 +704,70 @@ instance YesodHttpSig App where
                                 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 VerifKeyDetail
-                    return
+                        { vkdKeyId     = uKey
-                        ( Right vkid
+                        , vkdInboxOrId = Right vkid
-                        , verifKeyPublic vk
+                        , vkdKey       = verifKeyPublic vk
-                        , verifKeyExpires vk
+                        , vkdExpires   = verifKeyExpires vk
-                        , ua
+                        , vkdActorId   = ua
-                        , furiHost uKey
+                        , vkdHost      = furiHost uKey
-                        , s
+                        , vkdShared    = s
-                        )
+                        }
-                Nothing -> do
+                Nothing -> fetched2vkd uKey <$> fetchKey' muActorHeader uKey
-                    Fetched k mexp ua uinb h s <- fetchKey' muActorHeader u
-                    return (Left uinb, k, mexp, ua, h, s)
         let verify' k = verify k input signature
             errSig = throwE "Ed25519 sig verification says not valid"
             errTime = throwE "Key expired"
-            existsInDB = isRight inboxOrVkid
+            existsInDB = isRight $ vkdInboxOrId vkd
         now <- liftIO getCurrentTime
         let stillValid Nothing        = True
             stillValid (Just expires) = expires > now
-        (write, key', mexpires') <-
+
-            if verify' key && stillValid mexpires
+        mvkd <-
-                then return (not existsInDB, key, mexpires)
+            if verify' (vkdKey vkd) && stillValid (vkdExpires vkd)
+                then return $ if existsInDB
+                                then Nothing
+                                else Just vkd
                 else if existsInDB
                     then do
-                        Fetched newKey newExp newActor _newInbox h s <- fetchKey' muActorHeader u
+                        Fetched newKey newExp newActor _newInbox h s <- fetchKey' muActorHeader uKey
-                        if shared == s
+                        if vkdShared vkd == s
                             then return ()
                             else throwE "Key scope changed, we reject that"
-                        if shared
+                        if vkdShared vkd
-                            then if h == host
+                            then if h == vkdHost vkd
                                     then return ()
                                     else fail "BUG! We re-fetched a key and the host changed"
-                            else if newActor == uActor
+                            else if newActor == vkdActorId vkd
                                     then return ()
                                     else throwE "Key owner changed, we reject that"
                         if stillValid newExp
                             then return ()
                             else errTime
                         if verify' newKey
-                            then return (True, newKey, newExp)
+                            then return $ Just vkd
+                                    { vkdKey     = newKey
+                                    , vkdExpires = newExp
+                                    }
                             else errSig
-                    else if stillValid mexpires
+                    else if stillValid $ vkdExpires vkd
                             then errSig
                             else errTime
-        when write $ ExceptT $ runDB $
+
-            case inboxOrVkid of
+        for_ mvkd $ ExceptT . fmap (maybe (Right ()) Left) . runDB .  updateVerifKeyInDB . makeVerifKeyUpdate
-                Left inbox ->
+        return $ vkdActorId vkd
-                    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 ()
-                                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 <- either entityKey id <$> insertBy (Instance host)
-                                    rsid <- insert $ RemoteSharer uActor iid inbox
-                                    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"
-                Right vkid -> do
-                    update vkid
-                        [VerifKeyExpires =. mexpires', VerifKeyPublic =. key']
-                    return $ Right ()
-        return uActor
         where
         fetchKey' mua uk = do
             manager <- getsYesod appHttpManager
             ExceptT $ fetchKey manager (isJust malgo) mua uk
+        fetched2vkd uk (Fetched k mexp ua uinb h s) = VerifKeyDetail
+            { vkdKeyId     = uk
+            , vkdInboxOrId = Left uinb
+            , vkdKey       = k
+            , vkdExpires   = mexp
+            , vkdActorId   = ua
+            , vkdHost      = h
+            , vkdShared    = s
+            }
 
 instance YesodBreadcrumbs App where
     breadcrumb route = return $ case route of