diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,27 @@ +# Version 0.0.4 + +* _COMPILER ASSISTED BREAKING CHANGE._ `registryConf_with` now takes a + `Di` as extra argument. + +* _BREAKING CHANGE._ `Moto.File` registry now now takes `/foo/bar` on the + command line, rather than `file:///foo/bar`. + +* Added `Moto.File.jsonStore`. See issue #11. + +* Added `Moto.dummyStore`. See issue #3. + +* Added `Moto.dummyBackup`. See issue #7. + +* Added `--unsafe-commit` and `--unsafe-abort` switches to the `clean` CLI. + These can be used to force the cleanup of a dirty migration registry without + actually running any clean-up code, which can be useful in case of manual + recovery. See issue #13. + +* Made compatible with `di-df1` version `1.2`. + +* Improved exception logging. + + # Version 0.0.3 * Haddocks and Hackage choke on internal Cabal libraries, so we remove the diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/lib/Moto.hs b/lib/Moto.hs --- a/lib/Moto.hs +++ b/lib/Moto.hs @@ -76,7 +76,9 @@ , I.Mig(..) , I.Store(..) , I.mapStore + , dummyStore , I.Backup(..) + , dummyBackup , I.Change(..) , I.Direction(..) , I.direction @@ -96,6 +98,18 @@ import qualified Moto.Internal as I import qualified Moto.Internal.Cli as IC + +-- | A 'I.Store' that does nothing and always succeeds. +dummyStore :: I.Store () +dummyStore = I.Store + { I.store_delete = \_di _mId -> pure () + , I.store_save = \_di _mId () -> pure () + , I.store_load = \_di _mId k -> k () + } + +-- | A 'I.Backup' that does nothing and always succeeds. +dummyBackup :: I.Backup () +dummyBackup = I.Backup (\_di k -> k ()) {- $example diff --git a/lib/Moto/File.hs b/lib/Moto/File.hs --- a/lib/Moto/File.hs +++ b/lib/Moto/File.hs @@ -16,12 +16,14 @@ registryConf , withRegistry - , -- * Store - store + -- * Store + , store + , jsonStore ) where import Control.Applicative (empty) import qualified Control.Exception.Safe as Ex +import Control.Monad (when) import qualified Control.Monad.Trans.State.Strict as S import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans (lift) @@ -31,10 +33,15 @@ import qualified Data.ByteString.Builder as BB import qualified Data.Char as Char import qualified Data.Text as T +import Data.Maybe (isJust) +import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL +import qualified Di.Df1 as Di import GHC.IO.Handle as IO (LockMode(ExclusiveLock), hLock) import qualified Pipes as P +import qualified Pipes.Aeson as PAe +import qualified Pipes.Aeson.Unchecked as PAeu import qualified Pipes.Attoparsec as Pa import qualified Pipes.ByteString as Pb import qualified System.Directory as Dir @@ -52,23 +59,20 @@ -- filesystem using 'withRegistry'. registryConf :: IC.RegistryConf registryConf = IC.RegistryConf - { IC.registryConf_help = - "File where registry file is stored. E.g., \ - \file:///var/db/migrations" + { IC.registryConf_with = withRegistry + , IC.registryConf_help = + "File where registry file is stored. E.g., /var/db/migrations" , IC.registryConf_parse = \case - 'f':'i':'l':'e':':':'/':'/':xs -> case xs of - "" -> Left "Invalid file path" - "/" -> Left "Invaild file path" - _ -> Right xs - _ -> Left "Invalid file path" - , IC.registryConf_with = withRegistry + fp@('/':_) -> pure fp + _ -> Left "File path must be absolute." } -- | Obtain a 'I.Registry' backed by an append-only file storage, using @moto@'s -- own file format. withRegistry :: (MonadIO m, Ex.MonadMask m) - => IO.FilePath + => Di.Df1 + -> IO.FilePath -- ^ File where to store the registry logs. -- -- An exclusive lock will be set on the this file (see 'IO.hLock'), which will @@ -76,8 +80,8 @@ -- interact with this file while this program is running. -> (I.Registry -> m a) -> m a -withRegistry fp = - withRegistryCustom renderLogLine parseLogLine fp +withRegistry di0 fp k = + withRegistryCustom renderLogLine parseLogLine di0 fp k -- | Obtain a 'I.Registry' backed by an append-only file storage as described by -- 'R.newAppendOnlyRegistry'. @@ -89,6 +93,7 @@ -> A8.Parser I.Log -- ^ Parse a single 'I.Log'. Be sure to consume and discard any trailing -- newline or similar separating one rendered 'I.Log' entry from the next. + -> Di.Df1 -> IO.FilePath -- ^ File where to store the registry logs. -- @@ -97,14 +102,20 @@ -- interact with this file while this program is running. -> (I.Registry -> m a) -> m a -withRegistryCustom render parser fp k = do +withRegistryCustom render parser di0 fp k = do + let di1 = Di.attr "file" fp di0 Ex.bracket (liftIO $ do + Di.debug_ di1 "Opening registry file..." h <- IO.openBinaryFile fp IO.ReadWriteMode + Di.debug_ di1 "Acquiring exclusive file lock..." IO.hLock h IO.ExclusiveLock pure h) - (liftIO . IO.hClose) + (\h -> liftIO $ do + Di.debug_ di1 "Closing registry file..." + IO.hClose h) (\h -> k =<< liftIO (do + Di.debug_ di1 "Loading state from registry..." state0 <- do ea <- flip S.runStateT I.emptyState $ P.runEffect $ do P.for (Pa.parsed parser (Pb.fromHandle h)) $ \l -> do @@ -218,3 +229,31 @@ \To backup these backups, it is sufficient to copy the contents\n\ \of this directory, preserving the file names." -} + +-- | Like 'store', but serializes data in a JSON format. +-- +-- WARNING: This holds all of @x@ in memory, so avoid using 'jsonStore' if your +-- data is too large. +jsonStore :: (Ae.FromJSON x, Ae.ToJSON x) => FilePath -> I.Store x +jsonStore fp = + let s0 = store fp + in I.Store + { I.store_delete = I.store_delete s0 + , I.store_save = \di mId x -> do + I.store_save s0 di mId (PAeu.encode x) + , I.store_load = \di mId k -> do + I.store_load s0 di mId $ \p0 -> do + yea <- S.evalStateT PAeu.decode p0 + case yea of + Nothing -> Ex.throwM Err_JsonStoreLoad_NoInput + Just (Left e) -> Ex.throwM (Err_JsonStoreLoad_Decoding e) + Just (Right x) -> k x + } + +-- | And error from 'jsonStore''s 'I.store_load'. +data Err_JsonStoreLoad + = Err_JsonStoreLoad_NoInput + | Err_JsonStoreLoad_Decoding PAe.DecodingError + deriving (Show) +instance Ex.Exception Err_JsonStoreLoad + diff --git a/lib/Moto/Internal.hs b/lib/Moto/Internal.hs --- a/lib/Moto/Internal.hs +++ b/lib/Moto/Internal.hs @@ -59,6 +59,8 @@ -- * Registry , Registry(..) , cleanRegistry + , unsafeCleanRegistry + , OnDirty(..) -- * State , State @@ -346,9 +348,9 @@ pimpBackup :: Backup x -> Backup x pimpBackup (Backup f) = Backup $ \di0 k -> do let di1 = Di.push "backup" di0 - Di.debug di1 "Running..." + Di.debug_ di1 "Running..." r <- logException di1 (f di1 k) - Di.debug di1 "Ran." + Di.debug_ di1 "Ran." -- Bonus track: Run GC to ensure we don't keep @x@ in memory. System.Mem.performMajorGC pure r @@ -426,22 +428,22 @@ pimpStore sto = sto { store_save = \di0 mId x -> do let di1 = Di.push "save" di0 - Di.debug di1 "Saving recovery data..." + Di.debug_ di1 "Saving recovery data..." logException di1 (store_save sto di1 mId x) - Di.debug di1 "Saved." + Di.debug_ di1 "Saved." , store_load = \di0 mId k -> do let di1 = Di.push "load" di0 - Di.debug di1 "Loading recovery data..." + Di.debug_ di1 "Loading recovery data..." r <- logException di1 (store_load sto di1 mId k) - Di.debug di1 "Loaded." + Di.debug_ di1 "Loaded." -- Bonus track: Run GC to ensure we don't keep @x@ in memory. System.Mem.performMajorGC pure r , store_delete = \di0 mId -> do let di1 = Di.push "delete" di0 - Di.notice di1 "Deleting recovery data..." + Di.notice_ di1 "Deleting recovery data..." r <- logException di1 (store_delete sto di1 mId) - Di.info di1 "Deleted." + Di.info_ di1 "Deleted." pure r } @@ -528,10 +530,10 @@ -- | Add some extra logging to a 'Change'. pimpChange :: Change x -> Change x pimpChange (Change f) = Change $ \di0 d m x -> do - let di1 = Di.attr "dir" (Df1.value d) (Di.push "alter" di0) - Di.notice di1 "Running..." + let di1 = Di.attr "dir" d $ Di.push "alter" di0 + Di.notice_ di1 "Running..." logException di1 (f di1 d m x) - <* Di.info di1 "Ran." + <* Di.info_ di1 "Ran." -------------------------------------------------------------------------------- @@ -756,6 +758,32 @@ -------------------------------------------------------------------------------- +-- | See 'unsafeCleanRegistry'. +data OnDirty + = OnDirty_Abort + | OnDirty_Commit + deriving (Eq, Show) + +-- | If the 'Registry' is currently 'Dirty', clean it up by __unsafely__ +-- aborting or commiting the pending migration, as requested by 'OnDirty'. +unsafeCleanRegistry :: Di.Df1 -> Registry -> OnDirty -> IO () +unsafeCleanRegistry di0 reg0 od = do + let reg = mkRegistrish reg0 + fmap state_status (registrish_state reg di0) >>= \case + Clean -> pure () + Dirty mId d -> do + let di1 = Di.attr "dir" d + $ Di.attr "mig" mId + $ Di.push "unsafe-clean" di0 + Di.warning_ di1 "Migration registry is dirty." + case od of + OnDirty_Abort -> do + Di.warning_ di1 "Unsafely aborting pending migration, as requested." + registrish_abort reg di1 mId d + OnDirty_Commit -> do + Di.warning_ di1 "Unsafely commiting pending migration, as requested." + registrish_commit reg di1 mId d + -- | If the 'Registry' is currently 'Dirty', clean it up by running -- the dirty migration in the direction opposite than originally intended. cleanRegistry :: Di.Df1 -> Migs graph -> Registry -> IO () @@ -764,16 +792,19 @@ fmap state_status (registrish_state reg di0) >>= \case Clean -> pure () Dirty mId d1 -> do - let di1 = Di.attr "mig" (Df1.value mId) (Di.push "clean" di0) - Di.warning di1 "Migration registry is dirty. Cleaning it up by undoing." + let di1 = Di.attr "dir" d1 + $ Di.attr "mig" mId + $ Di.push "clean" di0 + Di.warning_ di1 "Migration registry is dirty." case lookupMigs mId migs_ of Nothing -> do - Di.alert di1 "MigId in Registry but not in Plan." + Di.alert_ di1 "MigId in Registry but not in Plan." Ex.throwM (Err_CleanRegistry_NotFoundInMigs mId) Just (_, UGone) -> do - Di.alert di1 "Migration code is gone." + Di.alert_ di1 "Migration code is gone." Ex.throwM (Err_CleanRegistry_MigGone mId) Just (_, UMig (st :: Store x) _ (Change ch)) -> do + Di.notice_ di1 "Cleaning up by undoing..." store_load st di1 mId $ \x -> do Ex.uninterruptibleMask $ \restore -> do restore (ch di1 (opposite d1) Recovery x) @@ -789,7 +820,7 @@ Clean -> do let s1 :: Seq (MigId, UMig) = direction Seq.reverse id d0 s0 for_ s1 $ \(mId, UMig (st :: Store x) (Backup ba) (Change ch)) -> do - let di1 = Di.attr "mig" (Df1.value mId) di0 + let di1 = Di.attr "mig" mId di0 when (d0 == Forwards) $ do ba di1 (store_save st di1 mId) -- If 'ioDelete' is 'True' when we finish processing our migration, @@ -928,19 +959,19 @@ { registrish_state = registry_state reg , registrish_prepare = \di0 mId d -> do let di1 = Di.push "registry" di0 - Di.debug di1 "Adding pending registry change..." + Di.debug_ di1 "Adding pending registry change..." logException di1 (f =<< registry_prepare reg di1 mId d) - Di.debug di1 "Added pending registry change." + Di.debug_ di1 "Added pending registry change." , registrish_abort = \di0 mId d -> do let di1 = Di.push "registry" di0 - Di.debug di1 "Aborting pending registry change..." + Di.debug_ di1 "Aborting pending registry change..." logException di1 (f =<< registry_abort reg di1 mId d) - Di.debug di1 "Aborted pending registry change." + Di.debug_ di1 "Aborted pending registry change." , registrish_commit = \di0 mId d -> do let di1 = Di.push "registry" di0 - Di.debug di1 "Commiting change to registry..." + Di.debug_ di1 "Commiting change to registry..." logException di1 (f =<< registry_commit reg di1 mId d) - Di.debug di1 "Committed change to registry." + Di.debug_ di1 "Committed change to registry." } -------------------------------------------------------------------------------- @@ -1057,7 +1088,6 @@ -- given 'Df1'. logException :: (Ex.MonadMask m, MonadIO m) => Di.Df1 -> m a -> m a logException di0 m = do - Ex.withException m $ \(se :: Ex.SomeException) -> do - let di1 = Di.attr "exception" (fromString (show se)) di0 - Di.error di1 "Got exception!" + Ex.withException m $ \se -> + Di.error di0 (se :: Ex.SomeException) diff --git a/lib/Moto/Internal/Cli.hs b/lib/Moto/Internal/Cli.hs --- a/lib/Moto/Internal/Cli.hs +++ b/lib/Moto/Internal/Cli.hs @@ -14,17 +14,15 @@ , run ) where +import Control.Applicative ((<|>)) import qualified Control.Exception.Safe as Ex import qualified Data.ByteString.Builder as BB import Data.Foldable (for_, toList) -import qualified Data.Char as Char -import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.String (fromString) import qualified Data.Text as T import qualified Data.Text.Encoding as T -import qualified Df1 import qualified Di.Df1 as Di import qualified Options.Applicative as OA import qualified System.Exit as IO @@ -44,10 +42,9 @@ -- refining it into some @r@ of our choosing acceptable as an input to -- 'registryConf_with'. -- - -- Ideally, this 'String' should be an URI - -- (e.g., @file:\/\/\/var\/db\/migrations@, - -- or @postgres:\/\/user:password\@host:port\/database@). - , registryConf_with :: forall a. r -> (I.Registry -> IO a) -> IO a + -- This could be something like @\/var\/db\/migrations@ + -- or @postgres:\/\/user:password\@host:port\/database@. + , registryConf_with :: forall a. Di.Df1 -> r -> (I.Registry -> IO a) -> IO a -- ^ Given the @r@ obtained from 'registryConf_parse', get a 'I.Registry' -- that can be used within the given scope. } @@ -68,8 +65,8 @@ -- command-line option. -- -- Examples: @Moto.PostgreSQL.registryConf@ from - -- the [moto-postgresql](https://hackage.haskell.org/package/moto-library), - -- or @Moto.File.@'Moto.File.registryConf' from this library. + -- the [moto-postgresql](https://hackage.haskell.org/package/moto-postgresql) + -- library or @Moto.File.@'Moto.File.registryConf' from this library. -> OA.Parser a -- ^ This extra parser can be used to read some extra configuration -- values from the command-line arguments, besides @moto@'s own. @@ -114,7 +111,7 @@ run_Run :: Di.Df1 -> I.Migs graph -> Opts_Run -> IO () run_Run di0 migs x = do - runWithRegistry (opts_run_withRegistry x) $ \reg -> do + runWithRegistry (opts_run_withRegistry x) di0 $ \reg -> do I.getPlan di0 migs reg (opts_run_target x) >>= \case Left e -> Ex.throwM e Right p -> case opts_run_dryRun x of @@ -128,7 +125,7 @@ run_CheckMigrations :: Di.Df1 -> I.Migs graph -> Opts_CheckMigrations -> IO () run_CheckMigrations di0 migs x = do - runWithRegistry (opts_checkMigrations_withRegistry x) $ \reg -> do + runWithRegistry (opts_checkMigrations_withRegistry x) di0 $ \reg -> do -- The 'I.Target' here is an unused dummy value. I.getPlan di0 migs reg (I.Target I.Forwards Set.empty) >>= \case Left _ -> IO.exitFailure @@ -136,31 +133,33 @@ run_ShowRegistry :: Di.Df1 -> Opts_ShowRegistry -> IO () run_ShowRegistry di0 x = do - runWithRegistry (opts_showRegistry_withRegistry x) $ \reg -> do + runWithRegistry (opts_showRegistry_withRegistry x) di0 $ \reg -> do state <- I.registry_state reg di0 BB.hPutBuilder IO.stdout (renderState state) run_CleanRegistry :: Di.Df1 -> I.Migs graph -> Opts_CleanRegistry -> IO () run_CleanRegistry di0 migs x = do - runWithRegistry (opts_cleanRegistry_withRegistry x) $ \reg -> do + runWithRegistry (opts_cleanRegistry_withRegistry x) di0 $ \reg -> do case opts_cleanRegistry_dryRun x of - False -> I.cleanRegistry di0 migs reg True -> fmap I.state_status (I.registry_state reg di0) >>= \case I.Dirty _ _ -> IO.exitFailure I.Clean -> pure () + False -> case opts_cleanRegistry_unsafe x of + Just od -> I.unsafeCleanRegistry di0 reg od + Nothing -> I.cleanRegistry di0 migs reg run_DeleteRecoveryData :: Di.Df1 -> I.Migs graph -> Opts_DeleteRecoveryData -> IO () run_DeleteRecoveryData di0 migs x = do for_ (Set.toList (opts_store_migIds x)) $ \mId -> do - let di1 = Di.attr "mig" (Df1.value mId) di0 + let di1 = Di.attr "mig" mId di0 case I.lookupMigs mId migs of Just (_, I.UMig store _ _) -> I.store_delete store di1 mId Just (_, I.UGone) -> do - Di.error di1 "Migration code is gone." + Di.error_ di1 "Migration code is gone." IO.exitFailure Nothing -> do - Di.error di1 "Migration not unknown." + Di.error_ di1 "Migration not unknown." IO.exitFailure -------------------------------------------------------------------------------- @@ -293,14 +292,28 @@ OA.help "Don't clean registry, just show whether it is \ \clean and exit immediately with status 0 if so, \ \otherwise exit with status 1.") + <*> (OA.flag' (Just I.OnDirty_Abort) + (OA.long "unsafe-abort" <> + OA.help "If the registry is dirty, unsafely abort the pending \ + \migration without performing any actual clean-up.") + <|> + OA.flag' (Just I.OnDirty_Commit) + (OA.long "unsafe-commit" <> + OA.help "If the registry is dirty, unsafely commit the pending \ + \migration without performing any actual clean-up.") + <|> + pure Nothing) data Opts_CleanRegistry = Opts_CleanRegistry { opts_cleanRegistry_withRegistry :: WithRegistry - -- ^ Acquire a 'I.Registry' to use within a limited scope.. + -- ^ Acquire a 'I.Registry' to use within a limited scope. , opts_cleanRegistry_dryRun :: Bool -- ^ Whether to just show whether the registry is clean -- and exit immediately with status 0 if the so, -- otherwise exit with status 1. + , opts_cleanRegistry_unsafe :: Maybe I.OnDirty + -- ^ Whether to unsafely mark the registy as clean, without + -- actualy performing any clean-up. } -------------------------------------------------------------------------------- @@ -321,17 +334,17 @@ -------------------------------------------------------------------------------- data WithRegistry = WithRegistry - { runWithRegistry :: forall a. (I.Registry -> IO a) -> IO a } + (forall a. Di.Df1 -> (I.Registry -> IO a) -> IO a) +runWithRegistry :: WithRegistry -> Di.Df1 -> (I.Registry -> IO a) -> IO a +runWithRegistry (WithRegistry f) di0 k = f (Di.push "registry" di0) k + oa_p_WithRegistry :: RegistryConf -> OA.Parser WithRegistry oa_p_WithRegistry (RegistryConf rh rp rw) = OA.option - (OA.eitherReader $ \s -> do - case List.dropWhileEnd Char.isSpace (List.dropWhile Char.isSpace s) of - "" -> Left "Empty registry URI" - s' -> case rp s' of - Left e -> Left e - Right r -> Right (WithRegistry (rw r))) - (OA.long "registry" <> OA.metavar "URI" <> OA.help rh) + (OA.eitherReader $ \s -> case rp s of + Left e -> Left e + Right r -> Right (WithRegistry (flip rw r))) + (OA.long "registry" <> OA.metavar "SETTINGS" <> OA.help rh) -------------------------------------------------------------------------------- diff --git a/lib/cli_help.docs b/lib/cli_help.docs --- a/lib/cli_help.docs +++ b/lib/cli_help.docs @@ -28,12 +28,13 @@ Subcommand @run@: @ -Usage: moto-example run --registry URI [--backwards] [--mig ID] [--no-dry-run] +Usage: moto-example run --registry SETTINGS [--backwards] [--mig ID] + [--no-dry-run] Run migrations. Available options: - --registry URI File where registry file is stored. E.g., - file:\/\/\/var\/db\/migrations + --registry SETTINGS File where registry file is stored. E.g., + \/var\/db\/migrations --mig ID If specified, only consider running the migration identified by this ID. Use multiple times for multiple migrations. @@ -59,13 +60,13 @@ Subcommand @check-migrations@: @ -Usage: moto-example check-migrations --registry URI +Usage: moto-example check-migrations --registry SETTINGS Exit immediately with status 0 if the available migrations are compatible with the registry. Otherwise, exit with status 1. Available options: - --registry URI File where registry file is stored. E.g., - file:\/\/\/var\/db\/migrations + --registry SETTINGS File where registry file is stored. E.g., + \/var\/db\/migrations -h,--help Show this help text @ @@ -74,12 +75,12 @@ Subcommand @show-registry@: @ -Usage: moto-example show-registry --registry URI +Usage: moto-example show-registry --registry SETTINGS Show migrations registry. Available options: - --registry URI File where registry file is stored. E.g., - file:\/\/\/var\/db\/migrations + --registry SETTINGS File where registry file is stored. E.g., + \/var\/db\/migrations -h,--help Show this help text @ @@ -88,15 +89,20 @@ Subcommand @clean-registry@: @ -Usage: moto-example clean-registry --registry URI [--dry-run] +Usage: moto-example clean-registry --registry SETTINGS [--dry-run] + ([--unsafe-abort] | [--unsafe-commit]) Clean a dirty migrations registry. Available options: - --registry URI File where registry file is stored. E.g., - file:\/\/\/var\/db\/migrations + --registry SETTINGS File where registry file is stored. E.g., + \/var\/db\/migrations --dry-run Don't clean registry, just show whether it is clean and exit immediately with status 0 if so, otherwise exit with status 1. + --unsafe-abort If the registry is dirty, unsafely abort the pending + migration without performing any actual clean-up. + --unsafe-commit If the registry is dirty, unsafely commit the pending + migration without performing any actual clean-up. -h,--help Show this help text @ diff --git a/moto.cabal b/moto.cabal --- a/moto.cabal +++ b/moto.cabal @@ -1,5 +1,5 @@ name: moto -version: 0.0.3 +version: 0.0.4 synopsis: General purpose migrations library license: Apache-2.0 license-file: LICENSE.txt @@ -9,6 +9,8 @@ category: Database build-type: Simple cabal-version: >=2.0 +homepage: https://gitlab.com/k0001/moto +bug-reports: https://gitlab.com/k0001/moto/issues library hs-source-dirs: lib @@ -36,6 +38,7 @@ mtl, optparse-applicative, pipes, + pipes-aeson, pipes-attoparsec, pipes-bytestring, safe-exceptions, diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -38,6 +38,7 @@ import Test.Tasty.QuickCheck ((===)) import qualified Test.Tasty.Runners as Tasty +import qualified Moto import qualified Moto.Internal as U import qualified Moto.File @@ -52,7 +53,7 @@ -------------------------------------------------------------------------------- backup_noop :: x -> U.Backup x -backup_noop x = U.Backup (\_ k -> k x) +backup_noop x = fmap (\() -> x) Moto.dummyBackup backup_fail_sync :: String -> U.Backup x backup_fail_sync s = U.Backup (\_ _ -> fail_sync s) @@ -60,8 +61,7 @@ -------------------------------------------------------------------------------- store_noop :: x -> U.Store x -store_noop x = - U.Store (\_ _ _ -> pure ()) (\_ _ k -> k x) (\_ _ -> pure ()) +store_noop x = U.mapStore (const ()) (const x) Moto.dummyStore store_fail_sync_save :: x -> String -> U.Store x store_fail_sync_save x s = @@ -607,7 +607,7 @@ :: forall a. Di.Df1 -> U.Status -> [U.MigId] -> (U.Registry -> IO a) -> IO a withExpectedTestRegistry di sex idsex k = do dir <- getTempDir - Moto.File.withRegistry (dir ++ "/reg") $ \reg -> do + Moto.File.withRegistry di (dir ++ "/reg") $ \reg -> do Ex.finally (k reg) $ do s <- Ex.evaluate =<< U.registry_state reg di (sex, idsex) @=? (U.state_status s, map fst (U.state_committed s))