diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 458b8ce..75eec1c 100644 --- a/src/Vervis/Application.hs +++ b/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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 7b30f25..9464499 100644 --- a/src/Vervis/Foundation.hs +++ b/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.Simple (httpJSONEither, setRequestManager, addRequestHeader) +import Network.HTTP.Client 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 --- getHttpManager = appHttpManager +instance HasHttpManager App where + 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 -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 :: 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 YesodRemoteActorStore App where + siteInstanceMutex = appInstanceMutex + siteInstanceRoomMode = appMaxInstanceKeys . appSettings + siteActorRoomMode = appMaxActorKeys . appSettings + siteRejectOnMaxKeys = appRejectOnMaxKeys . appSettings 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 diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs new file mode 100644 index 0000000..4226a31 --- /dev/null +++ b/src/Vervis/RemoteActorStore.hs @@ -0,0 +1,433 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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) diff --git a/vervis.cabal b/vervis.cabal index 1050743..2916b6a 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -166,6 +166,7 @@ library Vervis.Patch Vervis.Query Vervis.Readme + Vervis.RemoteActorStore Vervis.Render Vervis.Role Vervis.Secure