Separate types/features/acid-state/backups across all features

hackage-server.cabal

@@ -218,6 +218,8 @@ library
     Paths_hackage_server
 
   exposed-modules:
+    Data.Acid.Compat
+
     Distribution.Server
 
     Distribution.Server.Prelude
@@ -288,7 +290,6 @@ library
     Distribution.Server.Util.ServeTarball
     Distribution.Server.Util.Validators
     Distribution.Server.Util.Validators.Internal
-    -- [unused] Distribution.Server.Util.TarIndex
     Distribution.Server.Util.GZip
     Distribution.Server.Util.ContentType
     Distribution.Server.Util.SigTerm
@@ -323,6 +324,9 @@ library
     Distribution.Server.Features.Upload.Backup
     Distribution.Server.Features.Users
     Distribution.Server.Features.UserNotify
+    Distribution.Server.Features.UserNotify.Acid
+    Distribution.Server.Features.UserNotify.Backup
+    Distribution.Server.Features.UserNotify.Types
 
 
   if flag(minimal)
@@ -333,10 +337,15 @@ library
       Distribution.Server.Features.TarIndexCache.State
       Distribution.Server.Features.LegacyRedirects
       Distribution.Server.Features.LegacyPasswds
+      Distribution.Server.Features.LegacyPasswds.Acid
       Distribution.Server.Features.LegacyPasswds.Auth
+      Distribution.Server.Features.LegacyPasswds.Backup
       Distribution.Server.Features.PackageContents
       Distribution.Server.Features.AdminFrontend
       Distribution.Server.Features.AdminLog
+      Distribution.Server.Features.AdminLog.Acid
+      Distribution.Server.Features.AdminLog.Backup
+      Distribution.Server.Features.AdminLog.Types
       Distribution.Server.Features.BuildReports
       Distribution.Server.Features.BuildReports.BuildReport
       Distribution.Server.Features.BuildReports.BuildReports
@@ -381,7 +390,10 @@ library
       Distribution.Server.Features.Votes
       Distribution.Server.Features.Votes.Render
       Distribution.Server.Features.Votes.State
+      Distribution.Server.Features.Votes.Types
       Distribution.Server.Features.Vouch
+      Distribution.Server.Features.Vouch.State
+      Distribution.Server.Features.Vouch.Types
       Distribution.Server.Features.RecentPackages
       Distribution.Server.Features.PreferredVersions
       Distribution.Server.Features.PreferredVersions.State
@@ -391,10 +403,18 @@ library
       Distribution.Server.Features.Tags
       Distribution.Server.Features.Tags.Backup
       Distribution.Server.Features.Tags.State
+      Distribution.Server.Features.Tags.Types
       Distribution.Server.Features.AnalyticsPixels
       Distribution.Server.Features.AnalyticsPixels.State
+      Distribution.Server.Features.AnalyticsPixels.Types
       Distribution.Server.Features.UserDetails
+      Distribution.Server.Features.UserDetails.Acid
+      Distribution.Server.Features.UserDetails.Backup
+      Distribution.Server.Features.UserDetails.Types
       Distribution.Server.Features.UserSignup
+      Distribution.Server.Features.UserSignup.Acid
+      Distribution.Server.Features.UserSignup.Backup
+      Distribution.Server.Features.UserSignup.Types
       Distribution.Server.Features.StaticFiles
       Distribution.Server.Features.ServerIntrospect
       Distribution.Server.Features.Sitemap
@@ -417,6 +437,7 @@ library
     , http-types             >= 0.10      && < 0.13
     , QuickCheck             >= 2.14      && < 2.16
     , acid-state            ^>= 0.16
+    , safecopy               >= 0.6       && < 0.11
     , async                 ^>= 2.2.1
     -- requires bumping http-io-streams
     , attoparsec            ^>= 0.14.4

src/Data/Acid/Compat.hs

@@ -0,0 +1,57 @@
+-- | This module re-exports enough of "Data.Acid" to give manual(ish) instances
+-- of 'IsAcidic' and related classes. The only reason to give manual instances
+-- is so that we can implement 'methodTag' via 'movedMethodTag'.
+--
+-- Among its many flaws, 'makeAcidic' gives an implementation of 'methodTag'
+-- which in turn bakes the /module name/ into the serialisation schema. This
+-- means calls to 'makeAcidic' are not referentially transparent, thus changing
+-- the defining module will prevent deserialisation.
+--
+-- Unfortunately, as part of #1486, it's very desirable to move these instances
+-- out of the main library component and into a deprecatable migration
+-- component.
+module Data.Acid.Compat
+  ( module Data.Acid.Compat
+  , module Data.Acid.Common
+  , module Data.Acid.Core
+  , module Data.SafeCopy
+  ) where
+
+import Data.Acid.Common
+import Data.Acid.Core
+import Data.ByteString.Lazy as Lazy (ByteString)
+import Data.ByteString.Lazy.Char8 as Lazy ( pack )
+import Data.Typeable
+import Data.SafeCopy
+
+-- Note [Acid Migration]
+-- ~~~~~~~~~~~~~~~~~~~~~
+--
+-- Due to silly technical reasons deep within @acid-state@, it's impossible to
+-- move a call to 'makeAcidic' into a different module. If you found
+-- a reference to this Note, it means we have /manually/ moved this
+-- 'makeAcidic' call.
+--
+-- If you find yourself needing to update one of these, uncomment the call to
+-- 'makeAcidic', turn on @-ddump-splices@, and then manually inline the
+-- resulting splice. You MUST change the splice and give a non-default
+-- implementation of 'methodTag':
+--
+-- @methodTag = 'movedMethodTag' "Original.Qualified.Module.Name"@
+--
+-- where @My.Qualified.Module@ is the full module name of the /original/
+-- location of the call to 'makeAcidic'. The original module name should be
+-- found in the reference to this note.
+
+
+-- | Generate a @Data.Acid.Core.Tag@ for some type @a@, explicitly overriding
+-- its module path to trick @acid-state@ into doing the right thing.
+movedMethodTag
+    :: Typeable a
+    => String
+    -- ^ Qualified module name where 'makeAcidic' used to be called.
+    -> a
+    -> Lazy.ByteString
+movedMethodTag modul = Lazy.pack . showQualifiedTypeRep . typeOf
+  where
+    showQualifiedTypeRep tr = modul <> "." <> show tr

src/Distribution/Server.hs

@@ -39,7 +39,6 @@ import qualified Distribution.Server.Features as Features
 import Distribution.Server.Features.Users
 
 import qualified Distribution.Server.Users.Types as Users
-import qualified Distribution.Server.Users.Users as Users
 import qualified Distribution.Server.Users.Group as Group
 
 import Distribution.Text

src/Distribution/Server/Features/AdminFrontend.hs

@@ -7,11 +7,14 @@ module Distribution.Server.Features.AdminFrontend (
 
 import Distribution.Server.Framework
 import Distribution.Server.Framework.Templating
+import Distribution.Server.Features.UserSignup.Types
 
 import Distribution.Server.Features.Users
 import Distribution.Server.Features.UserDetails
+import Distribution.Server.Features.UserDetails.Types
 import Distribution.Server.Features.UserSignup
 import Distribution.Server.Features.LegacyPasswds
+import qualified Distribution.Server.Features.LegacyPasswds.Acid as Acid
 
 import Distribution.Server.Users.Types
 import qualified Distribution.Server.Users.Users as Users
@@ -201,7 +204,7 @@ adminFrontendFeature _env templates
         cacheControlWithoutETag [Private]
         template     <- getTemplate templates "legacy.html"
         usersdb      <- queryGetUserDb
-        legacyUsers  <- enumerateAllUserLegacyPasswd <$> queryLegacyPasswds
+        legacyUsers  <- Acid.enumerateAllUserLegacyPasswd <$> queryLegacyPasswds
         ok $ toResponse $ template
           [ "accounts" $= [ accountBasicInfoToTemplate uid uinfo
                           | uid <- legacyUsers
@@ -226,7 +229,7 @@ adminFrontendFeature _env templates
         uinfo     <- lookupUserInfo uid
         mudetails <- queryUserDetails uid
         resetInfo <- lookupPasswordReset uid <$> queryAllSignupResetInfo
-        mlegacy   <- lookupUserLegacyPasswd uid <$> queryLegacyPasswds
+        mlegacy   <- Acid.lookupUserLegacyPasswd uid <$> queryLegacyPasswds
 
         ok $ toResponse $ template
           [ "account" $= accountBasicInfoToTemplate uid uinfo

src/Distribution/Server/Features/AdminLog.hs

@@ -1,9 +1,12 @@
-{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell, BangPatterns,
-             GeneralizedNewtypeDeriving, NamedFieldPuns, RecordWildCards,
-             PatternGuards, RankNTypes #-}
+{-# LANGUAGE NamedFieldPuns  #-}
+{-# LANGUAGE RankNTypes      #-}
+{-# LANGUAGE RecordWildCards #-}
 
 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.Types
 import Distribution.Server.Users.Types (UserId)
 import Distribution.Server.Users.Group
 import Distribution.Server.Framework
@@ -12,32 +15,9 @@ import Distribution.Server.Framework.BackupRestore
 import Distribution.Server.Pages.AdminLog
 import Distribution.Server.Features.Users
 
-import Data.SafeCopy (base, deriveSafeCopy)
-import Data.Maybe(mapMaybe)
-import Control.Monad.Reader
-import qualified Control.Monad.State as State
-import Data.Time (UTCTime)
 import Data.Time.Clock (getCurrentTime)
-import qualified Data.ByteString.Lazy.Char8 as BS
-import Text.Read (readMaybe)
 import Distribution.Server.Util.Parse
 
-data GroupDesc = MaintainerGroup BS.ByteString | AdminGroup | TrusteeGroup | OtherGroup BS.ByteString deriving (Eq, Ord, Read, Show)
-
-deriveSafeCopy 0 'base ''GroupDesc
-
-instance MemSize GroupDesc where
-    memSize (MaintainerGroup x) = memSize x
-    memSize _ = 0
-
-data AdminAction = Admin_GroupAddUser UserId GroupDesc | Admin_GroupDelUser UserId GroupDesc deriving (Eq, Ord, Read, Show)
-
-instance MemSize AdminAction where
-    memSize (Admin_GroupAddUser x y) = memSize2 x y
-    memSize (Admin_GroupDelUser x y) = memSize2 x y
-
-deriveSafeCopy 0 'base ''AdminAction
-
 --TODO Maybe Reason
 
 mkAdminAction :: GroupDescription -> Bool -> UserId -> AdminAction
@@ -47,36 +27,9 @@ mkAdminAction gd isAdd uid = (if isAdd then Admin_GroupAddUser else Admin_GroupD
                     | Just (pn,_) <- groupEntity gd, groupTitle gd == "Maintainers" = MaintainerGroup (packUTF8 pn)
                     | otherwise = OtherGroup $ packUTF8 (groupTitle gd ++ maybe "" ((' ':) . fst) (groupEntity gd))
 
-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
-
-makeAcidic ''AdminLog ['getAdminLog
-                      ,'replaceAdminLog
-                      ,'addAdminLog]
-
 data AdminLogFeature = AdminLogFeature {
       adminLogFeatureInterface :: HackageFeature
-    , queryGetAdminLog :: forall m. MonadIO m => m AdminLog
+    , queryGetAdminLog :: forall m. MonadIO m => m Acid.AdminLog
 }
 
 instance IsHackageFeature AdminLogFeature where
@@ -91,13 +44,13 @@ initAdminLogFeature ServerEnv{serverStateDir} = do
 
     registerHook groupChangedHook $ \(gd,addOrDel,actorUid,targetUid,reason) -> do
         now <- getCurrentTime
-        updateState adminLogState $ AddAdminLog
+        updateState adminLogState $ Acid.AddAdminLog
             (now, actorUid, mkAdminAction gd addOrDel targetUid, packUTF8 reason)
 
     return feature
 
 adminLogFeature :: UserFeature
-                -> StateComponent AcidState AdminLog
+                -> StateComponent AcidState Acid.AdminLog
                 -> AdminLogFeature
 adminLogFeature UserFeature{..} adminLogState
   = AdminLogFeature {..}
@@ -117,57 +70,35 @@ adminLogFeature UserFeature{..} adminLogState
         resourceGet  = [("html", serveAdminLogGet)]
       }
 
-    queryGetAdminLog :: MonadIO m => m AdminLog
-    queryGetAdminLog = queryState adminLogState GetAdminLog
+    queryGetAdminLog :: MonadIO m => m Acid.AdminLog
+    queryGetAdminLog = queryState adminLogState Acid.GetAdminLog
 
     serveAdminLogGet _ = do
-      aLog  <- queryState adminLogState GetAdminLog
+      aLog  <- queryState adminLogState Acid.GetAdminLog
       users <- queryGetUserDb
-      return . toResponse . adminLogPage users . map mkRow . adminLog $ aLog
+      return . toResponse . adminLogPage users . map mkRow . Acid.adminLog $ aLog
 
     mkRow (time, actorId, Admin_GroupDelUser targetId group, reason) =
-          (time, actorId, "Delete", targetId, nameIt group, unpackUTF8 reason)
+          (time, actorId, "Acid.Delete", targetId, nameIt group, unpackUTF8 reason)
     mkRow (time, actorId, Admin_GroupAddUser targetId group, reason) =
-          (time, actorId, "Add", targetId, nameIt group, unpackUTF8 reason)
+          (time, actorId, "Acid.Add", targetId, nameIt group, unpackUTF8 reason)
 
     nameIt (MaintainerGroup pn) = "Maintainers for " ++ unpackUTF8 pn
     nameIt AdminGroup           = "Administrators"
     nameIt TrusteeGroup         = "Trustees"
     nameIt (OtherGroup s)       = unpackUTF8 s
 
-adminLogStateComponent :: FilePath -> IO (StateComponent AcidState AdminLog)
+adminLogStateComponent :: FilePath -> IO (StateComponent AcidState Acid.AdminLog)
 adminLogStateComponent stateDir = do
-  st <- openLocalStateFrom (stateDir </> "db" </> "AdminLog") initialAdminLog
+  st <- openLocalStateFrom (stateDir </> "db" </> "AdminLog") Acid.initialAdminLog
   return StateComponent {
       stateDesc    = "AdminLog"
     , stateHandle  = st
-    , getState     = query st GetAdminLog
-    , putState     = update st . ReplaceAdminLog
-    , backupState  = \_ (AdminLog xs) ->
+    , getState     = query st Acid.GetAdminLog
+    , putState     = update st . Acid.ReplaceAdminLog
+    , backupState  = \_ (Acid.AdminLog xs) ->
                       [BackupByteString ["adminLog.txt"] . backupLogEntries $ xs]
     , restoreState = restoreAdminLogBackup
     , resetState   = adminLogStateComponent
     }
 
-restoreAdminLogBackup :: RestoreBackup AdminLog
-restoreAdminLogBackup =
-    go (AdminLog [])
-  where
-    go logs =
-      RestoreBackup {
-        restoreEntry = \entry -> case entry of
-                        BackupByteString ["adminLog.txt"] bs
-                          -> return . go $ importLogs logs bs
-                        _ -> return (go logs)
-      , restoreFinalize = return logs
-      }
-
-importLogs :: AdminLog -> BS.ByteString -> AdminLog
-importLogs (AdminLog ls) =
-    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