Record usage of instance keys in the DB

When we verify an HTTP signature,

* If we know the key, check in the DB whether we know the actor lists it. If it
  doesn't, and there's room left for keys, HTTP GET the actor and update the DB
  accordingly.
* If we know the key but had to update it, do the same, check usage in DB and
  update DB if needed
* If we don't know the key, record usage in DB

However,

* If we're GETing a key and discovering it's a shared key, we GET the actor to
  verify it lists the key. When we don't know the key at all yet, that's fine
  (can be further optimized but it's marginal), but if it's a key we do know,
  it means we already know the actor and for now it's enough for us to rely
  only on the DB to test usage.

config/models

@@ -48,6 +48,12 @@ VerifKey
 
     UniqueVerifKey ident
 
+VerifKeySharedUsage
+    key  VerifKeyId
+    user RemoteSharerId
+
+    UniqueVerifKeySharedUsage key user
+
 RemoteSharer
     ident    FedURI
     instance InstanceId

migrations/2019_02_03_verifkey.model

@@ -7,6 +7,12 @@ VerifKey
 
     UniqueVerifKey ident
 
+VerifKeySharedUsage
+    key  VerifKeyId
+    user RemoteSharerId
+
+    UniqueVerifKeySharedUsage key user
+
 RemoteSharer
     ident    Text
     instance InstanceId

src/Vervis/Foundation.hs

@@ -564,53 +564,114 @@ 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
 
+sumUpTo :: Int -> AppDB Int -> AppDB Int -> AppDB Bool
+sumUpTo limit action1 action2 = do
+    n <- action1
+    if n <= limit
+        then do
+            m <- action2
+            return $ n + m <= limit
+        else return False
+
+instanceAndActor
+    :: Text
+    -> FedURI
+    -> FedURI
+    -> AppDB (InstanceId, RemoteSharerId, Maybe Bool)
+instanceAndActor host uActor uInbox = do
+    mrs <- getBy $ UniqueRemoteSharer uActor
+    case mrs of
+        Nothing -> do
+            (iid, inew) <- idAndNew <$> insertBy (Instance host)
+            rsid <- insert $ RemoteSharer uActor iid uInbox
+            return (iid, rsid, if inew then Nothing else Just True)
+        Just (Entity rsid rs) ->
+            return (remoteSharerInstance rs, rsid, Just False)
+    where
+    idAndNew (Left (Entity iid _)) = (iid, False)
+    idAndNew (Right iid)           = (iid, True)
+
+actorRoom :: RemoteSharerId -> AppDB Bool
+actorRoom rsid =
+    sumUpTo 2
+        (count [VerifKeySharedUsageUser ==. rsid])
+        (count [VerifKeySharer ==. Just rsid])
+
+keyListedByActor'
+    :: Manager
+    -> InstanceId
+    -> VerifKeyId
+    -> FedURI
+    -> FedURI
+    -> Handler (Either String ())
+keyListedByActor' manager iid vkid uKey uActor = do
+    mresult <- do
+        ments <- runDB $ do
+            mrs <- getBy $ UniqueRemoteSharer uActor
+            for mrs $ \ (Entity rsid _) ->
+                (rsid,) . isJust <$>
+                    getBy (UniqueVerifKeySharedUsage vkid rsid)
+        return $
+            case ments of
+                Nothing -> Just Nothing
+                Just (rsid, used) ->
+                    if used
+                        then Nothing
+                        else Just $ Just rsid
+    runExceptT $ for_ mresult $ \ mrsid -> do
+        uInbox <- actorInbox <$> ExceptT (keyListedByActor manager uKey uActor)
+        ExceptT $ runDB $ case mrsid of
+            Nothing -> do
+                rsid <- insert $ RemoteSharer uActor iid uInbox
+                insert_ $ VerifKeySharedUsage vkid rsid
+                return $ Right ()
+            Just rsid -> do
+                room <- actorRoom rsid
+                if room
+                    then do
+                        insert_ $ VerifKeySharedUsage vkid rsid
+                        return $ Right ()
+                    else return $ Left "Actor already has at least 2 keys"
+
 data AddVerifKey = AddVerifKey
     { addvkHost       :: Text
     , addvkKeyId      :: FedURI
     , addvkExpires    :: Maybe UTCTime
     , addvkKey        :: PublicKey
+    , addvkActorId    :: FedURI
+    , addvkActorInbox :: FedURI
     }
 
 addSharedKey :: AddVerifKey -> AppDB (Maybe String)
-addSharedKey (AddVerifKey host uKey mexpires key) = do
+addSharedKey (AddVerifKey host uKey mexpires key uActor uInbox) = do
-    (iid, new) <- idAndNew <$> insertBy (Instance host)
+    (iid, rsid, inew) <- instanceAndActor host uActor uInbox
     room <-
-        if new
+        case inew of
+            Nothing -> pure True
+            Just rsnew -> do
+                iRoom <- instanceRoom iid
+                if iRoom
+                    then if rsnew
                             then pure True
-            else
+                            else actorRoom rsid
-                (< 2) <$>
+                    else return False
-                count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
     if room
         then do
-            insert_ $ VerifKey uKey iid mexpires key Nothing
+            vkid <- insert $ VerifKey uKey iid mexpires key Nothing
+            insert_ $ VerifKeySharedUsage vkid rsid
             return Nothing
         else return $ Just "We already store 2 keys"
     where
-    idAndNew (Left (Entity iid _)) = (iid, False)
+    instanceRoom iid =
-    idAndNew (Right iid)           = (iid, True)
+        (< 2) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
 
-data AddPersonalKey = AddPersonalKey
+addPersonalKey :: AddVerifKey -> AppDB (Maybe String)
-    { addpkKey        :: AddVerifKey
+addPersonalKey (AddVerifKey host uKey mexpires key uActor uInbox) = do
-    , addpkActorId    :: FedURI
+    (iid, rsid, inew) <- instanceAndActor host uActor uInbox
-    , 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
+        if inew == Just False
-            then pure True
+            then actorRoom rsid
-            else (< 2) <$> count [VerifKeySharer ==. Just rsid]
+            else pure True
     if room
         then do
             insert_ $ VerifKey uKey iid mexpires key (Just rsid)
@@ -630,12 +691,12 @@ updateVerifKey (UpdateVerifKey vkid mexpires key) = do
 
 data VerifKeyUpdate
     = VKUAddSharedKey AddVerifKey
-    | VKUAddPersonalKey AddPersonalKey
+    | VKUAddPersonalKey AddVerifKey
     | VKUUpdateKey UpdateVerifKey
 
 updateVerifKeyInDB :: VerifKeyUpdate -> AppDB (Maybe String)
 updateVerifKeyInDB (VKUAddSharedKey avk)   = addSharedKey avk
-updateVerifKeyInDB (VKUAddPersonalKey apk) = addPersonalKey apk
+updateVerifKeyInDB (VKUAddPersonalKey avk) = addPersonalKey avk
 updateVerifKeyInDB (VKUUpdateKey uvk)      = updateVerifKey uvk
 
 data VerifKeyDetail = VerifKeyDetail
@@ -652,10 +713,10 @@ makeVerifKeyUpdate :: VerifKeyDetail -> VerifKeyUpdate
 makeVerifKeyUpdate (VerifKeyDetail uKey iori key mexpires uActor host shared) =
     case iori of
         Left uInbox ->
-            let avk = AddVerifKey host uKey mexpires key
+            let avk = AddVerifKey host uKey mexpires key uActor uInbox
             in  if shared
                     then VKUAddSharedKey avk
-                    else VKUAddPersonalKey $ AddPersonalKey avk uActor uInbox
+                    else VKUAddPersonalKey avk
         Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key
 
 instance YesodHttpSig App where
@@ -686,7 +747,11 @@ instance YesodHttpSig App where
                 [] -> return Nothing
                 [b] -> fmap Just . ExceptT . pure $ do
                     t <- first displayException $ decodeUtf8' b
-                    parseFedURI t
+                    u <- parseFedURI t
+                    if furiHost u == furiHost uKey
+                        then Right ()
+                        else Left "Key and actor have different hosts"
+                    Right u
                 _ -> throwE "Multiple ActivityPub-Actor headers"
         vkd <- do
             ments <- lift $ runDB $ do
@@ -709,9 +774,10 @@ instance YesodHttpSig App where
                                 ua <- case muActorHeader of
                                     Nothing -> throwE "Got a sig with an instance key, but actor header not specified!"
                                     Just u -> return u
-                                _ <- do
                                 manager <- getsYesod appHttpManager
-                                    ExceptT $ keyListedByActor manager uKey ua
+                                let iid = verifKeyInstance vk
+                                ExceptT $
+                                    keyListedByActor' manager iid vkid uKey ua
                                 return (ua, True)
                     return VerifKeyDetail
                         { vkdKeyId     = uKey