Move remote actor DB code from Foundation to separate module

src/Vervis/Application.hs

@@ -65,6 +65,7 @@ import Web.Hashids.Local
 
 import Vervis.ActorKey (generateActorKey, actorKeyRotator)
 import Vervis.KeyFile (isInitialSetup)
+import Vervis.RemoteActorStore (newInstanceMutex)
 
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
@@ -122,7 +123,7 @@ makeFoundation appSettings = do
         newTVarIO =<<
         (,,) <$> generateActorKey <*> generateActorKey <*> pure True
 
-    appInstanceMutex <- newTVarIO M.empty
+    appInstanceMutex <- newInstanceMutex
 
     appActivities <- newTVarIO mempty
 

src/Vervis/Foundation.hs

@@ -34,8 +34,7 @@ import Data.Time.Interval (TimeInterval, fromTimeUnit, toTimeUnit)
 import Data.Time.Units (Second, Minute, Day)
 import Database.Persist.Sql (ConnectionPool, runSqlPool)
 import Graphics.SVGFonts.ReadFont (PreparedFont)
-import Network.HTTP.Client (Manager, HttpException, requestFromURI, responseBody)
+import Network.HTTP.Client
-import Network.HTTP.Simple (httpJSONEither, setRequestManager, addRequestHeader)
 import Network.HTTP.Types.Header (hHost)
 import Network.URI (URI, uriAuthority, uriFragment, uriRegName, parseURI)
 import Text.Shakespeare.Text (textFile)
@@ -76,6 +75,7 @@ import Vervis.Import.NoFoundation hiding (Handler, Day, last, init, logWarn)
 import Vervis.Model.Group
 import Vervis.Model.Ident
 import Vervis.Model.Role
+import Vervis.RemoteActorStore
 import Vervis.Widget (breadcrumbsW, revisionW)
 
 -- | The foundation datatype for your application. This can be a good place to
@@ -91,7 +91,7 @@ data App = App
     , appMailQueue    :: Maybe (Chan (MailRecipe App))
     , appSvgFont      :: PreparedFont Double
     , appActorKeys    :: TVar (ActorKey, ActorKey, Bool)
-    , appInstanceMutex :: TVar (HashMap Text (MVar ()))
+    , appInstanceMutex :: InstanceMutex
     , appCapSignKey   :: ActorKey
     , appHashidEncode :: Int64 -> Text
     , appHashidDecode :: Text -> Maybe Int64
@@ -575,8 +575,8 @@ instance RenderMessage App FormMessage where
 -- An example is background jobs that send email.
 -- This can also be useful for writing code that works across multiple Yesod
 -- applications.
---instance HasHttpManager App where
+instance HasHttpManager App where
---    getHttpManager = appHttpManager
+    getHttpManager = appHttpManager
 
 unsafeHandler :: App -> Handler a -> IO a
 unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
@@ -589,241 +589,11 @@ 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
 
--- TODO this is copied from stm-2.5, remove when we upgrade LTS
+instance YesodRemoteActorStore App where
-stateTVar :: TVar s -> (s -> (a, s)) -> STM a
+    siteInstanceMutex    = appInstanceMutex
-stateTVar var f = do
+    siteInstanceRoomMode = appMaxInstanceKeys . appSettings
-    s <- readTVar var
+    siteActorRoomMode    = appMaxActorKeys . appSettings
-    let (a, s') = f s -- since we destructure this, we are strict in f
+    siteRejectOnMaxKeys  = appRejectOnMaxKeys . appSettings
-    writeTVar var s'
-    return a
-
-withHostLock :: Text -> Handler a -> Handler a
-withHostLock host action = do
-    tvar <- getsYesod appInstanceMutex
-    mvar <- liftIO $ do
-        existing <- M.lookup host <$> readTVarIO tvar
-        case existing of
-            Just v -> return v
-            Nothing -> do
-                v <- newEmptyMVar
-                atomically $ stateTVar tvar $ \ m ->
-                    case M.lookup host m of
-                        Just v' -> (v', m)
-                        Nothing -> (v, M.insert host v m)
-    withMVar mvar $ const action
-
-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
-
--- | Grab instance and remote sharer IDs from the DB, inserting new ones if
--- they can't be found in the DB. The @Maybe Bool@ indicates whether the IDs
--- are newly inserted record: 'Nothing' means they're both new. @Just True@
--- means the instance record existed but the remote sharer is new. @Just False@
--- means both the instance and remote sharer existed in the DB.
-instanceAndActor
-    :: Text
-    -> LocalURI
-    -> LocalURI
-    -> AppDB (InstanceId, RemoteSharerId, Maybe Bool)
-instanceAndActor host luActor luInbox = do
-    (iid, inew) <- idAndNew <$> insertBy (Instance host)
-    let rs = RemoteSharer luActor iid luInbox
-    if inew
-        then do
-            rsid <- insert rs
-            return (iid, rsid, Nothing)
-        else do
-            (rsid, rsnew) <- idAndNew <$> insertBy rs
-            return (iid, rsid, Just rsnew)
-    where
-    idAndNew (Left (Entity iid _)) = (iid, False)
-    idAndNew (Right iid)           = (iid, True)
-
-actorRoom :: Int -> RemoteSharerId -> AppDB Bool
-actorRoom limit rsid = do
-    sumUpTo limit
-        (count [VerifKeySharedUsageUser ==. rsid])
-        (count [VerifKeySharer ==. Just rsid])
-
-getOldUsageId rsid = fmap entityKey . listToMaybe <$> selectList [VerifKeySharedUsageUser ==. rsid] [Asc VerifKeySharedUsageId, LimitTo 1]
-
-getOldPersonalKeyId rsid = fmap entityKey . listToMaybe <$> selectList [VerifKeySharer ==. Just rsid] [Asc VerifKeyExpires, Asc VerifKeyId, LimitTo 1]
-
-makeActorRoomByPersonal limit rsid vkid = do
-    room <-
-        if limit <= 1
-            then return False
-            else (< limit-1) <$> count [VerifKeySharer ==. Just rsid, VerifKeyId !=. vkid]
-    unless room $ delete vkid
-
-makeActorRoomByUsage limit rsid suid = do
-    room <-
-        if limit <= 1
-            then return False
-            else
-                sumUpTo (limit-1)
-                    (count [VerifKeySharedUsageUser ==. rsid, VerifKeySharedUsageId !=. suid])
-                    (count [VerifKeySharer ==. Just rsid])
-    unless room $ delete suid
-
--- | Checks whether the given actor has room left for a new shared key usage
--- record, and if not, deletes a record to make room for a new one. It prefers
--- to delete a usage record if any exist; otherwise it deletes a personal key.
---
--- The first parameter is the actor key storage limit, and it must be above
--- zero.
-makeActorRoomForUsage :: Int -> RemoteSharerId -> AppDB ()
-makeActorRoomForUsage limit rsid = do
-    msuid <- getOldUsageId rsid
-    case msuid of
-        Nothing -> do
-            mvkid <- getOldPersonalKeyId rsid
-            case mvkid of
-                Nothing -> return ()
-                Just vkid -> makeActorRoomByPersonal limit rsid vkid
-        Just suid -> makeActorRoomByUsage limit rsid suid
-
--- | Checks whether the given actor has room left for a new personal key
--- record, and if not, deletes a record to make room for a new one. It prefers
--- to delete a personal key if any exist; otherwise it deletes a usage record.
---
--- The first parameter is the actor key storage limit, and it must be above
--- zero.
-makeActorRoomForPersonalKey :: Int -> RemoteSharerId -> AppDB ()
-makeActorRoomForPersonalKey limit rsid = do
-    mvkid <- getOldPersonalKeyId rsid
-    case mvkid of
-        Nothing -> do
-            msuid <- getOldUsageId rsid
-            case msuid of
-                Nothing -> return ()
-                Just suid -> makeActorRoomByUsage limit rsid suid
-        Just vkid -> makeActorRoomByPersonal limit rsid vkid
-
--- | Checks whether the given instance has room left for a new shared key
--- record, and if not, deletes a record to make room for a new one.
---
--- The first parameter is the actor key storage limit, and it must be above
--- zero.
-makeInstanceRoom :: Int -> InstanceId -> AppDB ()
-makeInstanceRoom limit iid = do
-    mvk <- listToMaybe <$> selectList [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing] [Asc VerifKeyExpires, Asc VerifKeyId, LimitTo 1]
-    case mvk of
-        Nothing -> return ()
-        Just (Entity vkid _) -> do
-            room <-
-                if limit <= 1
-                    then return False
-                    else (< limit-1) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing, VerifKeyId !=. vkid]
-            unless room $ delete vkid
-
-data RoomModeDB
-    = RoomModeNoLimit
-    | RoomModeLimit Int
-
-data RoomMode
-    = RoomModeInstant
-    | RoomModeCached RoomModeDB
-
-roomModeFromLimit :: Maybe Int -> RoomMode
-roomModeFromLimit Nothing      = RoomModeCached $ RoomModeNoLimit
-roomModeFromLimit (Just limit) =
-    if limit <= 0
-        then RoomModeInstant
-        else RoomModeCached $ RoomModeLimit limit
-
-actorRoomMode :: AppSettings -> RoomMode
-actorRoomMode = roomModeFromLimit . appMaxActorKeys
-
-instanceRoomMode :: AppSettings -> RoomMode
-instanceRoomMode = roomModeFromLimit . appMaxInstanceKeys
-
--- | Given a shared key we have in our DB, verify that the given actor lists
--- this key, and update the DB accordingly.
---
---   * If the storage limit on actor keys is zero:
---       - If we're supposed to reject signatures when there's no room, raise
---         an error! We can't store anything with a limit of 0
---       - Otherwise, fetch the actor, store in DB if we don't have it, verify
---         usage via actor JSON. Usage isn't stored in the DB.
---   * If there's no storage limit, or it's above zero:
---     - If we know the actor and we have a record that it lists the key,
---       return success, no other 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 the maximal number of
---       keys: If we're supposed to reject signatures when there's no room,
---       raise an error. Otherwise, delete an old key/usage and store the new
---       usage in the 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 (if the storage limit isn't zero).
-keyListedByActorShared
-    :: Manager
-    -> InstanceId
-    -> VerifKeyId
-    -> Text
-    -> LocalURI
-    -> LocalURI
-    -> ExceptT String Handler ()
-keyListedByActorShared manager iid vkid host luKey luActor = do
-    (reject, roomMode) <- do
-        s <- getsYesod appSettings
-        return (appRejectOnMaxKeys s, actorRoomMode s)
-    case roomMode of
-        RoomModeInstant -> do
-            when reject $ throwE "Actor key storage limit is 0 and set to reject"
-            luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
-            _ <- lift $ runDB $ insertUnique $ RemoteSharer luActor iid luInbox
-            return ()
-        RoomModeCached m -> do
-            mresult <- do
-                ments <- lift $ runDB $ do
-                    mrs <- getBy $ UniqueRemoteSharer iid luActor
-                    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
-            for_ mresult $ \ mrsid -> do
-                luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
-                ExceptT $ runDB $ do
-                    vkExists <- isJust <$> get vkid
-                    case mrsid of
-                        Nothing -> do
-                            rsid <- insert $ RemoteSharer luActor iid luInbox
-                            when vkExists $ insert_ $ VerifKeySharedUsage vkid rsid
-                            return $ Right ()
-                        Just rsid -> runExceptT $ when vkExists $ do
-                            case m of
-                                RoomModeNoLimit -> return ()
-                                RoomModeLimit limit -> do
-                                    if reject
-                                        then do
-                                            room <- lift $ actorRoom limit rsid
-                                            unless room $ throwE "Actor key storage limit reached"
-                                        else lift $ makeActorRoomForUsage limit rsid
-                            lift $ insert_ $ VerifKeySharedUsage vkid rsid
-
-data VerifKeyDetail = VerifKeyDetail
-    { vkdKeyId     :: LocalURI
-    , vkdKey       :: PublicKey
-    , vkdExpires   :: Maybe UTCTime
-    , vkdActorId   :: LocalURI
-    , vkdShared    :: Bool
-    }
 
 instance YesodHttpSig App where
     data HttpSigVerResult App = HttpSigVerResult (Either String FedURI)
@@ -863,9 +633,8 @@ instance YesodHttpSig App where
                                 ua <- case mluActorHeader of
                                     Nothing -> throwE "Got a sig with an instance key, but actor header not specified!"
                                     Just u -> return u
-                                manager <- getsYesod appHttpManager
                                 let iid = verifKeyInstance vk
-                                withHostLock' host $ keyListedByActorShared manager iid vkid host luKey ua
+                                withHostLock' host $ keyListedByActorShared iid vkid host luKey ua
                                 return (ua, True)
                     return
                         ( Right (verifKeyInstance vk, vkid)
@@ -888,7 +657,7 @@ instance YesodHttpSig App where
 
         if verify' (vkdKey vkd) && stillValid (vkdExpires vkd)
             then case inboxOrVkid of
-                Left uinb -> ExceptT $ withHostLock host $ runDB $ addVerifKey host uinb vkd
+                Left uinb -> ExceptT $ withHostLock host $ runDB $ runExceptT $ addVerifKey host uinb vkd
                 Right _ids -> return ()
             else case inboxOrVkid of
                 Left _uinb ->
@@ -897,7 +666,7 @@ instance YesodHttpSig App where
                         else errTime
                 Right (iid, vkid) -> do
                     let ua = vkdActorId vkd
-                        listed = withHostLock' host $ keyListedByActorShared manager iid vkid host luKey ua
+                        listed = withHostLock' host $ keyListedByActorShared iid vkid host luKey ua
                     (newKey, newExp) <-
                         if vkdShared vkd
                             then fetchKnownSharedKey manager listed sigAlgo host ua luKey
@@ -948,63 +717,6 @@ instance YesodHttpSig App where
                 , 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 _) = runExceptT $ do
-                (reject, roomModeA, roomModeI) <- do
-                    s <- getsYesod appSettings
-                    return (appRejectOnMaxKeys s, actorRoomMode s, instanceRoomMode s)
-                (iid, rsid, inew) <- lift $ instanceAndActor host luActor luInbox
-                case roomModeI of
-                    RoomModeInstant ->
-                        when reject $ throwE "Instance key storage limit is 0 and set to reject"
-                    RoomModeCached m -> do
-                        case m of
-                            RoomModeNoLimit -> return ()
-                            RoomModeLimit limit ->
-                                if reject
-                                    then when (isJust inew) $ do
-                                        room <- lift $ instanceRoom limit iid
-                                        unless room $ throwE "Instance key storage limit reached"
-                                    else when (isJust inew) $ lift $ makeInstanceRoom limit iid
-                        vkid <- lift $ insert $ VerifKey luKey iid mexpires key Nothing
-                        case roomModeA of
-                            RoomModeInstant ->
-                                when reject $ throwE "Actor key storage limit is 0 and set to reject"
-                            RoomModeCached m -> do
-                                case m of
-                                    RoomModeNoLimit -> return ()
-                                    RoomModeLimit limit ->
-                                        if reject
-                                            then when (inew == Just False) $ do
-                                                room <- lift $ actorRoom limit rsid
-                                                unless room $ throwE "Actor key storage limit reached"
-                                            else when (inew == Just False) $ lift $ makeActorRoomForUsage limit rsid
-                                lift $ insert_ $ VerifKeySharedUsage vkid rsid
-                where
-                instanceRoom n iid =
-                    (< n) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
-            addPersonalKey host luInbox (VerifKeyDetail luKey key mexpires luActor _) = runExceptT $ do
-                (reject, roomMode) <- do
-                    s <- getsYesod appSettings
-                    return (appRejectOnMaxKeys s, actorRoomMode s)
-                (iid, rsid, inew) <- lift $ instanceAndActor host luActor luInbox
-                case roomMode of
-                    RoomModeInstant ->
-                        when reject $ throwE "Actor key storage limit is 0 and set to reject"
-                    RoomModeCached m -> do
-                        case m of
-                            RoomModeNoLimit -> return ()
-                            RoomModeLimit limit ->
-                                if reject
-                                    then when (inew == Just False) $ do
-                                        room <- lift $ actorRoom limit rsid
-                                        unless room $ throwE "Actor key storage limit reached"
-                                    else when (inew == Just False) $ lift $ makeActorRoomForPersonalKey limit rsid
-                        lift $ insert_ $ VerifKey luKey iid mexpires key (Just rsid)
         updateVerifKey vkid vkd =
             update vkid [VerifKeyExpires =. vkdExpires vkd, VerifKeyPublic =. vkdKey vkd]
         withHostLock' h = ExceptT . withHostLock h . runExceptT

src/Vervis/RemoteActorStore.hs

@@ -0,0 +1,433 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | This module collects functions for working with the storage of remote
+-- instances, actors and their details in our local database.
+module Vervis.RemoteActorStore
+    ( InstanceMutex ()
+    , newInstanceMutex
+    , YesodRemoteActorStore (..)
+    , withHostLock
+    , keyListedByActorShared
+    , VerifKeyDetail (..)
+    , addVerifKey
+    )
+where
+
+import Prelude
+
+import Control.Concurrent.MVar (MVar, newEmptyMVar)
+import Control.Concurrent.STM.TVar
+import Control.Monad
+import Control.Monad.STM
+import Control.Monad.Trans.Except
+import Data.Foldable
+import Data.HashMap.Strict (HashMap)
+import Data.Maybe
+import Data.Text (Text)
+import Data.Time.Clock
+import Data.Traversable
+import Database.Persist
+import Database.Persist.Sql
+import Network.HTTP.Client
+import UnliftIO.MVar (withMVar)
+import Yesod.Core
+import Yesod.Persist.Core
+
+import qualified Crypto.PubKey.Ed25519 as E
+import qualified Data.HashMap.Strict as M
+
+import Network.FedURI
+import Web.ActivityPub
+
+import Vervis.Model
+
+newtype InstanceMutex = InstanceMutex (TVar (HashMap Text (MVar ())))
+
+newInstanceMutex :: IO InstanceMutex
+newInstanceMutex = InstanceMutex <$> newTVarIO M.empty
+
+data RoomModeDB
+    = RoomModeNoLimit
+    | RoomModeLimit Int
+
+data RoomMode
+    = RoomModeInstant
+    | RoomModeCached RoomModeDB
+
+class Yesod site => YesodRemoteActorStore site where
+    siteInstanceMutex    :: site -> InstanceMutex
+    siteInstanceRoomMode :: site -> Maybe Int
+    siteActorRoomMode    :: site -> Maybe Int
+    siteRejectOnMaxKeys  :: site -> Bool
+
+-- TODO this is copied from stm-2.5, remove when we upgrade LTS
+stateTVar :: TVar s -> (s -> (a, s)) -> STM a
+stateTVar var f = do
+    s <- readTVar var
+    let (a, s') = f s -- since we destructure this, we are strict in f
+    writeTVar var s'
+    return a
+
+withHostLock
+    :: YesodRemoteActorStore site
+    => Text
+    -> HandlerFor site a
+    -> HandlerFor site a
+withHostLock host action = do
+    InstanceMutex tvar <- getsYesod siteInstanceMutex
+    mvar <- liftIO $ do
+        existing <- M.lookup host <$> readTVarIO tvar
+        case existing of
+            Just v -> return v
+            Nothing -> do
+                v <- newEmptyMVar
+                atomically $ stateTVar tvar $ \ m ->
+                    case M.lookup host m of
+                        Just v' -> (v', m)
+                        Nothing -> (v, M.insert host v m)
+    withMVar mvar $ const action
+
+sumUpTo :: Int -> YesodDB site Int -> YesodDB site Int -> YesodDB site Bool
+sumUpTo limit action1 action2 = do
+    n <- action1
+    if n <= limit
+        then do
+            m <- action2
+            return $ n + m <= limit
+        else return False
+
+-- | Grab instance and remote sharer IDs from the DB, inserting new ones if
+-- they can't be found in the DB. The @Maybe Bool@ indicates whether the IDs
+-- are newly inserted record: 'Nothing' means they're both new. @Just True@
+-- means the instance record existed but the remote sharer is new. @Just False@
+-- means both the instance and remote sharer existed in the DB.
+instanceAndActor
+    :: ( PersistUniqueWrite (YesodPersistBackend site)
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       )
+    => Text
+    -> LocalURI
+    -> LocalURI
+    -> YesodDB site (InstanceId, RemoteSharerId, Maybe Bool)
+instanceAndActor host luActor luInbox = do
+    (iid, inew) <- idAndNew <$> insertBy (Instance host)
+    let rs = RemoteSharer luActor iid luInbox
+    if inew
+        then do
+            rsid <- insert rs
+            return (iid, rsid, Nothing)
+        else do
+            (rsid, rsnew) <- idAndNew <$> insertBy rs
+            return (iid, rsid, Just rsnew)
+    where
+    idAndNew (Left (Entity iid _)) = (iid, False)
+    idAndNew (Right iid)           = (iid, True)
+
+actorRoom
+    :: ( PersistQueryRead (YesodPersistBackend site)
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       )
+    => Int
+    -> RemoteSharerId
+    -> YesodDB site Bool
+actorRoom limit rsid = do
+    sumUpTo limit
+        (count [VerifKeySharedUsageUser ==. rsid])
+        (count [VerifKeySharer ==. Just rsid])
+
+getOldUsageId
+    :: ( PersistQueryRead (YesodPersistBackend site)
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       )
+    => RemoteSharerId
+    -> YesodDB site (Maybe VerifKeySharedUsageId)
+getOldUsageId rsid = fmap entityKey . listToMaybe <$> selectList [VerifKeySharedUsageUser ==. rsid] [Asc VerifKeySharedUsageId, LimitTo 1]
+
+getOldPersonalKeyId
+    :: ( PersistQueryRead (YesodPersistBackend site)
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       )
+    => RemoteSharerId
+    -> YesodDB site (Maybe VerifKeyId)
+getOldPersonalKeyId rsid = fmap entityKey . listToMaybe <$> selectList [VerifKeySharer ==. Just rsid] [Asc VerifKeyExpires, Asc VerifKeyId, LimitTo 1]
+
+makeActorRoomByPersonal
+    :: ( PersistQueryRead (YesodPersistBackend site)
+       , PersistStoreWrite (YesodPersistBackend site)
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       )
+    => Int
+    -> RemoteSharerId
+    -> VerifKeyId
+    -> YesodDB site ()
+makeActorRoomByPersonal limit rsid vkid = do
+    room <-
+        if limit <= 1
+            then return False
+            else (< limit-1) <$> count [VerifKeySharer ==. Just rsid, VerifKeyId !=. vkid]
+    unless room $ delete vkid
+
+makeActorRoomByUsage
+    :: ( PersistQueryRead (YesodPersistBackend site)
+       , PersistStoreWrite (YesodPersistBackend site)
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       )
+    => Int
+    -> RemoteSharerId
+    -> VerifKeySharedUsageId
+    -> YesodDB site ()
+makeActorRoomByUsage limit rsid suid = do
+    room <-
+        if limit <= 1
+            then return False
+            else
+                sumUpTo (limit-1)
+                    (count [VerifKeySharedUsageUser ==. rsid, VerifKeySharedUsageId !=. suid])
+                    (count [VerifKeySharer ==. Just rsid])
+    unless room $ delete suid
+
+-- | Checks whether the given actor has room left for a new shared key usage
+-- record, and if not, deletes a record to make room for a new one. It prefers
+-- to delete a usage record if any exist; otherwise it deletes a personal key.
+--
+-- The first parameter is the actor key storage limit, and it must be above
+-- zero.
+makeActorRoomForUsage
+    :: ( PersistQueryRead (YesodPersistBackend site)
+       , PersistStoreWrite (YesodPersistBackend site)
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       )
+    => Int
+    -> RemoteSharerId
+    -> YesodDB site ()
+makeActorRoomForUsage limit rsid = do
+    msuid <- getOldUsageId rsid
+    case msuid of
+        Nothing -> do
+            mvkid <- getOldPersonalKeyId rsid
+            case mvkid of
+                Nothing -> return ()
+                Just vkid -> makeActorRoomByPersonal limit rsid vkid
+        Just suid -> makeActorRoomByUsage limit rsid suid
+
+-- | Checks whether the given actor has room left for a new personal key
+-- record, and if not, deletes a record to make room for a new one. It prefers
+-- to delete a personal key if any exist; otherwise it deletes a usage record.
+--
+-- The first parameter is the actor key storage limit, and it must be above
+-- zero.
+makeActorRoomForPersonalKey
+    :: ( PersistQueryRead (YesodPersistBackend site)
+       , PersistStoreWrite (YesodPersistBackend site)
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       )
+    => Int
+    -> RemoteSharerId
+    -> YesodDB site ()
+makeActorRoomForPersonalKey limit rsid = do
+    mvkid <- getOldPersonalKeyId rsid
+    case mvkid of
+        Nothing -> do
+            msuid <- getOldUsageId rsid
+            case msuid of
+                Nothing -> return ()
+                Just suid -> makeActorRoomByUsage limit rsid suid
+        Just vkid -> makeActorRoomByPersonal limit rsid vkid
+
+-- | Checks whether the given instance has room left for a new shared key
+-- record, and if not, deletes a record to make room for a new one.
+--
+-- The first parameter is the actor key storage limit, and it must be above
+-- zero.
+makeInstanceRoom
+    :: ( PersistQueryRead (YesodPersistBackend site)
+       , PersistStoreWrite (YesodPersistBackend site)
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       )
+    => Int
+    -> InstanceId
+    -> YesodDB site ()
+makeInstanceRoom limit iid = do
+    mvk <- listToMaybe <$> selectList [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing] [Asc VerifKeyExpires, Asc VerifKeyId, LimitTo 1]
+    case mvk of
+        Nothing -> return ()
+        Just (Entity vkid _) -> do
+            room <-
+                if limit <= 1
+                    then return False
+                    else (< limit-1) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing, VerifKeyId !=. vkid]
+            unless room $ delete vkid
+
+roomModeFromLimit :: Maybe Int -> RoomMode
+roomModeFromLimit Nothing      = RoomModeCached $ RoomModeNoLimit
+roomModeFromLimit (Just limit) =
+    if limit <= 0
+        then RoomModeInstant
+        else RoomModeCached $ RoomModeLimit limit
+
+-- | Given a shared key we have in our DB, verify that the given actor lists
+-- this key, and update the DB accordingly.
+--
+--   * If the storage limit on actor keys is zero:
+--       - If we're supposed to reject signatures when there's no room, raise
+--         an error! We can't store anything with a limit of 0
+--       - Otherwise, fetch the actor, store in DB if we don't have it, verify
+--         usage via actor JSON. Usage isn't stored in the DB.
+--   * If there's no storage limit, or it's above zero:
+--     - If we know the actor and we have a record that it lists the key,
+--       return success, no other 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 the maximal number of
+--       keys: If we're supposed to reject signatures when there's no room,
+--       raise an error. Otherwise, delete an old key/usage and store the new
+--       usage in the 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 (if the storage limit isn't zero).
+keyListedByActorShared
+    :: ( HasHttpManager site
+       , YesodPersist site
+       , YesodRemoteActorStore site
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       , PersistQueryRead (YesodPersistBackend site)
+       , PersistUniqueWrite (YesodPersistBackend site)
+       )
+    => InstanceId
+    -> VerifKeyId
+    -> Text
+    -> LocalURI
+    -> LocalURI
+    -> ExceptT String (HandlerFor site) ()
+keyListedByActorShared iid vkid host luKey luActor = do
+    manager <- getsYesod getHttpManager
+    reject <- getsYesod siteRejectOnMaxKeys
+    roomMode <- getsYesod $ roomModeFromLimit . siteActorRoomMode
+    case roomMode of
+        RoomModeInstant -> do
+            when reject $ throwE "Actor key storage limit is 0 and set to reject"
+            luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
+            _ <- lift $ runDB $ insertUnique $ RemoteSharer luActor iid luInbox
+            return ()
+        RoomModeCached m -> do
+            mresult <- do
+                ments <- lift $ runDB $ do
+                    mrs <- getBy $ UniqueRemoteSharer iid luActor
+                    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
+            for_ mresult $ \ mrsid -> do
+                luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
+                ExceptT $ runDB $ do
+                    vkExists <- isJust <$> get vkid
+                    case mrsid of
+                        Nothing -> do
+                            rsid <- insert $ RemoteSharer luActor iid luInbox
+                            when vkExists $ insert_ $ VerifKeySharedUsage vkid rsid
+                            return $ Right ()
+                        Just rsid -> runExceptT $ when vkExists $ do
+                            case m of
+                                RoomModeNoLimit -> return ()
+                                RoomModeLimit limit -> do
+                                    if reject
+                                        then do
+                                            room <- lift $ actorRoom limit rsid
+                                            unless room $ throwE "Actor key storage limit reached"
+                                        else lift $ makeActorRoomForUsage limit rsid
+                            lift $ insert_ $ VerifKeySharedUsage vkid rsid
+
+data VerifKeyDetail = VerifKeyDetail
+    { vkdKeyId     :: LocalURI
+    , vkdKey       :: E.PublicKey
+    , vkdExpires   :: Maybe UTCTime
+    , vkdActorId   :: LocalURI
+    , vkdShared    :: Bool
+    }
+
+addVerifKey
+    :: ( YesodRemoteActorStore site
+       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+       , PersistQueryRead (YesodPersistBackend site)
+       , PersistUniqueWrite (YesodPersistBackend site)
+       )
+    => Text
+    -> LocalURI
+    -> VerifKeyDetail
+    -> ExceptT String (YesodDB site) ()
+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
+        reject <- getsYesod siteRejectOnMaxKeys
+        roomModeA <- getsYesod $ roomModeFromLimit . siteActorRoomMode
+        roomModeI <- getsYesod $ roomModeFromLimit . siteInstanceRoomMode
+        (iid, rsid, inew) <- lift $ instanceAndActor host luActor luInbox
+        case roomModeI of
+            RoomModeInstant ->
+                when reject $ throwE "Instance key storage limit is 0 and set to reject"
+            RoomModeCached m -> do
+                case m of
+                    RoomModeNoLimit -> return ()
+                    RoomModeLimit limit ->
+                        if reject
+                            then when (isJust inew) $ do
+                                room <- lift $ instanceRoom limit iid
+                                unless room $ throwE "Instance key storage limit reached"
+                            else when (isJust inew) $ lift $ makeInstanceRoom limit iid
+                vkid <- lift $ insert $ VerifKey luKey iid mexpires key Nothing
+                case roomModeA of
+                    RoomModeInstant ->
+                        when reject $ throwE "Actor key storage limit is 0 and set to reject"
+                    RoomModeCached m -> do
+                        case m of
+                            RoomModeNoLimit -> return ()
+                            RoomModeLimit limit ->
+                                if reject
+                                    then when (inew == Just False) $ do
+                                        room <- lift $ actorRoom limit rsid
+                                        unless room $ throwE "Actor key storage limit reached"
+                                    else when (inew == Just False) $ lift $ makeActorRoomForUsage limit rsid
+                        lift $ insert_ $ VerifKeySharedUsage vkid rsid
+        where
+        instanceRoom n iid =
+            (< n) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing]
+    addPersonalKey host luInbox (VerifKeyDetail luKey key mexpires luActor _) = do
+        reject <- getsYesod siteRejectOnMaxKeys
+        roomMode <- getsYesod $ roomModeFromLimit . siteActorRoomMode
+        (iid, rsid, inew) <- lift $ instanceAndActor host luActor luInbox
+        case roomMode of
+            RoomModeInstant ->
+                when reject $ throwE "Actor key storage limit is 0 and set to reject"
+            RoomModeCached m -> do
+                case m of
+                    RoomModeNoLimit -> return ()
+                    RoomModeLimit limit ->
+                        if reject
+                            then when (inew == Just False) $ do
+                                room <- lift $ actorRoom limit rsid
+                                unless room $ throwE "Actor key storage limit reached"
+                            else when (inew == Just False) $ lift $ makeActorRoomForPersonalKey limit rsid
+                lift $ insert_ $ VerifKey luKey iid mexpires key (Just rsid)

vervis.cabal

@@ -166,6 +166,7 @@ library
                        Vervis.Patch
                        Vervis.Query
                        Vervis.Readme
+                       Vervis.RemoteActorStore
                        Vervis.Render
                        Vervis.Role
                        Vervis.Secure