diff --git a/hackage-server.cabal b/hackage-server.cabal index bd88d1455..ac0972b60 100644 --- a/hackage-server.cabal +++ b/hackage-server.cabal @@ -307,10 +307,13 @@ library Distribution.Server.Features.Browse.Options Distribution.Server.Features.Browse.Parsers Distribution.Server.Features.Core + Distribution.Server.Features.Core.Acid Distribution.Server.Features.Core.State - Distribution.Server.Features.Core.Backup - Distribution.Server.Features.Security - Distribution.Server.Features.Security.Backup + Distribution.Server.Features.Core.Store + Distribution.Server.Features.Core.Backup + Distribution.Server.Features.Security + Distribution.Server.Features.Security.Acid + Distribution.Server.Features.Security.Backup Distribution.Server.Features.Security.FileInfo Distribution.Server.Features.Security.Layout Distribution.Server.Features.Security.MD5 @@ -319,14 +322,25 @@ library Distribution.Server.Features.Security.ResponseContentTypes Distribution.Server.Features.Security.SHA256 Distribution.Server.Features.Security.State + Distribution.Server.Features.Security.Store Distribution.Server.Features.Mirror + Distribution.Server.Features.Mirror.Acid + Distribution.Server.Features.Mirror.Store + Distribution.Server.Features.TarIndexCache.Acid + Distribution.Server.Features.TarIndexCache.Store Distribution.Server.Features.Upload + Distribution.Server.Features.Upload.Acid + Distribution.Server.Features.Upload.Store Distribution.Server.Features.Upload.State Distribution.Server.Features.Upload.Backup Distribution.Server.Features.Users + Distribution.Server.Features.Users.Acid + Distribution.Server.Features.Users.Store Distribution.Server.Features.UserNotify Distribution.Server.Features.UserNotify.Acid + Distribution.Server.Features.UserNotify.Acid.Component Distribution.Server.Features.UserNotify.Backup + Distribution.Server.Features.UserNotify.Store Distribution.Server.Features.UserNotify.Types @@ -342,35 +356,49 @@ library Distribution.Server.Features.AdminLog Distribution.Server.Features.AdminLog.Acid Distribution.Server.Features.AdminLog.Backup + Distribution.Server.Features.AdminLog.State + Distribution.Server.Features.AdminLog.Store Distribution.Server.Features.AdminLog.Types Distribution.Server.Features.BuildReports Distribution.Server.Features.BuildReports.BuildReport Distribution.Server.Features.BuildReports.BuildReports + Distribution.Server.Features.BuildReports.Acid Distribution.Server.Features.BuildReports.Backup + Distribution.Server.Features.BuildReports.Store Distribution.Server.Features.BuildReports.Render Distribution.Server.Features.BuildReports.State Distribution.Server.Features.PackageCandidates + Distribution.Server.Features.PackageCandidates.Acid Distribution.Server.Features.PackageCandidates.Types Distribution.Server.Features.PackageCandidates.State Distribution.Server.Features.PackageCandidates.Backup + Distribution.Server.Features.PackageCandidates.Store Distribution.Server.Features.PackageFeed Distribution.Server.Features.PackageList Distribution.Server.Features.Distro + Distribution.Server.Features.Distro.Acid Distribution.Server.Features.Distro.Distributions Distribution.Server.Features.Distro.Backup Distribution.Server.Features.Distro.State + Distribution.Server.Features.Distro.Store Distribution.Server.Features.Distro.Types Distribution.Server.Features.Documentation + Distribution.Server.Features.Documentation.Acid Distribution.Server.Features.Documentation.State + Distribution.Server.Features.Documentation.Store Distribution.Server.Features.DownloadCount + Distribution.Server.Features.DownloadCount.Acid Distribution.Server.Features.DownloadCount.State + Distribution.Server.Features.DownloadCount.Store Distribution.Server.Features.DownloadCount.Backup Distribution.Server.Features.EditCabalFiles Distribution.Server.Features.Html Distribution.Server.Features.Html.HtmlUtilities Distribution.Server.Features.HoogleData Distribution.Server.Features.HaskellPlatform + Distribution.Server.Features.HaskellPlatform.Acid Distribution.Server.Features.HaskellPlatform.State + Distribution.Server.Features.HaskellPlatform.Store Distribution.Server.Features.PackageInfoJSON Distribution.Server.Features.Search Distribution.Server.Features.Search.BM25F @@ -385,33 +413,47 @@ library Distribution.Server.Features.Search.TermBag Distribution.Server.Features.Sitemap.Functions Distribution.Server.Features.Votes + Distribution.Server.Features.Votes.Acid Distribution.Server.Features.Votes.Render Distribution.Server.Features.Votes.State + Distribution.Server.Features.Votes.Store Distribution.Server.Features.Votes.Types Distribution.Server.Features.Vouch + Distribution.Server.Features.Vouch.Acid Distribution.Server.Features.Vouch.State + Distribution.Server.Features.Vouch.Store Distribution.Server.Features.Vouch.Types Distribution.Server.Features.RecentPackages Distribution.Server.Features.PreferredVersions + Distribution.Server.Features.PreferredVersions.Acid Distribution.Server.Features.PreferredVersions.State Distribution.Server.Features.PreferredVersions.Types Distribution.Server.Features.PreferredVersions.Backup + Distribution.Server.Features.PreferredVersions.Store Distribution.Server.Features.ReverseDependencies Distribution.Server.Features.ReverseDependencies.State Distribution.Server.Features.Tags + Distribution.Server.Features.Tags.Acid Distribution.Server.Features.Tags.Backup + Distribution.Server.Features.Tags.Store Distribution.Server.Features.Tags.State Distribution.Server.Features.Tags.Types Distribution.Server.Features.AnalyticsPixels + Distribution.Server.Features.AnalyticsPixels.Acid Distribution.Server.Features.AnalyticsPixels.State + Distribution.Server.Features.AnalyticsPixels.Store Distribution.Server.Features.AnalyticsPixels.Types Distribution.Server.Features.UserDetails Distribution.Server.Features.UserDetails.Acid Distribution.Server.Features.UserDetails.Backup + Distribution.Server.Features.UserDetails.State + Distribution.Server.Features.UserDetails.Store Distribution.Server.Features.UserDetails.Types Distribution.Server.Features.UserSignup Distribution.Server.Features.UserSignup.Acid Distribution.Server.Features.UserSignup.Backup + Distribution.Server.Features.UserSignup.State + Distribution.Server.Features.UserSignup.Store Distribution.Server.Features.UserSignup.Types Distribution.Server.Features.StaticFiles Distribution.Server.Features.ServerIntrospect diff --git a/src/Distribution/Server/Features/AdminLog.hs b/src/Distribution/Server/Features/AdminLog.hs index 8c6a39330..a14392f24 100755 --- a/src/Distribution/Server/Features/AdminLog.hs +++ b/src/Distribution/Server/Features/AdminLog.hs @@ -4,18 +4,18 @@ module Distribution.Server.Features.AdminLog where -import qualified Distribution.Server.Features.AdminLog.Acid as Acid -import Distribution.Server.Features.AdminLog.Backup +import Distribution.Server.Features.AdminLog.Acid (acidStore) +import qualified Distribution.Server.Features.AdminLog.Store as Store import Distribution.Server.Features.AdminLog.Types import Distribution.Server.Users.Types (UserId) import Distribution.Server.Users.Group import Distribution.Server.Framework -import Distribution.Server.Framework.BackupRestore import Distribution.Server.Pages.AdminLog import Distribution.Server.Features.Users -import Data.Time.Clock (getCurrentTime) +import Data.Time.Clock (getCurrentTime, UTCTime) +import qualified Data.ByteString.Lazy.Char8 as BS import Distribution.Server.Util.Parse --TODO Maybe Reason @@ -29,7 +29,7 @@ mkAdminAction gd isAdd uid = (if isAdd then Admin_GroupAddUser else Admin_GroupD data AdminLogFeature = AdminLogFeature { adminLogFeatureInterface :: HackageFeature - , queryGetAdminLog :: forall m. MonadIO m => m Acid.AdminLog + , queryGetAdminLog :: forall m. MonadIO m => m [(UTCTime,UserId,AdminAction,BS.ByteString)] } instance IsHackageFeature AdminLogFeature where @@ -37,22 +37,22 @@ instance IsHackageFeature AdminLogFeature where initAdminLogFeature :: ServerEnv -> IO (UserFeature -> IO AdminLogFeature) initAdminLogFeature ServerEnv{serverStateDir} = do - adminLogState <- adminLogStateComponent serverStateDir + adminLogBackend <- acidStore serverStateDir return $ \users@UserFeature{groupChangedHook} -> do - let feature = adminLogFeature users adminLogState + let feature = adminLogFeature users adminLogBackend registerHook groupChangedHook $ \(gd,addOrDel,actorUid,targetUid,reason) -> do now <- getCurrentTime - updateState adminLogState $ Acid.AddAdminLog + Store.addAdminLog (Store.backendStore adminLogBackend) (now, actorUid, mkAdminAction gd addOrDel targetUid, packUTF8 reason) return feature adminLogFeature :: UserFeature - -> StateComponent AcidState Acid.AdminLog + -> Store.Backend -> AdminLogFeature -adminLogFeature UserFeature{..} adminLogState +adminLogFeature UserFeature{..} Store.Backend{backendStore = adminLogStore, backendState} = AdminLogFeature {..} where @@ -60,7 +60,7 @@ adminLogFeature UserFeature{..} adminLogState (emptyHackageFeature "admin-actions-log") { featureDesc = "Log of additions and removals of users from groups.", featureResources = [adminLogResource], - featureState = [abstractAcidStateComponent adminLogState] + featureState = backendState } adminLogResource :: Resource @@ -70,13 +70,13 @@ adminLogFeature UserFeature{..} adminLogState resourceGet = [("html", serveAdminLogGet)] } - queryGetAdminLog :: MonadIO m => m Acid.AdminLog - queryGetAdminLog = queryState adminLogState Acid.GetAdminLog + queryGetAdminLog :: MonadIO m => m [(UTCTime,UserId,AdminAction,BS.ByteString)] + queryGetAdminLog = Store.getAdminLog adminLogStore serveAdminLogGet _ = do - aLog <- queryState adminLogState Acid.GetAdminLog + aLog <- queryGetAdminLog users <- queryGetUserDb - return . toResponse . adminLogPage users . map mkRow . Acid.adminLog $ aLog + return . toResponse . adminLogPage users . map mkRow $ aLog mkRow (time, actorId, Admin_GroupDelUser targetId group, reason) = (time, actorId, "Acid.Delete", targetId, nameIt group, unpackUTF8 reason) @@ -87,18 +87,3 @@ adminLogFeature UserFeature{..} adminLogState nameIt AdminGroup = "Administrators" nameIt TrusteeGroup = "Trustees" nameIt (OtherGroup s) = unpackUTF8 s - -adminLogStateComponent :: FilePath -> IO (StateComponent AcidState Acid.AdminLog) -adminLogStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "AdminLog") Acid.initialAdminLog - return StateComponent { - stateDesc = "AdminLog" - , stateHandle = st - , getState = query st Acid.GetAdminLog - , putState = update st . Acid.ReplaceAdminLog - , backupState = \_ (Acid.AdminLog xs) -> - [BackupByteString ["adminLog.txt"] . backupLogEntries $ xs] - , restoreState = restoreAdminLogBackup - , resetState = adminLogStateComponent - } - diff --git a/src/Distribution/Server/Features/AdminLog/Acid.hs b/src/Distribution/Server/Features/AdminLog/Acid.hs index 4c03477fb..9aca94195 100644 --- a/src/Distribution/Server/Features/AdminLog/Acid.hs +++ b/src/Distribution/Server/Features/AdminLog/Acid.hs @@ -1,96 +1,34 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, BangPatterns, - GeneralizedNewtypeDeriving, NamedFieldPuns, RecordWildCards, - PatternGuards, RankNTypes #-} +module Distribution.Server.Features.AdminLog.Acid + ( acidStore + ) where -module Distribution.Server.Features.AdminLog.Acid where - -import Distribution.Server.Features.AdminLog.Types -import Distribution.Server.Users.Types (UserId) +import Distribution.Server.Features.AdminLog.Backup +import qualified Distribution.Server.Features.AdminLog.State as State +import Distribution.Server.Features.AdminLog.Store import Distribution.Server.Framework - -import Control.Monad.Reader -import qualified Control.Monad.State as State -import Data.Time (UTCTime) -import qualified Data.ByteString.Lazy.Char8 as BS -import Data.Acid.Compat - -newtype AdminLog = AdminLog { - adminLog :: [(UTCTime,UserId,AdminAction,BS.ByteString)] -} deriving (Show, MemSize) - -deriveSafeCopy 0 'base ''AdminLog - -initialAdminLog :: AdminLog -initialAdminLog = AdminLog [] - -getAdminLog :: Query AdminLog AdminLog -getAdminLog = ask - -addAdminLog :: (UTCTime, UserId, AdminAction, BS.ByteString) -> Update AdminLog () -addAdminLog x = State.modify (\(AdminLog xs) -> AdminLog (x : xs)) - -instance Eq AdminLog where - (AdminLog (x:_)) == (AdminLog (y:_)) = x == y - (AdminLog []) == (AdminLog []) = True - _ == _ = False - -replaceAdminLog :: AdminLog -> Update AdminLog () -replaceAdminLog = State.put - ------------------------------- --- IsAcidic machinery --- --- See Note [Acid Migration] in "Data.Acid.Compat" --- original module name was Distribution.Server.Features.AdminLog" - --- makeAcidic ''AdminLog ['getAdminLog --- ,'replaceAdminLog --- ,'addAdminLog] - -instance IsAcidic AdminLog where - acidEvents - = [QueryEvent - (\ GetAdminLog -> getAdminLog) safeCopyMethodSerialiser, - UpdateEvent - (\ (ReplaceAdminLog arg_aDn6) -> replaceAdminLog arg_aDn6) - safeCopyMethodSerialiser, - UpdateEvent - (\ (AddAdminLog arg_aDn7) -> addAdminLog arg_aDn7) - safeCopyMethodSerialiser] -data GetAdminLog = GetAdminLog -instance SafeCopy GetAdminLog where - putCopy GetAdminLog = contain (do return ()) - getCopy = contain (return GetAdminLog) - errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy GetAdminLog" -instance Data.Acid.Compat.Method GetAdminLog where - type MethodResult GetAdminLog = AdminLog - type MethodState GetAdminLog = AdminLog - methodTag = movedMethodTag "Distribution.Server.Features.AdminLog" -instance QueryEvent GetAdminLog -newtype ReplaceAdminLog = ReplaceAdminLog AdminLog -instance SafeCopy ReplaceAdminLog where - putCopy (ReplaceAdminLog arg_aDmO) - = contain - (do safePut arg_aDmO - return ()) - getCopy = contain (return ReplaceAdminLog <*> safeGet) - errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy ReplaceAdminLog" -instance Data.Acid.Compat.Method ReplaceAdminLog where - type MethodResult ReplaceAdminLog = () - type MethodState ReplaceAdminLog = AdminLog - methodTag = movedMethodTag "Distribution.Server.Features.AdminLog" -instance UpdateEvent ReplaceAdminLog -newtype AddAdminLog - = AddAdminLog (UTCTime, UserId, AdminAction, BS.ByteString) -instance SafeCopy AddAdminLog where - putCopy (AddAdminLog arg_aDmT) - = contain - (do safePut arg_aDmT - return ()) - getCopy = contain (return AddAdminLog <*> safeGet) - errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy AddAdminLog" -instance Data.Acid.Compat.Method AddAdminLog where - type MethodResult AddAdminLog = () - type MethodState AddAdminLog = AdminLog - methodTag = movedMethodTag "Distribution.Server.Features.AdminLog" -instance UpdateEvent AddAdminLog +import Distribution.Server.Framework.BackupRestore + +acidStore :: FilePath -> IO Backend +acidStore stateDir = do + adminLogState <- adminLogStateComponent stateDir + pure Backend { + backendStore = Store { + getAdminLog = State.adminLog <$> queryState adminLogState State.GetAdminLog + , addAdminLog = \entry -> updateState adminLogState (State.AddAdminLog entry) + } + , backendState = [abstractAcidStateComponent adminLogState] + } + +adminLogStateComponent :: FilePath -> IO (StateComponent AcidState State.AdminLog) +adminLogStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "AdminLog") State.initialAdminLog + return StateComponent { + stateDesc = "AdminLog" + , stateHandle = st + , getState = query st State.GetAdminLog + , putState = update st . State.ReplaceAdminLog + , backupState = \_ (State.AdminLog xs) -> + [BackupByteString ["adminLog.txt"] . backupLogEntries $ xs] + , restoreState = restoreAdminLogBackup + , resetState = adminLogStateComponent + } diff --git a/src/Distribution/Server/Features/AdminLog/Backup.hs b/src/Distribution/Server/Features/AdminLog/Backup.hs index 6713c3cd6..56fd4fb90 100644 --- a/src/Distribution/Server/Features/AdminLog/Backup.hs +++ b/src/Distribution/Server/Features/AdminLog/Backup.hs @@ -1,19 +1,19 @@ module Distribution.Server.Features.AdminLog.Backup where -import qualified Distribution.Server.Features.AdminLog.Acid as Acid import Distribution.Server.Features.AdminLog.Types -import Distribution.Server.Users.Types (UserId) +import qualified Distribution.Server.Features.AdminLog.State as State import Distribution.Server.Framework.BackupRestore +import Distribution.Server.Users.Types (UserId) import Data.Maybe(mapMaybe) -import Data.Time (UTCTime) import qualified Data.ByteString.Lazy.Char8 as BS +import Data.Time (UTCTime) import Text.Read (readMaybe) import Distribution.Server.Util.Parse -restoreAdminLogBackup :: RestoreBackup Acid.AdminLog +restoreAdminLogBackup :: RestoreBackup State.AdminLog restoreAdminLogBackup = - go (Acid.AdminLog []) + go (State.AdminLog []) where go logs = RestoreBackup { @@ -24,13 +24,12 @@ restoreAdminLogBackup = , restoreFinalize = return logs } -importLogs :: Acid.AdminLog -> BS.ByteString -> Acid.AdminLog -importLogs (Acid.AdminLog ls) = - Acid.AdminLog . (++ls) . mapMaybe fromRecord . lines . unpackUTF8 +importLogs :: State.AdminLog -> BS.ByteString -> State.AdminLog +importLogs (State.AdminLog ls) = + State.AdminLog . (++ls) . mapMaybe fromRecord . lines . unpackUTF8 where fromRecord :: String -> Maybe (UTCTime,UserId,AdminAction,BS.ByteString) fromRecord = readMaybe backupLogEntries :: [(UTCTime,UserId,AdminAction,BS.ByteString)] -> BS.ByteString backupLogEntries = packUTF8 . unlines . map show - diff --git a/src/Distribution/Server/Features/AdminLog/State.hs b/src/Distribution/Server/Features/AdminLog/State.hs new file mode 100644 index 000000000..259c79e7a --- /dev/null +++ b/src/Distribution/Server/Features/AdminLog/State.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, BangPatterns, + GeneralizedNewtypeDeriving, NamedFieldPuns, RecordWildCards, + PatternGuards, RankNTypes #-} + +module Distribution.Server.Features.AdminLog.State where + +import Distribution.Server.Features.AdminLog.Types +import Distribution.Server.Framework +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Reader +import qualified Control.Monad.State as State +import Data.Acid.Compat +import Data.Time (UTCTime) +import qualified Data.ByteString.Lazy.Char8 as BS + +newtype AdminLog = AdminLog { + adminLog :: [(UTCTime,UserId,AdminAction,BS.ByteString)] +} deriving (Show, MemSize) + +deriveSafeCopy 0 'base ''AdminLog + +initialAdminLog :: AdminLog +initialAdminLog = AdminLog [] + +getAdminLog :: Query AdminLog AdminLog +getAdminLog = ask + +addAdminLog :: (UTCTime, UserId, AdminAction, BS.ByteString) -> Update AdminLog () +addAdminLog x = State.modify (\(AdminLog xs) -> AdminLog (x : xs)) + +instance Eq AdminLog where + (AdminLog (x:_)) == (AdminLog (y:_)) = x == y + (AdminLog []) == (AdminLog []) = True + _ == _ = False + +replaceAdminLog :: AdminLog -> Update AdminLog () +replaceAdminLog = State.put + +------------------------------ +-- IsAcidic machinery +-- +-- See Note [Acid Migration] in "Data.Acid.Compat" +-- original module name was Distribution.Server.Features.AdminLog" + +-- makeAcidic ''AdminLog ['getAdminLog +-- ,'replaceAdminLog +-- ,'addAdminLog] + +instance IsAcidic AdminLog where + acidEvents + = [QueryEvent + (\ GetAdminLog -> getAdminLog) safeCopyMethodSerialiser, + UpdateEvent + (\ (ReplaceAdminLog arg_aDn6) -> replaceAdminLog arg_aDn6) + safeCopyMethodSerialiser, + UpdateEvent + (\ (AddAdminLog arg_aDn7) -> addAdminLog arg_aDn7) + safeCopyMethodSerialiser] +data GetAdminLog = GetAdminLog +instance SafeCopy GetAdminLog where + putCopy GetAdminLog = contain (do return ()) + getCopy = contain (return GetAdminLog) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy GetAdminLog" +instance Data.Acid.Compat.Method GetAdminLog where + type MethodResult GetAdminLog = AdminLog + type MethodState GetAdminLog = AdminLog + methodTag = movedMethodTag "Distribution.Server.Features.AdminLog" +instance QueryEvent GetAdminLog +newtype ReplaceAdminLog = ReplaceAdminLog AdminLog +instance SafeCopy ReplaceAdminLog where + putCopy (ReplaceAdminLog arg_aDmO) + = contain + (do safePut arg_aDmO + return ()) + getCopy = contain (return ReplaceAdminLog <*> safeGet) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy ReplaceAdminLog" +instance Data.Acid.Compat.Method ReplaceAdminLog where + type MethodResult ReplaceAdminLog = () + type MethodState ReplaceAdminLog = AdminLog + methodTag = movedMethodTag "Distribution.Server.Features.AdminLog" +instance UpdateEvent ReplaceAdminLog +newtype AddAdminLog + = AddAdminLog (UTCTime, UserId, AdminAction, BS.ByteString) +instance SafeCopy AddAdminLog where + putCopy (AddAdminLog arg_aDmT) + = contain + (do safePut arg_aDmT + return ()) + getCopy = contain (return AddAdminLog <*> safeGet) + errorTypeName _ = "Data.SafeCopy.SafeCopy.SafeCopy AddAdminLog" +instance Data.Acid.Compat.Method AddAdminLog where + type MethodResult AddAdminLog = () + type MethodState AddAdminLog = AdminLog + methodTag = movedMethodTag "Distribution.Server.Features.AdminLog" +instance UpdateEvent AddAdminLog diff --git a/src/Distribution/Server/Features/AdminLog/Store.hs b/src/Distribution/Server/Features/AdminLog/Store.hs new file mode 100644 index 000000000..5caf391ce --- /dev/null +++ b/src/Distribution/Server/Features/AdminLog/Store.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.AdminLog.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Features.AdminLog.Types (AdminAction) +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) +import Data.Time (UTCTime) +import qualified Data.ByteString.Lazy.Char8 as BS + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getAdminLog :: forall m. MonadIO m => m [(UTCTime,UserId,AdminAction,BS.ByteString)] + , addAdminLog :: forall m. MonadIO m => (UTCTime, UserId, AdminAction, BS.ByteString) -> m () + } diff --git a/src/Distribution/Server/Features/AnalyticsPixels.hs b/src/Distribution/Server/Features/AnalyticsPixels.hs index fb211cda3..ca9c6d8d0 100644 --- a/src/Distribution/Server/Features/AnalyticsPixels.hs +++ b/src/Distribution/Server/Features/AnalyticsPixels.hs @@ -10,11 +10,11 @@ module Distribution.Server.Features.AnalyticsPixels import Data.Set (Set) +import Distribution.Server.Features.AnalyticsPixels.Acid (acidStore) +import qualified Distribution.Server.Features.AnalyticsPixels.Store as Store import Distribution.Server.Features.AnalyticsPixels.Types -import qualified Distribution.Server.Features.AnalyticsPixels.State as Acid import Distribution.Server.Framework -import Distribution.Server.Framework.BackupRestore import Distribution.Server.Features.Core import Distribution.Server.Features.Upload @@ -53,7 +53,7 @@ initAnalyticsPixelsFeature :: ServerEnv -> UploadFeature -> IO AnalyticsPixelsFeature) initAnalyticsPixelsFeature env@ServerEnv{serverStateDir} = do - dbAnalyticsPixelsState <- analyticsPixelsStateComponent serverStateDir + dbAnalyticsPixelsState <- acidStore serverStateDir analyticsPixelAdded <- newHook analyticsPixelRemoved <- newHook @@ -64,27 +64,9 @@ initAnalyticsPixelsFeature env@ServerEnv{serverStateDir} = do return feature --- | Define the backing store (i.e. database component) -analyticsPixelsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.AnalyticsPixelsState) -analyticsPixelsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "AnalyticsPixels") Acid.initialAnalyticsPixelsState - return StateComponent { - stateDesc = "Backing store for AnalyticsPixels feature" - , stateHandle = st - , getState = query st Acid.GetAnalyticsPixelsState - , putState = update st . Acid.ReplaceAnalyticsPixelsState - , resetState = analyticsPixelsStateComponent - , backupState = \_ _ -> [] - , restoreState = RestoreBackup { - restoreEntry = error "Unexpected backup entry" - , restoreFinalize = return Acid.initialAnalyticsPixelsState - } - } - - -- | Default constructor for building this feature. analyticsPixelsFeature :: ServerEnv - -> StateComponent AcidState Acid.AnalyticsPixelsState + -> Store.Backend -> CoreFeature -- To get site package list -> UserFeature -- To authenticate users -> UploadFeature -- For accessing package maintainers and trustees @@ -93,7 +75,7 @@ analyticsPixelsFeature :: ServerEnv -> AnalyticsPixelsFeature analyticsPixelsFeature ServerEnv{..} - analyticsPixelsState + Store.Backend{backendStore = analyticsPixelsState, backendState} CoreFeature { coreResource = CoreResource{..} } UserFeature{..} UploadFeature{..} @@ -104,7 +86,7 @@ analyticsPixelsFeature ServerEnv{..} analyticsPixelsFeatureInterface = (emptyHackageFeature "AnalyticsPixels") { featureDesc = "Allow users to attach analytics pixels to their packages", featureResources = [analyticsPixelsResource, userAnalyticsPixelsResource] - , featureState = [abstractAcidStateComponent analyticsPixelsState] + , featureState = backendState } analyticsPixelsResource :: Resource @@ -114,16 +96,16 @@ analyticsPixelsFeature ServerEnv{..} userAnalyticsPixelsResource = resourceAt "/user/:username/analytics-pixels.:format" getPackageAnalyticsPixels :: MonadIO m => PackageName -> m (Set AnalyticsPixel) - getPackageAnalyticsPixels name = - queryState analyticsPixelsState (Acid.AnalyticsPixelsForPackage name) + getPackageAnalyticsPixels = + Store.getPackageAnalyticsPixels analyticsPixelsState addPackageAnalyticsPixel :: MonadIO m => PackageName -> AnalyticsPixel -> m Bool addPackageAnalyticsPixel name pixel = do - added <- updateState analyticsPixelsState (Acid.AddPackageAnalyticsPixel name pixel) + added <- Store.addPackageAnalyticsPixel analyticsPixelsState name pixel when added $ runHook_ analyticsPixelAdded (name, pixel) pure added removePackageAnalyticsPixel :: MonadIO m => PackageName -> AnalyticsPixel -> m () removePackageAnalyticsPixel name pixel = do - updateState analyticsPixelsState (Acid.RemovePackageAnalyticsPixel name pixel) + Store.removePackageAnalyticsPixel analyticsPixelsState name pixel runHook_ analyticsPixelRemoved (name, pixel) diff --git a/src/Distribution/Server/Features/AnalyticsPixels/Acid.hs b/src/Distribution/Server/Features/AnalyticsPixels/Acid.hs new file mode 100644 index 000000000..ce6cd7a4b --- /dev/null +++ b/src/Distribution/Server/Features/AnalyticsPixels/Acid.hs @@ -0,0 +1,37 @@ +module Distribution.Server.Features.AnalyticsPixels.Acid + ( acidStore + ) where + +import qualified Distribution.Server.Features.AnalyticsPixels.State as Acid +import Distribution.Server.Features.AnalyticsPixels.Store +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore + +acidStore :: FilePath -> IO Backend +acidStore stateDir = do + analyticsPixelsState <- analyticsPixelsStateComponent stateDir + return Backend { + backendStore = Store { + getPackageAnalyticsPixels = \name -> queryState analyticsPixelsState (Acid.AnalyticsPixelsForPackage name) + , addPackageAnalyticsPixel = \name pixel -> updateState analyticsPixelsState (Acid.AddPackageAnalyticsPixel name pixel) + , removePackageAnalyticsPixel = \name pixel -> updateState analyticsPixelsState (Acid.RemovePackageAnalyticsPixel name pixel) + } + , backendState = [abstractAcidStateComponent analyticsPixelsState] + } + +-- | Define the backing store (i.e. database component) +analyticsPixelsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.AnalyticsPixelsState) +analyticsPixelsStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "AnalyticsPixels") Acid.initialAnalyticsPixelsState + return StateComponent { + stateDesc = "Backing store for AnalyticsPixels feature" + , stateHandle = st + , getState = query st Acid.GetAnalyticsPixelsState + , putState = update st . Acid.ReplaceAnalyticsPixelsState + , resetState = analyticsPixelsStateComponent + , backupState = \_ _ -> [] + , restoreState = RestoreBackup { + restoreEntry = error "Unexpected backup entry" + , restoreFinalize = return Acid.initialAnalyticsPixelsState + } + } diff --git a/src/Distribution/Server/Features/AnalyticsPixels/Store.hs b/src/Distribution/Server/Features/AnalyticsPixels/Store.hs new file mode 100644 index 000000000..cd287269f --- /dev/null +++ b/src/Distribution/Server/Features/AnalyticsPixels/Store.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.AnalyticsPixels.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Features.AnalyticsPixels.Types +import Distribution.Server.Framework (AbstractStateComponent) + +import Distribution.Package (PackageName) + +import Control.Monad.Trans (MonadIO) +import Data.Set (Set) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getPackageAnalyticsPixels :: forall m. MonadIO m => PackageName -> m (Set AnalyticsPixel) + , addPackageAnalyticsPixel :: forall m. MonadIO m => PackageName -> AnalyticsPixel -> m Bool + , removePackageAnalyticsPixel :: forall m. MonadIO m => PackageName -> AnalyticsPixel -> m () + } diff --git a/src/Distribution/Server/Features/BuildReports.hs b/src/Distribution/Server/Features/BuildReports.hs index 7a3fb7be8..f4fb58f88 100644 --- a/src/Distribution/Server/Features/BuildReports.hs +++ b/src/Distribution/Server/Features/BuildReports.hs @@ -12,11 +12,11 @@ import Distribution.Server.Features.Users import Distribution.Server.Features.Upload import Distribution.Server.Features.Core -import Distribution.Server.Features.BuildReports.Backup -import qualified Distribution.Server.Features.BuildReports.State as Acid +import qualified Distribution.Server.Features.BuildReports.Acid as Acid +import qualified Distribution.Server.Features.BuildReports.Store as Store import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport import Distribution.Server.Features.BuildReports.BuildReport (BuildReport(..)) -import Distribution.Server.Features.BuildReports.BuildReports (BuildReports, BuildReportId(..), BuildCovg(..), BuildLog(..), TestLog(..), TestReportLog(..)) +import Distribution.Server.Features.BuildReports.BuildReports (BuildReportId(..), BuildCovg(..), BuildLog(..), TestLog(..), TestReportLog(..)) import qualified Distribution.Server.Framework.ResponseContentTypes as Resource import Distribution.Server.Packages.Types @@ -27,7 +27,6 @@ import Distribution.Text import Distribution.Package import Distribution.Version (nullVersion) -import Control.Arrow (second) import Data.ByteString.Lazy (toStrict) import Data.String (fromString) import Data.Maybe @@ -79,33 +78,20 @@ initBuildReportsFeature :: String -> CoreResource -> IO ReportsFeature) initBuildReportsFeature name env@ServerEnv{serverStateDir} = do - reportsState <- reportsStateComponent name serverStateDir + reportsBackend <- Acid.acidStore name serverStateDir return $ \user upload core -> do let feature = buildReportsFeature name env user upload core - reportsState + reportsBackend return feature -reportsStateComponent :: String -> FilePath -> IO (StateComponent AcidState BuildReports) -reportsStateComponent name stateDir = do - st <- openLocalStateFrom (stateDir "db" name) Acid.initialBuildReports - return StateComponent { - stateDesc = "Build reports" - , stateHandle = st - , getState = query st Acid.GetBuildReports - , putState = update st . Acid.ReplaceBuildReports - , backupState = \_ -> dumpBackup - , restoreState = restoreBackup - , resetState = reportsStateComponent name - } - buildReportsFeature :: String -> ServerEnv -> UserFeature -> UploadFeature -> CoreResource - -> StateComponent AcidState BuildReports + -> Store.Backend -> ReportsFeature buildReportsFeature name ServerEnv{serverBlobStore = store} @@ -115,7 +101,7 @@ buildReportsFeature name , lookupPackageId , corePackagePage } - reportsState + Store.Backend{backendStore = reportsStore, backendState} = ReportsFeature{..} where reportsFeatureInterface = (emptyHackageFeature name) { @@ -130,7 +116,7 @@ buildReportsFeature name , reportsReset , reportsTestsEnabled ] - , featureState = [abstractAcidStateComponent reportsState] + , featureState = backendState } reportsResource = ReportsResource @@ -212,15 +198,13 @@ buildReportsFeature name pkgid <- packageInPath dpath guardValidPackageId pkgid reportId <- reportIdInPath dpath - mreport <- queryState reportsState $ Acid.LookupReportCovg pkgid reportId + mreport <- Store.lookupReportCovg reportsStore pkgid reportId case mreport of Nothing -> errNotFound "Report not found" [MText "Build report does not exist"] Just (report, mlog, mtest, covg, testReportLog) -> return (reportId, report, mlog, mtest, covg, testReportLog) queryPackageReports :: MonadIO m => PackageId -> m [(BuildReportId, BuildReport)] - queryPackageReports pkgid = do - reports <- queryState reportsState $ Acid.LookupPackageReports pkgid - return $ map (second (\(a, _, _, _) -> a)) reports + queryPackageReports = Store.lookupPackageReports reportsStore queryBuildLog :: MonadIO m => BuildLog -> m Resource.BuildLog queryBuildLog (BuildLog blobId) = do @@ -239,9 +223,9 @@ buildReportsFeature name pkgReportDetails :: MonadIO m => (PackageIdentifier, Bool) -> m BuildReport.PkgDetails--(PackageIdentifier, Bool, Maybe (BuildStatus, Maybe UTCTime, Maybe Version)) pkgReportDetails (pkgid, docs) = do - failCnt <- queryState reportsState $ Acid.LookupFailCount pkgid - latestRpt <- queryState reportsState $ Acid.LookupLatestReport pkgid - runTests <- fmap Just . queryState reportsState $ Acid.LookupRunTests pkgid + failCnt <- Store.lookupFailCount reportsStore pkgid + latestRpt <- Store.lookupLatestReport reportsStore pkgid + runTests <- fmap Just $ Store.lookupRunTests reportsStore pkgid (time, ghcId) <- case latestRpt of Nothing -> return (Nothing,Nothing) Just (_, brp, _, _, _, _) -> do @@ -251,13 +235,13 @@ buildReportsFeature name queryLastReportStats :: MonadIO m => PackageIdentifier -> m (Maybe (BuildReportId, BuildReport, Maybe BuildCovg, Maybe TestReportLog)) queryLastReportStats pkgid = do - lookupRes <- queryState reportsState $ Acid.LookupLatestReport pkgid + lookupRes <- Store.lookupLatestReport reportsStore pkgid case lookupRes of Nothing -> return Nothing Just (rptId, rpt, _, _, covg, testReportLog) -> return (Just (rptId, rpt, covg, testReportLog)) queryRunTests :: MonadIO m => PackageId -> m Bool - queryRunTests pkgid = queryState reportsState $ Acid.LookupRunTests pkgid + queryRunTests = Store.lookupRunTests reportsStore --------------------------------------------------------------------------- @@ -311,7 +295,7 @@ buildReportsFeature name -- Check that the submitter can actually upload docs guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) report' <- liftIO $ BuildReport.affixTimestamp report - reportId <- updateState reportsState $ Acid.AddReport pkgid (report', Nothing) + reportId <- Store.addReport reportsStore pkgid (report', Nothing) -- redirect to new reports page seeOther (reportsPageUri reportsResource "" pkgid reportId) $ toResponse () @@ -332,7 +316,7 @@ buildReportsFeature name guardValidPackageId pkgid reportId <- reportIdInPath dpath guardAuthorised_ [InGroup trusteesGroup] - success <- updateState reportsState $ Acid.DeleteReport pkgid reportId + success <- Store.deleteReport reportsStore pkgid reportId if success then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse () else errNotFound "Build report not found" [MText $ "Build report #" ++ display reportId ++ " not found"] @@ -346,7 +330,7 @@ buildReportsFeature name guardAuthorised_ [AnyKnownUser] blogbody <- expectTextPlain buildLog <- liftIO $ BlobStorage.add store blogbody - void $ updateState reportsState $ Acid.SetBuildLog pkgid reportId (Just $ BuildLog buildLog) + void $ Store.setBuildLog reportsStore pkgid reportId (Just $ BuildLog buildLog) noContent (toResponse ()) putTestLog :: DynamicPath -> ServerPartE Response @@ -358,7 +342,7 @@ buildReportsFeature name guardAuthorised_ [AnyKnownUser] blogbody <- expectTextPlain testLog <- liftIO $ BlobStorage.add store blogbody - void $ updateState reportsState $ Acid.SetTestLog pkgid reportId (Just $ TestLog testLog) + void $ Store.setTestLog reportsStore pkgid reportId (Just $ TestLog testLog) noContent (toResponse ()) {- @@ -377,7 +361,7 @@ buildReportsFeature name guardValidPackageId pkgid reportId <- reportIdInPath dpath guardAuthorised_ [InGroup trusteesGroup] - void $ updateState reportsState $ Acid.SetBuildLog pkgid reportId Nothing + void $ Store.setBuildLog reportsStore pkgid reportId Nothing noContent (toResponse ()) deleteTestLog :: DynamicPath -> ServerPartE Response @@ -386,7 +370,7 @@ buildReportsFeature name guardValidPackageId pkgid reportId <- reportIdInPath dpath guardAuthorised_ [InGroup trusteesGroup] - void $ updateState reportsState $ Acid.SetTestLog pkgid reportId Nothing + void $ Store.setTestLog reportsStore pkgid reportId Nothing noContent (toResponse ()) guardAuthorisedAsMaintainerOrTrustee pkgname = @@ -397,7 +381,7 @@ buildReportsFeature name pkgid <- packageInPath dpath guardValidPackageId pkgid guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) - success <- updateState reportsState $ Acid.ResetFailCount pkgid + success <- Store.resetFailCount reportsStore pkgid if success then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse () else errNotFound "Report not found" [MText "Build report does not exist"] @@ -416,7 +400,7 @@ buildReportsFeature name runTests <- body $ looks "runTests" guardValidPackageId pkgid guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) - success <- updateState reportsState $ Acid.SetRunTests pkgid ("on" `elem` runTests) + success <- Store.setRunTests reportsStore pkgid ("on" `elem` runTests) if success then seeOther (reportsListUri reportsResource "" pkgid) $ toResponse () else errNotFound "Package not found" [MText "Package does not exist"] @@ -435,7 +419,7 @@ buildReportsFeature name testReportBody = BuildReport.testReportContent buildFiles failStatus = BuildReport.buildFail buildFiles - updateState reportsState $ Acid.SetFailStatus pkgid failStatus + Store.setFailStatus reportsStore pkgid failStatus -- Upload BuildReport case BuildReport.parse $ toStrict $ fromString $ fromMaybe "" reportBody of @@ -448,8 +432,7 @@ buildReportsFeature name logBlob <- liftIO $ traverse (\x -> BlobStorage.add store $ fromString x) logBody testBlob <- liftIO $ traverse (\x -> BlobStorage.add store $ fromString x) testBody testReportBlob <- liftIO $ traverse (\x -> BlobStorage.add store $ fromString x) testReportBody - reportId <- updateState reportsState $ - Acid.AddRptAllLogsCovg pkgid (report', (fmap BuildLog logBlob), (fmap TestLog testBlob), (fmap BuildReport.parseCovg covgBody), (fmap TestReportLog testReportBlob)) + reportId <- Store.addRptAllLogsCovg reportsStore pkgid (report', (fmap BuildLog logBlob), (fmap TestLog testBlob), (fmap BuildReport.parseCovg covgBody), (fmap TestReportLog testReportBlob)) -- redirect to new reports page seeOther (reportsPageUri reportsResource "" pkgid reportId) $ toResponse () diff --git a/src/Distribution/Server/Features/BuildReports/Acid.hs b/src/Distribution/Server/Features/BuildReports/Acid.hs new file mode 100644 index 000000000..0bbe2aa18 --- /dev/null +++ b/src/Distribution/Server/Features/BuildReports/Acid.hs @@ -0,0 +1,47 @@ +module Distribution.Server.Features.BuildReports.Acid + ( reportsStateComponent + , acidStore + ) where + +import qualified Distribution.Server.Features.BuildReports.State as State +import Distribution.Server.Features.BuildReports.Backup (dumpBackup, restoreBackup) +import Distribution.Server.Features.BuildReports.BuildReports (BuildReports) +import qualified Distribution.Server.Features.BuildReports.Store as Store +import Distribution.Server.Framework + +acidStore :: String -> FilePath -> IO Store.Backend +acidStore name stateDir = do + reportsState <- reportsStateComponent name stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.lookupReportCovg = \pkgid reportId -> queryState reportsState (State.LookupReportCovg pkgid reportId) + , Store.lookupPackageReports = \pkgid -> do + reports <- queryState reportsState (State.LookupPackageReports pkgid) + pure $ map (\(reportId, (report, _, _, _)) -> (reportId, report)) reports + , Store.lookupFailCount = \pkgid -> queryState reportsState (State.LookupFailCount pkgid) + , Store.lookupLatestReport = \pkgid -> queryState reportsState (State.LookupLatestReport pkgid) + , Store.lookupRunTests = \pkgid -> queryState reportsState (State.LookupRunTests pkgid) + , Store.addReport = \pkgid report -> updateState reportsState (State.AddReport pkgid report) + , Store.deleteReport = \pkgid reportId -> updateState reportsState (State.DeleteReport pkgid reportId) + , Store.setBuildLog = \pkgid reportId buildLog -> updateState reportsState (State.SetBuildLog pkgid reportId buildLog) + , Store.setTestLog = \pkgid reportId testLog -> updateState reportsState (State.SetTestLog pkgid reportId testLog) + , Store.resetFailCount = \pkgid -> updateState reportsState (State.ResetFailCount pkgid) + , Store.setRunTests = \pkgid enabled -> updateState reportsState (State.SetRunTests pkgid enabled) + , Store.setFailStatus = \pkgid status -> updateState reportsState (State.SetFailStatus pkgid status) + , Store.addRptAllLogsCovg = \pkgid report -> updateState reportsState (State.AddRptAllLogsCovg pkgid report) + } + , Store.backendState = [abstractAcidStateComponent reportsState] + } + +reportsStateComponent :: String -> FilePath -> IO (StateComponent AcidState BuildReports) +reportsStateComponent name stateDir = do + st <- openLocalStateFrom (stateDir "db" name) State.initialBuildReports + return StateComponent { + stateDesc = "Build reports" + , stateHandle = st + , getState = query st State.GetBuildReports + , putState = update st . State.ReplaceBuildReports + , backupState = \_ -> dumpBackup + , restoreState = restoreBackup + , resetState = reportsStateComponent name + } diff --git a/src/Distribution/Server/Features/BuildReports/Store.hs b/src/Distribution/Server/Features/BuildReports/Store.hs new file mode 100644 index 000000000..197b06583 --- /dev/null +++ b/src/Distribution/Server/Features/BuildReports/Store.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.BuildReports.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Package (PackageId) +import Distribution.Server.Features.BuildReports.BuildReport (BuildReport) +import Distribution.Server.Features.BuildReports.BuildReports + ( BuildReportId, BuildCovg, BuildLog, BuildStatus, TestLog, TestReportLog ) +import Distribution.Server.Framework (AbstractStateComponent) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + lookupReportCovg :: forall m. MonadIO m => PackageId -> BuildReportId -> m (Maybe (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog)) + , lookupPackageReports :: forall m. MonadIO m => PackageId -> m [(BuildReportId, BuildReport)] + , lookupFailCount :: forall m. MonadIO m => PackageId -> m (Maybe BuildStatus) + , lookupLatestReport :: forall m. MonadIO m => PackageId -> m (Maybe (BuildReportId, BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog)) + , lookupRunTests :: forall m. MonadIO m => PackageId -> m Bool + , addReport :: forall m. MonadIO m => PackageId -> (BuildReport, Maybe BuildLog) -> m BuildReportId + , deleteReport :: forall m. MonadIO m => PackageId -> BuildReportId -> m Bool + , setBuildLog :: forall m. MonadIO m => PackageId -> BuildReportId -> Maybe BuildLog -> m Bool + , setTestLog :: forall m. MonadIO m => PackageId -> BuildReportId -> Maybe TestLog -> m Bool + , resetFailCount :: forall m. MonadIO m => PackageId -> m Bool + , setRunTests :: forall m. MonadIO m => PackageId -> Bool -> m Bool + , setFailStatus :: forall m. MonadIO m => PackageId -> Bool -> m () + , addRptAllLogsCovg :: forall m. MonadIO m => PackageId -> (BuildReport, Maybe BuildLog, Maybe TestLog, Maybe BuildCovg, Maybe TestReportLog) -> m BuildReportId + } diff --git a/src/Distribution/Server/Features/Core.hs b/src/Distribution/Server/Features/Core.hs index 2bc6ff059..f30dc86dd 100644 --- a/src/Distribution/Server/Features/Core.hs +++ b/src/Distribution/Server/Features/Core.hs @@ -18,8 +18,6 @@ module Distribution.Server.Features.Core ( -- * Misc other utils packageExists, packageIdExists, - - packagesStateComponent, ) where -- stdlib @@ -37,9 +35,9 @@ import qualified Data.Vector as Vec -- hackage import Distribution.Server.Prelude -import Distribution.Server.Features.Core.Backup +import Distribution.Server.Features.Core.Acid (acidStore) +import qualified Distribution.Server.Features.Core.Store as Store import qualified Distribution.Server.Features.Core.State as Acid -import Distribution.Server.Features.Security.Migration import Distribution.Server.Features.Security.SHA256 (sha256) import Distribution.Server.Features.Users import Distribution.Server.Framework @@ -76,6 +74,15 @@ data CoreFeature = CoreFeature { -- | Retrieves the entire main package index. queryGetPackageIndex :: forall m. MonadIO m => m (PackageIndex PkgInfo), + -- | Retrieves all versions of a package. + queryLookupPackageName :: forall m. MonadIO m => PackageName -> m [PkgInfo], + + -- | Retrieves a specific package version. + queryLookupPackageId :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo), + + -- | Retrieves the latest version of every package. + queryLatestPackages :: forall m. MonadIO m => m [PkgInfo], + -- | Retrieve the raw tarball info queryGetIndexTarballInfo :: forall m. MonadIO m => m IndexTarballInfo, @@ -269,8 +276,8 @@ data CoreResource = CoreResource { initCoreFeature :: ServerEnv -> IO (UserFeature -> IO CoreFeature) initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, serverVerbosity = verbosity} = do - -- Canonical state - packagesState <- packagesStateComponent verbosity False serverStateDir + packagesBackend <- acidStore env verbosity False serverStateDir + let packagesStore = Store.backendStore packagesBackend -- Hooks packageChangeHook <- newHook @@ -300,16 +307,16 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, -- need any other kind of migration. migrateUpdateLog <- (isLeft . Acid.packageUpdateLog) <$> - queryState packagesState Acid.GetPackagesState + Store.getPackagesState packagesStore when migrateUpdateLog $ do -- Migrate Acid.PackagesState (introduce package update log) logTiming verbosity "migrating package update log" $ do userdb <- queryGetUserDb users - updateState packagesState (Acid.MigrateAddUpdateLog userdb) + Store.migrateAddUpdateLog packagesStore userdb -- Migrate PkgTarball logTiming verbosity "migrating PkgTarball" $ - migratePkgTarball_v1_to_v2 env packagesState + Store.migratePackageTarballs packagesStore -- Create a checkpoint -- @@ -325,11 +332,11 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, -- reconstruct the package log rather than use the package log as it was -- constructed in the first place, and we might potentially lose -- information. - createCheckpoint (stateHandle packagesState) + Store.createStoreCheckpoint packagesStore rec let (feature, getIndexTarball) = coreFeature env users - packagesState indexTar + packagesBackend indexTar packageChangeHook preIndexUpdateHook packageDownloadHook @@ -354,29 +361,14 @@ initCoreFeature env@ServerEnv{serverStateDir, serverCacheDelay, PackageChangeAdd _ -> return () _ -> do additionalEntries <- concat <$> runHook preIndexUpdateHook packageChange - forM_ additionalEntries $ updateState packagesState . Acid.AddOtherIndexEntry + forM_ additionalEntries $ Store.addOtherIndexEntry packagesStore prodAsyncCache indexTar "package change" return feature -packagesStateComponent :: Verbosity -> Bool -> FilePath -> IO (StateComponent AcidState Acid.PackagesState) -packagesStateComponent verbosity freshDB stateDir = do - let stateFile = stateDir "db" "PackagesState" - st <- logTiming verbosity "Loaded PackagesState" $ - openLocalStateFrom stateFile (Acid.initialPackagesState freshDB) - return StateComponent { - stateDesc = "Main package database" - , stateHandle = st - , getState = query st Acid.GetPackagesState - , putState = update st . Acid.ReplacePackagesState - , backupState = \_ -> indexToAllVersions - , restoreState = packagesBackup - , resetState = packagesStateComponent verbosity True - } - coreFeature :: ServerEnv -> UserFeature - -> StateComponent AcidState Acid.PackagesState + -> Store.Backend -> AsyncCache IndexTarballInfo -> Hook PackageChange () -> Hook PackageChange [TarIndexEntry] @@ -385,7 +377,7 @@ coreFeature :: ServerEnv , IO IndexTarballInfo ) coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} - packagesState cacheIndexTarball + Store.Backend{backendStore = packagesStore, backendState} cacheIndexTarball packageChangeHook preIndexUpdateHook packageDownloadHook @@ -408,7 +400,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} , coreAdminDeauth , corePackUserDeauth ] - , featureState = [abstractAcidStateComponent packagesState] + , featureState = backendState , featureCaches = [ CacheComponent { cacheDesc = "main package index tarball", @@ -505,7 +497,16 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} -- Queries -- queryGetPackageIndex :: MonadIO m => m (PackageIndex PkgInfo) - queryGetPackageIndex = Acid.packageIndex <$> queryState packagesState Acid.GetPackagesState + queryGetPackageIndex = Acid.packageIndex <$> Store.getPackagesState packagesStore + + queryLookupPackageName :: MonadIO m => PackageName -> m [PkgInfo] + queryLookupPackageName = Store.lookupPackageName packagesStore + + queryLookupPackageId :: MonadIO m => PackageId -> m (Maybe PkgInfo) + queryLookupPackageId = Store.lookupPackageId packagesStore + + queryLatestPackages :: MonadIO m => m [PkgInfo] + queryLatestPackages = Store.latestPackages packagesStore queryGetIndexTarballInfo :: MonadIO m => m IndexTarballInfo queryGetIndexTarballInfo = readAsyncCache cacheIndexTarball @@ -526,12 +527,11 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} let pkginfo = Acid.mkPackageInfo pkgid cabalFile uploadinfo mtarball additionalEntries <- concat `liftM` runHook preIndexUpdateHook (PackageChangeAdd pkginfo) - successFlag <- updateState packagesState $ - Acid.AddPackage3 - pkginfo - uploadinfo - (userName userInfo) - additionalEntries + successFlag <- Store.addPackage packagesStore + pkginfo + uploadinfo + (userName userInfo) + additionalEntries loginfo maxBound ("updateState(AddPackage3," ++ display pkgid ++ ") -> " ++ show successFlag) if successFlag @@ -541,7 +541,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} updateDeletePackage :: MonadIO m => PackageId -> m Bool updateDeletePackage pkgid = logTiming maxBound ("updateDeletePackage " ++ display pkgid) $ do - mpkginfo <- updateState packagesState (Acid.DeletePackage pkgid) + mpkginfo <- Store.deletePackage packagesStore pkgid case mpkginfo of Nothing -> return False Just pkginfo -> do @@ -552,12 +552,11 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} updateAddPackageRevision pkgid cabalfile uploadinfo@(_, uid) = logTiming maxBound ("updateAddPackageRevision " ++ display pkgid) $ do usersdb <- queryGetUserDb let Just userInfo = lookupUserId uid usersdb - (moldpkginfo, newpkginfo) <- updateState packagesState $ - Acid.AddPackageRevision2 - pkgid - cabalfile - uploadinfo - (userName userInfo) + (moldpkginfo, newpkginfo) <- Store.addPackageRevision packagesStore + pkgid + cabalfile + uploadinfo + (userName userInfo) loginfo maxBound ("updateState(AddPackageRevision2," ++ display pkgid ++ ") -> " ++ maybe "Nothing" (const "Just _") moldpkginfo) case moldpkginfo of Nothing -> @@ -567,7 +566,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} updateAddPackageTarball :: MonadIO m => PackageId -> PkgTarball -> UploadInfo -> m Bool updateAddPackageTarball pkgid tarball uploadinfo = logTiming maxBound ("updateAddPackageTarball " ++ display pkgid) $ do - mpkginfo <- updateState packagesState (Acid.AddPackageTarball pkgid tarball uploadinfo) + mpkginfo <- Store.addPackageTarball packagesStore pkgid tarball uploadinfo case mpkginfo of Nothing -> return False @@ -576,7 +575,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} return True updateSetPackageUploader pkgid userid = do - mpkginfo <- updateState packagesState (Acid.SetPackageUploader pkgid userid) + mpkginfo <- Store.setPackageUploader packagesStore pkgid userid case mpkginfo of Nothing -> return False Just (oldpkginfo, newpkginfo) -> do @@ -584,7 +583,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} return True updateSetPackageUploadTime pkgid time = do - mpkginfo <- updateState packagesState (Acid.SetPackageUploadTime pkgid time) + mpkginfo <- Store.setPackageUploadTime packagesStore pkgid time case mpkginfo of Nothing -> return False Just (oldpkginfo, newpkginfo) -> do @@ -593,8 +592,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} updateArchiveIndexEntry :: MonadIO m => FilePath -> LazyByteString -> UTCTime -> m () updateArchiveIndexEntry entryName entryData entryTime = logTiming maxBound ("updateArchiveIndexEntry " ++ show entryName) $ do - updateState packagesState $ - Acid.AddOtherIndexEntry $ ExtraEntry entryName entryData entryTime + Store.addOtherIndexEntry packagesStore $ ExtraEntry entryName entryData entryTime runHook_ packageChangeHook (PackageChangeIndexExtra entryName entryData entryTime) -- Cache updates @@ -603,7 +601,7 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} getIndexTarball = do users <- queryGetUserDb -- note, changes here don't automatically propagate time <- getCurrentTime - Acid.PackagesState index (Right updateSeq) <- queryState packagesState Acid.GetPackagesState + Acid.PackagesState index (Right updateSeq) <- Store.getPackagesState packagesStore let updateLog = Foldable.toList updateSeq legacyTarball = Packages.Index.writeLegacy users @@ -638,8 +636,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} lookupPackageName :: PackageName -> ServerPartE [PkgInfo] lookupPackageName pkgname = do - pkgsIndex <- queryGetPackageIndex - case PackageIndex.lookupPackageName pkgsIndex pkgname of + pkgs <- queryLookupPackageName pkgname + case pkgs of [] -> packageError [MText "No such package in package index"] pkgs -> return pkgs @@ -649,8 +647,8 @@ coreFeature ServerEnv{serverBlobStore = store} UserFeature{..} -- pkgs is sorted by version number and non-empty return (last pkgs) lookupPackageId pkgid = do - pkgsIndex <- queryGetPackageIndex - case PackageIndex.lookupPackageId pkgsIndex pkgid of + mpkg <- queryLookupPackageId pkgid + case mpkg of Just pkg -> return pkg _ -> packageError [MText $ "No such package version for " ++ display (packageName pkgid)] diff --git a/src/Distribution/Server/Features/Core/Acid.hs b/src/Distribution/Server/Features/Core/Acid.hs new file mode 100644 index 000000000..9cbf31095 --- /dev/null +++ b/src/Distribution/Server/Features/Core/Acid.hs @@ -0,0 +1,65 @@ +module Distribution.Server.Features.Core.Acid + ( acidStore + , packagesStateComponent + ) where + +import Distribution.Server.Features.Core.Backup +import Distribution.Server.Features.Core.Store +import qualified Distribution.Server.Features.Core.State as Acid +import Distribution.Server.Features.Security.Migration +import Distribution.Server.Framework +import qualified Distribution.Server.Packages.PackageIndex as PackageIndex + +import qualified Data.List.NonEmpty as NE + +acidStore :: ServerEnv -> Verbosity -> Bool -> FilePath -> IO Backend +acidStore env verbosity freshDB stateDir = do + packagesState <- packagesStateComponent verbosity freshDB stateDir + pure Backend { + backendStore = Store { + getPackagesState = queryState packagesState Acid.GetPackagesState + , lookupPackageName = \pkgname -> do + packages <- queryState packagesState Acid.GetPackagesState + pure (PackageIndex.lookupPackageName (Acid.packageIndex packages) pkgname) + , lookupPackageId = \pkgid -> do + packages <- queryState packagesState Acid.GetPackagesState + pure (PackageIndex.lookupPackageId (Acid.packageIndex packages) pkgid) + , latestPackages = do + packages <- queryState packagesState Acid.GetPackagesState + pure (NE.last <$> PackageIndex.allPackagesByNameNE (Acid.packageIndex packages)) + , addPackage = \pkginfo uploadinfo username entries -> + updateState packagesState (Acid.AddPackage3 pkginfo uploadinfo username entries) + , deletePackage = \pkgid -> + updateState packagesState (Acid.DeletePackage pkgid) + , addPackageRevision = \pkgid cabalfile uploadinfo username -> + updateState packagesState (Acid.AddPackageRevision2 pkgid cabalfile uploadinfo username) + , addPackageTarball = \pkgid tarball uploadinfo -> + updateState packagesState (Acid.AddPackageTarball pkgid tarball uploadinfo) + , setPackageUploader = \pkgid userid -> + updateState packagesState (Acid.SetPackageUploader pkgid userid) + , setPackageUploadTime = \pkgid time -> + updateState packagesState (Acid.SetPackageUploadTime pkgid time) + , addOtherIndexEntry = \entry -> + updateState packagesState (Acid.AddOtherIndexEntry entry) + , migrateAddUpdateLog = \userdb -> + updateState packagesState (Acid.MigrateAddUpdateLog userdb) + , migratePackageTarballs = migratePkgTarball_v1_to_v2 env packagesState + , createStoreCheckpoint = createCheckpoint (stateHandle packagesState) + } + , backendState = [abstractAcidStateComponent packagesState] + } + +packagesStateComponent :: Verbosity -> Bool -> FilePath -> IO (StateComponent AcidState Acid.PackagesState) +packagesStateComponent verbosity freshDB stateDir = do + let stateFile = stateDir "db" "PackagesState" + st <- logTiming verbosity "Loaded PackagesState" $ + openLocalStateFrom stateFile (Acid.initialPackagesState freshDB) + return StateComponent { + stateDesc = "Main package database" + , stateHandle = st + , getState = query st Acid.GetPackagesState + , putState = update st . Acid.ReplacePackagesState + , backupState = \_ -> indexToAllVersions + , restoreState = packagesBackup + , resetState = packagesStateComponent verbosity True + } diff --git a/src/Distribution/Server/Features/Core/Store.hs b/src/Distribution/Server/Features/Core/Store.hs new file mode 100644 index 000000000..23856468a --- /dev/null +++ b/src/Distribution/Server/Features/Core/Store.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Core.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Features.Core.State (PackagesState) +import Distribution.Server.Packages.Index (TarIndexEntry) +import Distribution.Server.Packages.Types +import Distribution.Server.Users.Types (UserId, UserName) +import Distribution.Server.Users.Users (Users) + +import Distribution.Package (PackageId, PackageName) + +import Control.Monad.Trans (MonadIO) +import Data.Time.Clock (UTCTime) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getPackagesState :: forall m. MonadIO m => m PackagesState + , lookupPackageName :: forall m. MonadIO m => PackageName -> m [PkgInfo] + , lookupPackageId :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo) + , latestPackages :: forall m. MonadIO m => m [PkgInfo] + , addPackage :: forall m. MonadIO m => PkgInfo -> UploadInfo -> UserName -> [TarIndexEntry] -> m Bool + , deletePackage :: forall m. MonadIO m => PackageId -> m (Maybe PkgInfo) + , addPackageRevision :: forall m. MonadIO m => PackageId -> CabalFileText -> UploadInfo -> UserName -> m (Maybe PkgInfo, PkgInfo) + , addPackageTarball :: forall m. MonadIO m => PackageId -> PkgTarball -> UploadInfo -> m (Maybe (PkgInfo, PkgInfo)) + , setPackageUploader :: forall m. MonadIO m => PackageId -> UserId -> m (Maybe (PkgInfo, PkgInfo)) + , setPackageUploadTime :: forall m. MonadIO m => PackageId -> UTCTime -> m (Maybe (PkgInfo, PkgInfo)) + , addOtherIndexEntry :: forall m. MonadIO m => TarIndexEntry -> m () + , migrateAddUpdateLog :: forall m. MonadIO m => Users -> m () + , migratePackageTarballs :: IO () + , createStoreCheckpoint :: IO () + } diff --git a/src/Distribution/Server/Features/Distro.hs b/src/Distribution/Server/Features/Distro.hs index 156714e00..9f7fa0eae 100644 --- a/src/Distribution/Server/Features/Distro.hs +++ b/src/Distribution/Server/Features/Distro.hs @@ -11,9 +11,9 @@ import Distribution.Server.Features.Core import Distribution.Server.Features.Users import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), nullDescription) -import qualified Distribution.Server.Features.Distro.State as Acid +import qualified Distribution.Server.Features.Distro.Acid as Acid +import qualified Distribution.Server.Features.Distro.Store as Store import Distribution.Server.Features.Distro.Types -import Distribution.Server.Features.Distro.Backup (dumpBackup, restoreBackup) import Distribution.Server.Util.Parse (unpackUTF8) import Distribution.Text (display, simpleParse) @@ -46,7 +46,8 @@ data DistroResource = DistroResource { initDistroFeature :: ServerEnv -> IO (UserFeature -> CoreFeature -> IO DistroFeature) initDistroFeature ServerEnv{serverStateDir} = do - distrosState <- distrosStateComponent serverStateDir + distrosBackend <- Acid.acidStore serverStateDir + let distrosStore = Store.backendStore distrosBackend return $ \user@UserFeature{adminGroup, groupResourcesAt} core@CoreFeature{coreResource} -> do rec @@ -55,14 +56,14 @@ initDistroFeature ServerEnv{serverStateDir} = do maintainersUserGroup name = UserGroup { groupDesc = maintainerGroupDescription name, - queryUserGroup = queryState distrosState $ Acid.GetDistroMaintainers name, - addUserToGroup = updateState distrosState . Acid.AddDistroMaintainer name, - removeUserFromGroup = updateState distrosState . Acid.RemoveDistroMaintainer name, + queryUserGroup = Store.queryDistroMaintainers distrosStore name, + addUserToGroup = Store.addDistroMaintainer distrosStore name, + removeUserFromGroup = Store.removeDistroMaintainer distrosStore name, groupsAllowedToAdd = [adminGroup], groupsAllowedToDelete = [adminGroup] } - feature = distroFeature user core distrosState maintainersGroupResource maintainersUserGroup - distroNames <- queryState distrosState Acid.EnumerateDistros + feature = distroFeature user core distrosBackend maintainersGroupResource maintainersUserGroup + distroNames <- Store.enumerateDistros distrosStore (_maintainersGroup, maintainersGroupResource) <- groupResourcesAt "/distro/:package/maintainers" maintainersUserGroup @@ -72,28 +73,15 @@ initDistroFeature ServerEnv{serverStateDir} = do return feature -distrosStateComponent :: FilePath -> IO (StateComponent AcidState Acid.Distros) -distrosStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Distros") Acid.initialDistros - return StateComponent { - stateDesc = "" - , stateHandle = st - , getState = query st Acid.GetDistributions - , putState = \(Acid.Distros dists versions) -> update st (Acid.ReplaceDistributions dists versions) - , backupState = \_ -> dumpBackup - , restoreState = restoreBackup - , resetState = distrosStateComponent - } - distroFeature :: UserFeature -> CoreFeature - -> StateComponent AcidState Acid.Distros + -> Store.Backend -> GroupResource -> (DistroName -> UserGroup) -> DistroFeature distroFeature UserFeature{..} CoreFeature{coreResource=CoreResource{packageInPath}} - distrosState + Store.Backend{backendStore = distrosStore, backendState} maintainersGroupResource distroGroup = DistroFeature{..} @@ -108,11 +96,11 @@ distroFeature UserFeature{..} , distroPackages , distroPackage ] - , featureState = [abstractAcidStateComponent distrosState] + , featureState = backendState } queryPackageStatus :: MonadIO m => PackageName -> m [(DistroName, DistroPackageInfo)] - queryPackageStatus pkgname = queryState distrosState (Acid.PackageStatus pkgname) + queryPackageStatus = Store.queryPackageStatus distrosStore distroResource = DistroResource { distroIndexPage = (resourceAt "/distros/.:format") { @@ -135,7 +123,7 @@ distroFeature UserFeature{..} } } - textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (queryState distrosState Acid.EnumerateDistros) + textEnumDistros _ = fmap (toResponse . intercalate ", " . map display) (Store.enumerateDistros distrosStore) textDistroPkgs dpath = withDistroPath dpath $ \dname pkgs -> do let pkglines = map (\(name, info) -> display name ++ " at " ++ display (distroVersion info) ++ ": " ++ distroUrl info) pkgs return $ toResponse (unlines $ ("Packages for " ++ display dname):pkglines) @@ -148,7 +136,7 @@ distroFeature UserFeature{..} withDistroNamePath dpath $ \distro -> do guardAuthorised_ [InGroup adminGroup] -- should also check for existence here of distro here - void $ updateState distrosState $ Acid.RemoveDistro distro + Store.removeDistro distrosStore distro seeOther "/distros/" (toResponse ()) -- result: ok response or not-found error @@ -158,21 +146,21 @@ distroFeature UserFeature{..} case info of Nothing -> notFound . toResponse $ "Package not found for " ++ display pkgname Just {} -> do - void $ updateState distrosState $ Acid.DropPackage dname pkgname + Store.dropDistroPackage distrosStore dname pkgname ok $ toResponse "Ok!" -- result: see-other response, or an error: not authenticated or not found (todo) distroPackagePut dpath = withDistroPackagePath dpath $ \dname pkgname _ -> lookPackageInfo $ \newPkgInfo -> do guardAuthorised_ [InGroup $ distroGroup dname] - void $ updateState distrosState $ Acid.AddPackage dname pkgname newPkgInfo + Store.addDistroPackage distrosStore dname pkgname newPkgInfo seeOther ("/distro/" ++ display dname ++ "/" ++ display pkgname) $ toResponse "Ok!" -- result: see-other response, or an error: not authentcated or bad request distroPostNew _ = lookDistroName $ \dname -> do guardAuthorised_ [InGroup adminGroup] - success <- updateState distrosState $ Acid.AddDistro dname + success <- Store.addDistro distrosStore dname if success then seeOther ("/distro/" ++ display dname) $ toResponse "Ok!" else badRequest $ toResponse "Selected distribution name is already in use" @@ -180,7 +168,7 @@ distroFeature UserFeature{..} distroPutNew dpath = withDistroNamePath dpath $ \dname -> do guardAuthorised_ [InGroup adminGroup] - _success <- updateState distrosState $ Acid.AddDistro dname + _success <- Store.addDistro distrosStore dname -- it doesn't matter if it exists already or not ok $ toResponse "Ok!" @@ -194,7 +182,7 @@ distroFeature UserFeature{..} badRequest $ toResponse $ "Could not parse CSV File to a distro package list: " ++ msg Right list -> do - void $ updateState distrosState $ Acid.PutDistroPackageList dname list + Store.putDistroPackageList distrosStore dname list ok $ toResponse "Ok!" withDistroNamePath :: DynamicPath -> (DistroName -> ServerPartE Response) -> ServerPartE Response @@ -202,11 +190,11 @@ distroFeature UserFeature{..} withDistroPath :: DynamicPath -> (DistroName -> [(PackageName, DistroPackageInfo)] -> ServerPartE Response) -> ServerPartE Response withDistroPath dpath func = withDistroNamePath dpath $ \dname -> do - isDist <- queryState distrosState (Acid.IsDistribution dname) + isDist <- Store.isDistribution distrosStore dname case isDist of False -> notFound $ toResponse "Distribution does not exist" True -> do - pkgs <- queryState distrosState (Acid.DistroStatus dname) + pkgs <- Store.queryDistroStatus distrosStore dname func dname pkgs -- guards on the distro existing, but not the package @@ -214,11 +202,11 @@ distroFeature UserFeature{..} withDistroPackagePath dpath func = withDistroNamePath dpath $ \dname -> do pkgname <- packageInPath dpath - isDist <- queryState distrosState (Acid.IsDistribution dname) + isDist <- Store.isDistribution distrosStore dname case isDist of False -> notFound $ toResponse "Distribution does not exist" True -> do - pkgInfo <- queryState distrosState (Acid.DistroPackageStatus dname pkgname) + pkgInfo <- Store.queryDistroPackageStatus distrosStore dname pkgname func dname pkgname pkgInfo lookPackageInfo :: (DistroPackageInfo -> ServerPartE Response) -> ServerPartE Response diff --git a/src/Distribution/Server/Features/Distro/Acid.hs b/src/Distribution/Server/Features/Distro/Acid.hs new file mode 100644 index 000000000..053e09bba --- /dev/null +++ b/src/Distribution/Server/Features/Distro/Acid.hs @@ -0,0 +1,43 @@ +module Distribution.Server.Features.Distro.Acid + ( acidStore + ) where + +import qualified Distribution.Server.Features.Distro.State as State +import qualified Distribution.Server.Features.Distro.Store as Store +import Distribution.Server.Features.Distro.Backup (dumpBackup, restoreBackup) +import Distribution.Server.Framework + +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + distrosState <- distrosStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.queryDistroMaintainers = \name -> queryState distrosState (State.GetDistroMaintainers name) + , Store.addDistroMaintainer = \name uid -> updateState distrosState (State.AddDistroMaintainer name uid) + , Store.removeDistroMaintainer = \name uid -> updateState distrosState (State.RemoveDistroMaintainer name uid) + , Store.enumerateDistros = queryState distrosState State.EnumerateDistros + , Store.queryPackageStatus = \pkgname -> queryState distrosState (State.PackageStatus pkgname) + , Store.queryDistroStatus = \name -> queryState distrosState (State.DistroStatus name) + , Store.isDistribution = \name -> queryState distrosState (State.IsDistribution name) + , Store.queryDistroPackageStatus = \name pkgname -> queryState distrosState (State.DistroPackageStatus name pkgname) + , Store.removeDistro = \name -> updateState distrosState (State.RemoveDistro name) + , Store.dropDistroPackage = \name pkgname -> updateState distrosState (State.DropPackage name pkgname) + , Store.addDistroPackage = \name pkgname info -> updateState distrosState (State.AddPackage name pkgname info) + , Store.addDistro = \name -> updateState distrosState (State.AddDistro name) + , Store.putDistroPackageList = \name pkgs -> updateState distrosState (State.PutDistroPackageList name pkgs) + } + , Store.backendState = [abstractAcidStateComponent distrosState] + } + +distrosStateComponent :: FilePath -> IO (StateComponent AcidState State.Distros) +distrosStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Distros") State.initialDistros + return StateComponent { + stateDesc = "" + , stateHandle = st + , getState = query st State.GetDistributions + , putState = \(State.Distros dists versions) -> update st (State.ReplaceDistributions dists versions) + , backupState = \_ -> dumpBackup + , restoreState = restoreBackup + , resetState = distrosStateComponent + } diff --git a/src/Distribution/Server/Features/Distro/Store.hs b/src/Distribution/Server/Features/Distro/Store.hs new file mode 100644 index 000000000..40f7d6960 --- /dev/null +++ b/src/Distribution/Server/Features/Distro/Store.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Distro.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Package (PackageName) +import Distribution.Server.Features.Distro.Types (DistroName, DistroPackageInfo) +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Group (UserIdSet) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + queryDistroMaintainers :: forall m. MonadIO m => DistroName -> m UserIdSet + , addDistroMaintainer :: forall m. MonadIO m => DistroName -> UserId -> m () + , removeDistroMaintainer :: forall m. MonadIO m => DistroName -> UserId -> m () + , enumerateDistros :: forall m. MonadIO m => m [DistroName] + , queryPackageStatus :: forall m. MonadIO m => PackageName -> m [(DistroName, DistroPackageInfo)] + , queryDistroStatus :: forall m. MonadIO m => DistroName -> m [(PackageName, DistroPackageInfo)] + , isDistribution :: forall m. MonadIO m => DistroName -> m Bool + , queryDistroPackageStatus :: forall m. MonadIO m => DistroName -> PackageName -> m (Maybe DistroPackageInfo) + , removeDistro :: forall m. MonadIO m => DistroName -> m () + , dropDistroPackage :: forall m. MonadIO m => DistroName -> PackageName -> m () + , addDistroPackage :: forall m. MonadIO m => DistroName -> PackageName -> DistroPackageInfo -> m () + , addDistro :: forall m. MonadIO m => DistroName -> m Bool + , putDistroPackageList :: forall m. MonadIO m => DistroName -> [(PackageName, DistroPackageInfo)] -> m () + } diff --git a/src/Distribution/Server/Features/Documentation.hs b/src/Distribution/Server/Features/Documentation.hs index fb3ebfa63..959856dec 100644 --- a/src/Distribution/Server/Features/Documentation.hs +++ b/src/Distribution/Server/Features/Documentation.hs @@ -10,7 +10,8 @@ module Distribution.Server.Features.Documentation ( import Distribution.Server.Features.Security.SHA256 (sha256) import Distribution.Server.Framework -import qualified Distribution.Server.Features.Documentation.State as Acid +import Distribution.Server.Features.Documentation.Acid (acidStore) +import qualified Distribution.Server.Features.Documentation.Store as Store import Distribution.Server.Features.Upload import Distribution.Server.Features.Users import Distribution.Server.Features.Core @@ -18,7 +19,6 @@ import Distribution.Server.Features.TarIndexCache import Distribution.Server.Features.BuildReports import Distribution.Version (Version, nullVersion) -import Distribution.Server.Framework.BackupRestore import qualified Distribution.Server.Framework.ResponseContentTypes as Resource import Distribution.Server.Framework.BlobStorage (BlobId) import qualified Distribution.Server.Framework.BlobStorage as BlobStorage @@ -98,7 +98,7 @@ initDocumentationFeature :: String initDocumentationFeature name env@ServerEnv{serverStateDir} = do -- Canonical state - documentationState <- documentationStateComponent name serverStateDir + documentationBackend <- acidStore name serverStateDir -- Hooks documentationChangeHook <- newHook @@ -106,43 +106,10 @@ initDocumentationFeature name return $ \core getPackages upload tarIndexCache reportsCore user version -> do let feature = documentationFeature name env core getPackages upload tarIndexCache reportsCore user version - documentationState + documentationBackend documentationChangeHook return feature -documentationStateComponent :: String -> FilePath -> IO (StateComponent AcidState Acid.Documentation) -documentationStateComponent name stateDir = do - st <- openLocalStateFrom (stateDir "db" name) Acid.initialDocumentation - return StateComponent { - stateDesc = "Package documentation" - , stateHandle = st - , getState = query st Acid.GetDocumentation - , putState = update st . Acid.ReplaceDocumentation - , backupState = \_ -> dumpBackup - , restoreState = updateDocumentation (Acid.Documentation Map.empty) - , resetState = documentationStateComponent name - } - where - dumpBackup doc = - let exportFunc (pkgid, blob) = BackupBlob [display pkgid, "documentation.tar"] blob - in map exportFunc . Map.toList $ Acid.documentation doc - - updateDocumentation :: Acid.Documentation -> RestoreBackup Acid.Documentation - updateDocumentation docs = RestoreBackup { - restoreEntry = \entry -> - case entry of - BackupBlob [str, "documentation.tar"] blobId | Just pkgId <- simpleParse str -> do - docs' <- importDocumentation pkgId blobId docs - return (updateDocumentation docs') - _ -> - return (updateDocumentation docs) - , restoreFinalize = return docs - } - - importDocumentation :: PackageId -> BlobId -> Acid.Documentation -> Restore Acid.Documentation - importDocumentation pkgId blobId (Acid.Documentation docs) = - return (Acid.Documentation (Map.insert pkgId blobId docs)) - documentationFeature :: String -> ServerEnv -> CoreResource @@ -152,7 +119,7 @@ documentationFeature :: String -> ReportsFeature -> UserFeature -> VersionsFeature - -> StateComponent AcidState Acid.Documentation + -> Store.Backend -> Hook PackageId () -> DocumentationFeature documentationFeature name @@ -170,10 +137,12 @@ documentationFeature name ReportsFeature{..} UserFeature{ guardAuthorised_ } VersionsFeature{queryGetPreferredInfo} - documentationState + documentationBackend documentationChangeHook = DocumentationFeature{..} where + documentationStore = Store.backendStore documentationBackend + documentationFeatureInterface = (emptyHackageFeature name) { featureDesc = "Maintain and display documentation" , featureResources = @@ -182,18 +151,18 @@ documentationFeature name , packageDocsWhole , packageDocsStats ] - , featureState = [abstractAcidStateComponent documentationState] + , featureState = Store.backendState documentationBackend } queryHasDocumentation :: MonadIO m => PackageIdentifier -> m Bool - queryHasDocumentation pkgid = queryState documentationState (Acid.HasDocumentation pkgid) + queryHasDocumentation pkgid = Store.hasDocumentation documentationStore pkgid queryDocumentation :: MonadIO m => PackageIdentifier -> m (Maybe BlobId) - queryDocumentation pkgid = queryState documentationState (Acid.LookupDocumentation pkgid) + queryDocumentation pkgid = Store.lookupDocumentation documentationStore pkgid queryDocumentationIndex :: MonadIO m => m (Map.Map PackageId BlobId) queryDocumentationIndex = - liftM Acid.documentation (queryState documentationState Acid.GetDocumentation) + Store.getDocumentationIndex documentationStore documentationResource = fix $ \r -> DocumentationResource { packageDocsContent = (extendResourcePath "/docs/.." corePackagePage) { @@ -368,7 +337,7 @@ documentationFeature name case mres of Left err -> errBadRequest "Invalid documentation tarball" [MText err] Right ((), blobid) -> do - updateState documentationState $ Acid.InsertDocumentation pkgid blobid + Store.insertDocumentation documentationStore pkgid blobid runHook_ documentationChangeHook pkgid noContent (toResponse ()) @@ -401,7 +370,7 @@ documentationFeature name pkgid <- packageInPath dpath guardValidPackageId pkgid guardAuthorisedAsMaintainerOrTrustee (packageName pkgid) - updateState documentationState $ Acid.RemoveDocumentation pkgid + Store.removeDocumentation documentationStore pkgid runHook_ documentationChangeHook pkgid noContent (toResponse ()) @@ -465,7 +434,7 @@ documentationFeature name tempRedirect latestPkgPath (toResponse "") Nothing -> errNotFoundH "Not Found" [MText "There is no documentation for this package."] False -> do - mdocs <- queryState documentationState $ Acid.LookupDocumentation pkgid + mdocs <- Store.lookupDocumentation documentationStore pkgid case mdocs of Nothing -> errNotFoundH "Not Found" diff --git a/src/Distribution/Server/Features/Documentation/Acid.hs b/src/Distribution/Server/Features/Documentation/Acid.hs new file mode 100644 index 000000000..8349da2a6 --- /dev/null +++ b/src/Distribution/Server/Features/Documentation/Acid.hs @@ -0,0 +1,60 @@ +module Distribution.Server.Features.Documentation.Acid + ( acidStore + ) where + +import qualified Distribution.Server.Features.Documentation.State as State +import qualified Distribution.Server.Features.Documentation.Store as Store +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore +import Distribution.Server.Framework.BlobStorage (BlobId) + +import Distribution.Package (PackageId) +import Distribution.Text (display, simpleParse) +import qualified Data.Map as Map + +acidStore :: String -> FilePath -> IO Store.Backend +acidStore name stateDir = do + documentationState <- documentationStateComponent name stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.hasDocumentation = \pkgid -> queryState documentationState (State.HasDocumentation pkgid) + , Store.lookupDocumentation = \pkgid -> queryState documentationState (State.LookupDocumentation pkgid) + , Store.getDocumentationIndex = State.documentation <$> queryState documentationState State.GetDocumentation + , Store.insertDocumentation = \pkgid blobid -> updateState documentationState (State.InsertDocumentation pkgid blobid) + , Store.removeDocumentation = \pkgid -> updateState documentationState (State.RemoveDocumentation pkgid) + } + , Store.backendState = [abstractAcidStateComponent documentationState] + } + +documentationStateComponent :: String -> FilePath -> IO (StateComponent AcidState State.Documentation) +documentationStateComponent name stateDir = do + st <- openLocalStateFrom (stateDir "db" name) State.initialDocumentation + return StateComponent { + stateDesc = "Package documentation" + , stateHandle = st + , getState = query st State.GetDocumentation + , putState = update st . State.ReplaceDocumentation + , backupState = \_ -> dumpBackup + , restoreState = updateDocumentation (State.Documentation Map.empty) + , resetState = documentationStateComponent name + } + where + dumpBackup doc = + let exportFunc (pkgid, blob) = BackupBlob [display pkgid, "documentation.tar"] blob + in map exportFunc . Map.toList $ State.documentation doc + + updateDocumentation :: State.Documentation -> RestoreBackup State.Documentation + updateDocumentation docs = RestoreBackup { + restoreEntry = \entry -> + case entry of + BackupBlob [str, "documentation.tar"] blobId | Just pkgId <- simpleParse str -> do + docs' <- importDocumentation pkgId blobId docs + return (updateDocumentation docs') + _ -> + return (updateDocumentation docs) + , restoreFinalize = return docs + } + + importDocumentation :: PackageId -> BlobId -> State.Documentation -> Restore State.Documentation + importDocumentation pkgId blobId (State.Documentation docs) = + return (State.Documentation (Map.insert pkgId blobId docs)) diff --git a/src/Distribution/Server/Features/Documentation/Store.hs b/src/Distribution/Server/Features/Documentation/Store.hs new file mode 100644 index 000000000..9f72eeefd --- /dev/null +++ b/src/Distribution/Server/Features/Documentation/Store.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Documentation.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Framework.BlobStorage (BlobId) + +import Distribution.Package (PackageId, PackageIdentifier) + +import Control.Monad.Trans (MonadIO) +import Data.Map (Map) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + hasDocumentation :: forall m. MonadIO m => PackageIdentifier -> m Bool + , lookupDocumentation :: forall m. MonadIO m => PackageIdentifier -> m (Maybe BlobId) + , getDocumentationIndex :: forall m. MonadIO m => m (Map PackageId BlobId) + , insertDocumentation :: forall m. MonadIO m => PackageId -> BlobId -> m () + , removeDocumentation :: forall m. MonadIO m => PackageId -> m () + } diff --git a/src/Distribution/Server/Features/DownloadCount.hs b/src/Distribution/Server/Features/DownloadCount.hs index 527ac859d..93dd607cb 100644 --- a/src/Distribution/Server/Features/DownloadCount.hs +++ b/src/Distribution/Server/Features/DownloadCount.hs @@ -33,6 +33,8 @@ import Distribution.Server.Framework.BackupRestore import Distribution.Server.Features.DownloadCount.State import Distribution.Server.Features.DownloadCount.Backup +import Distribution.Server.Features.DownloadCount.Acid (acidStore) +import qualified Distribution.Server.Features.DownloadCount.Store as Store import Distribution.Server.Features.Core import Distribution.Server.Features.Users @@ -74,7 +76,7 @@ data PackageDownloads = PackageDownloads { initDownloadFeature :: ServerEnv -> IO (CoreFeature -> UserFeature -> IO DownloadFeature) initDownloadFeature serverEnv@ServerEnv{serverStateDir} = do - inMemState <- inMemStateComponent serverStateDir + inMemBackend <- acidStore serverStateDir let onDiskState = onDiskStateComponent serverStateDir (recentDownloads, totalDownloads) <- computeRecentAndTotalDownloads =<< getState onDiskState @@ -83,26 +85,12 @@ initDownloadFeature serverEnv@ServerEnv{serverStateDir} = do downChan <- newChan return $ \core users -> do - let feature = downloadFeature core users serverEnv inMemState + let feature = downloadFeature core users serverEnv inMemBackend onDiskState totalsCache recentCache downChan registerHook (packageDownloadHook core) (writeChan downChan) return feature -inMemStateComponent :: FilePath -> IO (StateComponent AcidState InMemStats) -inMemStateComponent stateDir = do - initSt <- initInMemStats <$> getToday - st <- openLocalStateFrom (dcPath stateDir "inmem") initSt - return StateComponent { - stateDesc = "Today's download counts" - , stateHandle = st - , getState = query st GetInMemStats - , putState = update st . ReplaceInMemStats - , backupState = \_ -> inMemBackup - , restoreState = inMemRestore - , resetState = inMemStateComponent - } - onDiskStateComponent :: FilePath -> StateComponent OnDiskState OnDiskStats onDiskStateComponent stateDir = StateComponent { stateDesc = "All time download counts" @@ -121,7 +109,7 @@ onDiskStateComponent stateDir = StateComponent { downloadFeature :: CoreFeature -> UserFeature -> ServerEnv - -> StateComponent AcidState InMemStats + -> Store.Backend -> StateComponent OnDiskState OnDiskStats -> MemState TotalDownloads -> MemState RecentDownloads @@ -131,21 +119,22 @@ downloadFeature :: CoreFeature downloadFeature CoreFeature{} UserFeature{..} ServerEnv{serverStateDir} - inMemState + inMemBackend onDiskState totalDownloadsCache recentDownloadsCache downloadStream = DownloadFeature{..} where + inMemStore = Store.backendStore inMemBackend + downloadFeatureInterface = (emptyHackageFeature "download") { featureResources = [ topDownloads downloadResource , downloadCSV ] , featurePostInit = void $ forkIO registerDownloads - , featureState = [ abstractAcidStateComponent inMemState - , abstractOnDiskStateComponent onDiskState - ] + , featureState = Store.backendState inMemBackend + ++ [abstractOnDiskStateComponent onDiskState] , featureCaches = [ CacheComponent { cacheDesc = "recent package downloads cache", @@ -167,15 +156,15 @@ downloadFeature CoreFeature{} registerDownloads = forever $ do pkg <- readChan downloadStream today <- getToday - today' <- query (stateHandle inMemState) RecordedToday + today' <- Store.recordedToday inMemStore --TODO: do this asyncronously rather than blocking this request when (today /= today') $ do -- For the first download each day we reset the in-memory stats and.. - inMemStats <- getState inMemState - putState inMemState $ initInMemStats today + inMemStats <- Store.getInMemStats inMemStore + Store.replaceInMemStats inMemStore $ initInMemStats today -- we can discard the large eventlog by writing a small checkpoint - createCheckpoint (stateHandle inMemState) + Store.checkpointInMemStats inMemStore -- Write yesterday's downloads to the log appendToLog (dcPath serverStateDir) inMemStats @@ -191,7 +180,8 @@ downloadFeature CoreFeature{} writeMemState totalDownloadsCache totalDownloads - updateState inMemState $ RegisterDownload pkg + Store.registerDownload inMemStore pkg + downloadResource = DownloadResource { diff --git a/src/Distribution/Server/Features/DownloadCount/Acid.hs b/src/Distribution/Server/Features/DownloadCount/Acid.hs new file mode 100644 index 000000000..b300b86db --- /dev/null +++ b/src/Distribution/Server/Features/DownloadCount/Acid.hs @@ -0,0 +1,38 @@ +module Distribution.Server.Features.DownloadCount.Acid + ( acidStore + ) where + +import Distribution.Server.Features.DownloadCount.Backup +import qualified Distribution.Server.Features.DownloadCount.State as State +import qualified Distribution.Server.Features.DownloadCount.Store as Store +import Distribution.Server.Framework + +import Data.Time.Clock (getCurrentTime, utctDay) + +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + inMemState <- inMemStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.recordedToday = queryState inMemState State.RecordedToday + , Store.getInMemStats = queryState inMemState State.GetInMemStats + , Store.replaceInMemStats = \stats -> updateState inMemState (State.ReplaceInMemStats stats) + , Store.registerDownload = \pkgid -> updateState inMemState (State.RegisterDownload pkgid) + , Store.checkpointInMemStats = liftIO (createCheckpoint (stateHandle inMemState)) + } + , Store.backendState = [abstractAcidStateComponent inMemState] + } + +inMemStateComponent :: FilePath -> IO (StateComponent AcidState State.InMemStats) +inMemStateComponent stateDir = do + initSt <- State.initInMemStats . utctDay <$> getCurrentTime + st <- openLocalStateFrom (stateDir "db" "DownloadCount" "inmem") initSt + return StateComponent { + stateDesc = "Today's download counts" + , stateHandle = st + , getState = query st State.GetInMemStats + , putState = update st . State.ReplaceInMemStats + , backupState = \_ -> inMemBackup + , restoreState = inMemRestore + , resetState = inMemStateComponent + } diff --git a/src/Distribution/Server/Features/DownloadCount/Store.hs b/src/Distribution/Server/Features/DownloadCount/Store.hs new file mode 100644 index 000000000..e1cd90952 --- /dev/null +++ b/src/Distribution/Server/Features/DownloadCount/Store.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.DownloadCount.Store + ( Backend(..) + , Store(..) + ) where + +import qualified Distribution.Server.Features.DownloadCount.State as State +import Distribution.Server.Framework (AbstractStateComponent) + +import Distribution.Package (PackageId) + +import Control.Monad.Trans (MonadIO) +import Data.Time.Calendar (Day) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + recordedToday :: forall m. MonadIO m => m Day + , getInMemStats :: forall m. MonadIO m => m State.InMemStats + , replaceInMemStats :: forall m. MonadIO m => State.InMemStats -> m () + , registerDownload :: forall m. MonadIO m => PackageId -> m () + , checkpointInMemStats :: forall m. MonadIO m => m () + } diff --git a/src/Distribution/Server/Features/HaskellPlatform.hs b/src/Distribution/Server/Features/HaskellPlatform.hs index 90f5f241b..12cf7093d 100644 --- a/src/Distribution/Server/Features/HaskellPlatform.hs +++ b/src/Distribution/Server/Features/HaskellPlatform.hs @@ -6,17 +6,15 @@ module Distribution.Server.Features.HaskellPlatform ( ) where import Distribution.Server.Framework -import Distribution.Server.Framework.BackupRestore -import qualified Distribution.Server.Features.HaskellPlatform.State as Acid +import Distribution.Server.Features.HaskellPlatform.Acid (acidStore) +import qualified Distribution.Server.Features.HaskellPlatform.Store as Store import Distribution.Package import Distribution.Version import Distribution.Text import Data.Function -import qualified Data.Map as Map -import qualified Data.Set as Set -- Note: this can be generalized into dividing Hackage up into however many @@ -47,34 +45,15 @@ data PlatformResource = PlatformResource { initPlatformFeature :: ServerEnv -> IO (IO PlatformFeature) initPlatformFeature ServerEnv{serverStateDir} = do - platformState <- platformStateComponent serverStateDir + platformState <- acidStore serverStateDir return $ do let feature = platformFeature platformState return feature -platformStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PlatformPackages) -platformStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Acid.PlatformPackages") Acid.initialPlatformPackages - return StateComponent { - stateDesc = "Platform packages" - , stateHandle = st - , getState = query st Acid.GetPlatformPackages - , putState = update st . Acid.ReplacePlatformPackages - , resetState = platformStateComponent - -- TODO: backup - -- For now backup is just empty, as this package is basically featureless - -- It defines state, but there is no way at all to modify this state - , backupState = \_ _ -> [] - , restoreState = RestoreBackup { - restoreEntry = error "Unexpected backup entry for platform" - , restoreFinalize = return Acid.initialPlatformPackages - } - } - -platformFeature :: StateComponent AcidState Acid.PlatformPackages +platformFeature :: Store.Backend -> PlatformFeature -platformFeature platformState +platformFeature Store.Backend{..} = PlatformFeature{..} where platformFeatureInterface = (emptyHackageFeature "platform") { @@ -84,7 +63,7 @@ platformFeature platformState platformPackage , platformPackages ] - , featureState = [abstractAcidStateComponent platformState] + , featureState = backendState } platformResource = fix $ \r -> PlatformResource @@ -107,14 +86,13 @@ platformFeature platformState ------------------------------------------ -- functionality: showing status for a single package, and for all packages, adding a package, deleting a package platformVersions :: MonadIO m => PackageName -> m [Version] - platformVersions pkgname = liftM Set.toList $ queryState platformState $ Acid.GetPlatformPackage pkgname + platformVersions = Store.platformVersions backendStore platformPackageLatest :: MonadIO m => m [(PackageName, Version)] - platformPackageLatest = liftM (Map.toList . Map.map Set.findMax . Acid.blessedPackages) $ queryState platformState Acid.GetPlatformPackages + platformPackageLatest = Store.platformPackageLatest backendStore setPlatform :: MonadIO m => PackageName -> [Version] -> m () - setPlatform pkgname versions = updateState platformState $ Acid.SetPlatformPackage pkgname (Set.fromList versions) + setPlatform = Store.setPlatform backendStore removePlatform :: MonadIO m => PackageName -> m () - removePlatform pkgname = updateState platformState $ Acid.SetPlatformPackage pkgname Set.empty - + removePlatform = Store.removePlatform backendStore diff --git a/src/Distribution/Server/Features/HaskellPlatform/Acid.hs b/src/Distribution/Server/Features/HaskellPlatform/Acid.hs new file mode 100644 index 000000000..7ae06d481 --- /dev/null +++ b/src/Distribution/Server/Features/HaskellPlatform/Acid.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE NamedFieldPuns #-} + +module Distribution.Server.Features.HaskellPlatform.Acid + ( acidStore + ) where + +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore + +import qualified Distribution.Server.Features.HaskellPlatform.State as Acid +import Distribution.Server.Features.HaskellPlatform.Store + +import qualified Data.Map as Map +import qualified Data.Set as Set + +acidStore :: FilePath -> IO Backend +acidStore stateDir = do + platformState <- platformStateComponent stateDir + pure Backend + { backendStore = Store + { platformVersions = \pkgname -> fmap Set.toList $ queryState platformState $ Acid.GetPlatformPackage pkgname + , platformPackageLatest = fmap (Map.toList . Map.map Set.findMax . Acid.blessedPackages) $ queryState platformState Acid.GetPlatformPackages + , setPlatform = \pkgname versions -> updateState platformState $ Acid.SetPlatformPackage pkgname (Set.fromList versions) + , removePlatform = \pkgname -> updateState platformState $ Acid.SetPlatformPackage pkgname Set.empty + } + , backendState = [abstractAcidStateComponent platformState] + } + +platformStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PlatformPackages) +platformStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Acid.PlatformPackages") Acid.initialPlatformPackages + return StateComponent { + stateDesc = "Platform packages" + , stateHandle = st + , getState = query st Acid.GetPlatformPackages + , putState = update st . Acid.ReplacePlatformPackages + , resetState = platformStateComponent + -- TODO: backup + -- For now backup is just empty, as this package is basically featureless + -- It defines state, but there is no way at all to modify this state + , backupState = \_ _ -> [] + , restoreState = RestoreBackup { + restoreEntry = error "Unexpected backup entry for platform" + , restoreFinalize = return Acid.initialPlatformPackages + } + } diff --git a/src/Distribution/Server/Features/HaskellPlatform/Store.hs b/src/Distribution/Server/Features/HaskellPlatform/Store.hs new file mode 100644 index 000000000..94c7a092c --- /dev/null +++ b/src/Distribution/Server/Features/HaskellPlatform/Store.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.HaskellPlatform.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) + +import Distribution.Package (PackageName) +import Distribution.Version (Version) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + platformVersions :: forall m. MonadIO m => PackageName -> m [Version] + , platformPackageLatest :: forall m. MonadIO m => m [(PackageName, Version)] + , setPlatform :: forall m. MonadIO m => PackageName -> [Version] -> m () + , removePlatform :: forall m. MonadIO m => PackageName -> m () + } diff --git a/src/Distribution/Server/Features/Mirror.hs b/src/Distribution/Server/Features/Mirror.hs index 0db7660cd..253c6a63e 100644 --- a/src/Distribution/Server/Features/Mirror.hs +++ b/src/Distribution/Server/Features/Mirror.hs @@ -13,15 +13,14 @@ import Distribution.Server.Framework import Distribution.Server.Features.Core import Distribution.Server.Features.Users -import Distribution.Server.Users.State +import Distribution.Server.Features.Mirror.Acid (acidStore) +import qualified Distribution.Server.Features.Mirror.Store as Store import Distribution.Server.Packages.Types -import Distribution.Server.Users.Backup import Distribution.Server.Users.Types import Distribution.Server.Users.Users hiding (lookupUserName) import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), nullDescription) import qualified Distribution.Server.Framework.BlobStorage as BlobStorage import qualified Distribution.Server.Packages.Unpack as Upload -import Distribution.Server.Framework.BackupDump import Distribution.Server.Util.Parse (unpackUTF8) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult) @@ -61,7 +60,7 @@ initMirrorFeature :: ServerEnv -> IO MirrorFeature) initMirrorFeature env@ServerEnv{serverStateDir} = do -- Canonical state - mirrorersState <- mirrorersStateComponent serverStateDir + mirrorersState <- acidStore serverStateDir return $ \core user@UserFeature{..} -> do -- Tie the knot with a do-rec @@ -73,23 +72,10 @@ initMirrorFeature env@ServerEnv{serverStateDir} = do return feature -mirrorersStateComponent :: FilePath -> IO (StateComponent AcidState MirrorClients) -mirrorersStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "MirrorClients") initialMirrorClients - return StateComponent { - stateDesc = "Mirror clients" - , stateHandle = st - , getState = query st GetMirrorClients - , putState = update st . ReplaceMirrorClients . mirrorClients - , backupState = \_ (MirrorClients clients) -> [csvToBackup ["clients.csv"] $ groupToCSV clients] - , restoreState = MirrorClients <$> groupBackup ["clients.csv"] - , resetState = mirrorersStateComponent - } - mirrorFeature :: ServerEnv -> CoreFeature -> UserFeature - -> StateComponent AcidState MirrorClients + -> Store.Backend -> UserGroup -> GroupResource -> (MirrorFeature, UserGroup) @@ -106,7 +92,8 @@ mirrorFeature ServerEnv{serverBlobStore = store} , updateSetPackageUploader } UserFeature{..} - mirrorersState mirrorGroup mirrorGroupResource + Store.Backend{backendStore = mirrorersState, backendState} + mirrorGroup mirrorGroupResource = (MirrorFeature{..}, mirrorersGroupDesc) where mirrorFeatureInterface = (emptyHackageFeature "mirror") { @@ -121,7 +108,7 @@ mirrorFeature ServerEnv{serverBlobStore = store} [ groupResource mirrorGroupResource , groupUserResource mirrorGroupResource ] - , featureState = [abstractAcidStateComponent mirrorersState] + , featureState = backendState } mirrorResource = MirrorResource { @@ -152,9 +139,9 @@ mirrorFeature ServerEnv{serverBlobStore = store} mirrorersGroupDesc = UserGroup { groupDesc = nullDescription { groupTitle = "Mirror clients" }, - queryUserGroup = queryState mirrorersState GetMirrorClientsList, - addUserToGroup = updateState mirrorersState . AddMirrorClient, - removeUserFromGroup = updateState mirrorersState . RemoveMirrorClient, + queryUserGroup = Store.getMirrorClientsList mirrorersState, + addUserToGroup = Store.addMirrorClient mirrorersState, + removeUserFromGroup = Store.removeMirrorClient mirrorersState, groupsAllowedToDelete = [adminGroup], groupsAllowedToAdd = [adminGroup] } diff --git a/src/Distribution/Server/Features/Mirror/Acid.hs b/src/Distribution/Server/Features/Mirror/Acid.hs new file mode 100644 index 000000000..cfcad3f75 --- /dev/null +++ b/src/Distribution/Server/Features/Mirror/Acid.hs @@ -0,0 +1,45 @@ +module Distribution.Server.Features.Mirror.Acid + ( acidStore + ) where + +import Distribution.Server.Prelude + +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Features.Mirror.Store +import Distribution.Server.Users.State + ( MirrorClients(..) + , GetMirrorClients(..) + , GetMirrorClientsList(..) + , ReplaceMirrorClients(..) + , AddMirrorClient(..) + , RemoveMirrorClient(..) + , initialMirrorClients + , mirrorClients + ) +import Distribution.Server.Users.Backup (groupBackup, groupToCSV) + +acidStore :: FilePath -> IO Backend +acidStore stateDir = do + mirrorersState <- mirrorersStateComponent stateDir + pure Backend { + backendStore = Store { + getMirrorClientsList = queryState mirrorersState GetMirrorClientsList + , addMirrorClient = \uid -> updateState mirrorersState (AddMirrorClient uid) + , removeMirrorClient = \uid -> updateState mirrorersState (RemoveMirrorClient uid) + } + , backendState = [abstractAcidStateComponent mirrorersState] + } + +mirrorersStateComponent :: FilePath -> IO (StateComponent AcidState MirrorClients) +mirrorersStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "MirrorClients") initialMirrorClients + return StateComponent { + stateDesc = "Mirror clients" + , stateHandle = st + , getState = query st GetMirrorClients + , putState = update st . ReplaceMirrorClients . mirrorClients + , backupState = \_ (MirrorClients clients) -> [csvToBackup ["clients.csv"] $ groupToCSV clients] + , restoreState = MirrorClients <$> groupBackup ["clients.csv"] + , resetState = mirrorersStateComponent + } diff --git a/src/Distribution/Server/Features/Mirror/Store.hs b/src/Distribution/Server/Features/Mirror/Store.hs new file mode 100644 index 000000000..93b338691 --- /dev/null +++ b/src/Distribution/Server/Features/Mirror/Store.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Mirror.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.UserIdSet (UserIdSet) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getMirrorClientsList :: forall m. MonadIO m => m UserIdSet + , addMirrorClient :: forall m. MonadIO m => UserId -> m () + , removeMirrorClient :: forall m. MonadIO m => UserId -> m () + } diff --git a/src/Distribution/Server/Features/PackageCandidates.hs b/src/Distribution/Server/Features/PackageCandidates.hs index 7ad2c22c4..ee82812ce 100644 --- a/src/Distribution/Server/Features/PackageCandidates.hs +++ b/src/Distribution/Server/Features/PackageCandidates.hs @@ -11,8 +11,8 @@ module Distribution.Server.Features.PackageCandidates ( import Distribution.Server.Framework import Distribution.Server.Features.PackageCandidates.Types -import Distribution.Server.Features.PackageCandidates.State -import Distribution.Server.Features.PackageCandidates.Backup +import qualified Distribution.Server.Features.PackageCandidates.Acid as Acid +import qualified Distribution.Server.Features.PackageCandidates.Store as Store import Distribution.Server.Features.Core import Distribution.Server.Features.Upload @@ -138,43 +138,31 @@ initPackageCandidatesFeature :: ServerEnv -> TarIndexCacheFeature -> IO PackageCandidatesFeature) initPackageCandidatesFeature env@ServerEnv{serverStateDir} = do - candidatesState <- candidatesStateComponent False serverStateDir + candidatesBackend <- Acid.acidStore serverStateDir + let candidatesStore = Store.backendStore candidatesBackend return $ \user core upload@UploadFeature{..} tarIndexCache -> do -- one-off migration - CandidatePackages{candidateMigratedPkgTarball = migratedPkgTarball} <- - queryState candidatesState GetCandidatePackages + migratedPkgTarball <- Store.candidateTarballIsMigrated candidatesStore unless migratedPkgTarball $ do - migrateCandidatePkgTarball_v1_to_v2 env candidatesState - updateState candidatesState SetMigratedPkgTarball + candidateIndex <- Store.getCandidateIndex candidatesStore + migrateCandidatePkgTarball_v1_to_v2 env candidateIndex $ \pkgid pkginfo -> + void $ Store.updateCandidatePkgInfo candidatesStore pkgid pkginfo + Store.setCandidateTarballMigrated candidatesStore - registerHook packageUploaded $ updateState candidatesState . DeleteCandidate + registerHook packageUploaded $ Store.deleteCandidate candidatesStore let feature = candidatesFeature env user core upload tarIndexCache - candidatesState + candidatesBackend return feature -candidatesStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState CandidatePackages) -candidatesStateComponent freshDB stateDir = do - st <- openLocalStateFrom (stateDir "db" "CandidatePackages") - (initialCandidatePackages freshDB) - return StateComponent { - stateDesc = "Candidate packages" - , stateHandle = st - , getState = query st GetCandidatePackages - , putState = update st . ReplaceCandidatePackages - , resetState = candidatesStateComponent True - , backupState = \_ -> backupCandidates - , restoreState = restoreCandidates - } - candidatesFeature :: ServerEnv -> UserFeature -> CoreFeature -> UploadFeature -> TarIndexCacheFeature - -> StateComponent AcidState CandidatePackages + -> Store.Backend -> PackageCandidatesFeature candidatesFeature ServerEnv{serverBlobStore = store} UserFeature{..} @@ -184,7 +172,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} } UploadFeature{..} TarIndexCacheFeature{packageTarball, findToplevelFile} - candidatesState + Store.Backend{backendStore = candidatesStore, backendState} = PackageCandidatesFeature{..} where candidatesFeatureInterface = (emptyHackageFeature "candidates") { @@ -202,11 +190,11 @@ candidatesFeature ServerEnv{serverBlobStore = store} , candidateContents , candidateChangeLog ] - , featureState = [abstractAcidStateComponent candidatesState] + , featureState = backendState } queryGetCandidateIndex :: MonadIO m => m (PackageIndex CandPkgInfo) - queryGetCandidateIndex = return . candidateList =<< queryState candidatesState GetCandidatePackages + queryGetCandidateIndex = Store.getCandidateIndex candidatesStore candidatesCoreResource = fix $ \r -> CoreResource { -- TODO: There is significant overlap between this definition and the one in Core @@ -353,14 +341,14 @@ candidatesFeature ServerEnv{serverBlobStore = store} doDeleteCandidate dpath = do candidate <- packageInPath dpath >>= lookupCandidateId guardAuthorisedAsMaintainerOrTrustee (packageName candidate) - void $ updateState candidatesState $ DeleteCandidate (packageId candidate) + Store.deleteCandidate candidatesStore (packageId candidate) seeOther (packageCandidatesUri candidatesResource "" $ packageName candidate) $ toResponse () doDeleteCandidates :: DynamicPath -> ServerPartE Response doDeleteCandidates dpath = do pkgname <- packageInPath dpath guardAuthorisedAsMaintainerOrTrustee pkgname - void $ updateState candidatesState $ DeleteCandidates pkgname + Store.deleteCandidates candidatesStore pkgname seeOther (packageCandidatesUri candidatesResource "" pkgname) $ toResponse () serveCandidateTarball :: DynamicPath -> ServerPartE Response @@ -412,7 +400,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} checkCandidate "Upload failed" uid regularIndex candidate >>= \case Just failed -> throwError failed Nothing -> do - void $ updateState candidatesState $ AddCandidate candidate + Store.addCandidate candidatesStore candidate let group = maintainersGroup (packageName pkgid) liftIO $ Group.addUserToGroup group uid return candidate @@ -473,7 +461,7 @@ candidatesFeature ServerEnv{serverBlobStore = store} then do -- delete when requested: "moving" the resource -- should this be required? (see notes in PackageCandidatesResource) - when doDelete $ updateState candidatesState $ DeleteCandidate (packageId candidate) + when doDelete $ Store.deleteCandidate candidatesStore (packageId candidate) return uresult else errForbidden "Upload failed" [MText "Package already exists."] @@ -552,8 +540,8 @@ candidatesFeature ServerEnv{serverBlobStore = store} lookupCandidateName :: PackageName -> ServerPartE [CandPkgInfo] lookupCandidateName pkgname = do guardValidPackageName core pkgname - state <- queryState candidatesState GetCandidatePackages - return $ PackageIndex.lookupPackageName (candidateList state) pkgname + candidateIndex <- queryGetCandidateIndex + return $ PackageIndex.lookupPackageName candidateIndex pkgname -- TODO: Unlike the corresponding function in core, we don't return the -- "latest" candidate when Version is empty. Should we? @@ -561,8 +549,8 @@ candidatesFeature ServerEnv{serverBlobStore = store} lookupCandidateId :: PackageId -> ServerPartE CandPkgInfo lookupCandidateId pkgid = do guard (pkgVersion pkgid /= nullVersion) - state <- queryState candidatesState GetCandidatePackages - case PackageIndex.lookupPackageId (candidateList state) pkgid of + candidateIndex <- queryGetCandidateIndex + case PackageIndex.lookupPackageId candidateIndex pkgid of Just pkg -> return pkg _ -> errNotFound "Candidate not found" [MText $ "No such candidate version for " ++ display (packageName pkgid)] diff --git a/src/Distribution/Server/Features/PackageCandidates/Acid.hs b/src/Distribution/Server/Features/PackageCandidates/Acid.hs new file mode 100644 index 000000000..5a26e6c1d --- /dev/null +++ b/src/Distribution/Server/Features/PackageCandidates/Acid.hs @@ -0,0 +1,39 @@ +module Distribution.Server.Features.PackageCandidates.Acid + ( candidatesStateComponent + , acidStore + ) where + +import qualified Distribution.Server.Features.PackageCandidates.State as State +import Distribution.Server.Features.PackageCandidates.Backup +import qualified Distribution.Server.Features.PackageCandidates.Store as Store +import Distribution.Server.Framework + +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + candidatesState <- candidatesStateComponent False stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getCandidateIndex = State.candidateList <$> queryState candidatesState State.GetCandidatePackages + , Store.candidateTarballIsMigrated = State.candidateMigratedPkgTarball <$> queryState candidatesState State.GetCandidatePackages + , Store.setCandidateTarballMigrated = updateState candidatesState State.SetMigratedPkgTarball + , Store.addCandidate = \candidate -> updateState candidatesState (State.AddCandidate candidate) + , Store.deleteCandidate = \pkgid -> updateState candidatesState (State.DeleteCandidate pkgid) + , Store.deleteCandidates = \pkgname -> updateState candidatesState (State.DeleteCandidates pkgname) + , Store.updateCandidatePkgInfo = \pkgid pkginfo -> updateState candidatesState (State.UpdateCandidatePkgInfo pkgid pkginfo) + } + , Store.backendState = [abstractAcidStateComponent candidatesState] + } + +candidatesStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState State.CandidatePackages) +candidatesStateComponent freshDB stateDir = do + st <- openLocalStateFrom (stateDir "db" "CandidatePackages") + (State.initialCandidatePackages freshDB) + return StateComponent { + stateDesc = "Candidate packages" + , stateHandle = st + , getState = query st State.GetCandidatePackages + , putState = update st . State.ReplaceCandidatePackages + , resetState = candidatesStateComponent True + , backupState = \_ -> backupCandidates + , restoreState = restoreCandidates + } diff --git a/src/Distribution/Server/Features/PackageCandidates/Store.hs b/src/Distribution/Server/Features/PackageCandidates/Store.hs new file mode 100644 index 000000000..461d67f35 --- /dev/null +++ b/src/Distribution/Server/Features/PackageCandidates/Store.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.PackageCandidates.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Package (PackageId, PackageName) +import Distribution.Server.Features.PackageCandidates.Types (CandPkgInfo) +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Packages.PackageIndex (PackageIndex) +import Distribution.Server.Packages.Types (PkgInfo) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getCandidateIndex :: forall m. MonadIO m => m (PackageIndex CandPkgInfo) + , candidateTarballIsMigrated :: forall m. MonadIO m => m Bool + , setCandidateTarballMigrated :: forall m. MonadIO m => m () + , addCandidate :: forall m. MonadIO m => CandPkgInfo -> m () + , deleteCandidate :: forall m. MonadIO m => PackageId -> m () + , deleteCandidates :: forall m. MonadIO m => PackageName -> m () + , updateCandidatePkgInfo :: forall m. MonadIO m => PackageId -> PkgInfo -> m Bool + } diff --git a/src/Distribution/Server/Features/PackageList.hs b/src/Distribution/Server/Features/PackageList.hs index d2b063c29..5f03931cd 100644 --- a/src/Distribution/Server/Features/PackageList.hs +++ b/src/Distribution/Server/Features/PackageList.hs @@ -19,7 +19,6 @@ import Distribution.Server.Users.Users (userIdToName) import qualified Distribution.Server.Users.UserIdSet as UserIdSet import Distribution.Server.Users.Group(UserGroup(..), GroupDescription(..)) import Distribution.Server.Features.PreferredVersions -import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Util.CountingMap (cmFind) import Distribution.Server.Packages.Types @@ -152,8 +151,8 @@ initListFeature _env = do registerHookJust packageChangeHook isPackageAdd $ \pkg -> do let pkgname = packageName . packageId $ pkg prefsinfo <- queryGetPreferredInfo pkgname - index <- queryGetPackageIndex - let allVersions = packageVersion <$> PackageIndex.lookupPackageName index pkgname + pkgs <- queryLookupPackageName pkgname + let allVersions = packageVersion <$> pkgs modifyItem pkgname $ \x -> updateReferenceVersion prefsinfo allVersions $ x @@ -196,8 +195,8 @@ initListFeature _env = do runHook_ itemUpdate (Set.singleton pkgname) registerHook updatePreferredHook $ \(pkgname, prefsinfo) -> do - index <- queryGetPackageIndex - let allVersions = packageVersion <$> PackageIndex.lookupPackageName index pkgname + pkgs <- queryLookupPackageName pkgname + let allVersions = packageVersion <$> pkgs modifyItem pkgname $ updateReferenceVersion prefsinfo allVersions return feature @@ -252,15 +251,13 @@ listFeature CoreFeature{..} case hasItem of True -> modifyMemState itemCache $ Map.adjust token pkgname False -> do - index <- queryGetPackageIndex - let pkgs = PackageIndex.lookupPackageName index pkgname + pkgs <- queryLookupPackageName pkgname case pkgs of [] -> return () --this shouldn't happen _ -> modifyMemState itemCache . uncurry Map.insert =<< constructItem (last pkgs) updateDesc pkgname = do - index <- queryGetPackageIndex - let pkgs = PackageIndex.lookupPackageName index pkgname + pkgs <- queryLookupPackageName pkgname case pkgs of [] -> modifyMemState itemCache (Map.delete pkgname) _ -> modifyItem pkgname (updateDescriptionItem $ pkgDesc $ last pkgs) @@ -276,8 +273,8 @@ listFeature CoreFeature{..} constructItemIndex :: IO (Map PackageName PackageItem) constructItemIndex = do - index <- queryGetPackageIndex - items <- mapM (constructItem . last) $ PackageIndex.allPackagesByName index + latestPackages <- queryLatestPackages + items <- mapM constructItem latestPackages return $ Map.fromList items constructItem :: PkgInfo -> IO (PackageName, PackageItem) diff --git a/src/Distribution/Server/Features/PreferredVersions.hs b/src/Distribution/Server/Features/PreferredVersions.hs index a66def777..a654aa175 100644 --- a/src/Distribution/Server/Features/PreferredVersions.hs +++ b/src/Distribution/Server/Features/PreferredVersions.hs @@ -19,8 +19,10 @@ module Distribution.Server.Features.PreferredVersions ( import Distribution.Server.Framework +import qualified Distribution.Server.Features.PreferredVersions.Acid as Acid +import Distribution.Server.Features.PreferredVersions.Acid (preferredStateComponent) +import qualified Distribution.Server.Features.PreferredVersions.Store as Store import Distribution.Server.Features.PreferredVersions.State -import Distribution.Server.Features.PreferredVersions.Backup import Distribution.Server.Features.PreferredVersions.Types import Distribution.Server.Features.Core @@ -106,7 +108,7 @@ initVersionsFeature :: ServerEnv -> UserFeature -> IO VersionsFeature) initVersionsFeature env@ServerEnv{serverStateDir} = do - preferredState <- preferredStateComponent False serverStateDir + preferredBackend <- Acid.acidStore serverStateDir deprecatedHook <- newHook updatePreferredHook <- newHook @@ -114,30 +116,16 @@ initVersionsFeature env@ServerEnv{serverStateDir} = do let feature = versionsFeature env core upload tags user - preferredState deprecatedHook + preferredBackend deprecatedHook updatePreferredHook return feature -preferredStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState PreferredVersions) -preferredStateComponent freshDB stateDir = do - st <- openLocalStateFrom (stateDir "db" "PreferredVersions") - (initialPreferredVersions freshDB) - return StateComponent { - stateDesc = "Preferred package versions" - , stateHandle = st - , getState = query st GetPreferredVersions - , putState = update st . ReplacePreferredVersions - , resetState = preferredStateComponent True - , backupState = \_ -> backupPreferredVersions - , restoreState = restorePreferredVersions - } - versionsFeature :: ServerEnv -> CoreFeature -> UploadFeature -> TagsFeature -> UserFeature - -> StateComponent AcidState PreferredVersions + -> Store.Backend -> Hook (PackageName, Maybe [PackageName]) () -> Hook (PackageName, PreferredInfo) () -> VersionsFeature @@ -146,7 +134,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } UploadFeature{..} TagsFeature{..} UserFeature{ guardAuthorised_ } - preferredState + Store.Backend{backendStore = preferredStore, backendState} deprecatedHook updatePreferredHook = VersionsFeature{..} @@ -162,20 +150,20 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } ] , featurePostInit = do updateDeprecatedTags ephemeralPrefsMigration - , featureState = [abstractAcidStateComponent preferredState] + , featureState = backendState } queryGetPreferredInfo :: MonadIO m => PackageName -> m PreferredInfo - queryGetPreferredInfo name = queryState preferredState (GetPreferredInfo name) + queryGetPreferredInfo = Store.getPreferredInfo preferredStore queryGetDeprecatedFor :: MonadIO m => PackageName -> m (Maybe [PackageName]) - queryGetDeprecatedFor name = queryState preferredState (GetDeprecatedFor name) + queryGetDeprecatedFor = Store.getDeprecatedFor preferredStore queryGetPreferredVersions :: MonadIO m => m PreferredVersions - queryGetPreferredVersions = queryState preferredState GetPreferredVersions + queryGetPreferredVersions = Store.getPreferredVersions preferredStore updateDeprecatedTags = do - pkgs <- deprecatedMap <$> queryState preferredState GetPreferredVersions + pkgs <- deprecatedMap <$> Store.getPreferredVersions preferredStore setCalculatedTag (Tag "deprecated") (Map.keysSet pkgs) CoreResource{..} = coreResource @@ -225,7 +213,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } handlePackagesDeprecatedGet :: DynamicPath -> ServerPartE Response handlePackagesDeprecatedGet _ = do - deprPkgs <- deprecatedMap <$> queryState preferredState GetPreferredVersions + deprPkgs <- deprecatedMap <$> Store.getPreferredVersions preferredStore return $ toResponse $ array [ object [ ("deprecated-package", string $ display deprPkg) @@ -238,7 +226,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } handlePackageDeprecatedGet dpath = do pkgname <- packageInPath dpath guardValidPackageName pkgname - mdep <- queryState preferredState (GetDeprecatedFor pkgname) + mdep <- Store.getDeprecatedFor preferredStore pkgname return $ toResponse $ object [ ("is-deprecated", Bool (isJust mdep)) @@ -277,7 +265,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } updatePackageDeprecation :: MonadIO m => PackageName -> Maybe [PackageName] -> m () updatePackageDeprecation pkgname deprs = liftIO $ do - updateState preferredState $ SetDeprecatedFor pkgname deprs + Store.setDeprecatedFor preferredStore pkgname deprs runHook_ deprecatedHook (pkgname, deprs) updateDeprecatedTags @@ -301,7 +289,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } pkgIndex <- queryGetPackageIndex case PackageIndex.lookupPackageName pkgIndex (packageName pkgid) of [] -> packageError [MText "No such package in package index. ", MLink "Search for related terms instead?" $ "/packages/search?terms=" ++ (display $ pkgName pkgid)] - pkgs | pkgVersion pkgid == nullVersion -> queryState preferredState (GetPreferredInfo $ packageName pkgid) >>= \info -> do + pkgs | pkgVersion pkgid == nullVersion -> Store.getPreferredInfo preferredStore (packageName pkgid) >>= \info -> do let rangeToCheck = sumRange info case maybe id (\r -> filter (flip withinRange r . packageVersion)) rangeToCheck pkgs of -- no preferred version available, choose latest from list ordered by version @@ -324,7 +312,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } guardAuthorisedAsMaintainerOrTrustee pkgname (prefs, deprs) <- lookPrefRangeDeprecatedVersions pkgs - prefinfo <- updateState preferredState (SetPreferredInfo pkgname prefs deprs) + prefinfo <- Store.setPreferredInfo preferredStore pkgname prefs deprs runHook_ updatePreferredHook (pkgname, prefinfo { deprecatedVersions = deprs }) -- It seems they are not set updateIndexPackagePreferredVersions pkgname prefinfo where @@ -378,7 +366,7 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } where deprecatedError = errBadRequest "Deprecation failed" . return . MText doUpdates deprs = do - void $ updateState preferredState $ SetDeprecatedFor pkgname deprs + Store.setDeprecatedFor preferredStore pkgname deprs runHook_ deprecatedHook (pkgname, deprs) liftIO updateDeprecatedTags @@ -392,25 +380,25 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } doPreferredRender :: PackageName -> ServerPartE PreferredRender doPreferredRender pkgname = do guardValidPackageName pkgname - pref <- queryState preferredState $ GetPreferredInfo pkgname + pref <- Store.getPreferredInfo preferredStore pkgname return $ renderPrefInfo pref doDeprecatedRender :: PackageName -> ServerPartE (Maybe [PackageName]) doDeprecatedRender pkgname = do guardValidPackageName pkgname - queryState preferredState $ GetDeprecatedFor pkgname + Store.getDeprecatedFor preferredStore pkgname doPreferredsRender :: MonadIO m => m [(PackageName, PreferredRender)] - doPreferredsRender = queryState preferredState GetPreferredVersions >>= + doPreferredsRender = Store.getPreferredVersions preferredStore >>= return . map (second renderPrefInfo) . Map.toList . preferredMap doDeprecatedsRender :: MonadIO m => m [(PackageName, [PackageName])] - doDeprecatedsRender = queryState preferredState GetPreferredVersions >>= + doDeprecatedsRender = Store.getPreferredVersions preferredStore >>= return . Map.toList . deprecatedMap makeGlobalPreferredVersions :: (Functor m, MonadIO m) => m String makeGlobalPreferredVersions = do - prefs <- preferredMap <$> queryState preferredState GetPreferredVersions + prefs <- preferredMap <$> Store.getPreferredVersions preferredStore return $! formatGlobalPreferredVersions (Map.toList prefs) formatSinglePreferredVersions :: PackageName -> PreferredInfo -> Maybe String @@ -437,13 +425,13 @@ versionsFeature ServerEnv{ serverVerbosity = verbosity } -- One-off complex migration ephemeralPrefsMigration = do PreferredVersions {migratedEphemeralPrefs, preferredMap} - <- queryState preferredState GetPreferredVersions + <- Store.getPreferredVersions preferredStore unless migratedEphemeralPrefs $ logTiming verbosity "preferred-versions migration" $ do sequence_ [ updateIndexPackagePreferredVersions pkgname prefinfo | (pkgname, prefinfo) <- Map.toList preferredMap ] - updateState preferredState SetMigratedEphemeralPrefs + Store.setMigratedEphemeralPrefs preferredStore {------------------------------------------------------------------------------ Some aeson auxiliary functions diff --git a/src/Distribution/Server/Features/PreferredVersions/Acid.hs b/src/Distribution/Server/Features/PreferredVersions/Acid.hs new file mode 100644 index 000000000..a96406242 --- /dev/null +++ b/src/Distribution/Server/Features/PreferredVersions/Acid.hs @@ -0,0 +1,38 @@ +module Distribution.Server.Features.PreferredVersions.Acid + ( preferredStateComponent + , acidStore + ) where + +import qualified Distribution.Server.Features.PreferredVersions.State as State +import Distribution.Server.Features.PreferredVersions.Backup +import qualified Distribution.Server.Features.PreferredVersions.Store as Store +import Distribution.Server.Framework + +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + preferredState <- preferredStateComponent False stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getPreferredInfo = \name -> queryState preferredState (State.GetPreferredInfo name) + , Store.getDeprecatedFor = \name -> queryState preferredState (State.GetDeprecatedFor name) + , Store.getPreferredVersions = queryState preferredState State.GetPreferredVersions + , Store.setDeprecatedFor = \name deprs -> updateState preferredState (State.SetDeprecatedFor name deprs) + , Store.setPreferredInfo = \name ranges versions -> updateState preferredState (State.SetPreferredInfo name ranges versions) + , Store.setMigratedEphemeralPrefs = updateState preferredState State.SetMigratedEphemeralPrefs + } + , Store.backendState = [abstractAcidStateComponent preferredState] + } + +preferredStateComponent :: Bool -> FilePath -> IO (StateComponent AcidState State.PreferredVersions) +preferredStateComponent freshDB stateDir = do + st <- openLocalStateFrom (stateDir "db" "PreferredVersions") + (State.initialPreferredVersions freshDB) + return StateComponent { + stateDesc = "Preferred package versions" + , stateHandle = st + , getState = query st State.GetPreferredVersions + , putState = update st . State.ReplacePreferredVersions + , resetState = preferredStateComponent True + , backupState = \_ -> backupPreferredVersions + , restoreState = restorePreferredVersions + } diff --git a/src/Distribution/Server/Features/PreferredVersions/Store.hs b/src/Distribution/Server/Features/PreferredVersions/Store.hs new file mode 100644 index 000000000..e49450f60 --- /dev/null +++ b/src/Distribution/Server/Features/PreferredVersions/Store.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.PreferredVersions.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Package (PackageName) +import Distribution.Server.Features.PreferredVersions.State (PreferredInfo, PreferredVersions) +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Version (Version, VersionRange) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getPreferredInfo :: forall m. MonadIO m => PackageName -> m PreferredInfo + , getDeprecatedFor :: forall m. MonadIO m => PackageName -> m (Maybe [PackageName]) + , getPreferredVersions :: forall m. MonadIO m => m PreferredVersions + , setDeprecatedFor :: forall m. MonadIO m => PackageName -> Maybe [PackageName] -> m () + , setPreferredInfo :: forall m. MonadIO m => PackageName -> [VersionRange] -> [Version] -> m PreferredInfo + , setMigratedEphemeralPrefs :: forall m. MonadIO m => m () + } diff --git a/src/Distribution/Server/Features/Search.hs b/src/Distribution/Server/Features/Search.hs index 9bae0e2f3..6d57f9513 100644 --- a/src/Distribution/Server/Features/Search.hs +++ b/src/Distribution/Server/Features/Search.hs @@ -12,7 +12,6 @@ import Distribution.Server.Features.PackageList import Distribution.Server.Features.Search.PkgSearch import qualified Distribution.Server.Features.Search.SearchEngine as SearchEngine -import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Packages.Types @@ -102,12 +101,11 @@ searchFeature ServerEnv{serverBaseURI} CoreFeature{..} ListFeature{getAllLists} getSearchDoc = flattenPackageDescription . pkgDesc postInit = do - pkgindex <- queryGetPackageIndex + latestPackages <- queryLatestPackages pkgdownloads <- getDownloadCounts let pkgs = [ (getSearchDoc pkgLatestVer, pkgdownloads pkgname) - | pkgVers <- PackageIndex.allPackagesByName pkgindex - , let pkgLatestVer = last pkgVers - pkgname = packageName pkgLatestVer ] + | pkgLatestVer <- latestPackages + , let pkgname = packageName pkgLatestVer ] se = SearchEngine.insertDocs pkgs initialPkgSearchEngine writeMemState searchEngineState se @@ -117,8 +115,7 @@ searchFeature ServerEnv{serverBaseURI} CoreFeature{..} ListFeature{getAllLists} --TODO: update periodically for download count changes updatePackage :: PackageName -> IO () updatePackage pkgname = do - index <- queryGetPackageIndex - let pkgs = PackageIndex.lookupPackageName index pkgname + pkgs <- queryLookupPackageName pkgname case reverse pkgs of [] -> modifyMemState searchEngineState (SearchEngine.deleteDoc pkgname) diff --git a/src/Distribution/Server/Features/Security.hs b/src/Distribution/Server/Features/Security.hs index 71780d0ce..8baab97d3 100644 --- a/src/Distribution/Server/Features/Security.hs +++ b/src/Distribution/Server/Features/Security.hs @@ -13,9 +13,10 @@ import qualified Data.ByteString.Lazy.Char8 as BS.Lazy -- Hackage import Distribution.Server.Features.Core -import Distribution.Server.Features.Security.Backup +import qualified Distribution.Server.Features.Security.Acid as Acid import Distribution.Server.Features.Security.Layout import Distribution.Server.Features.Security.ResponseContentTypes +import qualified Distribution.Server.Features.Security.Store as Store import Distribution.Server.Features.Security.State import Distribution.Server.Features.Security.FileInfo import Distribution.Server.Framework @@ -36,12 +37,13 @@ instance IsHackageFeature SecurityFeature where initSecurityFeature :: ServerEnv -> IO (CoreFeature -> IO SecurityFeature) initSecurityFeature env = do - securityState <- securityStateComponent env (serverStateDir env) + securityBackend <- Acid.acidStore env (serverStateDir env) return $ \coreFeature -> do + let securityStore = Store.backendStore securityBackend -- Update the security state whenever the main package index changes registerHook (indexUpdatedHook coreFeature) $ \_ -> - updateIndexFileInfo coreFeature securityState + updateIndexFileInfo coreFeature securityStore -- Add package metadata whenever a package is added/changed -- @@ -78,7 +80,7 @@ initSecurityFeature env = do loginfo maxBound (mconcat ["TUF preIndexUpdateHook invoked (", msg, ", n = ", show (length ents), ")"]) return ents - return $ securityFeature env securityState + return $ securityFeature env securityBackend where indexEntriesFor :: PkgInfo -> [TarIndexEntry] indexEntriesFor pkgInfo = @@ -98,17 +100,17 @@ initSecurityFeature env = do -- Note that even once we have author signing, per-package targets.json file -- do not get their own resource, but are instead recorded in the tarball. securityFeature :: ServerEnv - -> StateComponent AcidState SecurityState + -> Store.Backend -> SecurityFeature -securityFeature env securityState = +securityFeature env Store.Backend{backendStore = securityStore, backendState = securityStateComponents} = SecurityFeature{..} where securityFeatureInterface = (emptyHackageFeature "security") { featureDesc = "TUF Security" - , featureState = [abstractAcidStateComponent securityState] - , featureReloadFiles = updateRootMirrorsAndKeys env securityState - , featurePostInit = updateRootMirrorsAndKeys env securityState - >> setupResignCronJob env securityState + , featureState = securityStateComponents + , featureReloadFiles = updateRootMirrorsAndKeys env securityStore + , featurePostInit = updateRootMirrorsAndKeys env securityStore + >> setupResignCronJob env securityStore , featureResources = [ resourceTimestamp , resourceSnapshot @@ -139,7 +141,7 @@ securityFeature env securityState = -> DynamicPath -> ServerPartE Response serveFromState file _ = do - msfiles <- queryState securityState GetSecurityFiles + msfiles <- Store.getSecurityFiles securityStore case msfiles of Nothing -> errNotFound "Security files not available" [MText $ "The repository is not currently using TUF " @@ -156,48 +158,28 @@ securityFeature env securityState = enableRange return $ toResponse tufFile -securityStateComponent :: ServerEnv - -> FilePath - -> IO (StateComponent AcidState SecurityState) -securityStateComponent env stateDir = do - let stateFile = stateDir "db" "TUF" - st <- logTiming (serverVerbosity env) "Loaded SecurityState" $ - openLocalStateFrom stateFile initialSecurityState - return StateComponent { - stateDesc = "TUF specific state" - , stateHandle = st - , getState = query st GetSecurityState - , putState = update st . ReplaceSecurityState - , resetState = securityStateComponent env - , backupState = \_ -> securityBackup - , restoreState = securityRestore - } - updateIndexFileInfo :: CoreFeature - -> StateComponent AcidState SecurityState + -> Store.Store -> IO () -updateIndexFileInfo coreFeature securityState = do +updateIndexFileInfo coreFeature securityStore = do IndexTarballInfo{..} <- queryGetIndexTarballInfo coreFeature let !tarGzFileInfo = fileInfo indexTarballIncremGz !tarFileInfo = fileInfo indexTarballIncremUn now <- getCurrentTime - updateState securityState (SetTarGzFileInfo tarGzFileInfo tarFileInfo now) + Store.setTarGzFileInfo securityStore tarGzFileInfo tarFileInfo now updateRootMirrorsAndKeys :: ServerEnv - -> StateComponent AcidState SecurityState + -> Store.Store -> IO () -updateRootMirrorsAndKeys env securityState = do +updateRootMirrorsAndKeys env securityStore = do mbRootMirrorsAndKeys <- loadRootMirrorsAndKeys env - st <- queryState securityState GetSecurityState + st <- Store.getSecurityState securityStore case mbRootMirrorsAndKeys of Just (root, mirrors, snapshotKey, timestampKey) | anyChange st root mirrors snapshotKey timestampKey -> do loginfo (serverVerbosity env) "Security files changed, updating" now <- getCurrentTime - updateState securityState (SetRootMirrorsAndKeys - root mirrors - snapshotKey timestampKey - now) + Store.setRootMirrorsAndKeys securityStore root mirrors snapshotKey timestampKey now _ -> loginfo (serverVerbosity env) "Security files unchanged" where anyChange SecurityState{ securityStateFiles = Nothing } _ _ _ _ = True @@ -227,16 +209,16 @@ loadRootMirrorsAndKeys env = do return (Just (root, mirrors, snapshotKey, timestampKey)) setupResignCronJob :: ServerEnv - -> StateComponent AcidState SecurityState + -> Store.Store -> IO () -setupResignCronJob env securityState = +setupResignCronJob env securityStore = addCronJob (serverCron env) CronJob { cronJobName = "Resign TUF data" , cronJobFrequency = DailyJobFrequency , cronJobOneShot = False , cronJobAction = do now <- getCurrentTime - updateState securityState (ResignSnapshotAndTimestamp maxAge now) + Store.resignSnapshotAndTimestamp securityStore maxAge now } where maxAge = 60 * 60 * 23 -- Don't resign if unchanged and younger than ~1 day diff --git a/src/Distribution/Server/Features/Security/Acid.hs b/src/Distribution/Server/Features/Security/Acid.hs new file mode 100644 index 000000000..37f4140e2 --- /dev/null +++ b/src/Distribution/Server/Features/Security/Acid.hs @@ -0,0 +1,43 @@ +module Distribution.Server.Features.Security.Acid + ( securityStateComponent + , acidStore + ) where + +import qualified Distribution.Server.Features.Security.State as State +import Distribution.Server.Features.Security.Backup (securityBackup, securityRestore) +import qualified Distribution.Server.Features.Security.Store as Store +import Distribution.Server.Framework + +acidStore :: ServerEnv -> FilePath -> IO Store.Backend +acidStore env stateDir = do + securityState <- securityStateComponent env stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getSecurityState = queryState securityState State.GetSecurityState + , Store.getSecurityFiles = queryState securityState State.GetSecurityFiles + , Store.setRootMirrorsAndKeys = \root mirrors snapshotKey timestampKey now -> + updateState securityState (State.SetRootMirrorsAndKeys root mirrors snapshotKey timestampKey now) + , Store.setTarGzFileInfo = \tarGzInfo tarInfo now -> + updateState securityState (State.SetTarGzFileInfo tarGzInfo tarInfo now) + , Store.resignSnapshotAndTimestamp = \maxAge now -> + updateState securityState (State.ResignSnapshotAndTimestamp maxAge now) + } + , Store.backendState = [abstractAcidStateComponent securityState] + } + +securityStateComponent :: ServerEnv + -> FilePath + -> IO (StateComponent AcidState State.SecurityState) +securityStateComponent env stateDir = do + let stateFile = stateDir "db" "TUF" + st <- logTiming (serverVerbosity env) "Loaded SecurityState" $ + openLocalStateFrom stateFile State.initialSecurityState + return StateComponent { + stateDesc = "TUF specific state" + , stateHandle = st + , getState = query st State.GetSecurityState + , putState = update st . State.ReplaceSecurityState + , resetState = securityStateComponent env + , backupState = \_ -> securityBackup + , restoreState = securityRestore + } diff --git a/src/Distribution/Server/Features/Security/Migration.hs b/src/Distribution/Server/Features/Security/Migration.hs index c30fe525b..b612c44ef 100644 --- a/src/Distribution/Server/Features/Security/Migration.hs +++ b/src/Distribution/Server/Features/Security/Migration.hs @@ -25,7 +25,6 @@ import Distribution.Package (PackageId) -- hackage import Distribution.Server.Features.Core.State -import Distribution.Server.Features.PackageCandidates.State import Distribution.Server.Features.PackageCandidates.Types import Distribution.Server.Features.Security.Layout import Distribution.Server.Framework hiding (Length) @@ -68,15 +67,15 @@ migratePkgTarball_v1_to_v2 env@ServerEnv{ serverVerbosity = verbosity } -- | Similar migration for candidates migrateCandidatePkgTarball_v1_to_v2 :: ServerEnv - -> StateComponent AcidState CandidatePackages + -> PackageIndex.PackageIndex CandPkgInfo + -> (PackageId -> PkgInfo -> IO ()) -> IO () migrateCandidatePkgTarball_v1_to_v2 env@ServerEnv{ serverVerbosity = verbosity } - candidatesState + candidateIndex updatePackage = do precomputedHashes <- readPrecomputedHashes env - CandidatePackages{candidateList} <- queryState candidatesState GetCandidatePackages - let allCandidates = PackageIndex.allPackages candidateList - partitionSz = PackageIndex.numPackageVersions candidateList `div` 10 + let allCandidates = PackageIndex.allPackages candidateIndex + partitionSz = PackageIndex.numPackageVersions candidateIndex `div` 10 partitioned = partition partitionSz allCandidates stats <- forM (zip [1..] partitioned) $ \(i, candidates) -> do let pkgs = map candPkgInfo candidates @@ -84,12 +83,6 @@ migrateCandidatePkgTarball_v1_to_v2 env@ServerEnv{ serverVerbosity = verbosity } migratePkgs env updatePackage precomputedHashes pkgs loginfo verbosity $ prettyMigrationStats (mconcat stats) where - updatePackage :: PackageId -> PkgInfo -> IO () - updatePackage pkgId pkgInfo = do - _didUpdate <- updateState candidatesState $ - UpdateCandidatePkgInfo pkgId pkgInfo - return () - partitionLogMsg :: Int -> Int -> String partitionLogMsg i n = "Computing candidates blob info " ++ "(" ++ show i ++ "/" ++ show n ++ ")" diff --git a/src/Distribution/Server/Features/Security/Store.hs b/src/Distribution/Server/Features/Security/Store.hs new file mode 100644 index 000000000..fc4a02984 --- /dev/null +++ b/src/Distribution/Server/Features/Security/Store.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Security.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Features.Security.FileInfo (FileInfo) +import Distribution.Server.Features.Security.ResponseContentTypes (Mirrors, Root) +import Distribution.Server.Features.Security.State (SecurityState, SecurityStateFiles) +import Distribution.Server.Framework (AbstractStateComponent) + +import Control.Monad.Trans (MonadIO) +import Data.Time (UTCTime) +import Hackage.Security.Util.Some (Some) +import qualified Hackage.Security.Server as Sec + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getSecurityState :: forall m. MonadIO m => m SecurityState + , getSecurityFiles :: forall m. MonadIO m => m (Maybe SecurityStateFiles) + , setRootMirrorsAndKeys :: forall m. MonadIO m => Root -> Mirrors -> Some Sec.Key -> Some Sec.Key -> UTCTime -> m () + , setTarGzFileInfo :: forall m. MonadIO m => FileInfo -> FileInfo -> UTCTime -> m () + , resignSnapshotAndTimestamp :: forall m. MonadIO m => Int -> UTCTime -> m () + } diff --git a/src/Distribution/Server/Features/Tags.hs b/src/Distribution/Server/Features/Tags.hs index 09b4723e8..b9a6fa112 100644 --- a/src/Distribution/Server/Features/Tags.hs +++ b/src/Distribution/Server/Features/Tags.hs @@ -10,11 +10,11 @@ module Distribution.Server.Features.Tags ( ) where import Distribution.Server.Framework -import Distribution.Server.Framework.BackupDump import Distribution.Server.Features.Tags.Types -import qualified Distribution.Server.Features.Tags.State as Acid -import Distribution.Server.Features.Tags.Backup +import qualified Distribution.Server.Features.Tags.Acid as Acid +import qualified Distribution.Server.Features.Tags.Store as Store +import qualified Distribution.Server.Features.Tags.State as State import Distribution.Server.Features.Core import Distribution.Server.Features.Upload import Distribution.Server.Features.Users @@ -95,14 +95,14 @@ initTagsFeature :: ServerEnv -> UserFeature -> IO TagsFeature) initTagsFeature ServerEnv{serverStateDir} = do - tagsState <- tagsStateComponent serverStateDir - tagAlias <- tagsAliasComponent serverStateDir - specials <- newMemStateWHNF Acid.emptyPackageTags + tagsBackend <- Acid.acidStore serverStateDir + let tagsStore = Store.backendStore tagsBackend + specials <- newMemStateWHNF State.emptyPackageTags updateTag <- newHook tagProposalLog <- newMemStateWHNF Map.empty return $ \core@CoreFeature{..} upload user -> do - let feature = tagsFeature core upload user tagsState tagAlias specials updateTag tagProposalLog + let feature = tagsFeature core upload user tagsBackend specials updateTag tagProposalLog registerHookJust packageChangeHook isPackageChangeAny $ \(pkgid, mpkginfo) -> case mpkginfo of @@ -110,55 +110,27 @@ initTagsFeature ServerEnv{serverStateDir} = do Just pkginfo -> do let pkgname = packageName pkgid itags = constructImmutableTags . pkgDesc $ pkginfo - curtags <- queryState tagsState $ Acid.TagsForPackage pkgname - aliases <- mapM (queryState tagAlias . Acid.GetTagAlias) (itags ++ Set.toList curtags) + curtags <- Store.getTagsForPackage tagsStore pkgname + aliases <- mapM (Store.getTagAlias tagsStore) (itags ++ Set.toList curtags) let newtags = Set.fromList aliases - updateState tagsState . Acid.SetPackageTags pkgname $ newtags + Store.setPackageTags tagsStore pkgname newtags runHook_ updateTag (Set.singleton pkgname, newtags) return feature -tagsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PackageTags) -tagsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Tags" "Existing") Acid.initialPackageTags - return StateComponent { - stateDesc = "Package tags" - , stateHandle = st - , getState = query st Acid.GetPackageTags - , putState = update st . Acid.ReplacePackageTags - , backupState = \_ pkgTags -> [csvToBackup ["tags.csv"] $ tagsToCSV pkgTags] - , restoreState = tagsBackup - , resetState = tagsStateComponent - } - -tagsAliasComponent :: FilePath -> IO (StateComponent AcidState Acid.TagAlias) -tagsAliasComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Tags" "Alias") Acid.emptyTagAlias - return StateComponent { - stateDesc = "Tags Alias" - , stateHandle = st - , getState = query st Acid.GetTagAliasesState - , putState = update st . Acid.AddTagAliasesState - , backupState = \_ aliases -> [csvToBackup ["aliases.csv"] $ aliasToCSV aliases] - , restoreState = aliasBackup - , resetState = tagsAliasComponent - } - tagsFeature :: CoreFeature -> UploadFeature -> UserFeature - -> StateComponent AcidState Acid.PackageTags - -> StateComponent AcidState Acid.TagAlias - -> MemState Acid.PackageTags + -> Store.Backend + -> MemState State.PackageTags -> Hook (Set PackageName, Set Tag) () -> MemState (Map PackageName (Set Tag, Set Tag)) -> TagsFeature -tagsFeature CoreFeature{ queryGetPackageIndex } +tagsFeature CoreFeature{ queryLatestPackages } UploadFeature{ maintainersGroup, trusteesGroup } UserFeature{ guardAuthorised' } - tagsState - tagsAlias + Store.Backend{backendStore = tagsStore, backendState} calculatedTags tagsUpdated tagProposalLog @@ -189,7 +161,7 @@ tagsFeature CoreFeature{ queryGetPackageIndex } , packageTagsListing ] , featurePostInit = initImmutableTags - , featureState = [abstractAcidStateComponent tagsState] + , featureState = backendState , featureCaches = [ CacheComponent { cacheDesc = "calculated tags", @@ -200,63 +172,64 @@ tagsFeature CoreFeature{ queryGetPackageIndex } initImmutableTags :: IO () initImmutableTags = do - index <- queryGetPackageIndex - let calcTags = Acid.tagPackages $ constructImmutableTagIndex index - aliases <- mapM (queryState tagsAlias . Acid.GetTagAlias) $ Map.keys calcTags + latestPackages <- queryLatestPackages + let calcTags = State.tagPackages $ constructImmutableTagIndex latestPackages + aliases <- mapM (Store.getTagAlias tagsStore) $ Map.keys calcTags let calcTags' = Map.toList . Map.fromListWith Set.union $ zip aliases (Map.elems calcTags) forM_ calcTags' $ uncurry setCalculatedTag queryGetTagList :: MonadIO m => m [(Tag, Set PackageName)] - queryGetTagList = queryState tagsState Acid.GetTagList + queryGetTagList = Store.getTagList tagsStore queryTagsForPackage :: MonadIO m => PackageName -> m (Set Tag) - queryTagsForPackage pkgname = queryState tagsState (Acid.TagsForPackage pkgname) + queryTagsForPackage = Store.getTagsForPackage tagsStore queryAliasForTag :: MonadIO m => Tag -> m Tag - queryAliasForTag tag = queryState tagsAlias (Acid.GetTagAlias tag) + queryAliasForTag = Store.getTagAlias tagsStore queryReviewTagsForPackage :: MonadIO m => PackageName -> m (Set Tag,Set Tag) - queryReviewTagsForPackage pkgname = queryState tagsState (Acid.LookupReviewTags pkgname) + queryReviewTagsForPackage = Store.getReviewTagsForPackage tagsStore setCalculatedTag :: Tag -> Set PackageName -> IO () setCalculatedTag tag pkgs = do - modifyMemState calculatedTags (Acid.setTag tag pkgs) - void $ updateState tagsState $ Acid.SetTagPackages tag pkgs + modifyMemState calculatedTags (State.setTag tag pkgs) + Store.setTagPackages tagsStore tag pkgs runHook_ tagsUpdated (pkgs, Set.singleton tag) withTagPath :: DynamicPath -> (Tag -> Set PackageName -> ServerPartE a) -> ServerPartE a withTagPath dpath func = case simpleParse =<< lookup "tag" dpath of Nothing -> mzero Just tag -> do - pkgs <- queryState tagsState $ Acid.PackagesForTag tag + pkgs <- Store.getPackagesForTag tagsStore tag func tag pkgs collectTags :: MonadIO m => Set PackageName -> m (Map PackageName (Set Tag)) collectTags pkgs = do - pkgMap <- liftM Acid.packageTags $ queryState tagsState Acid.GetPackageTags + pkgMap <- liftM State.packageTags $ Store.getPackageTags tagsStore return $ Map.fromDistinctAscList . map (\pkg -> (pkg, Map.findWithDefault Set.empty pkg pkgMap)) $ Set.toList pkgs mergeTags :: Maybe String -> Tag -> ServerPartE () mergeTags targetTag deprTag = case simpleParse =<< targetTag of Just (Tag orig) -> do - index <- queryGetPackageIndex - void $ updateState tagsAlias $ Acid.AddTagAlias (Tag orig) deprTag - void $ constructMergedTagIndex (Tag orig) deprTag index + latestPkgs <- queryLatestPackages + let pkgNames = packageName <$> latestPkgs + Store.addTagAlias tagsStore (Tag orig) deprTag + void $ constructMergedTagIndex (Tag orig) deprTag pkgNames _ -> errBadRequest "Tag not recognised" [MText "Couldn't parse tag. It should be a single tag."] -- tags on merging - constructMergedTagIndex :: forall m. (Functor m, MonadIO m) => Tag -> Tag -> PackageIndex PkgInfo -> m Acid.PackageTags - constructMergedTagIndex orig depr = foldM addToTags Acid.emptyPackageTags . PackageIndex.allPackageNames + constructMergedTagIndex :: forall m. (Functor m, MonadIO m) => Tag -> Tag -> [PackageName] -> m State.PackageTags + constructMergedTagIndex orig depr = foldM addToTags State.emptyPackageTags where addToTags calcTags pn = do pkgTags <- queryTagsForPackage pn if Set.member depr pkgTags then do let newTags = Set.delete depr (Set.insert orig pkgTags) - void $ updateState tagsState $ Acid.SetPackageTags pn newTags + Store.setPackageTags tagsStore pn newTags runHook_ tagsUpdated (Set.singleton pn, newTags) - return $ Acid.setTags pn newTags calcTags - else return $ Acid.setTags pn pkgTags calcTags + return $ State.setTags pn newTags calcTags + else return $ State.setTags pn pkgTags calcTags putTags :: Maybe String -> Maybe String -> Maybe String -> Maybe String -> PackageName -> ServerPartE () putTags addns delns raddns rdelns pkgname = @@ -269,7 +242,7 @@ tagsFeature CoreFeature{ queryGetPackageIndex } if trustainer then do calcTags <- queryTagsForPackage pkgname - aliases <- mapM (queryState tagsAlias . Acid.GetTagAlias) add + aliases <- mapM (Store.getTagAlias tagsStore) add revTags <- queryReviewTagsForPackage pkgname let tagSet = (addTags `Set.union` calcTags) `Set.difference` delTags addTags = Set.fromList aliases @@ -283,18 +256,18 @@ tagsFeature CoreFeature{ queryGetPackageIndex } addRev = Set.difference (fst revTags) (Set.fromList add `Set.union` Set.fromList radd') delRev = Set.difference (snd revTags) (Set.fromList del `Set.union` Set.fromList rdel') modifyTags (a, d) = (a `Set.intersection` addRev, d `Set.intersection` delRev) - updateState tagsState $ Acid.SetPackageTags pkgname tagSet - updateState tagsState $ Acid.InsertReviewTags' pkgname addRev delRev + Store.setPackageTags tagsStore pkgname tagSet + Store.replaceReviewTags tagsStore pkgname addRev delRev modifyMemState tagProposalLog (Map.adjust modifyTags pkgname) runHook_ tagsUpdated (Set.singleton pkgname, tagSet) return () else if user then do - aliases <- mapM (queryState tagsAlias . Acid.GetTagAlias) add + aliases <- mapM (Store.getTagAlias tagsStore) add calcTags <- queryTagsForPackage pkgname let addTags = Set.fromList aliases `Set.difference` calcTags delTags = Set.fromList del `Set.intersection` calcTags - updateState tagsState $ Acid.InsertReviewTags pkgname addTags delTags + Store.insertReviewTags tagsStore pkgname addTags delTags modifyMemState tagProposalLog (Map.insertWith (<>) pkgname (addTags, delTags)) return () else errBadRequest "Authorization Error" [MText "You need to be logged in to propose tags"] @@ -302,23 +275,23 @@ tagsFeature CoreFeature{ queryGetPackageIndex } Nothing -> errBadRequest "Tags not recognized" [MText "Couldn't parse your tag list. It should be comma separated with any number of alphanumerical tags. Tags can also also have -+#*."] -- initial tags, on import -constructTagIndex :: PackageIndex PkgInfo -> Acid.PackageTags -constructTagIndex = foldl' addToTags Acid.emptyPackageTags . PackageIndex.allPackagesByName +constructTagIndex :: PackageIndex PkgInfo -> State.PackageTags +constructTagIndex = foldl' addToTags State.emptyPackageTags . PackageIndex.allPackagesByName where addToTags pkgTags pkgList = let info = pkgDesc $ last pkgList pkgname = packageName info categoryTags = Set.fromList . constructCategoryTags . packageDescription $ info immutableTags = Set.fromList . constructImmutableTags $ info - in Acid.setTags pkgname (Set.union categoryTags immutableTags) pkgTags + in State.setTags pkgname (Set.union categoryTags immutableTags) pkgTags -- tags on startup -constructImmutableTagIndex :: PackageIndex PkgInfo -> Acid.PackageTags -constructImmutableTagIndex = foldl' addToTags Acid.emptyPackageTags . PackageIndex.allPackagesByName - where addToTags calcTags pkgList = - let info = pkgDesc $ last pkgList +constructImmutableTagIndex :: [PkgInfo] -> State.PackageTags +constructImmutableTagIndex = foldl' addToTags State.emptyPackageTags + where addToTags calcTags pkg = + let info = pkgDesc pkg !pn = packageName info !tags = constructImmutableTags info - in Acid.setTags pn (Set.fromList tags) calcTags + in State.setTags pn (Set.fromList tags) calcTags -- These are constructed when a package is uploaded/on startup constructCategoryTags :: PackageDescription -> [Tag] diff --git a/src/Distribution/Server/Features/Tags/Acid.hs b/src/Distribution/Server/Features/Tags/Acid.hs new file mode 100644 index 000000000..14995306a --- /dev/null +++ b/src/Distribution/Server/Features/Tags/Acid.hs @@ -0,0 +1,60 @@ +module Distribution.Server.Features.Tags.Acid + ( tagsStateComponent + , tagsAliasComponent + , acidStore + ) where + +import qualified Distribution.Server.Features.Tags.State as State +import qualified Distribution.Server.Features.Tags.Store as Store +import Distribution.Server.Features.Tags.Backup +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump + +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + tagsState <- tagsStateComponent stateDir + tagAlias <- tagsAliasComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getTagList = queryState tagsState State.GetTagList + , Store.getTagsForPackage = \pkgname -> queryState tagsState (State.TagsForPackage pkgname) + , Store.getReviewTagsForPackage = \pkgname -> queryState tagsState (State.LookupReviewTags pkgname) + , Store.getTagAlias = \tag -> queryState tagAlias (State.GetTagAlias tag) + , Store.getPackagesForTag = \tag -> queryState tagsState (State.PackagesForTag tag) + , Store.getPackageTags = queryState tagsState State.GetPackageTags + , Store.setPackageTags = \pkgname tags -> updateState tagsState (State.SetPackageTags pkgname tags) + , Store.setTagPackages = \tag pkgs -> updateState tagsState (State.SetTagPackages tag pkgs) + , Store.addTagAlias = \tag alias -> updateState tagAlias (State.AddTagAlias tag alias) + , Store.insertReviewTags = \pkgname add del -> updateState tagsState (State.InsertReviewTags pkgname add del) + , Store.replaceReviewTags = \pkgname add del -> updateState tagsState (State.InsertReviewTags' pkgname add del) + } + , Store.backendState = [ abstractAcidStateComponent tagsState + , abstractAcidStateComponent tagAlias + ] + } + +tagsStateComponent :: FilePath -> IO (StateComponent AcidState State.PackageTags) +tagsStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Tags" "Existing") State.initialPackageTags + return StateComponent { + stateDesc = "Package tags" + , stateHandle = st + , getState = query st State.GetPackageTags + , putState = update st . State.ReplacePackageTags + , backupState = \_ pkgTags -> [csvToBackup ["tags.csv"] $ tagsToCSV pkgTags] + , restoreState = tagsBackup + , resetState = tagsStateComponent + } + +tagsAliasComponent :: FilePath -> IO (StateComponent AcidState State.TagAlias) +tagsAliasComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Tags" "Alias") State.emptyTagAlias + return StateComponent { + stateDesc = "Tags Alias" + , stateHandle = st + , getState = query st State.GetTagAliasesState + , putState = update st . State.AddTagAliasesState + , backupState = \_ aliases -> [csvToBackup ["aliases.csv"] $ aliasToCSV aliases] + , restoreState = aliasBackup + , resetState = tagsAliasComponent + } diff --git a/src/Distribution/Server/Features/Tags/State.hs b/src/Distribution/Server/Features/Tags/State.hs index 4f0956f8e..014bd262d 100644 --- a/src/Distribution/Server/Features/Tags/State.hs +++ b/src/Distribution/Server/Features/Tags/State.hs @@ -34,6 +34,9 @@ data PackageTags = PackageTags { data TagAlias = TagAlias (Map Tag (Set Tag)) deriving (Eq, Show) +instance MemSize TagAlias where + memSize (TagAlias aliases) = memSize1 aliases + addTagAlias :: Tag -> Tag -> Update TagAlias () addTagAlias tag alias = do TagAlias m <- get @@ -216,4 +219,3 @@ $(makeAcidic ''PackageTags ['tagsForPackage ,'lookupReviewTags ,'clearReviewTags ]) - diff --git a/src/Distribution/Server/Features/Tags/Store.hs b/src/Distribution/Server/Features/Tags/Store.hs new file mode 100644 index 000000000..d303b0668 --- /dev/null +++ b/src/Distribution/Server/Features/Tags/Store.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Tags.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Package (PackageName) +import Distribution.Server.Features.Tags.State (PackageTags) +import Distribution.Server.Features.Tags.Types (Tag) +import Distribution.Server.Framework (AbstractStateComponent) + +import Control.Monad.Trans (MonadIO) +import Data.Set (Set) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getTagList :: forall m. MonadIO m => m [(Tag, Set PackageName)] + , getTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag) + , getReviewTagsForPackage :: forall m. MonadIO m => PackageName -> m (Set Tag, Set Tag) + , getTagAlias :: forall m. MonadIO m => Tag -> m Tag + , getPackagesForTag :: forall m. MonadIO m => Tag -> m (Set PackageName) + , getPackageTags :: forall m. MonadIO m => m PackageTags + , setPackageTags :: forall m. MonadIO m => PackageName -> Set Tag -> m () + , setTagPackages :: forall m. MonadIO m => Tag -> Set PackageName -> m () + , addTagAlias :: forall m. MonadIO m => Tag -> Tag -> m () + , insertReviewTags :: forall m. MonadIO m => PackageName -> Set Tag -> Set Tag -> m () + , replaceReviewTags :: forall m. MonadIO m => PackageName -> Set Tag -> Set Tag -> m () + } diff --git a/src/Distribution/Server/Features/TarIndexCache.hs b/src/Distribution/Server/Features/TarIndexCache.hs index e075d1b8c..83bbda3a0 100644 --- a/src/Distribution/Server/Features/TarIndexCache.hs +++ b/src/Distribution/Server/Features/TarIndexCache.hs @@ -17,6 +17,8 @@ import Distribution.Server.Framework import Distribution.Server.Framework.BlobStorage import qualified Distribution.Server.Framework.BlobStorage as BlobStorage import Distribution.Server.Framework.BackupRestore +import Distribution.Server.Features.TarIndexCache.Acid (acidStore) +import qualified Distribution.Server.Features.TarIndexCache.Store as Store import qualified Distribution.Server.Features.TarIndexCache.State as Acid import Distribution.Server.Features.Users import Distribution.Server.Packages.Types @@ -45,36 +47,19 @@ initTarIndexCacheFeature :: ServerEnv -> IO (UserFeature -> IO TarIndexCacheFeature) initTarIndexCacheFeature env@ServerEnv{serverStateDir} = do - tarIndexCache <- tarIndexCacheStateComponent serverStateDir + tarIndexCacheBackend <- acidStore serverStateDir return $ \users -> do - let feature = tarIndexCacheFeature env users tarIndexCache + let feature = tarIndexCacheFeature env users tarIndexCacheBackend return feature -tarIndexCacheStateComponent :: FilePath -> IO (StateComponent AcidState Acid.TarIndexCache) -tarIndexCacheStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "TarIndexCache") Acid.initialTarIndexCache - return StateComponent { - stateDesc = "Mapping from tarball blob IDs to tarindex blob IDs" - , stateHandle = st - , getState = query st Acid.GetTarIndexCache - , putState = update st . Acid.ReplaceTarIndexCache - , resetState = tarIndexCacheStateComponent - -- We don't backup the tar indices, but reconstruct them on demand - , backupState = \_ _ -> [] - , restoreState = RestoreBackup { - restoreEntry = error "The impossible happened" - , restoreFinalize = return Acid.initialTarIndexCache - } - } - tarIndexCacheFeature :: ServerEnv -> UserFeature - -> StateComponent AcidState Acid.TarIndexCache + -> Store.Backend -> TarIndexCacheFeature tarIndexCacheFeature ServerEnv{serverBlobStore = store} UserFeature{..} - tarIndexCache = + Store.Backend{backendStore = tarIndexCache, backendState} = TarIndexCacheFeature{..} where tarIndexCacheFeatureInterface :: HackageFeature @@ -84,7 +69,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} -- (TODO: We could potentially check that if a package occurs in both -- packages then both caches point to identical tar indices, but for -- that we would need to be in IO) - , featureState = [abstractAcidStateComponent' (\_ _ -> []) tarIndexCache] + , featureState = backendState , featureResources = [ (resourceAt "/server-status/tarindices.:format") { resourceDesc = [ (GET, "Which tar indices have been generated?") @@ -99,7 +84,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} -- This is the heart of this feature cachedTarIndex :: BlobId -> IO TarIndex cachedTarIndex tarBallBlobId = do - mTarIndexBlobId <- queryState tarIndexCache (Acid.FindTarIndex tarBallBlobId) + mTarIndexBlobId <- Store.findTarIndex tarIndexCache tarBallBlobId case mTarIndexBlobId of Just tarIndexBlobId -> do serializedTarIndex <- fetch store tarIndexBlobId @@ -112,7 +97,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} Left err -> throwIO (userError err) Right tarIndex -> return tarIndex tarIndexBlobId <- add store (runPutLazy (safePut tarIndex)) - updateState tarIndexCache (Acid.SetTarIndex tarBallBlobId tarIndexBlobId) + Store.setTarIndex tarIndexCache tarBallBlobId tarIndexBlobId return tarIndex cachedPackageTarIndex :: PkgTarball -> IO TarIndex @@ -120,7 +105,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} serveTarIndicesStatus :: ServerPartE Response serveTarIndicesStatus = do - Acid.TarIndexCache state <- liftIO $ getState tarIndexCache + Acid.TarIndexCache state <- liftIO $ Store.getTarIndexCache tarIndexCache return . toResponse . toJSON . Map.toList $ state -- | With curl: @@ -131,7 +116,7 @@ tarIndexCacheFeature ServerEnv{serverBlobStore = store} guardAuthorised_ [InGroup adminGroup] -- TODO: This resets the tar indices _state_ only, we don't actually -- remove any blobs - liftIO $ putState tarIndexCache Acid.initialTarIndexCache + liftIO $ Store.replaceTarIndexCache tarIndexCache Acid.initialTarIndexCache ok $ toResponse "Ok!" -- Functions to access specific files in a tarball diff --git a/src/Distribution/Server/Features/TarIndexCache/Acid.hs b/src/Distribution/Server/Features/TarIndexCache/Acid.hs new file mode 100644 index 000000000..458424a3c --- /dev/null +++ b/src/Distribution/Server/Features/TarIndexCache/Acid.hs @@ -0,0 +1,41 @@ +module Distribution.Server.Features.TarIndexCache.Acid + ( acidStore + ) where + +import Distribution.Server.Prelude + +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore +import Distribution.Server.Features.TarIndexCache.Store +import Distribution.Server.Features.TarIndexCache.State as Acid + +acidStore :: FilePath -> IO Backend +acidStore stateDir = do + state <- tarIndexCacheStateComponent stateDir + let st = stateHandle state + pure Backend { + backendStore = Store { + getTarIndexCache = query st Acid.GetTarIndexCache + , replaceTarIndexCache = update st . Acid.ReplaceTarIndexCache + , findTarIndex = query st . Acid.FindTarIndex + , setTarIndex = \tar index -> update st (Acid.SetTarIndex tar index) + } + , backendState = [abstractAcidStateComponent' (\_ _ -> []) state] + } + +tarIndexCacheStateComponent :: FilePath -> IO (StateComponent AcidState Acid.TarIndexCache) +tarIndexCacheStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "TarIndexCache") Acid.initialTarIndexCache + return StateComponent { + stateDesc = "Mapping from tarball blob IDs to tarindex blob IDs" + , stateHandle = st + , getState = query st Acid.GetTarIndexCache + , putState = update st . Acid.ReplaceTarIndexCache + , resetState = tarIndexCacheStateComponent + -- We don't backup the tar indices, but reconstruct them on demand + , backupState = \_ _ -> [] + , restoreState = RestoreBackup { + restoreEntry = error "The impossible happened" + , restoreFinalize = return Acid.initialTarIndexCache + } + } diff --git a/src/Distribution/Server/Features/TarIndexCache/Store.hs b/src/Distribution/Server/Features/TarIndexCache/Store.hs new file mode 100644 index 000000000..7f618ef1a --- /dev/null +++ b/src/Distribution/Server/Features/TarIndexCache/Store.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.TarIndexCache.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Features.TarIndexCache.State (TarIndexCache) +import Distribution.Server.Framework.BlobStorage (BlobId) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getTarIndexCache :: IO TarIndexCache + , replaceTarIndexCache :: TarIndexCache -> IO () + , findTarIndex :: BlobId -> IO (Maybe BlobId) + , setTarIndex :: BlobId -> BlobId -> IO () + } diff --git a/src/Distribution/Server/Features/Upload.hs b/src/Distribution/Server/Features/Upload.hs index d01da0dc4..03cca15ba 100644 --- a/src/Distribution/Server/Features/Upload.hs +++ b/src/Distribution/Server/Features/Upload.hs @@ -7,15 +7,13 @@ module Distribution.Server.Features.Upload ( ) where import Distribution.Server.Framework -import Distribution.Server.Framework.BackupDump -import qualified Distribution.Server.Features.Upload.State as Acid -import Distribution.Server.Features.Upload.Backup +import qualified Distribution.Server.Features.Upload.Acid as UploadAcid +import qualified Distribution.Server.Features.Upload.Store as UploadStore import Distribution.Server.Features.Core import Distribution.Server.Features.Users -import Distribution.Server.Users.Backup import Distribution.Server.Packages.Types import qualified Distribution.Server.Users.Types as Users import qualified Distribution.Server.Users.Group as Group @@ -109,9 +107,7 @@ initUploadFeature :: ServerEnv -> IO (UserFeature -> CoreFeature -> IO UploadFeature) initUploadFeature env@ServerEnv{serverStateDir} = do -- Canonical state - trusteesState <- trusteesStateComponent serverStateDir - uploadersState <- uploadersStateComponent serverStateDir - maintainersState <- maintainersStateComponent serverStateDir + uploadBackend <- UploadAcid.acidStore serverStateDir packageUploaded <- newHook @@ -124,9 +120,10 @@ initUploadFeature env@ServerEnv{serverStateDir} = do trusteesGroupDescription, uploadersGroupDescription, maintainersGroupDescription) = uploadFeature env core user - trusteesState trusteesGroup trusteesGroupResource - uploadersState uploadersGroup uploadersGroupResource - maintainersState maintainersGroup maintainersGroupResource + uploadBackend + trusteesGroup trusteesGroupResource + uploadersGroup uploadersGroupResource + maintainersGroup maintainersGroupResource packageUploaded (trusteesGroup, trusteesGroupResource) <- @@ -145,51 +142,13 @@ initUploadFeature env@ServerEnv{serverStateDir} = do return feature -trusteesStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageTrustees) -trusteesStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "HackageTrustees") Acid.initialHackageTrustees - return StateComponent { - stateDesc = "Trustees" - , stateHandle = st - , getState = query st Acid.GetHackageTrustees - , putState = update st . Acid.ReplaceHackageTrustees . Acid.trusteeList - , backupState = \_ (Acid.HackageTrustees trustees) -> [csvToBackup ["trustees.csv"] $ groupToCSV trustees] - , restoreState = Acid.HackageTrustees <$> groupBackup ["trustees.csv"] - , resetState = trusteesStateComponent - } - -uploadersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageUploaders) -uploadersStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "HackageUploaders") Acid.initialHackageUploaders - return StateComponent { - stateDesc = "Uploaders" - , stateHandle = st - , getState = query st Acid.GetHackageUploaders - , putState = update st . Acid.ReplaceHackageUploaders . Acid.uploaderList - , backupState = \_ (Acid.HackageUploaders uploaders) -> [csvToBackup ["uploaders.csv"] $ groupToCSV uploaders] - , restoreState = Acid.HackageUploaders <$> groupBackup ["uploaders.csv"] - , resetState = uploadersStateComponent - } - -maintainersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PackageMaintainers) -maintainersStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "PackageMaintainers") Acid.initialPackageMaintainers - return StateComponent { - stateDesc = "Package maintainers" - , stateHandle = st - , getState = query st Acid.AllPackageMaintainers - , putState = update st . Acid.ReplacePackageMaintainers - , backupState = \_ (Acid.PackageMaintainers mains) -> [maintToExport mains] - , restoreState = maintainerBackup - , resetState = maintainersStateComponent - } - uploadFeature :: ServerEnv -> CoreFeature -> UserFeature - -> StateComponent AcidState Acid.HackageTrustees -> UserGroup -> GroupResource - -> StateComponent AcidState Acid.HackageUploaders -> UserGroup -> GroupResource - -> StateComponent AcidState Acid.PackageMaintainers -> (PackageName -> UserGroup) -> GroupResource + -> UploadStore.Backend + -> UserGroup -> GroupResource + -> UserGroup -> GroupResource + -> (PackageName -> UserGroup) -> GroupResource -> Hook PackageId () -> (UploadFeature, UserGroup, @@ -202,9 +161,10 @@ uploadFeature ServerEnv{serverBlobStore = store} , updateAddPackage } UserFeature{..} - trusteesState trusteesGroup trusteesGroupResource - uploadersState uploadersGroup uploadersGroupResource - maintainersState maintainersGroup maintainersGroupResource + UploadStore.Backend{backendStore = uploadStore, backendState = uploadStateComponents} + trusteesGroup trusteesGroupResource + uploadersGroup uploadersGroupResource + maintainersGroup maintainersGroupResource packageUploaded = ( UploadFeature {..} , trusteesGroupDescription, uploadersGroupDescription, maintainersGroupDescription) @@ -220,11 +180,7 @@ uploadFeature ServerEnv{serverBlobStore = store} , groupResource uploadersGroupResource , groupUserResource uploadersGroupResource ] - , featureState = [ - abstractAcidStateComponent trusteesState - , abstractAcidStateComponent uploadersState - , abstractAcidStateComponent maintainersState - ] + , featureState = uploadStateComponents } uploadResource = UploadResource @@ -255,9 +211,9 @@ uploadFeature ServerEnv{serverBlobStore = store} trusteesGroupDescription :: UserGroup trusteesGroupDescription = UserGroup { groupDesc = trusteeDescription, - queryUserGroup = queryState trusteesState Acid.GetTrusteesList, - addUserToGroup = updateState trusteesState . Acid.AddHackageTrustee, - removeUserFromGroup = updateState trusteesState . Acid.RemoveHackageTrustee, + queryUserGroup = UploadStore.getTrustees uploadStore, + addUserToGroup = UploadStore.addTrustee uploadStore, + removeUserFromGroup = UploadStore.removeTrustee uploadStore, groupsAllowedToAdd = [adminGroup], groupsAllowedToDelete = [adminGroup] } @@ -265,9 +221,9 @@ uploadFeature ServerEnv{serverBlobStore = store} uploadersGroupDescription :: UserGroup uploadersGroupDescription = UserGroup { groupDesc = uploaderDescription, - queryUserGroup = queryState uploadersState Acid.GetUploadersList, - addUserToGroup = updateState uploadersState . Acid.AddHackageUploader, - removeUserFromGroup = updateState uploadersState . Acid.RemoveHackageUploader, + queryUserGroup = UploadStore.getUploaders uploadStore, + addUserToGroup = UploadStore.addUploader uploadStore, + removeUserFromGroup = UploadStore.removeUploader uploadStore, groupsAllowedToAdd = [adminGroup, trusteesGroup], groupsAllowedToDelete = [adminGroup, trusteesGroup] } @@ -277,9 +233,9 @@ uploadFeature ServerEnv{serverBlobStore = store} fix $ \thisgroup -> UserGroup { groupDesc = maintainerDescription name, - queryUserGroup = queryState maintainersState $ Acid.GetPackageMaintainers name, - addUserToGroup = updateState maintainersState . Acid.AddPackageMaintainer name, - removeUserFromGroup = updateState maintainersState . Acid.RemovePackageMaintainer name, + queryUserGroup = UploadStore.getPackageMaintainers uploadStore name, + addUserToGroup = UploadStore.addPackageMaintainer uploadStore name, + removeUserFromGroup = UploadStore.removePackageMaintainer uploadStore name, groupsAllowedToAdd = [thisgroup, adminGroup], groupsAllowedToDelete = [thisgroup, adminGroup] } diff --git a/src/Distribution/Server/Features/Upload/Acid.hs b/src/Distribution/Server/Features/Upload/Acid.hs new file mode 100644 index 000000000..ca7f175eb --- /dev/null +++ b/src/Distribution/Server/Features/Upload/Acid.hs @@ -0,0 +1,75 @@ +module Distribution.Server.Features.Upload.Acid + ( trusteesStateComponent + , uploadersStateComponent + , maintainersStateComponent + , acidStore + ) where + +import qualified Distribution.Server.Features.Upload.Store as Store +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Features.Upload.Backup (maintToExport, maintainerBackup) +import qualified Distribution.Server.Features.Upload.State as Acid +import Distribution.Server.Users.Backup + +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + trusteesState <- trusteesStateComponent stateDir + uploadersState <- uploadersStateComponent stateDir + maintainersState <- maintainersStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getTrustees = queryState trusteesState Acid.GetTrusteesList + , Store.addTrustee = updateState trusteesState . Acid.AddHackageTrustee + , Store.removeTrustee = updateState trusteesState . Acid.RemoveHackageTrustee + , Store.getUploaders = queryState uploadersState Acid.GetUploadersList + , Store.addUploader = updateState uploadersState . Acid.AddHackageUploader + , Store.removeUploader = updateState uploadersState . Acid.RemoveHackageUploader + , Store.getPackageMaintainers = \name -> queryState maintainersState (Acid.GetPackageMaintainers name) + , Store.addPackageMaintainer = \name -> updateState maintainersState . Acid.AddPackageMaintainer name + , Store.removePackageMaintainer = \name -> updateState maintainersState . Acid.RemovePackageMaintainer name + } + , Store.backendState = [ abstractAcidStateComponent trusteesState + , abstractAcidStateComponent uploadersState + , abstractAcidStateComponent maintainersState + ] + } + +trusteesStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageTrustees) +trusteesStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "HackageTrustees") Acid.initialHackageTrustees + return StateComponent { + stateDesc = "Trustees" + , stateHandle = st + , getState = query st Acid.GetHackageTrustees + , putState = update st . Acid.ReplaceHackageTrustees . Acid.trusteeList + , backupState = \_ (Acid.HackageTrustees trustees) -> [csvToBackup ["trustees.csv"] $ groupToCSV trustees] + , restoreState = Acid.HackageTrustees <$> groupBackup ["trustees.csv"] + , resetState = trusteesStateComponent + } + +uploadersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageUploaders) +uploadersStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "HackageUploaders") Acid.initialHackageUploaders + return StateComponent { + stateDesc = "Uploaders" + , stateHandle = st + , getState = query st Acid.GetHackageUploaders + , putState = update st . Acid.ReplaceHackageUploaders . Acid.uploaderList + , backupState = \_ (Acid.HackageUploaders uploaders) -> [csvToBackup ["uploaders.csv"] $ groupToCSV uploaders] + , restoreState = Acid.HackageUploaders <$> groupBackup ["uploaders.csv"] + , resetState = uploadersStateComponent + } + +maintainersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.PackageMaintainers) +maintainersStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "PackageMaintainers") Acid.initialPackageMaintainers + return StateComponent { + stateDesc = "Package maintainers" + , stateHandle = st + , getState = query st Acid.AllPackageMaintainers + , putState = update st . Acid.ReplacePackageMaintainers + , backupState = \_ (Acid.PackageMaintainers mains) -> [maintToExport mains] + , restoreState = maintainerBackup + , resetState = maintainersStateComponent + } diff --git a/src/Distribution/Server/Features/Upload/Store.hs b/src/Distribution/Server/Features/Upload/Store.hs new file mode 100644 index 000000000..bac013abb --- /dev/null +++ b/src/Distribution/Server/Features/Upload/Store.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Upload.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Group (UserIdSet) + +import Distribution.Package (PackageName) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getTrustees :: forall m. MonadIO m => m UserIdSet + , addTrustee :: forall m. MonadIO m => UserId -> m () + , removeTrustee :: forall m. MonadIO m => UserId -> m () + , getUploaders :: forall m. MonadIO m => m UserIdSet + , addUploader :: forall m. MonadIO m => UserId -> m () + , removeUploader :: forall m. MonadIO m => UserId -> m () + , getPackageMaintainers :: forall m. MonadIO m => PackageName -> m UserIdSet + , addPackageMaintainer :: forall m. MonadIO m => PackageName -> UserId -> m () + , removePackageMaintainer :: forall m. MonadIO m => PackageName -> UserId -> m () + } diff --git a/src/Distribution/Server/Features/UserDetails.hs b/src/Distribution/Server/Features/UserDetails.hs index 6d67d44c6..833c98998 100644 --- a/src/Distribution/Server/Features/UserDetails.hs +++ b/src/Distribution/Server/Features/UserDetails.hs @@ -8,11 +8,10 @@ module Distribution.Server.Features.UserDetails ( UserDetailsFeature(..), ) where -import qualified Distribution.Server.Features.UserDetails.Acid as Acid -import Distribution.Server.Features.UserDetails.Backup +import Distribution.Server.Features.UserDetails.Acid (acidStore) +import qualified Distribution.Server.Features.UserDetails.Store as Store import Distribution.Server.Features.UserDetails.Types import Distribution.Server.Framework -import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.Templating import Distribution.Server.Features.Users @@ -41,24 +40,6 @@ instance IsHackageFeature UserDetailsFeature where getFeatureInterface = userDetailsFeatureInterface ---------------------- --- State components --- - -userDetailsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.UserDetailsTable) -userDetailsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "UserDetails") Acid.emptyUserDetailsTable - return StateComponent { - stateDesc = "Extra details associated with user accounts, email addresses etc" - , stateHandle = st - , getState = query st Acid.GetUserDetailsTable - , putState = update st . Acid.ReplaceUserDetailsTable - , backupState = \backuptype users -> - [csvToBackup ["users.csv"] (userDetailsToCSV backuptype users)] - , restoreState = userDetailsBackup - , resetState = userDetailsStateComponent - } - ---------------------------------------- -- Feature definition & initialisation -- @@ -69,8 +50,7 @@ initUserDetailsFeature :: ServerEnv -> UploadFeature -> IO UserDetailsFeature) initUserDetailsFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do - -- Canonical state - usersDetailsState <- userDetailsStateComponent serverStateDir + userDetailsBackend <- acidStore serverStateDir --TODO: link up to user feature to delete @@ -80,24 +60,24 @@ initUserDetailsFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTempl [ "user-details-form.html" ] return $ \users core upload -> do - let feature = userDetailsFeature templates usersDetailsState users core upload + let feature = userDetailsFeature templates userDetailsBackend users core upload return feature userDetailsFeature :: Templates - -> StateComponent AcidState Acid.UserDetailsTable + -> Store.Backend -> UserFeature -> CoreFeature -> UploadFeature -> UserDetailsFeature -userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} UploadFeature{uploadersGroup} +userDetailsFeature templates Store.Backend{backendStore = userDetailsStore, backendState} UserFeature{..} CoreFeature{..} UploadFeature{uploadersGroup} = UserDetailsFeature {..} where userDetailsFeatureInterface = (emptyHackageFeature "user-details") { featureDesc = "Extra information about user accounts, email addresses etc." , featureResources = [userNameContactResource, userAdminInfoResource] - , featureState = [abstractAcidStateComponent userDetailsState] + , featureState = backendState , featureCaches = [] } @@ -132,11 +112,11 @@ userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} Up -- queryUserDetails :: MonadIO m => UserId -> m (Maybe AccountDetails) - queryUserDetails uid = queryState userDetailsState (Acid.LookupUserDetails uid) + queryUserDetails = Store.lookupUserDetails userDetailsStore updateUserDetails :: MonadIO m => UserId -> AccountDetails -> m () updateUserDetails uid udetails = do - updateState userDetailsState (Acid.SetUserDetails uid udetails) + Store.setUserDetails userDetailsStore uid udetails -- Request handlers -- @@ -188,14 +168,14 @@ userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} Up NameAndContact name email <- expectAesonContent guardValidLookingName name guardValidLookingEmail email - updateState userDetailsState (Acid.SetUserNameContact uid name email) + Store.setUserNameContact userDetailsStore uid name email noContent $ toResponse () handlerDeleteUserNameContact :: DynamicPath -> ServerPartE Response handlerDeleteUserNameContact dpath = do uid <- lookupUserName =<< userNameInPath dpath guardAuthorised_ [IsUserId uid, InGroup adminGroup] - updateState userDetailsState (Acid.SetUserNameContact uid T.empty T.empty) + Store.setUserNameContact userDetailsStore uid T.empty T.empty noContent $ toResponse () handlerGetAdminInfo :: DynamicPath -> ServerPartE Response @@ -217,12 +197,12 @@ userDetailsFeature templates userDetailsState UserFeature{..} CoreFeature{..} Up guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath AdminInfo akind notes <- expectAesonContent - updateState userDetailsState (Acid.SetUserAdminInfo uid akind notes) + Store.setUserAdminInfo userDetailsStore uid akind notes noContent $ toResponse () handlerDeleteAdminInfo :: DynamicPath -> ServerPartE Response handlerDeleteAdminInfo dpath = do guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath - updateState userDetailsState (Acid.SetUserAdminInfo uid Nothing T.empty) + Store.setUserAdminInfo userDetailsStore uid Nothing T.empty noContent $ toResponse () diff --git a/src/Distribution/Server/Features/UserDetails/Acid.hs b/src/Distribution/Server/Features/UserDetails/Acid.hs index 9d218805f..c4d113cc2 100644 --- a/src/Distribution/Server/Features/UserDetails/Acid.hs +++ b/src/Distribution/Server/Features/UserDetails/Acid.hs @@ -1,86 +1,28 @@ -{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, - NamedFieldPuns, RecordWildCards #-} -module Distribution.Server.Features.UserDetails.Acid where +{-# LANGUAGE TemplateHaskell, TypeFamilies #-} -import Distribution.Server.Features.UserDetails.Types -import Distribution.Server.Framework - -import Distribution.Server.Users.Types - -import Data.SafeCopy (base, deriveSafeCopy) - -import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap -import Data.Text (Text) -import qualified Data.Text as T - -import Control.Monad.Reader (ask) -import Control.Monad.State (get, put) - - -------------------------- --- Types of stored data --- - -newtype UserDetailsTable = UserDetailsTable (IntMap AccountDetails) - deriving (Eq, Show) - -emptyAccountDetails :: AccountDetails -emptyAccountDetails = AccountDetails T.empty T.empty Nothing T.empty - -emptyUserDetailsTable :: UserDetailsTable -emptyUserDetailsTable = UserDetailsTable IntMap.empty - -$(deriveSafeCopy 0 'base ''UserDetailsTable) - -instance MemSize UserDetailsTable where - memSize (UserDetailsTable a) = memSize1 a +module Distribution.Server.Features.UserDetails.Acid + ( acidStore + ) where +import Distribution.Server.Features.UserDetails.State +import qualified Distribution.Server.Features.UserDetails.Store as Store +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Features.UserDetails.Backup ------------------------------ --- State queries and updates +-- Acid event types -- -getUserDetailsTable :: Query UserDetailsTable UserDetailsTable -getUserDetailsTable = ask - -replaceUserDetailsTable :: UserDetailsTable -> Update UserDetailsTable () -replaceUserDetailsTable = put - -lookupUserDetails :: UserId -> Query UserDetailsTable (Maybe AccountDetails) -lookupUserDetails (UserId uid) = do - UserDetailsTable tbl <- ask - return $! IntMap.lookup uid tbl - -setUserDetails :: UserId -> AccountDetails -> Update UserDetailsTable () -setUserDetails (UserId uid) udetails = do - UserDetailsTable tbl <- get - put $! UserDetailsTable (IntMap.insert uid udetails tbl) - -deleteUserDetails :: UserId -> Update UserDetailsTable Bool -deleteUserDetails (UserId uid) = do - UserDetailsTable tbl <- get - if IntMap.member uid tbl - then do put $! UserDetailsTable (IntMap.delete uid tbl) - return True - else return False - -setUserNameContact :: UserId -> Text -> Text -> Update UserDetailsTable () -setUserNameContact (UserId uid) name email = do - UserDetailsTable tbl <- get - put $! UserDetailsTable (IntMap.alter upd uid tbl) - where - upd Nothing = Just emptyAccountDetails { accountName = name, accountContactEmail = email } - upd (Just udetails) = Just udetails { accountName = name, accountContactEmail = email } - -setUserAdminInfo :: UserId -> Maybe AccountKind -> Text -> Update UserDetailsTable () -setUserAdminInfo (UserId uid) akind notes = do - UserDetailsTable tbl <- get - put $! UserDetailsTable (IntMap.alter upd uid tbl) - where - upd Nothing = Just emptyAccountDetails { accountKind = akind, accountAdminNotes = notes } - upd (Just udetails) = Just udetails { accountKind = akind, accountAdminNotes = notes } - +-- This splice generates an orphan IsAcidic UserDetailsTable instance: +-- IsAcidic comes from acid-state, and UserDetailsTable is defined in +-- State. +-- +-- makeAcidic generates the instance together with the event +-- types. The serialized event tags of the event types depend on the +-- name of the module where the splice is run, so for simplicity we +-- continue to run the splice here, despite UserDetailsTable no longer +-- being defined here. makeAcidic ''UserDetailsTable [ --queries 'getUserDetailsTable, @@ -94,3 +36,33 @@ makeAcidic ''UserDetailsTable [ ] +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + userDetailsState <- userDetailsStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.lookupUserDetails = \uid -> queryState userDetailsState (LookupUserDetails uid) + , Store.setUserDetails = \uid details -> updateState userDetailsState (SetUserDetails uid details) + , Store.setUserNameContact = \uid name email -> updateState userDetailsState (SetUserNameContact uid name email) + , Store.setUserAdminInfo = \uid kind notes -> updateState userDetailsState (SetUserAdminInfo uid kind notes) + } + , Store.backendState = [abstractAcidStateComponent userDetailsState] + } + +--------------------- +-- State components +-- + +userDetailsStateComponent :: FilePath -> IO (StateComponent AcidState UserDetailsTable) +userDetailsStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "UserDetails") emptyUserDetailsTable + return StateComponent { + stateDesc = "Extra details associated with user accounts, email addresses etc" + , stateHandle = st + , getState = query st GetUserDetailsTable + , putState = update st . ReplaceUserDetailsTable + , backupState = \backuptype users -> + [csvToBackup ["users.csv"] (userDetailsToCSV backuptype users)] + , restoreState = userDetailsBackup + , resetState = userDetailsStateComponent + } diff --git a/src/Distribution/Server/Features/UserDetails/Backup.hs b/src/Distribution/Server/Features/UserDetails/Backup.hs index d759fce78..4d6484823 100644 --- a/src/Distribution/Server/Features/UserDetails/Backup.hs +++ b/src/Distribution/Server/Features/UserDetails/Backup.hs @@ -1,6 +1,6 @@ module Distribution.Server.Features.UserDetails.Backup where -import qualified Distribution.Server.Features.UserDetails.Acid as Acid +import qualified Distribution.Server.Features.UserDetails.State as State import Distribution.Server.Features.UserDetails.Types import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.BackupRestore @@ -18,10 +18,10 @@ import Text.CSV (CSV, Record) -- Data backup and restore -- -userDetailsBackup :: RestoreBackup Acid.UserDetailsTable -userDetailsBackup = updateUserBackup Acid.emptyUserDetailsTable +userDetailsBackup :: RestoreBackup State.UserDetailsTable +userDetailsBackup = updateUserBackup State.emptyUserDetailsTable -updateUserBackup :: Acid.UserDetailsTable -> RestoreBackup Acid.UserDetailsTable +updateUserBackup :: State.UserDetailsTable -> RestoreBackup State.UserDetailsTable updateUserBackup users = RestoreBackup { restoreEntry = \entry -> case entry of BackupByteString ["users.csv"] bs -> do @@ -34,11 +34,11 @@ updateUserBackup users = RestoreBackup { return users } -importUserDetails :: CSV -> Acid.UserDetailsTable -> Restore Acid.UserDetailsTable +importUserDetails :: CSV -> State.UserDetailsTable -> Restore State.UserDetailsTable importUserDetails = concatM . map fromRecord . drop 2 where - fromRecord :: Record -> Acid.UserDetailsTable -> Restore Acid.UserDetailsTable - fromRecord [idStr, nameStr, emailStr, kindStr, notesStr] (Acid.UserDetailsTable tbl) = do + fromRecord :: Record -> State.UserDetailsTable -> Restore State.UserDetailsTable + fromRecord [idStr, nameStr, emailStr, kindStr, notesStr] (State.UserDetailsTable tbl) = do UserId uid <- parseText "user id" idStr akind <- parseKind kindStr let udetails = AccountDetails { @@ -47,7 +47,7 @@ importUserDetails = concatM . map fromRecord . drop 2 accountKind = akind, accountAdminNotes = T.pack notesStr } - return $! Acid.UserDetailsTable (IntMap.insert uid udetails tbl) + return $! State.UserDetailsTable (IntMap.insert uid udetails tbl) fromRecord x _ = fail $ "Error processing user details record: " ++ show x @@ -56,8 +56,8 @@ importUserDetails = concatM . map fromRecord . drop 2 parseKind "special" = return (Just AccountKindSpecial) parseKind sts = fail $ "unable to parse account kind: " ++ sts -userDetailsToCSV :: BackupType -> Acid.UserDetailsTable -> CSV -userDetailsToCSV backuptype (Acid.UserDetailsTable tbl) +userDetailsToCSV :: BackupType -> State.UserDetailsTable -> CSV +userDetailsToCSV backuptype (State.UserDetailsTable tbl) = ([showVersion userCSVVer]:) $ (userdetailsCSVKey:) $ diff --git a/src/Distribution/Server/Features/UserDetails/State.hs b/src/Distribution/Server/Features/UserDetails/State.hs new file mode 100644 index 000000000..e5bbfe49a --- /dev/null +++ b/src/Distribution/Server/Features/UserDetails/State.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} + +module Distribution.Server.Features.UserDetails.State where + +import Distribution.Server.Features.UserDetails.Types +import Distribution.Server.Users.Types + +import Data.SafeCopy (base, deriveSafeCopy) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import qualified Data.Text as T +import Data.Text (Text) + +import Control.Monad.Reader (ask) +import Control.Monad.State (get, put) + +import Distribution.Server.Framework + +------------------------- +-- Types of stored data +-- + +newtype UserDetailsTable = UserDetailsTable (IntMap AccountDetails) + deriving (Eq, Show) + +emptyAccountDetails :: AccountDetails +emptyAccountDetails = AccountDetails T.empty T.empty Nothing T.empty + +emptyUserDetailsTable :: UserDetailsTable +emptyUserDetailsTable = UserDetailsTable IntMap.empty + +$(deriveSafeCopy 0 'base ''UserDetailsTable) + +instance MemSize UserDetailsTable where + memSize (UserDetailsTable a) = memSize1 a + + +------------------------------ +-- State queries and updates +-- + +getUserDetailsTable :: Query UserDetailsTable UserDetailsTable +getUserDetailsTable = ask + +replaceUserDetailsTable :: UserDetailsTable -> Update UserDetailsTable () +replaceUserDetailsTable = put + +lookupUserDetails :: UserId -> Query UserDetailsTable (Maybe AccountDetails) +lookupUserDetails (UserId uid) = do + UserDetailsTable tbl <- ask + return $! IntMap.lookup uid tbl + +setUserDetails :: UserId -> AccountDetails -> Update UserDetailsTable () +setUserDetails (UserId uid) udetails = do + UserDetailsTable tbl <- get + put $! UserDetailsTable (IntMap.insert uid udetails tbl) + +deleteUserDetails :: UserId -> Update UserDetailsTable Bool +deleteUserDetails (UserId uid) = do + UserDetailsTable tbl <- get + if IntMap.member uid tbl + then do put $! UserDetailsTable (IntMap.delete uid tbl) + return True + else return False + +setUserNameContact :: UserId -> Text -> Text -> Update UserDetailsTable () +setUserNameContact (UserId uid) name email = do + UserDetailsTable tbl <- get + put $! UserDetailsTable (IntMap.alter upd uid tbl) + where + upd Nothing = Just emptyAccountDetails { accountName = name, accountContactEmail = email } + upd (Just udetails) = Just udetails { accountName = name, accountContactEmail = email } + +setUserAdminInfo :: UserId -> Maybe AccountKind -> Text -> Update UserDetailsTable () +setUserAdminInfo (UserId uid) akind notes = do + UserDetailsTable tbl <- get + put $! UserDetailsTable (IntMap.alter upd uid tbl) + where + upd Nothing = Just emptyAccountDetails { accountKind = akind, accountAdminNotes = notes } + upd (Just udetails) = Just udetails { accountKind = akind, accountAdminNotes = notes } diff --git a/src/Distribution/Server/Features/UserDetails/Store.hs b/src/Distribution/Server/Features/UserDetails/Store.hs new file mode 100644 index 000000000..9e265a06d --- /dev/null +++ b/src/Distribution/Server/Features/UserDetails/Store.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.UserDetails.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Features.UserDetails.Types +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) +import Data.Text (Text) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + lookupUserDetails :: forall m. MonadIO m => UserId -> m (Maybe AccountDetails) + , setUserDetails :: forall m. MonadIO m => UserId -> AccountDetails -> m () + , setUserNameContact :: forall m. MonadIO m => UserId -> Text -> Text -> m () + , setUserAdminInfo :: forall m. MonadIO m => UserId -> Maybe AccountKind -> Text -> m () + } diff --git a/src/Distribution/Server/Features/UserNotify.hs b/src/Distribution/Server/Features/UserNotify.hs index 9f753fc31..7370513fd 100644 --- a/src/Distribution/Server/Features/UserNotify.hs +++ b/src/Distribution/Server/Features/UserNotify.hs @@ -18,7 +18,9 @@ module Distribution.Server.Features.UserNotify ( ) where import Distribution.Server.Features.UserDetails.Types +import qualified Distribution.Server.Features.UserNotify.Acid.Component as AcidComponent import qualified Distribution.Server.Features.UserNotify.Acid as Acid +import qualified Distribution.Server.Features.UserNotify.Store as Store import Distribution.Server.Features.UserNotify.Acid (NotifyPref(..)) import Distribution.Server.Features.UserNotify.Backup import Distribution.Server.Features.UserNotify.Types @@ -36,11 +38,9 @@ import Distribution.Server.Packages.Types import qualified Distribution.Server.Packages.PackageIndex as PackageIndex import Distribution.Server.Framework -import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.Templating import Distribution.Server.Features.AdminLog -import qualified Distribution.Server.Features.AdminLog.Acid as Acid import Distribution.Server.Features.AdminLog.Types import Distribution.Server.Features.BuildReports import qualified Distribution.Server.Features.BuildReports.BuildReport as BuildReport @@ -211,20 +211,6 @@ instance ToRadioButtons OK where -- State Component -- -notifyStateComponent :: FilePath -> IO (StateComponent AcidState Acid.NotifyData) -notifyStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "UserNotify") =<< Acid.emptyNotifyData - return StateComponent { - stateDesc = "State to keep track of revision notifications" - , stateHandle = st - , getState = query st Acid.GetNotifyData - , putState = update st . Acid.ReplaceNotifyData - , backupState = \backuptype tbl -> - [csvToBackup ["notifydata.csv"] (notifyDataToCSV backuptype tbl)] - , restoreState = userNotifyBackup - , resetState = notifyStateComponent - } - ---------------------------- -- Core Feature -- @@ -243,7 +229,7 @@ initUserNotifyFeature :: ServerEnv initUserNotifyFeature ServerEnv{ serverStateDir, serverTemplatesDir, serverTemplatesMode } = do -- Canonical state - notifyState <- notifyStateComponent serverStateDir + notifyBackend <- AcidComponent.acidStore serverStateDir -- Page templates templates <- loadTemplates serverTemplatesMode @@ -253,7 +239,7 @@ initUserNotifyFeature ServerEnv{ serverStateDir, serverTemplatesDir, return $ \users core uploadfeature adminlog userdetails reports tags revers vouch -> do let feature = userNotifyFeature users core uploadfeature adminlog userdetails reports tags - revers vouch notifyState templates + revers vouch notifyBackend templates return feature data InRange = InRange | OutOfRange @@ -384,7 +370,7 @@ userNotifyFeature :: UserFeature -> TagsFeature -> ReverseFeature -> VouchFeature - -> StateComponent AcidState Acid.NotifyData + -> Store.Backend -> Templates -> UserNotifyFeature userNotifyFeature UserFeature{..} @@ -396,7 +382,8 @@ userNotifyFeature UserFeature{..} TagsFeature{..} ReverseFeature{queryReverseIndex} VouchFeature{drainQueuedNotifications} - notifyState templates + Store.Backend{backendStore = notifyStore, backendState} + templates = UserNotifyFeature {..} where @@ -404,7 +391,7 @@ userNotifyFeature UserFeature{..} userNotifyFeatureInterface = (emptyHackageFeature "user-notify") { featureDesc = "Notifications to users on metadata updates." , featureResources = [userNotifyResource] -- TODO we can add json features here for updating prefs - , featureState = [abstractAcidStateComponent notifyState] + , featureState = backendState , featureCaches = [] , featureReloadFiles = reloadTemplates templates , featurePostInit = setupNotifyCronJob @@ -428,10 +415,10 @@ userNotifyFeature UserFeature{..} -- queryGetUserNotifyPref :: MonadIO m => UserId -> m (Maybe Acid.NotifyPref) - queryGetUserNotifyPref uid = queryState notifyState (Acid.LookupNotifyPref uid) + queryGetUserNotifyPref = Store.lookupNotifyPref notifyStore updateSetUserNotifyPref :: MonadIO m => UserId -> Acid.NotifyPref -> m () - updateSetUserNotifyPref uid np = updateState notifyState (Acid.AddNotifyPref uid np) + updateSetUserNotifyPref = Store.addNotifyPref notifyStore -- Request handlers -- @@ -489,7 +476,7 @@ userNotifyFeature UserFeature{..} } notifyCronAction = do - (notifyPrefs, lastNotifyTime) <- Acid.unNotifyData <$> queryState notifyState Acid.GetNotifyData + (notifyPrefs, lastNotifyTime) <- Store.getNotificationData notifyStore now <- getCurrentTime let trimLastTime = if diffUTCTime now lastNotifyTime > (60*60*6) -- cap at 6hr then addUTCTime (negate $ (60*60*6)) now @@ -526,7 +513,7 @@ userNotifyFeature UserFeature{..} ] mapM_ sendNotifyEmailAndDelay emails - updateState notifyState (Acid.SetNotifyTime now) + Store.setNotifyTime notifyStore now collectRevisionsAndUploads earlier now = do pkgIndex <- queryGetPackageIndex @@ -536,7 +523,7 @@ userNotifyFeature UserFeature{..} return $ filter isRecent $ (PackageIndex.allPackages pkgIndex) collectAdminActions earlier now = do - aLog <- Acid.adminLog <$> queryGetAdminLog + aLog <- queryGetAdminLog let isRecent (t,_,_,_) = t > earlier && t <= now return $ filter isRecent $ aLog diff --git a/src/Distribution/Server/Features/UserNotify/Acid/Component.hs b/src/Distribution/Server/Features/UserNotify/Acid/Component.hs new file mode 100644 index 000000000..630ab15a3 --- /dev/null +++ b/src/Distribution/Server/Features/UserNotify/Acid/Component.hs @@ -0,0 +1,37 @@ +module Distribution.Server.Features.UserNotify.Acid.Component + ( notifyStateComponent + , acidStore + ) where + +import qualified Distribution.Server.Features.UserNotify.Acid as Acid +import Distribution.Server.Features.UserNotify.Backup +import qualified Distribution.Server.Features.UserNotify.Store as Store +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump + +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + notifyState <- notifyStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.lookupNotifyPref = \uid -> queryState notifyState (Acid.LookupNotifyPref uid) + , Store.addNotifyPref = \uid pref -> updateState notifyState (Acid.AddNotifyPref uid pref) + , Store.getNotificationData = Acid.unNotifyData <$> queryState notifyState Acid.GetNotifyData + , Store.setNotifyTime = \time -> updateState notifyState (Acid.SetNotifyTime time) + } + , Store.backendState = [abstractAcidStateComponent notifyState] + } + +notifyStateComponent :: FilePath -> IO (StateComponent AcidState Acid.NotifyData) +notifyStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "UserNotify") =<< Acid.emptyNotifyData + return StateComponent { + stateDesc = "State to keep track of revision notifications" + , stateHandle = st + , getState = query st Acid.GetNotifyData + , putState = update st . Acid.ReplaceNotifyData + , backupState = \backuptype tbl -> + [csvToBackup ["notifydata.csv"] (notifyDataToCSV backuptype tbl)] + , restoreState = userNotifyBackup + , resetState = notifyStateComponent + } diff --git a/src/Distribution/Server/Features/UserNotify/Store.hs b/src/Distribution/Server/Features/UserNotify/Store.hs new file mode 100644 index 000000000..131984f20 --- /dev/null +++ b/src/Distribution/Server/Features/UserNotify/Store.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.UserNotify.Store + ( Backend(..) + , Store(..) + ) where + +import qualified Distribution.Server.Features.UserNotify.Acid as Acid +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) +import Data.Map (Map) +import Data.Time (UTCTime) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + lookupNotifyPref :: forall m. MonadIO m => UserId -> m (Maybe Acid.NotifyPref) + , addNotifyPref :: forall m. MonadIO m => UserId -> Acid.NotifyPref -> m () + , getNotificationData :: forall m. MonadIO m => m (Map UserId Acid.NotifyPref, UTCTime) + , setNotifyTime :: forall m. MonadIO m => UTCTime -> m () + } diff --git a/src/Distribution/Server/Features/UserSignup.hs b/src/Distribution/Server/Features/UserSignup.hs index fb771c078..8c19f7053 100644 --- a/src/Distribution/Server/Features/UserSignup.hs +++ b/src/Distribution/Server/Features/UserSignup.hs @@ -12,12 +12,11 @@ module Distribution.Server.Features.UserSignup ( ) where import qualified Distribution.Server.Features.UserSignup.Acid as Acid -import Distribution.Server.Features.UserSignup.Backup +import qualified Distribution.Server.Features.UserSignup.Store as Store import Distribution.Server.Features.UserSignup.Types import Distribution.Server.Framework import Distribution.Server.Framework.Templating -import Distribution.Server.Framework.BackupDump import Distribution.Server.Features.Upload import Distribution.Server.Features.Users @@ -30,7 +29,6 @@ import Distribution.Server.Util.Nonce import Distribution.Server.Util.Validators import qualified Distribution.Server.Users.Users as Users -import qualified Data.Map as Map import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -90,26 +88,6 @@ instance IsHackageFeature UserSignupFeature where -- set new password -- ---------------------- --- State components --- - -signupResetStateComponent :: FilePath -> IO (StateComponent AcidState Acid.SignupResetTable) -signupResetStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "UserSignupReset") Acid.emptySignupResetTable - return StateComponent { - stateDesc = "State to keep track of outstanding requests for user signup and password resets" - , stateHandle = st - , getState = query st Acid.GetSignupResetTable - , putState = update st . Acid.ReplaceSignupResetTable - , backupState = \backuptype tbl -> - [csvToBackup ["signups.csv"] (signupInfoToCSV backuptype tbl) - ,csvToBackup ["resets.csv"] (resetInfoToCSV backuptype tbl)] - , restoreState = signupResetBackup - , resetState = signupResetStateComponent - } - - ---------------------------------------- -- Feature definition & initialisation -- @@ -122,7 +100,7 @@ initUserSignupFeature :: ServerEnv initUserSignupFeature env@ServerEnv{ serverStateDir, serverTemplatesDir, serverTemplatesMode } = do -- Canonical state - signupResetState <- signupResetStateComponent serverStateDir + signupResetBackend <- Acid.acidStore serverStateDir -- Page templates templates <- loadTemplates serverTemplatesMode @@ -135,7 +113,7 @@ initUserSignupFeature env@ServerEnv{ serverStateDir, serverTemplatesDir, return $ \users userdetails upload -> do let feature = userSignupFeature env users userdetails upload - signupResetState templates + signupResetBackend templates return feature @@ -143,15 +121,17 @@ userSignupFeature :: ServerEnv -> UserFeature -> UserDetailsFeature -> UploadFeature - -> StateComponent AcidState Acid.SignupResetTable + -> Store.Backend -> Templates -> UserSignupFeature userSignupFeature ServerEnv{serverBaseURI, serverCron} UserFeature{..} UserDetailsFeature{..} - UploadFeature{uploadersGroup} signupResetState templates + UploadFeature{uploadersGroup} signupResetBackend templates = UserSignupFeature {..} where + signupResetStore = Store.backendStore signupResetBackend + userSignupFeatureInterface = (emptyHackageFeature "user-signup-reset") { featureDesc = "Extra information about user accounts, email addresses etc." , featureResources = [signupRequestsResource, @@ -159,7 +139,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} signupRequestResource, resetRequestsResource, resetRequestResource] - , featureState = [abstractAcidStateComponent signupResetState] + , featureState = Store.backendState signupResetBackend , featureCaches = [] , featureReloadFiles = reloadTemplates templates , featurePostInit = setupExpireCronJob @@ -211,31 +191,29 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} -- queryAllSignupResetInfo :: MonadIO m => m [SignupResetInfo] - queryAllSignupResetInfo = - queryState signupResetState Acid.GetSignupResetTable - >>= \(Acid.SignupResetTable tbl) -> return (Map.elems tbl) + queryAllSignupResetInfo = Store.getSignupResetInfos signupResetStore querySignupInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo) querySignupInfo nonce = - justSignupInfo <$> queryState signupResetState (Acid.LookupSignupResetInfo nonce) + justSignupInfo <$> Store.lookupSignupResetInfo signupResetStore nonce where justSignupInfo (Just info@SignupInfo{}) = Just info justSignupInfo _ = Nothing queryResetInfo :: Nonce -> MonadIO m => m (Maybe SignupResetInfo) queryResetInfo nonce = - justResetInfo <$> queryState signupResetState (Acid.LookupSignupResetInfo nonce) + justResetInfo <$> Store.lookupSignupResetInfo signupResetStore nonce where justResetInfo (Just info@ResetInfo{}) = Just info justResetInfo _ = Nothing updateAddSignupResetInfo :: Nonce -> SignupResetInfo -> MonadIO m => m Bool updateAddSignupResetInfo nonce signupInfo = - updateState signupResetState (Acid.AddSignupResetInfo nonce signupInfo) + Store.addSignupResetInfo signupResetStore nonce signupInfo updateDeleteSignupResetInfo :: Nonce -> MonadIO m => m () updateDeleteSignupResetInfo nonce = - updateState signupResetState (Acid.DeleteSignupResetInfo nonce) + Store.deleteSignupResetInfo signupResetStore nonce -- Expiry -- @@ -247,7 +225,7 @@ userSignupFeature ServerEnv{serverBaseURI, serverCron} cronJobAction = do now <- getCurrentTime let expire = now { utctDay = addDays (-7) (utctDay now) } - updateState signupResetState (Acid.DeleteAllExpired expire) + Store.deleteExpiredResetInfos signupResetStore expire } -- Request handlers diff --git a/src/Distribution/Server/Features/UserSignup/Acid.hs b/src/Distribution/Server/Features/UserSignup/Acid.hs index cdd9badae..6ee9ec40a 100644 --- a/src/Distribution/Server/Features/UserSignup/Acid.hs +++ b/src/Distribution/Server/Features/UserSignup/Acid.hs @@ -1,35 +1,57 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -Wno-orphans #-} module Distribution.Server.Features.UserSignup.Acid where import Distribution.Server.Features.UserSignup.Types +import Distribution.Server.Features.UserSignup.State +import Distribution.Server.Features.UserSignup.Backup +import qualified Distribution.Server.Features.UserSignup.Store as Store import Distribution.Server.Framework hiding (Method) +import Distribution.Server.Framework.BackupDump import Distribution.Server.Util.Nonce -import Data.Map (Map) import qualified Data.Map as Map import Control.Monad.Reader (ask) import Control.Monad.State (get, put, modify) import Data.Acid.Compat -import Data.SafeCopy import Data.Time -------------------------- --- Types of stored data --- - -newtype SignupResetTable = SignupResetTable (Map Nonce SignupResetInfo) - deriving (Eq, Show, MemSize) - -emptySignupResetTable :: SignupResetTable -emptySignupResetTable = SignupResetTable Map.empty - -$(deriveSafeCopy 0 'base ''SignupResetTable) +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + signupResetState <- signupResetStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getSignupResetInfos = + queryState signupResetState GetSignupResetTable + >>= \(SignupResetTable tbl) -> return (Map.elems tbl) + , Store.lookupSignupResetInfo = \nonce -> queryState signupResetState (LookupSignupResetInfo nonce) + , Store.addSignupResetInfo = \nonce info -> updateState signupResetState (AddSignupResetInfo nonce info) + , Store.deleteSignupResetInfo = \nonce -> updateState signupResetState (DeleteSignupResetInfo nonce) + , Store.deleteExpiredResetInfos = \expiry -> updateState signupResetState (DeleteAllExpired expiry) + } + , Store.backendState = [abstractAcidStateComponent signupResetState] + } + +signupResetStateComponent :: FilePath -> IO (StateComponent AcidState SignupResetTable) +signupResetStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "UserSignupReset") emptySignupResetTable + return StateComponent { + stateDesc = "State to keep track of outstanding requests for user signup and password resets" + , stateHandle = st + , getState = query st GetSignupResetTable + , putState = update st . ReplaceSignupResetTable + , backupState = \backuptype tbl -> + [csvToBackup ["signups.csv"] (signupInfoToCSV backuptype tbl) + ,csvToBackup ["resets.csv"] (resetInfoToCSV backuptype tbl)] + , restoreState = signupResetBackup + , resetState = signupResetStateComponent + } ------------------------------ -- State queries and updates diff --git a/src/Distribution/Server/Features/UserSignup/Backup.hs b/src/Distribution/Server/Features/UserSignup/Backup.hs index abb20e35b..5d179a62e 100644 --- a/src/Distribution/Server/Features/UserSignup/Backup.hs +++ b/src/Distribution/Server/Features/UserSignup/Backup.hs @@ -3,7 +3,7 @@ module Distribution.Server.Features.UserSignup.Backup where import Distribution.Server.Features.UserSignup.Types -import qualified Distribution.Server.Features.UserSignup.Acid as Acid +import qualified Distribution.Server.Features.UserSignup.State as State import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.BackupRestore @@ -20,10 +20,10 @@ import Text.CSV (CSV, Record) -- Data backup and restore -- -signupResetBackup :: RestoreBackup Acid.SignupResetTable +signupResetBackup :: RestoreBackup State.SignupResetTable signupResetBackup = go [] where - go :: [(Nonce, SignupResetInfo)] -> RestoreBackup Acid.SignupResetTable + go :: [(Nonce, SignupResetInfo)] -> RestoreBackup State.SignupResetTable go st = RestoreBackup { restoreEntry = \entry -> case entry of @@ -40,7 +40,7 @@ signupResetBackup = go [] _ -> return (go st) , restoreFinalize = - return (Acid.SignupResetTable (Map.fromList st)) + return (State.SignupResetTable (Map.fromList st)) } importSignupInfo :: CSV -> Restore [(Nonce, SignupResetInfo)] @@ -59,8 +59,8 @@ importSignupInfo = mapM fromRecord . drop 2 return (nonce, signupinfo) fromRecord x = fail $ "Error processing signup info record: " ++ show x -signupInfoToCSV :: BackupType -> Acid.SignupResetTable -> CSV -signupInfoToCSV backuptype (Acid.SignupResetTable tbl) +signupInfoToCSV :: BackupType -> State.SignupResetTable -> CSV +signupInfoToCSV backuptype (State.SignupResetTable tbl) = ["0.1"] : [ "token", "username", "realname", "email", "timestamp" ] : [ [ if backuptype == FullBackup @@ -90,8 +90,8 @@ importResetInfo = mapM fromRecord . drop 2 return (nonce, signupinfo) fromRecord x = fail $ "Error processing signup info record: " ++ show x -resetInfoToCSV :: BackupType -> Acid.SignupResetTable -> CSV -resetInfoToCSV backuptype (Acid.SignupResetTable tbl) +resetInfoToCSV :: BackupType -> State.SignupResetTable -> CSV +resetInfoToCSV backuptype (State.SignupResetTable tbl) = ["0.1"] : [ "token", "userid", "timestamp" ] : [ [ if backuptype == FullBackup @@ -101,4 +101,3 @@ resetInfoToCSV backuptype (Acid.SignupResetTable tbl) , formatUTCTime nonceTimestamp ] | (nonce, ResetInfo{..}) <- Map.toList tbl ] - diff --git a/src/Distribution/Server/Features/UserSignup/State.hs b/src/Distribution/Server/Features/UserSignup/State.hs new file mode 100644 index 000000000..6a4371c2f --- /dev/null +++ b/src/Distribution/Server/Features/UserSignup/State.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell #-} + +module Distribution.Server.Features.UserSignup.State where + +import Distribution.Server.Features.UserSignup.Types +import Distribution.Server.Framework (MemSize) +import Distribution.Server.Util.Nonce (Nonce) + +import qualified Data.Map as Map +import Data.Map (Map) +import Data.SafeCopy + +------------------------- +-- Types of stored data +-- + +newtype SignupResetTable = SignupResetTable (Map Nonce SignupResetInfo) + deriving (Eq, Show, MemSize) + +emptySignupResetTable :: SignupResetTable +emptySignupResetTable = SignupResetTable Map.empty + +$(deriveSafeCopy 0 'base ''SignupResetTable) diff --git a/src/Distribution/Server/Features/UserSignup/Store.hs b/src/Distribution/Server/Features/UserSignup/Store.hs new file mode 100644 index 000000000..81ba403c1 --- /dev/null +++ b/src/Distribution/Server/Features/UserSignup/Store.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.UserSignup.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Features.UserSignup.Types (SignupResetInfo) +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Util.Nonce (Nonce) + +import Control.Monad.Trans (MonadIO) +import Data.Time (UTCTime) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getSignupResetInfos :: forall m. MonadIO m => m [SignupResetInfo] + , lookupSignupResetInfo :: forall m. MonadIO m => Nonce -> m (Maybe SignupResetInfo) + , addSignupResetInfo :: forall m. MonadIO m => Nonce -> SignupResetInfo -> m Bool + , deleteSignupResetInfo :: forall m. MonadIO m => Nonce -> m () + , deleteExpiredResetInfos :: forall m. MonadIO m => UTCTime -> m () + } diff --git a/src/Distribution/Server/Features/Users.hs b/src/Distribution/Server/Features/Users.hs index b158521a7..227098bf3 100644 --- a/src/Distribution/Server/Features/Users.hs +++ b/src/Distribution/Server/Features/Users.hs @@ -10,14 +10,13 @@ module Distribution.Server.Features.Users ( ) where import Distribution.Server.Framework -import Distribution.Server.Framework.BackupDump import Distribution.Server.Framework.Templating import qualified Distribution.Server.Framework.Auth as Auth import Distribution.Server.Users.Types -import qualified Distribution.Server.Users.State as Acid -import Distribution.Server.Users.Backup import qualified Distribution.Server.Users.Users as Acid +import qualified Distribution.Server.Features.Users.Acid as UserAcid +import qualified Distribution.Server.Features.Users.Store as UserStore import qualified Distribution.Server.Users.Group as Group import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), UserIdSet, nullDescription) @@ -230,8 +229,7 @@ deriveJSON (compatAesonOptionsDropPrefix "ui_") ''UserGroupResource initUserFeature :: ServerEnv -> IO (IO UserFeature) initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do -- Canonical state - usersState <- usersStateComponent serverStateDir - adminsState <- adminsStateComponent serverStateDir + userBackend <- UserAcid.acidStore serverStateDir -- Ephemeral state groupIndex <- newMemStateWHNF emptyGroupIndex @@ -257,8 +255,7 @@ initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTe -- rec let (feature@UserFeature{groupResourceAt}, adminGroupDesc) = userFeature templates - usersState - adminsState + userBackend groupIndex userAdded authFailHook groupChangedHook adminG adminR @@ -268,35 +265,8 @@ initUserFeature serverEnv@ServerEnv{serverStateDir, serverTemplatesDir, serverTe return feature -usersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.Users) -usersStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Users") Acid.initialUsers - return StateComponent { - stateDesc = "List of users" - , stateHandle = st - , getState = query st Acid.GetUserDb - , putState = update st . Acid.ReplaceUserDb - , backupState = usersBackup - , restoreState = usersRestore - , resetState = usersStateComponent - } - -adminsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageAdmins) -adminsStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "HackageAdmins") Acid.initialHackageAdmins - return StateComponent { - stateDesc = "Admins" - , stateHandle = st - , getState = query st Acid.GetHackageAdmins - , putState = update st . Acid.ReplaceHackageAdmins . Acid.adminList - , backupState = \_ (Acid.HackageAdmins admins) -> [csvToBackup ["admins.csv"] (groupToCSV admins)] - , restoreState = Acid.HackageAdmins <$> groupBackup ["admins.csv"] - , resetState = adminsStateComponent - } - userFeature :: Templates - -> StateComponent AcidState Acid.Users - -> StateComponent AcidState Acid.HackageAdmins + -> UserStore.Backend -> MemState GroupIndex -> Hook () () -> Hook Auth.AuthError (Maybe ErrorResponse) @@ -305,7 +275,7 @@ userFeature :: Templates -> GroupResource -> ServerEnv -> (UserFeature, UserGroup) -userFeature templates usersState adminsState +userFeature templates UserStore.Backend{backendStore = userStore, backendState = userStateComponents} groupIndex userAdded authFailHook groupChangedHook adminGroup adminResource userFeatureServerEnv = (UserFeature {..}, adminGroupDesc) @@ -325,10 +295,7 @@ userFeature templates usersState adminsState groupResource adminResource , groupUserResource adminResource ] - , featureState = [ - abstractAcidStateComponent usersState - , abstractAcidStateComponent adminsState - ] + , featureState = userStateComponents , featureCaches = [ CacheComponent { cacheDesc = "user group index", @@ -397,18 +364,18 @@ userFeature templates usersState adminsState -- queryGetUserDb :: MonadIO m => m Acid.Users - queryGetUserDb = queryState usersState Acid.GetUserDb + queryGetUserDb = UserStore.getUsers userStore updateAddUser :: MonadIO m => UserName -> UserAuth -> m (Either Acid.ErrUserNameClash UserId) - updateAddUser uname auth = updateState usersState (Acid.AddUserEnabled uname auth) + updateAddUser = UserStore.addUser userStore updateSetUserEnabledStatus :: MonadIO m => UserId -> Bool -> m (Maybe (Either Acid.ErrNoSuchUserId Acid.ErrDeletedUser)) - updateSetUserEnabledStatus uid isenabled = updateState usersState (Acid.SetUserEnabledStatus uid isenabled) + updateSetUserEnabledStatus = UserStore.setUserEnabledStatus userStore updateSetUserAuth :: MonadIO m => UserId -> UserAuth -> m (Maybe (Either Acid.ErrNoSuchUserId Acid.ErrDeletedUser)) - updateSetUserAuth uid auth = updateState usersState (Acid.SetUserAuth uid auth) + updateSetUserAuth = UserStore.setUserAuth userStore -- -- Authorisation: authentication checks and privilege checks @@ -555,7 +522,7 @@ userFeature templates usersState adminsState serveUserPut dpath = do guardAuthorised_ [InGroup adminGroup] username <- userNameInPath dpath - muid <- updateState usersState $ Acid.AddUserDisabled username + muid <- UserStore.addDisabledUser userStore username case muid of Left Acid.ErrUserNameClash -> errBadRequest "Username already exists" @@ -570,7 +537,7 @@ userFeature templates usersState adminsState serveUserDelete dpath = do guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath - merr <- updateState usersState $ Acid.DeleteUser uid + merr <- UserStore.deleteUser userStore uid case merr of Nothing -> noContent $ toResponse () --TODO: need to be able to delete user by name to fix this race condition @@ -590,7 +557,7 @@ userFeature templates usersState adminsState guardAuthorised_ [InGroup adminGroup] uid <- lookupUserName =<< userNameInPath dpath EnabledResource enabled <- expectAesonContent - merr <- updateState usersState (Acid.SetUserEnabledStatus uid enabled) + merr <- UserStore.setUserEnabledStatus userStore uid enabled case merr of Nothing -> noContent $ toResponse () Just (Left Acid.ErrNoSuchUserId) -> @@ -634,7 +601,7 @@ userFeature templates usersState adminsState template <- getTemplate templates "token-created.html" origTok <- liftIO generateOriginalToken let storeTok = convertToken origTok - res <- updateState usersState (Acid.AddAuthToken uid storeTok desc) + res <- UserStore.addAuthToken userStore uid storeTok desc case res of Nothing -> ok $ toResponse $ @@ -653,7 +620,7 @@ userFeature templates usersState adminsState [MText "The auth token provided is malformed: " ,MText err] Right authToken -> do - res <- updateState usersState (Acid.RevokeAuthToken uid authToken) + res <- UserStore.revokeAuthToken userStore uid authToken case res of Nothing -> ok $ toResponse $ @@ -678,7 +645,7 @@ userFeature templates usersState adminsState lookupUserNameFull :: UserName -> ServerPartE (UserId, UserInfo) lookupUserNameFull uname = do - users <- queryState usersState Acid.GetUserDb + users <- UserStore.getUsers userStore case Acid.lookupUserName uname users of Just u -> return u Nothing -> userLost "Could not find user: not presently registered" @@ -689,7 +656,7 @@ userFeature templates usersState adminsState lookupUserInfo :: UserId -> ServerPartE UserInfo lookupUserInfo uid = do - users <- queryState usersState Acid.GetUserDb + users <- UserStore.getUsers userStore case Acid.lookupUserId uid users of Just uinfo -> return uinfo Nothing -> errInternalError [MText "user id does not exist"] @@ -717,7 +684,7 @@ userFeature templates usersState adminsState Nothing -> errBadRequest "Error registering user" [MText "Not a valid user name!"] Just uname -> do let auth = newUserAuth uname password - muid <- updateState usersState $ Acid.AddUserEnabled uname auth + muid <- UserStore.addUser userStore uname auth case muid of Left Acid.ErrUserNameClash -> errForbidden "Error registering user" [MText "A user account with that user name already exists."] Right _ -> return uname @@ -725,7 +692,7 @@ userFeature templates usersState adminsState -- Arguments: the auth'd user id, the user path id (derived from the :username) canChangePassword :: MonadIO m => UserId -> UserId -> m Bool canChangePassword uid userPathId = do - admins <- queryState adminsState Acid.GetAdminList + admins <- UserStore.getAdminList userStore return $ uid == userPathId || (uid `Group.member` admins) --FIXME: this thing is a total mess! @@ -740,7 +707,7 @@ userFeature templates usersState adminsState forbidChange "Copies of new password do not match or is an invalid password (ex: blank)" let passwd = PasswdPlain passwd1 auth = newUserAuth username passwd - res <- updateState usersState (Acid.SetUserAuth uid auth) + res <- UserStore.setUserAuth userStore uid auth case res of Nothing -> return () Just (Left Acid.ErrNoSuchUserId) -> errInternalError [MText "user id lookup failure"] @@ -755,9 +722,9 @@ userFeature templates usersState adminsState adminGroupDesc :: UserGroup adminGroupDesc = UserGroup { groupDesc = nullDescription { groupTitle = "Hackage admins" }, - queryUserGroup = queryState adminsState Acid.GetAdminList, - addUserToGroup = updateState adminsState . Acid.AddHackageAdmin, - removeUserFromGroup = updateState adminsState . Acid.RemoveHackageAdmin, + queryUserGroup = UserStore.getAdminList userStore, + addUserToGroup = UserStore.addAdmin userStore, + removeUserFromGroup = UserStore.removeAdmin userStore, groupsAllowedToAdd = [adminGroupDesc], groupsAllowedToDelete = [adminGroupDesc] } @@ -765,7 +732,7 @@ userFeature templates usersState adminsState groupAddUser :: UserGroup -> DynamicPath -> ServerPartE () groupAddUser group _ = do actorUid <- guardAuthorised (map InGroup (groupsAllowedToAdd group)) - users <- queryState usersState Acid.GetUserDb + users <- UserStore.getUsers userStore muser <- optional $ look "user" reason <- optional $ look "reason" case muser of diff --git a/src/Distribution/Server/Features/Users/Acid.hs b/src/Distribution/Server/Features/Users/Acid.hs new file mode 100644 index 000000000..1f424c1b8 --- /dev/null +++ b/src/Distribution/Server/Features/Users/Acid.hs @@ -0,0 +1,61 @@ +module Distribution.Server.Features.Users.Acid + ( usersStateComponent + , adminsStateComponent + , acidStore + ) where + +import qualified Distribution.Server.Features.Users.Store as Store +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupDump +import Distribution.Server.Users.Backup +import qualified Distribution.Server.Users.State as Acid +import qualified Distribution.Server.Users.Users as Acid + +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + usersState <- usersStateComponent stateDir + adminsState <- adminsStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getUsers = queryState usersState Acid.GetUserDb + , Store.addUser = \uname auth -> updateState usersState (Acid.AddUserEnabled uname auth) + , Store.addDisabledUser = \uname -> updateState usersState (Acid.AddUserDisabled uname) + , Store.setUserEnabledStatus = \uid enabled -> updateState usersState (Acid.SetUserEnabledStatus uid enabled) + , Store.deleteUser = \uid -> updateState usersState (Acid.DeleteUser uid) + , Store.setUserAuth = \uid auth -> updateState usersState (Acid.SetUserAuth uid auth) + , Store.addAuthToken = \uid token description -> updateState usersState (Acid.AddAuthToken uid token description) + , Store.revokeAuthToken = \uid token -> updateState usersState (Acid.RevokeAuthToken uid token) + , Store.getAdminList = queryState adminsState Acid.GetAdminList + , Store.addAdmin = updateState adminsState . Acid.AddHackageAdmin + , Store.removeAdmin = updateState adminsState . Acid.RemoveHackageAdmin + } + , Store.backendState = [ abstractAcidStateComponent usersState + , abstractAcidStateComponent adminsState + ] + } + +usersStateComponent :: FilePath -> IO (StateComponent AcidState Acid.Users) +usersStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Users") Acid.initialUsers + return StateComponent { + stateDesc = "List of users" + , stateHandle = st + , getState = query st Acid.GetUserDb + , putState = update st . Acid.ReplaceUserDb + , backupState = usersBackup + , restoreState = usersRestore + , resetState = usersStateComponent + } + +adminsStateComponent :: FilePath -> IO (StateComponent AcidState Acid.HackageAdmins) +adminsStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "HackageAdmins") Acid.initialHackageAdmins + return StateComponent { + stateDesc = "Admins" + , stateHandle = st + , getState = query st Acid.GetHackageAdmins + , putState = update st . Acid.ReplaceHackageAdmins . Acid.adminList + , backupState = \_ (Acid.HackageAdmins admins) -> [csvToBackup ["admins.csv"] (groupToCSV admins)] + , restoreState = Acid.HackageAdmins <$> groupBackup ["admins.csv"] + , resetState = adminsStateComponent + } diff --git a/src/Distribution/Server/Features/Users/Store.hs b/src/Distribution/Server/Features/Users/Store.hs new file mode 100644 index 000000000..a68989f89 --- /dev/null +++ b/src/Distribution/Server/Features/Users/Store.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Users.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Group (UserIdSet) +import Distribution.Server.Users.Types (AuthToken, UserAuth, UserId, UserName) +import Distribution.Server.Users.Users + ( Users + , ErrUserNameClash + , ErrNoSuchUserId + , ErrDeletedUser + , ErrTokenNotOwned + ) + +import Control.Monad.Trans (MonadIO) +import Data.Text (Text) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getUsers :: forall m. MonadIO m => m Users + , addUser :: forall m. MonadIO m => UserName -> UserAuth -> m (Either ErrUserNameClash UserId) + , addDisabledUser :: forall m. MonadIO m => UserName -> m (Either ErrUserNameClash UserId) + , setUserEnabledStatus :: forall m. MonadIO m => UserId -> Bool -> m (Maybe (Either ErrNoSuchUserId ErrDeletedUser)) + , deleteUser :: forall m. MonadIO m => UserId -> m (Maybe ErrNoSuchUserId) + , setUserAuth :: forall m. MonadIO m => UserId -> UserAuth -> m (Maybe (Either ErrNoSuchUserId ErrDeletedUser)) + , addAuthToken :: forall m. MonadIO m => UserId -> AuthToken -> Text -> m (Maybe ErrNoSuchUserId) + , revokeAuthToken :: forall m. MonadIO m => UserId -> AuthToken -> m (Maybe (Either ErrNoSuchUserId ErrTokenNotOwned)) + , getAdminList :: forall m. MonadIO m => m UserIdSet + , addAdmin :: forall m. MonadIO m => UserId -> m () + , removeAdmin :: forall m. MonadIO m => UserId -> m () + } diff --git a/src/Distribution/Server/Features/Votes.hs b/src/Distribution/Server/Features/Votes.hs index 8739824c1..b23761e8c 100644 --- a/src/Distribution/Server/Features/Votes.hs +++ b/src/Distribution/Server/Features/Votes.hs @@ -4,15 +4,21 @@ -- module Distribution.Server.Features.Votes ( VotesFeature(..) + , Backend(..) + , Store(..) , initVotesFeature + , initVotesFeatureWith ) where import Distribution.Server.Features.Votes.Types (Score) -import qualified Distribution.Server.Features.Votes.State as Acid +import Distribution.Server.Features.Votes.Acid (acidStore) import qualified Distribution.Server.Features.Votes.Render as Render +import Distribution.Server.Features.Votes.Store + ( votesScore + , Backend(..) + , Store(..) ) import Distribution.Server.Framework -import Distribution.Server.Framework.BackupRestore import Distribution.Server.Features.Core import Distribution.Server.Features.Users @@ -52,7 +58,15 @@ initVotesFeature :: ServerEnv -> UserFeature -> IO VotesFeature) initVotesFeature env@ServerEnv{serverStateDir} = do - dbVotesState <- votesStateComponent serverStateDir + initVotesFeatureWith (acidStore serverStateDir) env + +initVotesFeatureWith :: IO Backend + -> ServerEnv + -> IO ( CoreFeature + -> UserFeature + -> IO VotesFeature ) +initVotesFeatureWith openVotesStore env = do + dbVotesState <- openVotesStore updateVotes <- newHook return $ \coref@CoreFeature{..} userf@UserFeature{..} -> do @@ -62,34 +76,16 @@ initVotesFeature env@ServerEnv{serverStateDir} = do return feature --- | Define the backing store (i.e. database component) -votesStateComponent :: FilePath -> IO (StateComponent AcidState Acid.VotesState) -votesStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Votes") Acid.initialVotesState - return StateComponent { - stateDesc = "Backing store for Map PackageName -> Users who voted for it" - , stateHandle = st - , getState = query st Acid.GetVotesState - , putState = update st . Acid.ReplaceVotesState - , resetState = votesStateComponent - , backupState = \_ _ -> [] - , restoreState = RestoreBackup { - restoreEntry = error "Unexpected backup entry" - , restoreFinalize = return $ Acid.VotesState Map.empty - } - } - - -- | Default constructor for building this feature. votesFeature :: ServerEnv - -> StateComponent AcidState Acid.VotesState + -> Backend -> CoreFeature -- To get site package list -> UserFeature -- To authenticate users -> Hook (PackageName, Float) () -> VotesFeature votesFeature ServerEnv{..} - votesState + Backend{backendStore = votesState, backendState} CoreFeature { coreResource = CoreResource{..} } UserFeature{..} votesUpdated @@ -100,7 +96,7 @@ votesFeature ServerEnv{..} featureResources = [ packagesVotesResource , packageVotesResource ] - , featureState = [abstractAcidStateComponent votesState] + , featureState = backendState } @@ -129,9 +125,9 @@ votesFeature ServerEnv{..} servePackageVotesGet :: DynamicPath -> ServerPartE Response servePackageVotesGet _ = do cacheControlWithoutETag [Public, maxAgeMinutes 10] - votesMap <- queryState votesState Acid.GetAllPackageVoteSets + votesMap <- getAllPackageVoteSets votesState ok . toResponse $ objectL - [ (display pkgname, toJSON (Acid.votesScore pkgMap)) + [ (display pkgname, toJSON (votesScore pkgMap)) | (pkgname, pkgMap) <- Map.toList votesMap ] -- Get the number of votes a package has. If the package @@ -161,7 +157,7 @@ votesFeature ServerEnv{..} "2" -> pure 2 "3" -> pure 3 _ -> fail "invalid score value received" - _ <- updateState votesState (Acid.AddVote pkgname uid score) + _ <- addVote votesState pkgname uid score pkgScore <- pkgNumScore pkgname runHook_ votesUpdated (pkgname, pkgScore) ok . toResponse $ "Package voted for successfully" @@ -174,7 +170,7 @@ votesFeature ServerEnv{..} pkgname <- packageInPath dpath guardValidPackageName pkgname - success <- updateState votesState (Acid.RemoveVote pkgname uid) + success <- removeVote votesState pkgname uid pkgScore <- pkgNumScore pkgname when success $ runHook_ votesUpdated (pkgname, pkgScore) @@ -187,21 +183,17 @@ votesFeature ServerEnv{..} -- Returns true if a user has previously voted for the -- package in question. didUserVote :: MonadIO m => PackageName -> UserId -> m Bool - didUserVote pkgname uid = - queryState votesState (Acid.GetPackageUserVoted pkgname uid) + didUserVote = getPackageUserVoted votesState -- Returns the number of votes a package has. pkgNumVotes :: MonadIO m => PackageName -> m Int - pkgNumVotes pkgname = - queryState votesState (Acid.GetPackageVoteCount pkgname) + pkgNumVotes = getPackageVoteCount votesState pkgNumScore :: MonadIO m => PackageName -> m Float - pkgNumScore pkgname = - queryState votesState (Acid.GetPackageVoteScore pkgname) + pkgNumScore = getPackageVoteScore votesState pkgUserVote :: MonadIO m => PackageName -> UserId -> m (Maybe Score) - pkgUserVote pkgname uid = - queryState votesState (Acid.GetPackageUserVote pkgname uid) + pkgUserVote = getPackageUserVote votesState -- Renders the HTML for the "Votes:" section on package pages. renderVotesHtml :: PackageName -> ServerPartE X.Html diff --git a/src/Distribution/Server/Features/Votes/Acid.hs b/src/Distribution/Server/Features/Votes/Acid.hs new file mode 100644 index 000000000..aa9ee0997 --- /dev/null +++ b/src/Distribution/Server/Features/Votes/Acid.hs @@ -0,0 +1,45 @@ +module Distribution.Server.Features.Votes.Acid + ( acidStore + , votesStateComponent + ) where + +import Distribution.Server.Features.Votes.Store +import qualified Distribution.Server.Features.Votes.State as Acid + +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore + +import qualified Data.Map as Map + +acidStore :: FilePath -> IO Backend +acidStore stateDir = do + votesState <- votesStateComponent stateDir + return Backend { + backendStore = Store { + getAllPackageVoteSets = queryState votesState Acid.GetAllPackageVoteSets + , addVote = \pkgname uid score -> updateState votesState (Acid.AddVote pkgname uid score) + , removeVote = \pkgname uid -> updateState votesState (Acid.RemoveVote pkgname uid) + , getPackageVoteCount = \pkgname -> queryState votesState (Acid.GetPackageVoteCount pkgname) + , getPackageVoteScore = \pkgname -> queryState votesState (Acid.GetPackageVoteScore pkgname) + , getPackageUserVoted = \pkgname uid -> queryState votesState (Acid.GetPackageUserVoted pkgname uid) + , getPackageUserVote = \pkgname uid -> queryState votesState (Acid.GetPackageUserVote pkgname uid) + } + , backendState = [abstractAcidStateComponent votesState] + } + +-- | Define the backing store (i.e. database component) +votesStateComponent :: FilePath -> IO (StateComponent AcidState Acid.VotesState) +votesStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Votes") Acid.initialVotesState + return StateComponent { + stateDesc = "Backing store for Map PackageName -> Users who voted for it" + , stateHandle = st + , getState = query st Acid.GetVotesState + , putState = update st . Acid.ReplaceVotesState + , resetState = votesStateComponent + , backupState = \_ _ -> [] + , restoreState = RestoreBackup { + restoreEntry = error "Unexpected backup entry" + , restoreFinalize = return $ Acid.VotesState Map.empty + } + } diff --git a/src/Distribution/Server/Features/Votes/State.hs b/src/Distribution/Server/Features/Votes/State.hs index 17b05bda3..3cb718d7e 100644 --- a/src/Distribution/Server/Features/Votes/State.hs +++ b/src/Distribution/Server/Features/Votes/State.hs @@ -4,6 +4,7 @@ module Distribution.Server.Features.Votes.State where import Distribution.Server.Features.Votes.Types +import Distribution.Server.Features.Votes.Store (votesScore) import Distribution.Server.Framework.MemSize import Distribution.Package (PackageName) @@ -15,9 +16,7 @@ import Distribution.Server.Users.State () import Data.Map (Map) import qualified Data.Map as Map -import Data.List import Data.Maybe (fromMaybe) -import Control.Arrow ((&&&)) import Data.Acid (Query, Update, makeAcidic) import Data.SafeCopy (base, extension, deriveSafeCopy, Migrate(..)) @@ -55,16 +54,6 @@ userVotedForPackage pkgname uid votes = Nothing -> False Just _ -> True --- Using a Bayesian average (m=1.5, C=2) to calculate scoring -votesScore :: Map UserId Score -> Float -votesScore m = - let grouping = map (head &&& length) . group . sort . Map.elems $ m - score :: Float - score = fromIntegral ((sum $ map (uncurry (*)) grouping) + 3)/ - fromIntegral (2 + sum (map snd grouping)) - roundedScore = fromIntegral (round (score * 4) :: Int) / 4 - in roundedScore - -- All the acid state transactions addVote :: PackageName -> UserId -> Score -> Update VotesState Float diff --git a/src/Distribution/Server/Features/Votes/Store.hs b/src/Distribution/Server/Features/Votes/Store.hs new file mode 100644 index 000000000..5cc87fd61 --- /dev/null +++ b/src/Distribution/Server/Features/Votes/Store.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Votes.Store + ( Backend(..) + , Store(..) + , votesScore + ) where + +import Distribution.Server.Features.Votes.Types +import Distribution.Server.Framework.Feature (AbstractStateComponent) +import Distribution.Server.Users.Types (UserId) + +import Distribution.Package (PackageName) + +import Control.Arrow ((&&&)) +import Control.Monad.Trans (MonadIO) +import Data.List (group, sort) +import Data.Map (Map) +import qualified Data.Map as Map + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getAllPackageVoteSets :: forall m. MonadIO m => m (Map.Map PackageName (Map.Map UserId Score)) + , addVote :: forall m. MonadIO m => PackageName -> UserId -> Score -> m Float + , removeVote :: forall m. MonadIO m => PackageName -> UserId -> m Bool + , getPackageVoteCount :: forall m. MonadIO m => PackageName -> m Int + , getPackageVoteScore :: forall m. MonadIO m => PackageName -> m Float + , getPackageUserVoted :: forall m. MonadIO m => PackageName -> UserId -> m Bool + , getPackageUserVote :: forall m. MonadIO m => PackageName -> UserId -> m (Maybe Score) + } + +-- Using a Bayesian average (m=1.5, C=2) to calculate scoring +votesScore :: Map UserId Score -> Float +votesScore m = + let grouping = map (head &&& length) . group . sort . Map.elems $ m + score :: Float + score = fromIntegral ((sum $ map (uncurry (*)) grouping) + 3)/ + fromIntegral (2 + sum (map snd grouping)) + roundedScore = fromIntegral (round (score * 4) :: Int) / 4 + in roundedScore diff --git a/src/Distribution/Server/Features/Vouch.hs b/src/Distribution/Server/Features/Vouch.hs index af4b99fff..7337f43e9 100644 --- a/src/Distribution/Server/Features/Vouch.hs +++ b/src/Distribution/Server/Features/Vouch.hs @@ -3,24 +3,23 @@ module Distribution.Server.Features.Vouch (VouchFeature(..), initVouchFeature, judgeVouch) where -import qualified Distribution.Server.Features.Vouch.State as Acid +import Distribution.Server.Features.Vouch.Acid (acidStore) +import qualified Distribution.Server.Features.Vouch.Store as Store import Distribution.Server.Features.Vouch.Types import Control.Monad (when, join) import Control.Monad.Except (runExceptT, throwError) import Control.Monad.IO.Class (MonadIO) import qualified Data.ByteString.Lazy.Char8 as LBS -import qualified Data.Set as Set import Data.Time (UTCTime(..), addUTCTime, getCurrentTime, nominalDay, secondsToDiffTime) import Data.Time.Format.ISO8601 (formatShow, iso8601Format) import Text.XHtml.Strict (prettyHtmlFragment, stringToHtml, li) -import Distribution.Server.Framework ((), AcidState, DynamicPath, HackageFeature, IsHackageFeature, IsHackageFeature(..)) -import Distribution.Server.Framework (MessageSpan(MText), Method(..), Response, ServerEnv(..), ServerPartE, StateComponent(..)) -import Distribution.Server.Framework (abstractAcidStateComponent, emptyHackageFeature, errBadRequest) +import Distribution.Server.Framework ((), DynamicPath, HackageFeature, IsHackageFeature, IsHackageFeature(..)) +import Distribution.Server.Framework (MessageSpan(MText), Method(..), Response, ServerEnv(..), ServerPartE) +import Distribution.Server.Framework (emptyHackageFeature, errBadRequest) import Distribution.Server.Framework (featureDesc, featureReloadFiles, featureResources, featureState) -import Distribution.Server.Framework (liftIO, openLocalStateFrom, query, queryState, resourceAt, resourceDesc, resourceGet) -import Distribution.Server.Framework (resourcePost, toResponse, update, updateState) -import Distribution.Server.Framework.BackupRestore (RestoreBackup(..)) +import Distribution.Server.Framework (liftIO, resourceAt, resourceDesc, resourceGet) +import Distribution.Server.Framework (resourcePost, toResponse) import Distribution.Server.Framework.Templating (($=), TemplateAttr, getTemplate, loadTemplates, reloadTemplates, templateUnescaped) import qualified Distribution.Server.Users.Group as Group import Distribution.Server.Users.Types (UserId(..), UserInfo, UserName(..), userName) @@ -28,25 +27,6 @@ import Distribution.Server.Features.Upload(UploadFeature(..)) import Distribution.Server.Features.Users (UserFeature(..)) import Distribution.Simple.Utils (toUTF8LBS) -vouchStateComponent :: FilePath -> IO (StateComponent AcidState Acid.VouchData) -vouchStateComponent stateDir = do - st <- openLocalStateFrom (stateDir "db" "Vouch") (Acid.VouchData mempty mempty) - let initialVouchData = Acid.VouchData mempty mempty - restore = - RestoreBackup - { restoreEntry = error "Unexpected backup entry" - , restoreFinalize = return initialVouchData - } - pure StateComponent - { stateDesc = "Keeps track of vouches" - , stateHandle = st - , getState = query st Acid.GetVouchesData - , putState = update st . Acid.ReplaceVouchesData - , backupState = \_ _ -> [] - , restoreState = restore - , resetState = vouchStateComponent - } - data VouchFeature = VouchFeature { vouchFeatureInterface :: HackageFeature @@ -112,17 +92,18 @@ renderVouchers lookupUserInfo (uid, timestamp) = do initVouchFeature :: ServerEnv -> IO (UserFeature -> UploadFeature -> IO VouchFeature) initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMode} = do - vouchState <- vouchStateComponent serverStateDir + vouchBackend <- acidStore serverStateDir templates <- loadTemplates serverTemplatesMode [ serverTemplatesDir, serverTemplatesDir "Html"] ["vouch.html"] vouchTemplate <- getTemplate templates "vouch.html" return $ \UserFeature{userNameInPath, lookupUserName, lookupUserInfo, guardAuthenticated} UploadFeature{uploadersGroup} -> do let + vouchStore = Store.backendStore vouchBackend handleGetVouches :: DynamicPath -> ServerPartE Response handleGetVouches dpath = do uid <- lookupUserName =<< userNameInPath dpath - vouches <- queryState vouchState $ Acid.GetVouchesFor uid + vouches <- Store.getVouchesFor vouchStore uid param <- renderToLBS lookupUserInfo vouches pure . toResponse $ vouchTemplate [ "msg" $= "" @@ -135,8 +116,8 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo ugroup <- liftIO $ Group.queryUserGroup uploadersGroup now <- liftIO getCurrentTime vouchee <- lookupUserName =<< userNameInPath dpath - vouchersForVoucher <- queryState vouchState $ Acid.GetVouchesFor voucher - existingVouchers <- queryState vouchState $ Acid.GetVouchesFor vouchee + vouchersForVoucher <- Store.getVouchesFor vouchStore voucher + existingVouchers <- Store.getVouchesFor vouchStore vouchee case judgeVouch ugroup now vouchee vouchersForVoucher existingVouchers voucher of Left NotAnUploader -> errBadRequest "Not an uploader" [MText "You must be an uploader yourself to endorse other users."] @@ -149,16 +130,13 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo Left YouAlreadyVouched -> errBadRequest "Already endorsed" [MText "You have already endorsed this user."] Right result -> do - updateState vouchState $ Acid.PutVouch vouchee (voucher, now) + Store.addVouch vouchStore vouchee (voucher, now) param <- renderToLBS lookupUserInfo $ existingVouchers ++ [(voucher, now)] case result of AddVouchComplete -> do -- enqueue vouching completed notification -- which will be read using drainQueuedNotifications - Acid.VouchData vouches notNotified <- - queryState vouchState Acid.GetVouchesData - let newState = Acid.VouchData vouches (Set.insert vouchee notNotified) - updateState vouchState $ Acid.ReplaceVouchesData newState + Store.queueVouchCompleteNotification vouchStore vouchee liftIO $ Group.addUserToGroup uploadersGroup vouchee pure . toResponse $ vouchTemplate @@ -188,13 +166,8 @@ initVouchFeature ServerEnv{serverStateDir, serverTemplatesDir, serverTemplatesMo , resourcePost = [("html", handlePostVouch)] } ] - , featureState = [ abstractAcidStateComponent vouchState ] + , featureState = Store.backendState vouchBackend , featureReloadFiles = reloadTemplates templates }, - drainQueuedNotifications = do - Acid.VouchData vouches notNotified <- - queryState vouchState Acid.GetVouchesData - let newState = Acid.VouchData vouches mempty - updateState vouchState $ Acid.ReplaceVouchesData newState - pure $ Set.toList notNotified + drainQueuedNotifications = Store.drainQueuedNotifications vouchStore } diff --git a/src/Distribution/Server/Features/Vouch/Acid.hs b/src/Distribution/Server/Features/Vouch/Acid.hs new file mode 100644 index 000000000..92fc83e42 --- /dev/null +++ b/src/Distribution/Server/Features/Vouch/Acid.hs @@ -0,0 +1,47 @@ +module Distribution.Server.Features.Vouch.Acid + ( acidStore + ) where + +import qualified Distribution.Server.Features.Vouch.State as Acid +import qualified Distribution.Server.Features.Vouch.Store as Store +import Distribution.Server.Framework +import Distribution.Server.Framework.BackupRestore (RestoreBackup(..)) + +import qualified Data.Set as Set + +acidStore :: FilePath -> IO Store.Backend +acidStore stateDir = do + vouchState <- vouchStateComponent stateDir + pure Store.Backend { + Store.backendStore = Store.Store { + Store.getVouchesFor = \uid -> queryState vouchState (Acid.GetVouchesFor uid) + , Store.addVouch = \uid entry -> updateState vouchState (Acid.PutVouch uid entry) + , Store.queueVouchCompleteNotification = \uid -> do + Acid.VouchData vouches notNotified <- queryState vouchState Acid.GetVouchesData + updateState vouchState (Acid.ReplaceVouchesData (Acid.VouchData vouches (Set.insert uid notNotified))) + , Store.drainQueuedNotifications = do + Acid.VouchData vouches notNotified <- queryState vouchState Acid.GetVouchesData + updateState vouchState (Acid.ReplaceVouchesData (Acid.VouchData vouches mempty)) + pure (Set.toList notNotified) + } + , Store.backendState = [abstractAcidStateComponent vouchState] + } + +vouchStateComponent :: FilePath -> IO (StateComponent AcidState Acid.VouchData) +vouchStateComponent stateDir = do + st <- openLocalStateFrom (stateDir "db" "Vouch") (Acid.VouchData mempty mempty) + let initialVouchData = Acid.VouchData mempty mempty + restore = + RestoreBackup + { restoreEntry = error "Unexpected backup entry" + , restoreFinalize = return initialVouchData + } + pure StateComponent + { stateDesc = "Keeps track of vouches" + , stateHandle = st + , getState = query st Acid.GetVouchesData + , putState = update st . Acid.ReplaceVouchesData + , backupState = \_ _ -> [] + , restoreState = restore + , resetState = vouchStateComponent + } diff --git a/src/Distribution/Server/Features/Vouch/Store.hs b/src/Distribution/Server/Features/Vouch/Store.hs new file mode 100644 index 000000000..3dc6bb648 --- /dev/null +++ b/src/Distribution/Server/Features/Vouch/Store.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE RankNTypes #-} + +module Distribution.Server.Features.Vouch.Store + ( Backend(..) + , Store(..) + ) where + +import Distribution.Server.Framework (AbstractStateComponent) +import Distribution.Server.Users.Types (UserId) + +import Control.Monad.Trans (MonadIO) +import Data.Time (UTCTime) + +data Backend = Backend { + backendStore :: Store + , backendState :: [AbstractStateComponent] + } + +data Store = Store { + getVouchesFor :: forall m. MonadIO m => UserId -> m [(UserId, UTCTime)] + , addVouch :: forall m. MonadIO m => UserId -> (UserId, UTCTime) -> m () + , queueVouchCompleteNotification :: forall m. MonadIO m => UserId -> m () + , drainQueuedNotifications :: forall m. MonadIO m => m [UserId] + }