diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +# Version 0.0.3 + +* Haddocks and Hackage choke on internal Cabal libraries, so we remove the + internal `moto-internal` library. + + # Version 0.0.2 * Added file missing from distribution. diff --git a/lib/Moto.hs b/lib/Moto.hs new file mode 100644 --- /dev/null +++ b/lib/Moto.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE CPP #-} + +{- | + +@moto@ is a library for describing and running /migrations/. + +A /migration/ is any code that changes the environment somehow. The +stereotypical example of a migration is code that modifies the schema of a +database, but really anything that changes the environment somehow can be seen +as a migration. For example, moving a file to a different directory or host, +installing a package, deploying infrastructure, etc. + +Essentially, a migration is a glorified bash script to which we hold dear because +of how devastating it can be for our project if we get it wrong. @moto@ +understands this, so it is very careful about how, when, where and why it runs +these migrations, paying special attention to what happens when something goes +wrong. Of course, this being Haskell, we are encouraged to use domain specific +tools that can prevent us from accidentally writing the wrong migration code +(e.g., deleting a database rather than modifying it). + +In @moto@ we can specify migrations in such a way that any data that is going +modified or deleted by a migration can be backed up for us in one or more +storages of our choice. If anything goes wrong, or if we latter decide to undo +these changes, then this backup will be automatically made available to us. + +@moto@ is excellent for teams, where multiple collaborators can add new +migrations to the project at the same time, establishing dependencies between +them by saying “this migration needs to run before that other one” as a graph. +At compile time, @moto@ will ensure whether there is at least one way to execute +these migrations graph sequentially, or fail to compile otherwise. And at +runtime, it will execute this graph in any way that's compatible with the +environment where the migrations are being run. We don't need to worry about +serializing the release and deployment of migrations anymore, nor about making +sure that everybody runs migrations in the same order. We can delegate that +responsibility to @moto@. + +Also, @moto@ is an excellent interface to interacting with our migrations and +environment. The final product we obtain as a user of @moto@ is a ready-made +/command line interface/ program that we can deploy and use to run all or some +migrations, undo them, render the dependency graph, compare it with the current +registry of migrations that have been run so far, obtain an execution plan as +well as very detailed logs in human and computer readable formats, etc. + +@moto@ relies on a /registry/ of migrations to understand what has been run so +far and what hasn't. We can decide whether to keep this state locally or in +a remote database. + +Last, but not least, @moto@ encourages us to remove old migrations after some +time, once these migrations are so old that maintaining them in the project is +an unnecessary burden to us. To this end, @moto@ offers us enough vocabulary to +mark said migrations as /gone/. + +This module is inteded to be imported qualified: + +@ +import qualified "Moto" +@ + +-} +module Moto + ( + -- * Example + -- + -- $example + + -- * Frequently Asked Questions + -- + -- $faq + + -- * Running + IC.run + , IC.Opts + , IC.getOpts + + -- * Describing individual migrations + , I.Mig(..) + , I.Store(..) + , I.mapStore + , I.Backup(..) + , I.Change(..) + , I.Direction(..) + , I.direction + , I.Mode(..) + , I.MigId(..) + + -- * Describing migrations graph + , I.Migs + , I.migs + , (I.*) + , I.DAG + + -- * Command line help + -- + -- $cli_help + ) where + +import qualified Moto.Internal as I +import qualified Moto.Internal.Cli as IC + +{- $example + +The main interface to running migrations is the command line. As a user of +@moto@, we are expected to create an executable that calls 'I.cli'. This +executable can then be deployed and used to run migrations. + +Usually, the code in this executable will look like this: + +@ +\{\-\# LANGUAGE DataKinds \#\-\} +\{\-\# LANGUAGE PartialTypeSignatures \#\-\} + + +-- Our project will be an executable, so we name our module Main as it is +-- customary. +module Main (main) where + + +-- "Moto" is designed to be imported qualified, as well as "Di", a module that +-- provides the logging support required by "Moto". +import qualified "Di" +import qualified "Moto" + +-- Moreover, in this example we will use a migrations registry from the +-- "Moto.File" module as an example. +import qualified "Moto.File" + + +-- Here are some migrations, each of them with a identifier and a set of +-- identifiers for other migrations expected to be executed before them when +-- going 'Moto.Forwards'. +-- +-- Optional: It is actually recommended to put each migration in its own module. +-- It is not necessary, but GHC takes a longer time and more resources to +-- compile big modules. And considering the list of migrations in our project +-- will always be growing, it's better to organize things that way from the +-- start, as this can quickly become a source of slow compilation times. For +-- example, instead of Main.mig_black and Main.mig_blue, we can have +-- MyProject.Migs.Black.mig and MyProject.Migs.Blue.mig that we import as +-- necessary. +mig_red :: Moto.Mig "red" '["blue"] +mig_red = Moto.Mig ... -- Please see the documentation for 'Moto.Mig'. + +mig_yellow :: Moto.Mig "yellow" '["black","red"] +mig_yellow = Moto.Mig ... -- Please see the documentation for 'Moto.Mig'. + +mig_green :: Moto.Mig "green" '["red"] +mig_green = Moto.Mig ... -- Please see the documentation for 'Moto.Mig'. + +mig_black :: Moto.Mig "black" '["blue"] +mig_black = Moto.Mig ... -- Please see the documentation for 'Moto.Mig'. + +mig_blue :: Moto.Mig "blue" '[] +mig_blue = Moto.Mig ... -- Please see the documentation for 'Moto.Mig'. + + +-- All of the 'Mig's that we might want to run need to be put in directed +-- acyclic graph where each migration is a node and each edge is a dependency +-- between migrations. In "Moto", we use 'Moto.migs' and the infix 'Moto.*' +-- function to safely construct the graph of migrations. The way we define our +-- 'Moto.Migs' is a bit strange. Let's understand why. +-- +-- The Moto.* infix function says that the migrations that appear syntactically +-- to its right can only mention as their dependencies migrations that appear +-- to its syntactic left. This prevents us from mentioning our migrations in +-- any order, but on the other hand it ensures at construction that there are no +-- cycles nor dangling references in our dependency graph. If we get the order +-- wrong, we will get a type-checker error. Moreover, migration identifiers are +-- forced to be unique within this graph. The Moto.migs value itself is a dummy +-- starting point we use as the leftmost argument to our chain of Moto.* calls. +-- +-- Observation: Note we avoid giving an explicit type to myMigs. Instead, we +-- used the PartialTypeSignatures GHC extension to put an underscore there and +-- allow GHC to use the inferred type. This is a desirable thing to do so as to +-- prevent type-inference from accidentally inferring an undesired identifier +-- for our migrations. This approach forces all of our Moto.Mig values to have +-- their identifiers and dependencies fully specified at their definition site. +-- We could have accomplished the same by not giving an type signature to our +-- top level myMigs, or by simply inlining our definition of myMigs at its use +-- site later on. +myMigs :: Moto.Migs _ +myMigs = Moto.migs + Moto.* mig_blue + Moto.* mig_red + Moto.* mig_black + Moto.* mig_green + Moto.* mig_yellow + + +-- Finally, we have our main entry point. This program can be run from the +-- command line and allows us to run and inspect migrations. +main :: IO () +main = do + + -- Using 'Moto.getOpts' we parse the command-line arguments and obtain the + -- instructions necessary to call 'Moto.run' afterwards. We specify as + -- arguments a 'Moto.Cli.RegistryConf' that describes the migrations + -- registry where we keep track of the migrations that have run so far, as + -- well as any extra command-line parsing needs we may have. In our case, we + -- use a file in the filesystem as our registry, and we don't do any extra + -- command-line argument parsing. Please see the documentation of + -- 'Moto.getOpts' for more details. + (myOpts, ()) <- Moto.getOpts Moto.File.registryConf (pure ()) + + -- @moto@ uses "Di" for its own logging, so we first + -- need to obtain a @'Di.Di' 'Df1.Level' 'Df1.Path' 'Df1.Message'@ value (also + -- known by its 'Di.Df1' synonym). We can do this using 'Di.new'. + Di.new $ \\di -> do + + -- Finally, we 'Moto.run' @moto@ as instructed by @myOpts@, passing in the + -- 'Di.Df1' we just obtained, as well as the migrations graph + Moto.run di myMigs myOpts +@ +-} + +{- $faq + +Here are some answers to questions you'll frequently ask yourselves when using +@moto@. + +[Where should we maintain the migrations code for our project?] +Ideally, if you keep your whole project in a single code repository, you should +keep the migrations in that same repository, so that they are always in sync +with the code they cater for. You should create a standalone executable program +for running your migrations. + +[Should my migrations program depend on the code I am migrating?] +Definitely not. That code will change or disappear over time, and it will affect +your migrations code whenever it changes. Your migrations code should stand +alone and have a holistic view of the history of the many environments where +your project runs, without depending on it. + +[Can I use @moto@ to migrate projects not written in Haskell?] +Yes, @moto@ doesn't care about the language your project is written in. However, +the migrations code itself will have to be written Haskell. + +[How do I deploy this?] +The same way you deploy other executables. We recommend packaging the program as +a Nix derivation containing a statically linked executable. Moreover, you can +package the migrations execution as a NixOS module that runs automatically +whenever a new version is deployed. Future versions of @moto@ will provide a web +interface for making migration execution a bit more interactive. + +[How do I make sure my migrations work before deploying them?] +Generally speaking, as much as possible, you should use domain-specific +type-safe DSLs to describe your changes. But still, eventually, try the real +thing locally. Don't try to “mock” scenarios, that doesn't help. @moto@ makes +it quite easy to run migrations backwards afterwards. Moreover, in order to try +recovery scenarios, you try and throw exceptions from the different parts of +your migrations and see what happens. + +[I don't see anything about SQL nor versioned data-types here] +Whether you are modifying an SQL database or moving any other kind of +bits around, @moto@ doesn't care about those details. You can write all the SQL +you want inside your migration, using the SQL-supporting library of your choice, +or version your datatypes as well. + +[Is this ready for production?] +Migrations are a tricky business, and this is a very early release of @moto@, so +use at your own risk. + +[Is the API stable?] +No, and it will never be. We will always break the API as necessary if it allows +us offer better safety and experience. However, we understand the subtle nature +of the projects relying on @moto@ an we will take the necessary steps to ensure +a positive and maintainable experience over time. Please see +the [changelog](https://hackage.haskell.org/package/moto/changelog) to +understand differences between versions and learn about any necessary changes +you'll need to make. In a @moto@ version @x.y.z@, we will always increase one of +@x@ or @y@ whenever a new version introduces backwards incompatible changes. + +[I have more questions!] +We have more answers. Just [ask](https://gitlab.com/k0001/moto/issues). + +-} +#include "cli_help.docs" + diff --git a/lib/Moto/File.hs b/lib/Moto/File.hs new file mode 100644 --- /dev/null +++ b/lib/Moto/File.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | This module exports a 'I.Store' that stores 'I.Backup' data as files in the +-- filesystem, as well as a 'I.Registry' backed by a file in the filesystem and +-- related tools. +-- +-- Please import as: +-- +-- @ +-- import qualified "Moto.File" +-- @ +module Moto.File + ( -- * Registry + registryConf + , withRegistry + + , -- * Store + store + ) where + +import Control.Applicative (empty) +import qualified Control.Exception.Safe as Ex +import qualified Control.Monad.Trans.State.Strict as S +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans (lift) +import qualified Data.Aeson as Ae +import qualified Data.Attoparsec.ByteString.Char8 as A8 +import qualified Data.ByteString as B +import qualified Data.ByteString.Builder as BB +import qualified Data.Char as Char +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import GHC.IO.Handle as IO (LockMode(ExclusiveLock), hLock) +import qualified Pipes as P +import qualified Pipes.Attoparsec as Pa +import qualified Pipes.ByteString as Pb +import qualified System.Directory as Dir +import System.FilePath (()) +import qualified System.IO as IO +import qualified System.IO.Error as IO + +import qualified Moto.Internal as I +import qualified Moto.Internal.Cli as IC +import qualified Moto.Registry as R + +-------------------------------------------------------------------------------- + +-- | Command-line configuration for a 'I.Registry' stored as a file in the +-- 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_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 + } + +-- | 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 + -- ^ File where to store the registry logs. + -- + -- An exclusive lock will be set on the this file (see 'IO.hLock'), which will + -- stay open until this function returns. This is to prevent other programs to + -- interact with this file while this program is running. + -> (I.Registry -> m a) + -> m a +withRegistry fp = + withRegistryCustom renderLogLine parseLogLine fp + +-- | Obtain a 'I.Registry' backed by an append-only file storage as described by +-- 'R.newAppendOnlyRegistry'. +withRegistryCustom + :: (MonadIO m, Ex.MonadMask m) + => (I.Log -> BB.Builder) + -- ^ Render a single 'I.Log'. Be sure to add a trailing newline or similar if + -- necessary, in order to separate one 'I.Log' entry from the next. + -> 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. + -> IO.FilePath + -- ^ File where to store the registry logs. + -- + -- An exclusive lock will be set on the this file (see 'IO.hLock'), which will + -- stay open until this function returns. This is to prevent other programs to + -- interact with this file while this program is running. + -> (I.Registry -> m a) + -> m a +withRegistryCustom render parser fp k = do + Ex.bracket + (liftIO $ do + h <- IO.openBinaryFile fp IO.ReadWriteMode + IO.hLock h IO.ExclusiveLock + pure h) + (liftIO . IO.hClose) + (\h -> k =<< liftIO (do + state0 <- do + ea <- flip S.runStateT I.emptyState $ P.runEffect $ do + P.for (Pa.parsed parser (Pb.fromHandle h)) $ \l -> do + s0 <- lift S.get + lift (either Ex.throwM S.put (I.updateState s0 l)) + case ea of + (Left (e,_), _) -> Ex.throwM (I.Err_MalformedLog (show e)) + (Right _, x) -> pure x + R.newAppendOnlyRegistry state0 $ \log' -> do + BB.hPutBuilder h (render log') + IO.hFlush h)) + +-------------------------------------------------------------------------------- + +-- Renders a 'I.Log' as a line of text with a trailing new line. +-- +-- Use 'parseLogLine' to undo this rendering. +renderLogLine :: I.Log -> BB.Builder +renderLogLine l = Ae.fromEncoding (Ae.toEncoding (LogV1 l)) <> "\n" + +-- Parses a 'I.Log' from a line of text rendered by 'renderLogLine'. +-- +-- Any leading or trailing newlines are consumed and skipped. +parseLogLine :: A8.Parser I.Log +parseLogLine = do + _ <- A8.skipWhile (== '\n') + s <- A8.takeWhile (/= '\n') + _ <- A8.skipWhile (== '\n') + case Ae.decodeStrict s of + Just (LogV1 l) -> pure l + Nothing -> fail "Malformed Log" + +-- | Wrapper around 'I.Log' used for serialization purposes, so that we don't +-- expose a 'Ae.ToJSON' instance for 'I.Log'. +newtype LogV1 = LogV1 I.Log + +instance Ae.ToJSON LogV1 where + toJSON (LogV1 l) = case l of + I.Log_Commit t -> Ae.toJSON $ Ae.object + [ "action" Ae..= ("commit" :: T.Text) + , "timestamp" Ae..= t ] + I.Log_Abort t -> Ae.toJSON $ Ae.object + [ "action" Ae..= ("abort" :: T.Text) + , "timestamp" Ae..= t ] + I.Log_Prepare t (I.MigId m) d -> Ae.toJSON $ Ae.object + [ "action" Ae..= ("prepare" :: T.Text) + , "timestamp" Ae..= t + , "migration" Ae..= m + , "direction" Ae..= (I.direction "backwards" "forwards" d :: T.Text) ] + +instance Ae.FromJSON LogV1 where + parseJSON = Ae.withObject "Log" $ \o -> do + a :: T.Text <- o Ae..: "action" + fmap LogV1 $ case a of + "commit" -> I.Log_Commit + <$> (o Ae..: "timestamp") + "abort" -> I.Log_Abort + <$> (o Ae..: "timestamp") + "prepare" -> I.Log_Prepare + <$> (o Ae..: "timestamp") + <*> fmap I.MigId (o Ae..: "migration") + <*> (o Ae..: "direction" >>= \case + "backwards" -> pure I.Backwards + "forwards" -> pure I.Forwards + (_ :: T.Text) -> empty) + _ -> empty + +-------------------------------------------------------------------------------- + +-- | A 'Store' that keeps data stored as files (one per 'MigId') in a filesystem +-- directory. +-- +-- For maximum memory consumption efficiency, the data is written and read in a +-- streaming fasion using a 'P.Producer'. +store + :: FilePath -- ^ Path to a directory where the files are or will be stored. + -> I.Store (P.Producer B.ByteString IO ()) +store fp_dir = I.Store + { I.store_save = \_ mId x -> do + Dir.createDirectoryIfMissing True fp_dir + Ex.bracket + (IO.openBinaryFile (fp mId) IO.WriteMode) + IO.hClose + (\h -> do + IO.hSetFileSize h 0 + IO.hSetBuffering h (IO.BlockBuffering Nothing) + P.runEffect (x P.>-> Pb.toHandle h)) + , I.store_load = \_ mId k -> Ex.bracket + (IO.openBinaryFile (fp mId) IO.ReadMode) + IO.hClose + (k . Pb.fromHandle) + , I.store_delete = \_ mId -> Ex.catch + (Dir.removeFile (fp mId)) + (\case e | IO.isDoesNotExistError e -> pure () + | otherwise -> Ex.throwM e) + } + where + fp :: I.MigId -> FilePath + fp = \mId -> fp_dir TL.unpack (TL.decodeUtf8 (I.migId_sha1Hex mId)) <> + "_" <> escapeFileName (T.unpack (I.unMigId mId)) + escapeFileName :: String -> FilePath + escapeFileName = map (\case c | Char.isAscii c && Char.isAlphaNum c -> c + | otherwise -> '_') + +{- TODO save this to a README file + readme :: BB.Builder + readme = "This directory contains backups made by Moto.File.store.\n\ + \\n\ + \ https://hackage.haskell.org/package/moto/docs/Moto-File.html#v:store\n\n\ + \\n\ + \To backup these backups, it is sufficient to copy the contents\n\ + \of this directory, preserving the file names." +-} diff --git a/lib/Moto/Internal.hs b/lib/Moto/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Moto/Internal.hs @@ -0,0 +1,1063 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_HADDOCK hide #-} + +module Moto.Internal + ( run + + -- * Describing migrations + , Mig(Mig, Gone) + , UMig(UMig, UGone) + -- ** Backup + , Backup(Backup) + -- ** Change + , Change(Change) + -- ** Store + , Store(Store, store_save, store_load, store_delete) + , mapStore + + -- *** Direction + , Direction(Backwards, Forwards) + , direction + , opposite + + -- *** Mode + , Mode(Normal, Recovery) + + -- * Execution plan + , Migs(Migs) + , migs + , (Moto.Internal.*) + , DAG + , lookupMigs + + , Target(..) + + , Plan(Plan) + , mkPlan + , getPlan + + , MigId(MigId, unMigId) + , migId + , migId_sha1Hex + + -- * Registry + , Registry(..) + , cleanRegistry + + -- * State + , State + , state_status + , state_committed + , emptyState + , updateState + , Status(..) + , Log(..) + + -- * Errors + , Err_Run(..) + , Err_Plan(..) + , Err_Prepare(..) + , Err_Abort(..) + , Err_Commit(..) + , Err_UpdateState(..) + , Err_MalformedLog(..) + ) where + +import Control.Arrow ((&&&)) +import Control.Monad (when) +import qualified Control.Exception.Safe as Ex +import Control.Monad.IO.Class (MonadIO) +import qualified Crypto.Hash.SHA1 as SHA1 +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Builder.Prim as BBP +import qualified Data.ByteString.Lazy as BL +import Data.Foldable (for_) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import qualified Data.List as List +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes) +import Data.Proxy (Proxy(..)) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String (IsString, fromString) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Time as Time +import qualified Df1 +import qualified Di.Df1 as Di +import GHC.Exts (Constraint) +import GHC.TypeLits (KnownSymbol, symbolVal, Symbol) +import qualified GHC.TypeLits as GHC +import qualified System.Mem + +-------------------------------------------------------------------------------- + +-- | The directed acyclic graph of migrations available for execution. +-- +-- Construct using 'Moto.migs' and 'Moto.*'. For example: +-- +-- @ +-- 'Moto.migs' 'Moto.*' someMig 'Moto.*' anotherMig 'Moto.*' ... +-- @ +newtype Migs (graph :: [(Symbol, [Symbol])]) + = Migs (Map MigId (Set MigId, UMig)) + -- ^ Unsafe constructor. A map from 'MigId's, to the 'UMig' identfified by it, + -- as well as a set of all of the 'MigId's that must be executed before it. + +-- | An empty, yet valid, graph of migrations. +-- +-- You can use 'Moto.migs' as a starting point for constructing bigger +-- migrations graphs. For example: +-- +-- @ +-- 'Moto.migs' 'Moto.*' someMig 'Moto.*' anotherMig 'Moto.*' ... +-- @ +migs :: Migs '[] +migs = Migs Map.empty + +-- | Add a new migration with an unique identifier @id@ depending on each of +-- @deps@ to a graph of migrations @graph@. +-- +-- The 'DAG' constraint guarantees that the result is a directed acyclic graph. +-- +-- To create a 'Migs' from scratch, use 'Moto.*' in combination with +-- 'Moto.migs'. For example: +-- +-- @ +-- 'Moto.migs' 'Moto.*' someMig 'Moto.*' anotherMig 'Moto.*' ... +-- @ +infixl 7 * +(*) :: DAG id deps graph + => Migs graph + -> Mig id deps + -- ^ @id@ must not be present in @graph@. + -- + -- All of @deps@ must be present in @graph@. + -> Migs ('(id, deps) ': graph) +(*) (Migs m) (mig :: Mig id deps) = + let umig = case mig of + Mig s b c -> UMig (pimpStore s) (pimpBackup b) (pimpChange c) + Gone -> UGone + in Migs (Map.insert (migId (Proxy :: Proxy id)) + (Set.fromList (migIds (Proxy :: Proxy deps)), umig) + m) + +-- | This 'Constraint' is automatically satisfied by an @id@ that is absent from +-- @graph@, and @deps@ listing identifiers present in the given @graph@. +-- +-- In other words, 'DAG' effectively forces 'Moto.*' to always build Directed +-- Acyclic Graphs (hence the name). +-- +-- @ +-- 'DAG' id deps graph :: 'Constraint' +-- @ +type DAG id deps graph = DAG_ id deps graph + +-- | We don't export this to keep the haddocks clean. +type DAG_ (id :: Symbol) (deps :: [Symbol]) (graph :: [(Symbol, [Symbol])]) + = ( NotMember id deps + , NotMember id (Ids graph) + , Subset deps (Ids graph) + -- The following two constraints have nothing to do with DAGs, but by + -- putting them here we can keep the type of 'Moto.*' less noisy. + , KnownSymbol id + , KnownSymbols deps + ) + +-- | Obtain a term-level representation of a migration identifier from its +-- type-level representation as a 'Symbol' (as it appears in the @id@ type +-- parameter to 'Mig'). +migId :: KnownSymbol id => Proxy id -> MigId +migId = MigId . fromString . symbolVal + +-- | Obtain a term-level representation of some migration identifiers from their +-- type-level representation as @['Symbol']@ (as they appear in the @id@ type +-- parameter to 'Mig'). +migIds :: KnownSymbols ids => Proxy ids -> [MigId] +migIds = map (MigId . fromString) . symbolVals + +lookupMigs :: MigId -> Migs graph -> Maybe (Set MigId, UMig) +lookupMigs mId (Migs m) = Map.lookup mId m + +class All KnownSymbol ids => KnownSymbols (ids :: [Symbol]) where + symbolVals :: Proxy ids -> [String] +instance KnownSymbols '[] where + symbolVals _ = [] +instance (KnownSymbol id, KnownSymbols ids) => KnownSymbols (id ': ids) where + symbolVals (_ :: Proxy (id ': ids)) + = symbolVal (Proxy :: Proxy id) + : symbolVals (Proxy :: Proxy ids) + +type family All (f :: k -> Constraint) (as :: [k]) :: Constraint where + All _ '[] = () + All f (a ': as) = (f a, All f as) + +type family Subset (small :: [k]) (big :: [k]) :: Constraint where + Subset '[] _ = () + Subset (a ': as) bs = (Member a bs, Subset as bs) + +type family Ids (abs :: [(ka,kb)]) :: [ka] where + Ids '[] = '[] + Ids ( '(a,_) ': abs ) = (a ': Ids abs) + +type Member (a :: k) (as :: [k]) = Member_ a as (IsMember a as) +type family Member_ (a :: k) (as :: [k]) (found :: Bool) :: Constraint where + Member_ _ _ 'True = () + Member_ a as 'False = GHC.TypeError + ('GHC.ShowType a 'GHC.:<>: + 'GHC.Text " is not a member of " 'GHC.:<>: + 'GHC.ShowType as) + +type NotMember (a :: k) (as :: [k]) = NotMember_ a as (IsMember a as) +type family NotMember_ (a :: k) (as :: [k]) (found :: Bool) :: Constraint where + NotMember_ _ _ 'False = () + NotMember_ a as 'True = GHC.TypeError + ('GHC.ShowType a 'GHC.:<>: + 'GHC.Text " is a member of " 'GHC.:<>: + 'GHC.ShowType as) + +type family IsMember (a :: k) (as :: [k]) :: Bool where + IsMember _ '[] = 'False + IsMember a (a ': _) = 'True + IsMember a (b ': as) = IsMember a as + +-------------------------------------------------------------------------------- + +-- | Direction in which a migration runs. +-- +-- Running it 'Forwards' conveys the idea of “advancing” or “improving” your +-- state over time somehow, while running it 'Backwards' conveys the idea of +-- undoing all the changes that the migration does when going 'Forwards'. +data Direction = Backwards | Forwards + deriving stock (Eq, Ord, Show, Read) + +-- | Case analysis for 'Direction'. Evaluate to the first @a@ in case it is +-- 'Backwards', otherwise to the second @a@. +direction :: a -> a -> Direction -> a +direction bw fw = \case { Backwards -> bw; Forwards -> fw } + +-- | The opposite of the given direction. +opposite :: Direction -> Direction +opposite = direction Forwards Backwards + +instance Df1.ToValue Direction where + value = direction "backwards" "forwards" + +-------------------------------------------------------------------------------- + +-- | A single side-effecting migration uniquely identfied by @id@ and depending +-- on all of the migrations listed in @deps@. +-- +-- These migration identifiers that appear as type-level 'Symbol' here, will be +-- of type 'MigId' when represented at the type level. +data Mig (id :: Symbol) (deps :: [Symbol]) where + -- | Description of the different phashes that make up this migration + -- identified by @id@, depending on others identified by @deps@. + Mig :: Store x + -- ^ How to save and load data obtained during the 'Backup' phase when + -- necessary. + -- + -- Please note that you can reuse this same 'Store' across different + -- migrations. + -- + -- Any stored data will remain in the 'Store' until it is not necessary + -- anymore (but it can be manually deleted if desired, at your own risk). + -- + -- Please refer to 'Store' for further documentation. + -> Backup x + -- ^ Backup phase of this migration + -- + -- This phase is executed only once when trying to run the migration + -- 'Forwards' for the first time. + -- + -- Please refer to 'Backup' for further documentation. + -> Change x + -- ^ Change phase of this migration. + -- + -- This phase is executed both when going 'Forwards' and 'Backwards'. Here + -- we alter the environment somehow while having access to the @x@ data + -- obtained in the 'Backup' phase. + -- + -- Please refer to 'Change' for further documentation. + -> Mig id deps + + -- | This constructor conveys the idea that code for a particular migration is + -- gone, while still communicating the dependencies that this migration used + -- to have so that we don't change the past dependency graph over time, which + -- would make it impossible for @moto@ to operate reliably. + Gone :: Mig id deps + +-- | Internal. Like 'Mig', but without the type level data. +data UMig where + UGone :: UMig + UMig :: Store x -> Backup x -> Change x -> UMig + +-------------------------------------------------------------------------------- + +-- | The backup phase of a migration, collecting some data @x@ for backup in a +-- 'Store'. +-- +-- Here we interact with the environment in a /read-only/ manner, collecting all +-- data that may be destroyed by a subsequent 'Change' phase for backup in some +-- 'Store'. +-- +-- This data will be crucial for automatic recovery in case the 'Change' phase +-- of the 'Mig' that uses this 'Backup' fails, or in case we manually decide to +-- undo said 'Mig' at a later time. Thus, when deciding what data to return as +-- @x@, please consider those scenarios. +-- +-- The actual storing of the backup data is performed by the 'Store' that is +-- used as part of the same 'Mig'. That is, we don't physically store +-- the data within this 'Backup', all we do is return it as @x@. +-- +-- Please keep in mind that depending on your environment, @x@ could be really +-- large, so in those situations it best for @x@ to be some kind of /stream/ +-- (e.g., a 'Pipes.Producer'). +-- +-- Notice that @x@ is returned in a continuation-passing style so that we can +-- do proper resource deallocation after @x@ has been consumed. Using @x@ +-- outside of this intended scope is undefined. +data Backup (x :: *) = Backup (forall r. Di.Df1 -> (x -> IO r) -> IO r) + +-- | 'Backup' is covariant with @x@. +instance Functor Backup where + fmap f (Backup g) = Backup (\di k -> g di (k . f)) + +-- | Add some extra logging to a 'Backup'. +pimpBackup :: Backup x -> Backup x +pimpBackup (Backup f) = Backup $ \di0 k -> do + let di1 = Di.push "backup" di0 + Di.debug di1 "Running..." + r <- logException di1 (f di1 k) + Di.debug di1 "Ran." + -- Bonus track: Run GC to ensure we don't keep @x@ in memory. + System.Mem.performMajorGC + pure r + +-------------------------------------------------------------------------------- + +-- | A 'Store' describes how to save, load and delete the @x@ data obtained by +-- a 'Backup'. +-- +-- This @x@ data is used later by the 'Change' phase. +-- +-- A single 'Store' might be used by different 'Mig's. +-- +-- Hint: 'Moto.File.store' from the "Moto.File" module is a 'Store' you can use +-- that's distributed with the main @moto@ library. +data Store (x :: *) = Store + { store_save :: Di.Df1 -> MigId -> x -> IO () + -- ^ Saves the @x@ data originating from a 'Backup' step for a migration + -- identified by 'MigId', __overwriting__ previous data if any. + -- + -- If it's not possible to save the @x@ data, then this function must + -- fail with some exception. + -- + -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and + -- "Di.Df1"), but please don't log exceptions nor messages telling whether + -- this function succeeds or fails, since this library already does that for + -- you. + , store_load :: forall r. Di.Df1 -> MigId -> (x -> IO r) -> IO r + -- ^ Load the data previously saved by 'store_save', for a migration + -- identified by the given 'MigId'. + -- + -- Notice that @x@ is returned in a continuation-passing style so that we + -- can do proper resource deallocation after @x@ has been consumed. Using + -- @x@ outside of this intended scope is undefined. + -- + -- If it's was not possible to load the @x@ data, then this function must + -- fail with some exception. + -- + -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and + -- "Di.Df1"), but please don't log exceptions nor messages telling whether + -- this function succeeds or fails, since this library already does that for + -- you. + , store_delete :: Di.Df1 -> MigId -> IO () + -- ^ Delete the data previously saved by 'store_save', if any. for a + -- migration identified by the given 'MigId'. + -- + -- If it's there was no data to delete, then this function should return + -- @()@. On the other hand, if its acceptable to throw exceptions when + -- it's not possible to access the underlying storage. + -- + -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and + -- "Di.Df1"), but please don't log exceptions nor messages telling whether + -- this function succeeds or fails, since this library already does that for + -- you. + } + +-- | Given isomorpisms between @a@ and @b@, obtain an function from +-- @'Store' a@ and @'Store' b@. +-- +-- A @'Store' x@ is both covariant and contravariant with @x@. +-- +-- This function respects the functor laws. +mapStore + :: (b -> a) -- ^ Isomorphism from @b@ to @a@. + -> (a -> b) -- ^ Isomorphism from @a@ to @b@. + -> Store a + -> Store b +mapStore ba ab = \(Store s l d) -> + Store (\di mId b -> s di mId (ba b)) + (\di mId kb -> l di mId (kb . ab)) + d + +-- | Add some extra logging to a 'Store'. +pimpStore :: Store a -> Store a +pimpStore sto = sto + { store_save = \di0 mId x -> do + let di1 = Di.push "save" di0 + Di.debug di1 "Saving recovery data..." + logException di1 (store_save sto di1 mId x) + Di.debug di1 "Saved." + , store_load = \di0 mId k -> do + let di1 = Di.push "load" di0 + Di.debug di1 "Loading recovery data..." + r <- logException di1 (store_load sto di1 mId k) + 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..." + r <- logException di1 (store_delete sto di1 mId) + Di.info di1 "Deleted." + pure r + } + +-------------------------------------------------------------------------------- + +-- | Execution mode of a migration, describing why and how a 'Change' migration +-- is being run. +data Mode + = Normal + -- ^ The migration is being run as requested by the user, in the requested + -- 'Direction'. Every previous step until now has run successfully. You can + -- assume a clean starting point. + -- + -- If running the migration in 'Normal' mode fails, the same migration will be + -- run again in 'Recovery' mode /in the opposite 'Direction'/ as a way to + -- undo any partial changes and go back to having a clean state. This recovery + -- mechanism survives through different program executions, so even if a + -- failure when running a migration in 'Normal' mode causes the whole program + -- to crash, the corresponding 'Recovery' mode can still be run from the + -- command line program. In fact, /moto/ will refuse making any other changes + -- until this matter is sorted. For this reason, if let a 'Change' being + -- executed in 'Normal' mode fails, it is always preferrable to let that + -- exception propagate, and instead focus on writing any mitigating code as + -- part of the 'Recovery' mode. + | Recovery + -- ^ An attempt to run the migration in the 'Direction' requested by + -- the user has failed, so as a recovery meassure we are running the same + -- migration in the opposite direction now. You can't make assumptions + -- about the starting point, because running the migration in the desired + -- 'Direction' failed somewhere in the middle of process. Please rely on the + -- 'Backup' data you obtained before to decide how to correct the situation. + -- + -- Ultimately, running a migration in 'Recovery' mode in a particular + -- 'Direction' needs to accomplish the same outcome as running it in 'Normal' + -- mode in that same 'Direction'. + -- + -- If running a migration in 'Recovery' mode fails, then the program will exit + -- and the migrations registry will be left in a dirty state, from which you + -- can manually attempt to initiate a recovery again. At this point, reading + -- the output logs and understanding what when wrong will be very useful: + -- Maybe the migration failed because of a temporary phenomenon such as a + -- network connectivity issue, in which simply retrying later will solve it, + -- or maybe it failed because of a bug in the migration implementation, in + -- which case logs will be crucial to understand how to change the migrations + -- code in order to fix it. + +instance Df1.ToValue Mode where + value = \case + Normal -> "normal" + Recovery -> "recovery" + +-------------------------------------------------------------------------------- + +-- | A 'Change' describes how a 'Mig' /changes/ the environment. +-- +-- The given function will be called when running the migration both in +-- 'Forwards' or 'Backwards' direction. +-- +-- In both cases, we have access to the original 'Backup' data while +-- running the migration, which implies that even “irrecoverable” migrations +-- that delete things when going 'Forwards' can be undone by relying on data +-- from the 'Backup'. +-- +-- The given 'Mode' specifies why and how this 'Change' is being run. +-- Particularly, it describes the assumptions you can make about the +-- environment, which is very important if something goes wrong. Please refer to +-- the documentation for 'Mode' for a better understanding. +-- +-- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and +-- "Di.Df1"), but please don't log exceptions nor messages telling whether this +-- function as a whole succeeds or fails, since this library already does that +-- for you. However, for debugging purposes in case something goes wrong, it is +-- __very important__ that you log what your 'Change' is doing, particularly if +-- the changes themselves are not atomic. Please see the documentation for +-- 'Recovery' to understand what can be helpful. +-- +-- After a successful 'Backwards' execution of this 'Change', any recovery data +-- associated with the 'Mig' previously obtained during the 'Backup' phase can +-- be deleted from its 'Store', since it is not necessary anymore. This will +-- happen automatically if you request so when instructing /moto/ to run your +-- migrations. +newtype Change x = Change (Di.Df1 -> Direction -> Mode -> x -> IO ()) + +-- | 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..." + logException di1 (f di1 d m x) + <* Di.info di1 "Ran." + +-------------------------------------------------------------------------------- + +-- | A term-level identifier for a 'Mig'. +newtype MigId = MigId { unMigId :: T.Text } + deriving newtype (Eq, Ord, Show, IsString, Read, Df1.ToValue) + +-- | Hexadecimal representation of the SHA1 hash for this 'MigId'. +migId_sha1Hex :: MigId -> BL.ByteString +migId_sha1Hex + = BB.toLazyByteString + . BBP.primMapByteStringFixed BBP.word8HexFixed + . SHA1.hash . T.encodeUtf8 . unMigId + +-------------------------------------------------------------------------------- + +-- | The target to which to migrate. +data Target = Target Direction (Set MigId) + deriving (Eq, Show) + +-------------------------------------------------------------------------------- + +-- | A migrations execution plan. +data Plan = Plan Direction (Seq (MigId, UMig)) + -- ^ Unsafe constructor. The migrations are always listed in + -- 'Forwards' order, even if intended to be run 'Backwards'. + +-- | Obtain a migrations execution 'Plan' if possible. +mkPlan + :: Migs graph -- ^ Avaiable migrations. + -> [MigId] + -- ^ Migration history represented as the 'MigId's that have already been + -- run, in the 'Forwards' order they have been run. + -> Target -- ^ Migration target. + -> Either Err_Plan Plan +mkPlan (Migs []) [] (Target d []) = Right (Plan d []) +mkPlan (Migs m0) ran (Target d req0) = do + -- If 'req0' mentions an unknown, we abort. + case Set.difference req0 (Map.keysSet m0) of + [] -> pure () + req1 -> Left (Err_Plan_TargetsNotFound req1) + -- Find all topological orders. + let topos0 :: [[MigId]] + topos0 = topos (fmap fst m0) + -- Find the topological orders that share the 'ran' prefix. + case catMaybes (List.stripPrefix ran <$> topos0) :: [[MigId]] of + [] -> Left Err_Plan_HistoryUnknown + topos1 -> do + -- Find the topological order to use. + topo :: [MigId] <- direction (bw topos0) (fw topos1) d + -- Add 'UMig' data and return. + Right (Plan d (Seq.fromList (map (id &&& getUMig) topo))) + where + getUMig :: MigId -> UMig + getUMig = \mId -> snd (m0 Map.! mId) + isGone :: MigId -> Bool + isGone = \mId -> case getUMig mId of { UGone -> True; _ -> False } + fw :: [[MigId]] -> Either Err_Plan [MigId] + fw [] = error "fw: unreachable" + fw topos0@(topo0:_) = case req0 of + [] -> + -- No specific migration was requested, so we run everything not gone. + case filter (all (not . isGone)) topos0 of + [] -> Left (Err_Plan_TargetsGone (Set.fromList (filter isGone topo0))) + (topo:_) -> Right topo + _ -> + -- We exclude from 'req0' whatever has been run already. + case Set.difference req0 (Set.fromList ran) of + [] -> Right [] -- Nothing to do. All of 'req0' has been run already. + req1 -> do + -- Our final topological order will be a permutation of 'req1'. + let perms :: [[MigId]] = List.permutations (Set.toList req1) + -- We will only run as many migrations as 'req1' asks, so we + -- discard the rest to keep things simple below. + let topos1 :: [[MigId]] = List.take (Set.size req1) <$> topos0 + -- Select topological orders that matches one of 'perms', if any. + case filter (\topo -> any (== topo) perms) topos1 of + [] -> Left Err_Plan_TargetImpossible + topos2@(topo2:_) -> do + -- Select a topological order with migrations not gone. + case List.find (all (not . isGone)) topos2 of + Just topo -> Right topo + Nothing -> Left (Err_Plan_TargetsGone + (Set.fromList (filter isGone topo2))) + bw :: [[MigId]] -> Either Err_Plan [MigId] + bw [] = error "bw: unreachable" + bw topos0@(_:_) = case req0 of + [] -> + -- No specific migration was requested, so we undo everything not gone. + case filter isGone ran of + [] -> Right ran + xs -> Left (Err_Plan_TargetsGone (Set.fromList xs)) + _ -> + -- We exclude from 'req0' whatever hasn't been run already. + case Set.intersection req0 (Set.fromList ran) of + [] -> Right [] -- Nothing to do. None of 'req0' has run yet. + req1 -> do + -- Our final topological order will be a permutation of 'req1'. + let perms :: [[MigId]] = List.permutations (Set.toList req1) + -- We remove the prefix or ran non-removeable migrations. + let topos1 :: [[MigId]] + topos1 = List.drop (length ran - Set.size req1) <$> topos0 + -- We will only undo as many migrations as 'req1' asks, so we + -- discard the rest to keep things simple below. + let topos2 :: [[MigId]] = List.take (Set.size req1) <$> topos1 + -- Select a topological order that matches one of 'perms', if any. + case filter (\topo -> any (== topo) perms) topos2 of + [] -> Left Err_Plan_TargetImpossible + topos3@(topo3:_) -> + -- Select a topological order with migrations not gone. + case List.find (all (not . isGone)) topos3 of + -- Just topo -> Right (List.reverse topo) -- In forwards order. + Just topo -> Right topo + Nothing -> Left (Err_Plan_TargetsGone + (Set.fromList (filter isGone topo3))) + +-- | Like 'mkPlan', but gets the history of ran migrations directly from the +-- 'Registry'. +getPlan + :: Di.Df1 + -> Migs graph -- ^ Avaiable migrations. + -> Registry -- ^ Registry representing the current migration history. + -> Target -- ^ Migration target. + -> IO (Either Err_Plan Plan) +getPlan di0 migs_ reg tgt = do + state <- registry_state reg di0 + let ran = map fst (state_committed state) + pure (mkPlan migs_ ran tgt) + +-------------------------------------------------------------------------------- + +-- | A 'State' can be described as a list of 'Log's ordered chronologically (see +-- 'updateState'). +data Log + = Log_Prepare Time.UTCTime MigId Direction + -- ^ A particular migration identified by 'MigId' is going to be executed in + -- the specified 'Direction'. + -- + -- This is the first commit in the two-phase commit approach to registering a + -- migration as executed. + -- + -- The time when this log entry was created is mentioned as well. + | Log_Commit Time.UTCTime + -- ^ The migration most recently prepared for execution with 'Log_Prepare' is + -- being committed. + -- + -- This is the second commit in the two-phase commit approach to registering a + -- migration as executed. + -- + -- The time when this log entry was created is mentioned as well. + | Log_Abort Time.UTCTime + -- ^ The migration most recently prepared for execution with 'Log_Prepare' is + -- being aborted. + -- + -- This undoes the first commit in the two-phase commit approach to + -- registering a migration as executed. + -- + -- The time when this log entry was created is mentioned as well. + deriving (Eq, Show, Read) + +-------------------------------------------------------------------------------- + +-- | Registry status. +data Status + = Dirty MigId Direction + -- ^ There is an uncommitted migration being run in the specified direction in + -- the registry. + | Clean + -- ^ There are no uncommitted migrations in the registry. + deriving (Eq, Show) + +-------------------------------------------------------------------------------- + +-- | Internal 'State' of a 'Registry'. +-- +-- Create with 'emptyState' and 'updateState'. +data State = State Status [(MigId, Time.UTCTime)] + deriving (Eq, Show) + +-- | Whether the registry is currently 'Dirty' or 'Clean'. +state_status :: State -> Status +state_status (State x _) = x + +-- | Committed migrations, chronologically ordered, with the most recently +-- applied first last. +state_committed :: State -> [(MigId, Time.UTCTime)] +state_committed (State _ x) = List.reverse x + +-- | A clean 'State' without any committed migrations. +emptyState :: State +emptyState = State Clean [] + +-- | Modify a 'State' by applying a 'Log' to it, if possible. +-- +-- Use 'emptyState' as the initial state. +-- +-- @ +-- 'Data.Foldable.foldlM' 'updateState' 'emptyState' +-- :: 'Foldable' t +-- => t 'Log' +-- -> 'Either' 'Err_UpdateState' 'State' +-- @ +updateState :: State -> Log -> Either Err_UpdateState State +updateState (State Clean xs) (Log_Prepare _ mId Forwards) + | elem mId (map fst xs) = Left (Err_UpdateState_Duplicate mId) + | otherwise = Right (State (Dirty mId Forwards) xs) +updateState (State Clean xs) (Log_Prepare _ mId Backwards) + | elem mId (map fst xs) = Right (State (Dirty mId Backwards) xs) + | otherwise = Left (Err_UpdateState_NotFound mId) +updateState (State Clean _) _ + = Left Err_UpdateState_Clean +updateState (State (Dirty mId Forwards) xs) (Log_Commit t) + = Right (State Clean ((mId, t) : xs)) +updateState (State (Dirty _ Forwards) xs) (Log_Abort _) + = Right (State Clean xs) +updateState (State (Dirty mId Backwards) xs) (Log_Commit _) + = Right (State Clean (filter (\(mId', _) -> mId' /= mId) xs)) +updateState (State (Dirty _ Backwards) xs) (Log_Abort _) + = Right (State Clean xs) +updateState (State (Dirty _ _) _) _ + = Left Err_UpdateState_Dirty + +-------------------------------------------------------------------------------- + +-- | 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 () +cleanRegistry di0 migs_ reg0 = do + let reg = mkRegistrish reg0 + 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." + case lookupMigs mId migs_ of + Nothing -> do + 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." + Ex.throwM (Err_CleanRegistry_MigGone mId) + Just (_, UMig (st :: Store x) _ (Change ch)) -> do + store_load st di1 mId $ \x -> do + Ex.uninterruptibleMask $ \restore -> do + restore (ch di1 (opposite d1) Recovery x) + registrish_abort reg di1 mId d1 + +-------------------------------------------------------------------------------- + +run :: Di.Df1 -> Registry -> Plan -> IO () +run di0 reg0 (Plan d0 s0) = do + let reg = mkRegistrish reg0 + fmap state_status (registrish_state reg di0) >>= \case + Dirty mId d1 -> Ex.throwM (Err_Run_Dirty mId d1) + 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 + when (d0 == Forwards) $ do + ba di1 (store_save st di1 mId) + -- If 'ioDelete' is 'True' when we finish processing our migration, + -- then we will delete the data for 'mId' from the 'Store'. + ioDelete :: IORef Bool <- newIORef False + -- We run 'store_load' even if we already know what the recovery data + -- is, to ensure that it can be loaded later in case of catastrophe. + Ex.finally + (store_load st di1 mId $ \x -> do + registrish_prepare reg di1 mId d0 + Ex.uninterruptibleMask $ \restore -> do + Ex.onException + (restore (ch di1 d0 Normal x)) + (do ch di1 (opposite d0) Recovery x + registrish_abort reg di1 mId d0 + when (d0 == Forwards) + (writeIORef ioDelete True)) + registrish_commit reg di1 mId d0 + when (d0 == Backwards) + (writeIORef ioDelete True)) + (readIORef ioDelete >>= \case + True -> store_delete st di1 mId + False -> pure ()) + +-------------------------------------------------------------------------------- + +-- | Migrations registry, keeping track of what migrations have been run so far, +-- as well as those that are running. +-- +-- Consider using 'Moto.Registry.newAppendOnlyRegistry' as an easy way to +-- create a 'Registry'. +data Registry = Registry + { registry_state :: Di.Df1 -> IO State + -- ^ Current registry state. + -- + -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and + -- "Di.Df1"), but please don't log exceptions nor messages telling whether + -- this function succeeds or fails, since this library already does that for + -- you. + , registry_prepare :: Di.Df1 -> MigId -> Direction + -> IO (Either Err_Prepare Log) + -- ^ Register a new pending change in the registry. + -- + -- Returns the 'Log_Prepare' that describes this change to the registry. + -- + -- * This is the first commit in the two-phase commit mechanism to + -- registering migrations as executed ('registry_commit' is the second). + -- + -- * If 'Forwards', then the given 'MigId' shall be recorded in the + -- registry as fully exceuted after a subsequent 'registry_commit'. If the + -- given 'MigId' is already present and committed in the registry, then + -- 'registry_prepare' shall return 'Err_Prepare_Duplicate'. + -- + -- * If 'Backwards', then the given 'MigId', which must be already present + -- and committed to the registry, will be removed from the list of currently + -- committed migtrations after a subsequent 'registry_commit'. If the + -- 'MigId' is not already present and committed in the registry, then + -- 'registry_prepare' shall return 'Err_Prepare_NotFound'. + -- + -- * If there is already an uncommitted migration (that is, if the status is + -- 'Dirty'), then 'Err_Prepare_Dirty' shall be returned. This constraint + -- implies that it is impossible to have more than one pending change at a + -- time. + -- + -- * After a successful call to 'registry_prepare', the registry will be + -- left in a 'Dirty' status until one of 'registry_commit' or + -- 'registry_abort' is performed. + -- + -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and + -- "Di.Df1"), but don't log exceptions nor messages telling whether this + -- function succeeds or fails, since this library already does that for you. + , registry_abort :: Di.Df1 -> MigId -> Direction + -> IO (Either Err_Abort Log) + -- ^ Abort the pending change in the given 'Direction' most recently + -- introduced via 'registry_prepare', expected to be identified by the given + -- 'MigId'. + -- + -- Returns the 'Log_Abort' that describes this change to the registry. + -- + -- If there is no pending change to be aborted (that is, if the status is + -- 'Clean'), then 'Err_Abort_Clean' shall be returned. + -- + -- If the currently pending migration's identifier is different from the + -- the given 'MigId', or if its execution was intended for a 'Direction' + -- different than the one specified here, then 'Err_Abort_Dirty' shall be + -- returned. + -- + -- After a successful call to 'registry_abort', the registry will be left + -- in a 'Clean' status. + -- + -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and + -- "Di.Df1"), but don't log exceptions nor messages telling whether this + -- function succeeds or fails, since this library already does that for you. + , registry_commit :: Di.Df1 -> MigId -> Direction + -> IO (Either Err_Commit Log) + -- ^ Commit the pending change in the given 'Direction' most recently + -- introduced via 'registry_prepare', expected to be identified by the given + -- 'MigId'. + -- + -- Returns the 'Log_Commit' that describes this change to the registry. + -- + -- This is the first commit in the two-phase commit mechanism to + -- registering migrations as executed ('registry_prepare' is the first). + -- + -- If there is no pending change to be committed (that is, if the status + -- is 'Clean'), then 'Err_Commit_Clean' shall be returned. + -- + -- If the currently pending migration's identifier is different from the + -- the given 'MigId', or if its execution was intended for a 'Direction' + -- different than the one specified here, then 'Err_Commit_Dirty' shall be + -- returned. + -- + -- After a successful call to 'registry_commit', the registry will be left + -- in a 'Clean' status. + -- + -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and + -- "Di.Df1"), but don't log exceptions nor messages telling whether this + -- function succeeds or fails, since this library already does that for you. + } + +-- | This is just like 'Registry', except the 'Left' return values are +-- propagated as exceptions. +data Registrish = Registrish + { registrish_state :: Di.Df1 -> IO State + , registrish_prepare :: Di.Df1 -> MigId -> Direction -> IO () + , registrish_abort :: Di.Df1 -> MigId -> Direction -> IO () + , registrish_commit :: Di.Df1 -> MigId -> Direction -> IO () + } + +-- | Add some extra logging to a 'Registry', and promote the many 'Left' +mkRegistrish :: Registry -> Registrish +mkRegistrish reg = + let f :: Ex.Exception a => Either a b -> IO () + f = either Ex.throwM (const (pure ())) + in Registrish + { registrish_state = registry_state reg + , registrish_prepare = \di0 mId d -> do + let di1 = Di.push "registry" di0 + Di.debug di1 "Adding pending registry change..." + logException di1 (f =<< registry_prepare reg di1 mId d) + 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..." + logException di1 (f =<< registry_abort reg di1 mId d) + 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..." + logException di1 (f =<< registry_commit reg di1 mId d) + Di.debug di1 "Committed change to registry." + } + +-------------------------------------------------------------------------------- +-- Various errors. + +-- | A 'Log' representation was malformed and couldn't be parsed. +data Err_MalformedLog = Err_MalformedLog String deriving (Eq, Show) +instance Ex.Exception Err_MalformedLog + +-- | Errors from 'mkPlan'. +data Err_Plan + = Err_Plan_TargetsNotFound (Set MigId) + -- ^ The targeted 'MigId's are not present in the migrations graph. + | Err_Plan_HistoryUnknown + -- ^ The specified migration history is not a known possibility according + -- to the migrations dependency graph, meaning that it is not possible to + -- add new migrations to it. + | Err_Plan_TargetImpossible + -- ^ It is not possible to obtain an execution plan given the requirements and + -- dependency graph. + | Err_Plan_TargetsGone (Set MigId) + -- ^ Some migrations required to obtain an execution plan are 'Gone'. + deriving (Eq, Show) +instance Ex.Exception Err_Plan + +-- | Errors from 'cleanRegistry'. +-- +-- By the time you receive these errors, they have already been logged. +data Err_CleanRegistry + = Err_CleanRegistry_NotFoundInMigs MigId + -- ^ The currently dirty 'MigId', as it appears in the 'Registry' records, is + -- not present in the given 'Migs'. + | Err_CleanRegistry_MigGone MigId + -- ^ The code for the migration identfified 'MigId' is gone. + deriving (Eq, Show) +instance Ex.Exception Err_CleanRegistry + +-- | Errors from 'run'. +data Err_Run + = Err_Run_Dirty MigId Direction + -- ^ The migration registry has an unexpected pending migration. + deriving (Eq, Show) +instance Ex.Exception Err_Run + +-- | Errors from 'updateState'. +data Err_UpdateState + = Err_UpdateState_Duplicate MigId + | Err_UpdateState_NotFound MigId + | Err_UpdateState_Clean + | Err_UpdateState_Dirty + deriving (Eq, Show) +instance Ex.Exception Err_UpdateState + +-- | Errors from 'registry_prepare'. +data Err_Prepare + = Err_Prepare_Duplicate MigId + | Err_Prepare_NotFound MigId + | Err_Prepare_Dirty MigId Direction + deriving (Eq, Show) +instance Ex.Exception Err_Prepare + +-- | Errors from 'registry_abort'. +data Err_Abort + = Err_Abort_Clean + | Err_Abort_Dirty MigId Direction + deriving (Eq, Show) +instance Ex.Exception Err_Abort + +-- | Errors from 'registry_commit'. +data Err_Commit + = Err_Commit_Clean + | Err_Commit_Dirty MigId Direction + deriving (Eq, Show) +instance Ex.Exception Err_Commit + +-------------------------------------------------------------------------------- + +-- | Get all the topological orders for the given acyclic graph, in +-- depth-first order. +-- +-- Each node is represented as @k@, and the graph is represented as an +-- 'Map' from nodes to an 'Set' of nodes it depends on. For example, the graph +-- @1 <- 2 <- 3@ where @1@ must come before @2@ and @2@ must come before @3@ can +-- be represented as: +-- +-- @ +-- [(1,[]), (2,[1]), (3,[2])] :: 'Map' 'Int' ('Set' 'Int') +-- @ +-- +-- If there there are cycles in the graph, or if nodes depended upon are +-- missing, then @('mempty' :: 'Set')@ is returned. +-- +-- If the given map is empty, then @('pure' [] :: 'Set')@ is returned. +-- +-- The length of each @[k]@ equals the size of the given 'Map' (i.e., +-- 'Map.size'). +topos :: forall k. Ord k => Map k (Set k) -> [[k]] +topos [] = [[]] +topos m0 = go Set.empty m0 + where + go :: Set k -> Map k (Set k) -> [[k]] + go _ [] = [[]] + go s0 m1 = do + n <- Map.keys (Map.filter (\s1 -> s1 `Set.isSubsetOf` s0) m1) + fmap (n:) (go (Set.insert n s0) (Map.delete n m1)) + +-- TODO write more of these, especially for well formed graphs. +-- prop_topos :: IntMap IntSet -> Bool +-- prop_topos m = all (\y -> length y == IntMap.size m) (topos m) + +-------------------------------------------------------------------------------- + +-- | Runs the given action, and if some exception happens, then log it to the +-- 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!" + diff --git a/lib/Moto/Internal/Cli.hs b/lib/Moto/Internal/Cli.hs new file mode 100644 --- /dev/null +++ b/lib/Moto/Internal/Cli.hs @@ -0,0 +1,412 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StrictData #-} +{-# OPTIONS_HADDOCK hide #-} + +module Moto.Internal.Cli + ( RegistryConf(..) + , Opts + , getOpts + , run + ) where + +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 +import qualified System.IO as IO + +import qualified Moto.Internal as I + +-------------------------------------------------------------------------------- + +-- | Configuration for the 'I.Registry' that we'll use to keep track of the +-- migrations we've run so far. +data RegistryConf = forall r. RegistryConf + { registryConf_help :: String + -- ^ Help message for the @--registry@ command line option. + , registryConf_parse :: String -> Either String r + -- ^ Parse the string obtained from the @--registry@ command line option, + -- 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 + -- ^ Given the @r@ obtained from 'registryConf_parse', get a 'I.Registry' + -- that can be used within the given scope. + } + +-------------------------------------------------------------------------------- + +-- | Run the command-line arguments parser, obtaining the 'Opts' necessary for +-- calling 'run' afterwards. +-- +-- Notice that we can run the executable that calls 'getOpts' with a @--help@ +-- command line switch for extensive documentation on how to interact with +-- @moto@. +getOpts + :: RegistryConf + -- ^ Configuration for the 'I.Registry' to use. + -- + -- Among other things, this will dictate how we interpret the @--registry@ + -- 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. + -> OA.Parser a + -- ^ This extra parser can be used to read some extra configuration + -- values from the command-line arguments, besides @moto@'s own. + -- + -- For example, we can obtain things such as the name of a configuration + -- file or a database connection string we might want to use in our + -- migrations. + -- + -- If no such extra data is required, then @'pure' ()@ can be used. + -- + -- Notice that @moto@'s own command-line argument's parser has precedence + -- over this parser. Yet, in the command-line, the argument's for the parser + -- for @a@ should come before @moto@'s own subcommand arguments, otherwise the + -- command line program will complain about a malformed command-line. + -> IO (Opts, a) +getOpts rc p_a = OA.customExecParser + (OA.prefs (OA.showHelpOnEmpty <> OA.noBacktrack)) + (let pi0 = oa_pi_Opts rc + in pi0 { OA.infoParser = (,) <$> OA.infoParser pi0 <*> p_a }) + +-- | Run @moto@ on the given migrations graph 'I.Migs', according to the +-- instructions in 'Opts'. +run + :: Di.Df1 + -- ^ Root logger. If you don't have a 'Di.Df1' for your program yet, you can + -- obtain one using @Di.new@ from the + -- [di](https://hackage.haskell.org/package/di) library. + -> I.Migs graph + -- ^ Avaliable migrations graph. + -> Opts + -- ^ Instructions on how to interact with our migrations. + -- Obtain with 'getOpts'. + -> IO () +run di0 migs opts = do + case opts_sub opts of + Sub_Run x -> run_Run di0 migs x + Sub_ShowMigrations x -> run_ShowMigrations migs x + Sub_CheckMigrations x -> run_CheckMigrations di0 migs x + Sub_ShowRegistry x -> run_ShowRegistry di0 x + Sub_CleanRegistry x -> run_CleanRegistry di0 migs x + Sub_DeleteRecoveryData x -> run_DeleteRecoveryData di0 migs x + +run_Run :: Di.Df1 -> I.Migs graph -> Opts_Run -> IO () +run_Run di0 migs x = do + runWithRegistry (opts_run_withRegistry x) $ \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 + False -> I.run di0 reg p + True -> BB.hPutBuilder IO.stdout (renderPlan p) + +run_ShowMigrations :: I.Migs graph -> Opts_ShowMigrations -> IO () +run_ShowMigrations migs x = do + let gf = opts_showMigrations_graphFormat x + BB.hPutBuilder IO.stdout (renderMigs gf migs) + +run_CheckMigrations :: Di.Df1 -> I.Migs graph -> Opts_CheckMigrations -> IO () +run_CheckMigrations di0 migs x = do + runWithRegistry (opts_checkMigrations_withRegistry x) $ \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 + Right _ -> IO.exitSuccess + +run_ShowRegistry :: Di.Df1 -> Opts_ShowRegistry -> IO () +run_ShowRegistry di0 x = do + runWithRegistry (opts_showRegistry_withRegistry x) $ \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 + 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 () + +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 + 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." + IO.exitFailure + Nothing -> do + Di.error di1 "Migration not unknown." + IO.exitFailure + +-------------------------------------------------------------------------------- + +oa_pi_Opts :: RegistryConf -> OA.ParserInfo Opts +oa_pi_Opts rc = OA.info + (oa_p_Opts rc OA.<**> OA.helper) + (OA.fullDesc <> OA.progDesc "Command line interface to migrations.") + +oa_p_Opts :: RegistryConf -> OA.Parser Opts +oa_p_Opts rc = Opts <$> oa_p_Sub rc + +-- | This is the input required by 'run', obtained from the command line +-- arguments by using 'getOpts'. +data Opts = Opts + { opts_sub :: Sub + -- ^ Subcommand to run. + } + +-------------------------------------------------------------------------------- + +oa_p_Sub :: RegistryConf -> OA.Parser Sub +oa_p_Sub rc = OA.hsubparser $ mconcat + [ OA.command "run" + (fmap Sub_Run (oa_pi_Run rc)) + , OA.command "show-migrations" + (fmap Sub_ShowMigrations oa_pi_ShowMigrations) + , OA.command "check-migrations" + (fmap Sub_CheckMigrations (oa_pi_CheckMigrations rc)) + , OA.command "show-registry" + (fmap Sub_ShowRegistry (oa_pi_ShowRegistry rc)) + , OA.command "clean-registry" + (fmap Sub_CleanRegistry (oa_pi_CleanRegistry rc)) + , OA.command "delete-recovery-data" + (fmap Sub_DeleteRecoveryData oa_pi_DeleteRecoveryData) + ] + +data Sub + = Sub_Run Opts_Run + -- ^ Run migrations. + | Sub_ShowMigrations Opts_ShowMigrations + -- ^ Show available migrations. + | Sub_CheckMigrations Opts_CheckMigrations + -- ^ Check that the available migrations are compatible with the registry. + | Sub_ShowRegistry Opts_ShowRegistry + -- ^ Show migrations registry. + | Sub_CleanRegistry Opts_CleanRegistry + -- ^ I.Clean the registry if dirty. + | Sub_DeleteRecoveryData Opts_DeleteRecoveryData + -- ^ Delete content from the store. + +-------------------------------------------------------------------------------- + +oa_pi_Run :: RegistryConf -> OA.ParserInfo Opts_Run +oa_pi_Run rc = OA.info (oa_p_Run rc) (OA.progDesc "Run migrations.") + +oa_p_Run :: RegistryConf -> OA.Parser Opts_Run +oa_p_Run rc = Opts_Run + <$> oa_p_WithRegistry rc + <*> oa_p_Target + <*> OA.flag True False + (OA.long "no-dry-run" <> + OA.help "Don't just show the execution plan, run it!") + +data Opts_Run = Opts_Run + { opts_run_withRegistry :: WithRegistry + -- ^ Acquire a 'I.Registry' to use within a limited scope.. + , opts_run_target :: I.Target + -- ^ Migration target. + , opts_run_dryRun :: Bool + -- ^ Don't run migrations, just show the execution plan. + } + +-------------------------------------------------------------------------------- + +oa_pi_ShowMigrations :: OA.ParserInfo Opts_ShowMigrations +oa_pi_ShowMigrations = OA.info oa_p_ShowMigrations + (OA.progDesc "Show available migrations.") + +oa_p_ShowMigrations :: OA.Parser Opts_ShowMigrations +oa_p_ShowMigrations = Opts_ShowMigrations <$> oa_p_GraphFormat + +data Opts_ShowMigrations = Opts_ShowMigrations + { opts_showMigrations_graphFormat :: GraphFormat + -- ^ Format in which to render the migrations graph. + } + +-------------------------------------------------------------------------------- + +oa_pi_CheckMigrations :: RegistryConf -> OA.ParserInfo Opts_CheckMigrations +oa_pi_CheckMigrations rc = OA.info (oa_p_CheckMigrations rc) + (OA.progDesc "Exit immediately with status 0 if the available \ + \migrations are compatible with the registry. \ + \Otherwise, exit with status 1.") + +oa_p_CheckMigrations :: RegistryConf -> OA.Parser Opts_CheckMigrations +oa_p_CheckMigrations rc = Opts_CheckMigrations <$> oa_p_WithRegistry rc + +data Opts_CheckMigrations = Opts_CheckMigrations + { opts_checkMigrations_withRegistry :: WithRegistry + -- ^ Acquire a 'I.Registry' to use within a limited scope.. + } + +-------------------------------------------------------------------------------- + +oa_pi_ShowRegistry :: RegistryConf -> OA.ParserInfo Opts_ShowRegistry +oa_pi_ShowRegistry rc = OA.info + (oa_p_ShowRegistry rc) + (OA.progDesc "Show migrations registry.") + +oa_p_ShowRegistry :: RegistryConf -> OA.Parser Opts_ShowRegistry +oa_p_ShowRegistry rc = Opts_ShowRegistry <$> oa_p_WithRegistry rc + +data Opts_ShowRegistry = Opts_ShowRegistry + { opts_showRegistry_withRegistry :: WithRegistry + -- ^ Acquire a 'I.Registry' to use within a limited scope.. + } + +-------------------------------------------------------------------------------- + +oa_pi_CleanRegistry :: RegistryConf -> OA.ParserInfo Opts_CleanRegistry +oa_pi_CleanRegistry rc = OA.info + (oa_p_CleanRegistry rc) + (OA.progDesc "Clean a dirty migrations registry.") + +oa_p_CleanRegistry :: RegistryConf -> OA.Parser Opts_CleanRegistry +oa_p_CleanRegistry rc = Opts_CleanRegistry + <$> oa_p_WithRegistry rc + <*> OA.switch (OA.long "dry-run" <> + 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.") + +data Opts_CleanRegistry = Opts_CleanRegistry + { opts_cleanRegistry_withRegistry :: WithRegistry + -- ^ 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. + } + +-------------------------------------------------------------------------------- + +oa_pi_DeleteRecoveryData :: OA.ParserInfo Opts_DeleteRecoveryData +oa_pi_DeleteRecoveryData = OA.info oa_p_DeleteRecoveryData + (OA.progDesc "Delete contents from the migrations data store.") + +oa_p_DeleteRecoveryData :: OA.Parser Opts_DeleteRecoveryData +oa_p_DeleteRecoveryData = Opts_DeleteRecoveryData + <$> fmap Set.fromList (OA.some (OA.option OA.str (OA.long "mig"))) + +data Opts_DeleteRecoveryData = Opts_DeleteRecoveryData + { opts_store_migIds :: Set.Set I.MigId + -- ^ 'I.MigId's for which to remove contents from the data store. + } + +-------------------------------------------------------------------------------- + +data WithRegistry = WithRegistry + { runWithRegistry :: forall a. (I.Registry -> IO a) -> IO a } + +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_p_Target :: OA.Parser I.Target +oa_p_Target = I.Target + <$> OA.flag I.Forwards I.Backwards (OA.long "backwards") + <*> fmap Set.fromList (OA.many (OA.option OA.str + (OA.long "mig" <> OA.metavar "ID" <> + OA.help "If specified, only consider running the migration identified \ + \by this ID. Use multiple times for multiple migrations."))) + +-------------------------------------------------------------------------------- + +oa_p_GraphFormat :: OA.Parser GraphFormat +oa_p_GraphFormat = + OA.flag GraphFormatText GraphFormatDot + (OA.long "dot" <> OA.help "Render graph in DOT (Graphviz) format.") + +data GraphFormat + = GraphFormatText -- ^ Render as plain text. + | GraphFormatDot -- ^ Render as DOT (Graphviz). + +renderMigs :: GraphFormat -> I.Migs graph -> BB.Builder +renderMigs = \case + GraphFormatText -> renderMigs_Text + GraphFormatDot -> renderMigs_Dot + +renderMigs_Text :: I.Migs graph -> BB.Builder +renderMigs_Text (I.Migs m0) = mconcat $ do + (here, deps) <- Map.toList (fmap (toList . fst) m0) + case deps of + [] -> [ f here <> " has no dependencies.\n" ] + _ -> [ f here <> " depends on:\n" <> + mconcat (map (\mId -> " * " <> f mId <> "\n") deps) ] + where + f :: I.MigId -> BB.Builder + f (I.MigId x) = T.encodeUtf8Builder (T.pack (show x)) + +renderMigs_Dot :: I.Migs graph -> BB.Builder +renderMigs_Dot (I.Migs m0) = mconcat + [ "digraph G {\n" + , mconcat $ do + (here, deps) <- Map.toList (fmap (toList . fst) m0) + dep <- deps + [ " " <> f dep <> " -> " <> f here <> ";\n" ] + , "}\n" + ] + where + f :: I.MigId -> BB.Builder + f (I.MigId x) = T.encodeUtf8Builder (T.pack (show x)) + +-------------------------------------------------------------------------------- + +renderState :: I.State -> BB.Builder +renderState s = + "Status: " <> fromString (show (I.state_status s)) <> + "\nCommitted migrations: " <> + fromString (show (length (I.state_committed s))) <> "\n" <> + mconcat (map (\x -> " " <> fromString (show x) <> "\n") + (I.state_committed s)) + +-------------------------------------------------------------------------------- + +-- | Renders each 'MigId' in the 'Plan' preceded by its direction, and followed +-- by a trailing newline. +renderPlan :: I.Plan -> BB.Builder +renderPlan (I.Plan _ []) = "Execution plan is empty. Nothing to do.\n" +renderPlan (I.Plan d s) = mconcat + [ "Execution plan:\n" + , mconcat (map (\(mId,_) -> " Run " <> d' <> f mId <> "\n") (toList s)) + , "\nTo actually run the migrations, add --no-dry-run to " + , "the command-line arguments.\n" ] + where + d' :: BB.Builder + d' = I.direction "backwards " "forwards " d + f :: I.MigId -> BB.Builder + f (I.MigId x) = T.encodeUtf8Builder (T.pack (show x)) + diff --git a/lib/Moto/Registry.hs b/lib/Moto/Registry.hs new file mode 100644 --- /dev/null +++ b/lib/Moto/Registry.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} + +-- | This module exports tools for implementing a registry that @moto@ can use +-- in order to keep track of the migrations that have been run so far. +-- +-- It's unlikely that you'll need to concern yourself with this module as an +-- end user of @moto@. +-- +-- Please import as: +-- +-- @ +-- import qualified "Moto.Registry" as Moto +-- @ +module Moto.Registry + ( -- * Command-line support + IC.RegistryConf(..) + + -- * Registry + , I.Registry(..) + , newAppendOnlyRegistry + + -- * State + , I.State + , I.emptyState + , I.updateState + , I.Log(..) + + -- * Errors + , Err_Tainted(..) + , I.Err_Prepare(..) + , I.Err_Abort(..) + , I.Err_Commit(..) + , I.Err_UpdateState(..) + ) where + +import Control.Concurrent (readMVar, putMVar, takeMVar, newMVar) +import qualified Control.Exception.Safe as Ex +import qualified Data.Time as Time + +import qualified Moto.Internal as I +import qualified Moto.Internal.Cli as IC + +-------------------------------------------------------------------------------- + +-- | Create a 'I.Registry' backed by an append-only 'I.Log' storage. +-- +-- This registry maintains its internal 'I.State' in memory as long as it is +-- possible to successfuly store all the changes in the underlying append-only +-- storage. If at some point this fails unrecoverably, then 'Err_Tainted' will +-- be thrown by the functions acting on this 'I.Registry'. +-- +-- It's important to acquire some kind of exclusive lock on the underlying +-- storage, so that other applications can't poke it while our 'I.Registry' is +-- running. +newAppendOnlyRegistry + :: I.State + -- ^ Initial registry state obtained by reading 'I.Log's from the backing + -- append-only storage and running 'I.updateState' on them. + -> (I.Log -> IO ()) + -- ^ How to store a newly generated 'I.Log' in the backing append-only + -- storage. + -- + -- If this function throws an exception, then the execption will propagated + -- as usual, but also, this registry will be marked as tained and each + -- subsequent operation on it will throw 'Err_Tainted'. + -> IO I.Registry +newAppendOnlyRegistry !state0 putLog = do + mvState <- newMVar (Just state0) + let supdate :: (I.State -> Either e I.Log) -> IO (Either e I.Log) + supdate f = Ex.bracketOnError + (takeMVar mvState) + (\_ -> putMVar mvState Nothing) + (\case Nothing -> Ex.throwM Err_Tainted + Just s0 -> case f s0 of + Left e -> pure (Left e) + Right log_ -> case I.updateState s0 log_ of + Left e -> Ex.throwM e -- This is unreachable code. + Right !s1 -> do + putLog log_ + putMVar mvState (Just s1) + pure (Right log_)) + pure $ I.Registry + { I.registry_state = \_ -> do + maybe (Ex.throwM Err_Tainted) pure =<< readMVar mvState + , I.registry_prepare = \_ mId d -> do + t <- Time.getCurrentTime + supdate $ \s -> case I.state_status s of + I.Dirty mId' d' -> Left (I.Err_Prepare_Dirty mId' d') + I.Clean -> case (d, elem mId (map fst (I.state_committed s))) of + (I.Forwards, True) -> Left (I.Err_Prepare_Duplicate mId) + (I.Backwards, False) -> Left (I.Err_Prepare_NotFound mId) + _ -> Right (I.Log_Prepare t mId d) + , I.registry_abort = \_ mId d -> do + t <- Time.getCurrentTime + supdate $ \s -> case I.state_status s of + I.Clean -> Left I.Err_Abort_Clean + I.Dirty mId' d' + | mId /= mId' || d /= d' -> Left (I.Err_Abort_Dirty mId' d') + | otherwise -> Right (I.Log_Abort t) + , I.registry_commit = \_ mId d -> do + t <- Time.getCurrentTime + supdate $ \s -> case I.state_status s of + I.Clean -> Left I.Err_Commit_Clean + I.Dirty mId' d' + | mId /= mId' || d /= d' -> Left (I.Err_Commit_Dirty mId' d') + | otherwise -> Right (I.Log_Commit t) + } + +-- | The 'I.Registry' is tainted, meaning our last attempt to interact with the +-- registry's backing storage failed. We can't be certain about the current +-- state of the 'I.Registry'. +data Err_Tainted = Err_Tainted deriving (Eq, Show) +instance Ex.Exception Err_Tainted + diff --git a/lib/cli_help.docs b/lib/cli_help.docs new file mode 100644 --- /dev/null +++ b/lib/cli_help.docs @@ -0,0 +1,114 @@ +{- $cli_help + +This is the full description of the command line options supported by +'Moto.getOpts', using @Moto.File.fileRegistry@ as the registry. + +Main program (here called @moto-example@): + +@ +Usage: moto-example COMMAND + Command line interface to migrations. + +Available options: + -h,--help Show this help text + +Available commands: + run Run migrations. + show-migrations Show available migrations. + check-migrations Exit immediately with status 0 if the available + migrations are compatible with the registry. + Otherwise, exit with status 1. + show-registry Show migrations registry. + clean-registry Clean a dirty migrations registry. + delete-recovery-data Delete contents from the migrations data store. +@ + + + +Subcommand @run@: + +@ +Usage: moto-example run --registry URI [--backwards] [--mig ID] [--no-dry-run] + Run migrations. + +Available options: + --registry URI File where registry file is stored. E.g., + file:\/\/\/var\/db\/migrations + --mig ID If specified, only consider running the migration + identified by this ID. Use multiple times for + multiple migrations. + --no-dry-run Don't just show the execution plan, run it! + -h,--help Show this help text +@ + + + +Subcommand @show-migrations@: + +@ +Usage: moto-example show-migrations [--dot] + Show available migrations. + +Available options: + --dot Render graph in DOT (Graphviz) format. + -h,--help Show this help text +@ + + + +Subcommand @check-migrations@: + +@ +Usage: moto-example check-migrations --registry URI + 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 + -h,--help Show this help text +@ + + + +Subcommand @show-registry@: + +@ +Usage: moto-example show-registry --registry URI + Show migrations registry. + +Available options: + --registry URI File where registry file is stored. E.g., + file:\/\/\/var\/db\/migrations + -h,--help Show this help text +@ + + + +Subcommand @clean-registry@: + +@ +Usage: moto-example clean-registry --registry URI [--dry-run] + Clean a dirty migrations registry. + +Available options: + --registry URI File where registry file is stored. E.g., + file:\/\/\/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. + -h,--help Show this help text +@ + + + +Subcommand @delete-recovery-data@: + +@ +Usage: moto-example delete-recovery-data --mig ARG + Delete contents from the migrations data store. + +Available options: + -h,--help Show this help text +@ +-} diff --git a/lib/moto-internal/Moto/Internal.hs b/lib/moto-internal/Moto/Internal.hs deleted file mode 100644 --- a/lib/moto-internal/Moto/Internal.hs +++ /dev/null @@ -1,1062 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} - -module Moto.Internal - ( run - - -- * Describing migrations - , Mig(Mig, Gone) - , UMig(UMig, UGone) - -- ** Backup - , Backup(Backup) - -- ** Change - , Change(Change) - -- ** Store - , Store(Store, store_save, store_load, store_delete) - , mapStore - - -- *** Direction - , Direction(Backwards, Forwards) - , direction - , opposite - - -- *** Mode - , Mode(Normal, Recovery) - - -- * Execution plan - , Migs(Migs) - , migs - , (Moto.Internal.*) - , DAG - , lookupMigs - - , Target(..) - - , Plan(Plan) - , mkPlan - , getPlan - - , MigId(MigId, unMigId) - , migId - , migId_sha1Hex - - -- * Registry - , Registry(..) - , cleanRegistry - - -- * State - , State - , state_status - , state_committed - , emptyState - , updateState - , Status(..) - , Log(..) - - -- * Errors - , Err_Run(..) - , Err_Plan(..) - , Err_Prepare(..) - , Err_Abort(..) - , Err_Commit(..) - , Err_UpdateState(..) - , Err_MalformedLog(..) - ) where - -import Control.Arrow ((&&&)) -import Control.Monad (when) -import qualified Control.Exception.Safe as Ex -import Control.Monad.IO.Class (MonadIO) -import qualified Crypto.Hash.SHA1 as SHA1 -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Builder.Prim as BBP -import qualified Data.ByteString.Lazy as BL -import Data.Foldable (for_) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import qualified Data.List as List -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes) -import Data.Proxy (Proxy(..)) -import Data.Sequence (Seq) -import qualified Data.Sequence as Seq -import Data.Set (Set) -import qualified Data.Set as Set -import Data.String (IsString, fromString) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Time as Time -import qualified Df1 -import qualified Di.Df1 as Di -import GHC.Exts (Constraint) -import GHC.TypeLits (KnownSymbol, symbolVal, Symbol) -import qualified GHC.TypeLits as GHC -import qualified System.Mem - --------------------------------------------------------------------------------- - --- | The directed acyclic graph of migrations available for execution. --- --- Construct using 'Moto.migs' and 'Moto.*'. For example: --- --- @ --- 'Moto.migs' 'Moto.*' someMig 'Moto.*' anotherMig 'Moto.*' ... --- @ -newtype Migs (graph :: [(Symbol, [Symbol])]) - = Migs (Map MigId (Set MigId, UMig)) - -- ^ Unsafe constructor. A map from 'MigId's, to the 'UMig' identfified by it, - -- as well as a set of all of the 'MigId's that must be executed before it. - --- | An empty, yet valid, graph of migrations. --- --- You can use 'Moto.migs' as a starting point for constructing bigger --- migrations graphs. For example: --- --- @ --- 'Moto.migs' 'Moto.*' someMig 'Moto.*' anotherMig 'Moto.*' ... --- @ -migs :: Migs '[] -migs = Migs Map.empty - --- | Add a new migration with an unique identifier @id@ depending on each of --- @deps@ to a graph of migrations @graph@. --- --- The 'DAG' constraint guarantees that the result is a directed acyclic graph. --- --- To create a 'Migs' from scratch, use 'Moto.*' in combination with --- 'Moto.migs'. For example: --- --- @ --- 'Moto.migs' 'Moto.*' someMig 'Moto.*' anotherMig 'Moto.*' ... --- @ -infixl 7 * -(*) :: DAG id deps graph - => Migs graph - -> Mig id deps - -- ^ @id@ must not be present in @graph@. - -- - -- All of @deps@ must be present in @graph@. - -> Migs ('(id, deps) ': graph) -(*) (Migs m) (mig :: Mig id deps) = - let umig = case mig of - Mig s b c -> UMig (pimpStore s) (pimpBackup b) (pimpChange c) - Gone -> UGone - in Migs (Map.insert (migId (Proxy :: Proxy id)) - (Set.fromList (migIds (Proxy :: Proxy deps)), umig) - m) - --- | This 'Constraint' is automatically satisfied by an @id@ that is absent from --- @graph@, and @deps@ listing identifiers present in the given @graph@. --- --- In other words, 'DAG' effectively forces 'Moto.*' to always build Directed --- Acyclic Graphs (hence the name). --- --- @ --- 'DAG' id deps graph :: 'Constraint' --- @ -type DAG id deps graph = DAG_ id deps graph - --- | We don't export this to keep the haddocks clean. -type DAG_ (id :: Symbol) (deps :: [Symbol]) (graph :: [(Symbol, [Symbol])]) - = ( NotMember id deps - , NotMember id (Ids graph) - , Subset deps (Ids graph) - -- The following two constraints have nothing to do with DAGs, but by - -- putting them here we can keep the type of 'Moto.*' less noisy. - , KnownSymbol id - , KnownSymbols deps - ) - --- | Obtain a term-level representation of a migration identifier from its --- type-level representation as a 'Symbol' (as it appears in the @id@ type --- parameter to 'Mig'). -migId :: KnownSymbol id => Proxy id -> MigId -migId = MigId . fromString . symbolVal - --- | Obtain a term-level representation of some migration identifiers from their --- type-level representation as @['Symbol']@ (as they appear in the @id@ type --- parameter to 'Mig'). -migIds :: KnownSymbols ids => Proxy ids -> [MigId] -migIds = map (MigId . fromString) . symbolVals - -lookupMigs :: MigId -> Migs graph -> Maybe (Set MigId, UMig) -lookupMigs mId (Migs m) = Map.lookup mId m - -class All KnownSymbol ids => KnownSymbols (ids :: [Symbol]) where - symbolVals :: Proxy ids -> [String] -instance KnownSymbols '[] where - symbolVals _ = [] -instance (KnownSymbol id, KnownSymbols ids) => KnownSymbols (id ': ids) where - symbolVals (_ :: Proxy (id ': ids)) - = symbolVal (Proxy :: Proxy id) - : symbolVals (Proxy :: Proxy ids) - -type family All (f :: k -> Constraint) (as :: [k]) :: Constraint where - All _ '[] = () - All f (a ': as) = (f a, All f as) - -type family Subset (small :: [k]) (big :: [k]) :: Constraint where - Subset '[] _ = () - Subset (a ': as) bs = (Member a bs, Subset as bs) - -type family Ids (abs :: [(ka,kb)]) :: [ka] where - Ids '[] = '[] - Ids ( '(a,_) ': abs ) = (a ': Ids abs) - -type Member (a :: k) (as :: [k]) = Member_ a as (IsMember a as) -type family Member_ (a :: k) (as :: [k]) (found :: Bool) :: Constraint where - Member_ _ _ 'True = () - Member_ a as 'False = GHC.TypeError - ('GHC.ShowType a 'GHC.:<>: - 'GHC.Text " is not a member of " 'GHC.:<>: - 'GHC.ShowType as) - -type NotMember (a :: k) (as :: [k]) = NotMember_ a as (IsMember a as) -type family NotMember_ (a :: k) (as :: [k]) (found :: Bool) :: Constraint where - NotMember_ _ _ 'False = () - NotMember_ a as 'True = GHC.TypeError - ('GHC.ShowType a 'GHC.:<>: - 'GHC.Text " is a member of " 'GHC.:<>: - 'GHC.ShowType as) - -type family IsMember (a :: k) (as :: [k]) :: Bool where - IsMember _ '[] = 'False - IsMember a (a ': _) = 'True - IsMember a (b ': as) = IsMember a as - --------------------------------------------------------------------------------- - --- | Direction in which a migration runs. --- --- Running it 'Forwards' conveys the idea of “advancing” or “improving” your --- state over time somehow, while running it 'Backwards' conveys the idea of --- undoing all the changes that the migration does when going 'Forwards'. -data Direction = Backwards | Forwards - deriving stock (Eq, Ord, Show, Read) - --- | Case analysis for 'Direction'. Evaluate to the first @a@ in case it is --- 'Backwards', otherwise to the second @a@. -direction :: a -> a -> Direction -> a -direction bw fw = \case { Backwards -> bw; Forwards -> fw } - --- | The opposite of the given direction. -opposite :: Direction -> Direction -opposite = direction Forwards Backwards - -instance Df1.ToValue Direction where - value = direction "backwards" "forwards" - --------------------------------------------------------------------------------- - --- | A single side-effecting migration uniquely identfied by @id@ and depending --- on all of the migrations listed in @deps@. --- --- These migration identifiers that appear as type-level 'Symbol' here, will be --- of type 'MigId' when represented at the type level. -data Mig (id :: Symbol) (deps :: [Symbol]) where - -- | Description of the different phashes that make up this migration - -- identified by @id@, depending on others identified by @deps@. - Mig :: Store x - -- ^ How to save and load data obtained during the 'Backup' phase when - -- necessary. - -- - -- Please note that you can reuse this same 'Store' across different - -- migrations. - -- - -- Any stored data will remain in the 'Store' until it is not necessary - -- anymore (but it can be manually deleted if desired, at your own risk). - -- - -- Please refer to 'Store' for further documentation. - -> Backup x - -- ^ Backup phase of this migration - -- - -- This phase is executed only once when trying to run the migration - -- 'Forwards' for the first time. - -- - -- Please refer to 'Backup' for further documentation. - -> Change x - -- ^ Change phase of this migration. - -- - -- This phase is executed both when going 'Forwards' and 'Backwards'. Here - -- we alter the environment somehow while having access to the @x@ data - -- obtained in the 'Backup' phase. - -- - -- Please refer to 'Change' for further documentation. - -> Mig id deps - - -- | This constructor conveys the idea that code for a particular migration is - -- gone, while still communicating the dependencies that this migration used - -- to have so that we don't change the past dependency graph over time, which - -- would make it impossible for @moto@ to operate reliably. - Gone :: Mig id deps - --- | Internal. Like 'Mig', but without the type level data. -data UMig where - UGone :: UMig - UMig :: Store x -> Backup x -> Change x -> UMig - --------------------------------------------------------------------------------- - --- | The backup phase of a migration, collecting some data @x@ for backup in a --- 'Store'. --- --- Here we interact with the environment in a /read-only/ manner, collecting all --- data that may be destroyed by a subsequent 'Change' phase for backup in some --- 'Store'. --- --- This data will be crucial for automatic recovery in case the 'Change' phase --- of the 'Mig' that uses this 'Backup' fails, or in case we manually decide to --- undo said 'Mig' at a later time. Thus, when deciding what data to return as --- @x@, please consider those scenarios. --- --- The actual storing of the backup data is performed by the 'Store' that is --- used as part of the same 'Mig'. That is, we don't physically store --- the data within this 'Backup', all we do is return it as @x@. --- --- Please keep in mind that depending on your environment, @x@ could be really --- large, so in those situations it best for @x@ to be some kind of /stream/ --- (e.g., a 'Pipes.Producer'). --- --- Notice that @x@ is returned in a continuation-passing style so that we can --- do proper resource deallocation after @x@ has been consumed. Using @x@ --- outside of this intended scope is undefined. -data Backup (x :: *) = Backup (forall r. Di.Df1 -> (x -> IO r) -> IO r) - --- | 'Backup' is covariant with @x@. -instance Functor Backup where - fmap f (Backup g) = Backup (\di k -> g di (k . f)) - --- | Add some extra logging to a 'Backup'. -pimpBackup :: Backup x -> Backup x -pimpBackup (Backup f) = Backup $ \di0 k -> do - let di1 = Di.push "backup" di0 - Di.debug di1 "Running..." - r <- logException di1 (f di1 k) - Di.debug di1 "Ran." - -- Bonus track: Run GC to ensure we don't keep @x@ in memory. - System.Mem.performMajorGC - pure r - --------------------------------------------------------------------------------- - --- | A 'Store' describes how to save, load and delete the @x@ data obtained by --- a 'Backup'. --- --- This @x@ data is used later by the 'Change' phase. --- --- A single 'Store' might be used by different 'Mig's. --- --- Hint: 'Moto.File.store' from the "Moto.File" module is a 'Store' you can use --- that's distributed with the main @moto@ library. -data Store (x :: *) = Store - { store_save :: Di.Df1 -> MigId -> x -> IO () - -- ^ Saves the @x@ data originating from a 'Backup' step for a migration - -- identified by 'MigId', __overwriting__ previous data if any. - -- - -- If it's not possible to save the @x@ data, then this function must - -- fail with some exception. - -- - -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and - -- "Di.Df1"), but please don't log exceptions nor messages telling whether - -- this function succeeds or fails, since this library already does that for - -- you. - , store_load :: forall r. Di.Df1 -> MigId -> (x -> IO r) -> IO r - -- ^ Load the data previously saved by 'store_save', for a migration - -- identified by the given 'MigId'. - -- - -- Notice that @x@ is returned in a continuation-passing style so that we - -- can do proper resource deallocation after @x@ has been consumed. Using - -- @x@ outside of this intended scope is undefined. - -- - -- If it's was not possible to load the @x@ data, then this function must - -- fail with some exception. - -- - -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and - -- "Di.Df1"), but please don't log exceptions nor messages telling whether - -- this function succeeds or fails, since this library already does that for - -- you. - , store_delete :: Di.Df1 -> MigId -> IO () - -- ^ Delete the data previously saved by 'store_save', if any. for a - -- migration identified by the given 'MigId'. - -- - -- If it's there was no data to delete, then this function should return - -- @()@. On the other hand, if its acceptable to throw exceptions when - -- it's not possible to access the underlying storage. - -- - -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and - -- "Di.Df1"), but please don't log exceptions nor messages telling whether - -- this function succeeds or fails, since this library already does that for - -- you. - } - --- | Given isomorpisms between @a@ and @b@, obtain an function from --- @'Store' a@ and @'Store' b@. --- --- A @'Store' x@ is both covariant and contravariant with @x@. --- --- This function respects the functor laws. -mapStore - :: (b -> a) -- ^ Isomorphism from @b@ to @a@. - -> (a -> b) -- ^ Isomorphism from @a@ to @b@. - -> Store a - -> Store b -mapStore ba ab = \(Store s l d) -> - Store (\di mId b -> s di mId (ba b)) - (\di mId kb -> l di mId (kb . ab)) - d - --- | Add some extra logging to a 'Store'. -pimpStore :: Store a -> Store a -pimpStore sto = sto - { store_save = \di0 mId x -> do - let di1 = Di.push "save" di0 - Di.debug di1 "Saving recovery data..." - logException di1 (store_save sto di1 mId x) - Di.debug di1 "Saved." - , store_load = \di0 mId k -> do - let di1 = Di.push "load" di0 - Di.debug di1 "Loading recovery data..." - r <- logException di1 (store_load sto di1 mId k) - 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..." - r <- logException di1 (store_delete sto di1 mId) - Di.info di1 "Deleted." - pure r - } - --------------------------------------------------------------------------------- - --- | Execution mode of a migration, describing why and how a 'Change' migration --- is being run. -data Mode - = Normal - -- ^ The migration is being run as requested by the user, in the requested - -- 'Direction'. Every previous step until now has run successfully. You can - -- assume a clean starting point. - -- - -- If running the migration in 'Normal' mode fails, the same migration will be - -- run again in 'Recovery' mode /in the opposite 'Direction'/ as a way to - -- undo any partial changes and go back to having a clean state. This recovery - -- mechanism survives through different program executions, so even if a - -- failure when running a migration in 'Normal' mode causes the whole program - -- to crash, the corresponding 'Recovery' mode can still be run from the - -- command line program. In fact, /moto/ will refuse making any other changes - -- until this matter is sorted. For this reason, if let a 'Change' being - -- executed in 'Normal' mode fails, it is always preferrable to let that - -- exception propagate, and instead focus on writing any mitigating code as - -- part of the 'Recovery' mode. - | Recovery - -- ^ An attempt to run the migration in the 'Direction' requested by - -- the user has failed, so as a recovery meassure we are running the same - -- migration in the opposite direction now. You can't make assumptions - -- about the starting point, because running the migration in the desired - -- 'Direction' failed somewhere in the middle of process. Please rely on the - -- 'Backup' data you obtained before to decide how to correct the situation. - -- - -- Ultimately, running a migration in 'Recovery' mode in a particular - -- 'Direction' needs to accomplish the same outcome as running it in 'Normal' - -- mode in that same 'Direction'. - -- - -- If running a migration in 'Recovery' mode fails, then the program will exit - -- and the migrations registry will be left in a dirty state, from which you - -- can manually attempt to initiate a recovery again. At this point, reading - -- the output logs and understanding what when wrong will be very useful: - -- Maybe the migration failed because of a temporary phenomenon such as a - -- network connectivity issue, in which simply retrying later will solve it, - -- or maybe it failed because of a bug in the migration implementation, in - -- which case logs will be crucial to understand how to change the migrations - -- code in order to fix it. - -instance Df1.ToValue Mode where - value = \case - Normal -> "normal" - Recovery -> "recovery" - --------------------------------------------------------------------------------- - --- | A 'Change' describes how a 'Mig' /changes/ the environment. --- --- The given function will be called when running the migration both in --- 'Forwards' or 'Backwards' direction. --- --- In both cases, we have access to the original 'Backup' data while --- running the migration, which implies that even “irrecoverable” migrations --- that delete things when going 'Forwards' can be undone by relying on data --- from the 'Backup'. --- --- The given 'Mode' specifies why and how this 'Change' is being run. --- Particularly, it describes the assumptions you can make about the --- environment, which is very important if something goes wrong. Please refer to --- the documentation for 'Mode' for a better understanding. --- --- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and --- "Di.Df1"), but please don't log exceptions nor messages telling whether this --- function as a whole succeeds or fails, since this library already does that --- for you. However, for debugging purposes in case something goes wrong, it is --- __very important__ that you log what your 'Change' is doing, particularly if --- the changes themselves are not atomic. Please see the documentation for --- 'Recovery' to understand what can be helpful. --- --- After a successful 'Backwards' execution of this 'Change', any recovery data --- associated with the 'Mig' previously obtained during the 'Backup' phase can --- be deleted from its 'Store', since it is not necessary anymore. This will --- happen automatically if you request so when instructing /moto/ to run your --- migrations. -newtype Change x = Change (Di.Df1 -> Direction -> Mode -> x -> IO ()) - --- | 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..." - logException di1 (f di1 d m x) - <* Di.info di1 "Ran." - --------------------------------------------------------------------------------- - --- | A term-level identifier for a 'Mig'. -newtype MigId = MigId { unMigId :: T.Text } - deriving newtype (Eq, Ord, Show, IsString, Read, Df1.ToValue) - --- | Hexadecimal representation of the SHA1 hash for this 'MigId'. -migId_sha1Hex :: MigId -> BL.ByteString -migId_sha1Hex - = BB.toLazyByteString - . BBP.primMapByteStringFixed BBP.word8HexFixed - . SHA1.hash . T.encodeUtf8 . unMigId - --------------------------------------------------------------------------------- - --- | The target to which to migrate. -data Target = Target Direction (Set MigId) - deriving (Eq, Show) - --------------------------------------------------------------------------------- - --- | A migrations execution plan. -data Plan = Plan Direction (Seq (MigId, UMig)) - -- ^ Unsafe constructor. The migrations are always listed in - -- 'Forwards' order, even if intended to be run 'Backwards'. - --- | Obtain a migrations execution 'Plan' if possible. -mkPlan - :: Migs graph -- ^ Avaiable migrations. - -> [MigId] - -- ^ Migration history represented as the 'MigId's that have already been - -- run, in the 'Forwards' order they have been run. - -> Target -- ^ Migration target. - -> Either Err_Plan Plan -mkPlan (Migs []) [] (Target d []) = Right (Plan d []) -mkPlan (Migs m0) ran (Target d req0) = do - -- If 'req0' mentions an unknown, we abort. - case Set.difference req0 (Map.keysSet m0) of - [] -> pure () - req1 -> Left (Err_Plan_TargetsNotFound req1) - -- Find all topological orders. - let topos0 :: [[MigId]] - topos0 = topos (fmap fst m0) - -- Find the topological orders that share the 'ran' prefix. - case catMaybes (List.stripPrefix ran <$> topos0) :: [[MigId]] of - [] -> Left Err_Plan_HistoryUnknown - topos1 -> do - -- Find the topological order to use. - topo :: [MigId] <- direction (bw topos0) (fw topos1) d - -- Add 'UMig' data and return. - Right (Plan d (Seq.fromList (map (id &&& getUMig) topo))) - where - getUMig :: MigId -> UMig - getUMig = \mId -> snd (m0 Map.! mId) - isGone :: MigId -> Bool - isGone = \mId -> case getUMig mId of { UGone -> True; _ -> False } - fw :: [[MigId]] -> Either Err_Plan [MigId] - fw [] = error "fw: unreachable" - fw topos0@(topo0:_) = case req0 of - [] -> - -- No specific migration was requested, so we run everything not gone. - case filter (all (not . isGone)) topos0 of - [] -> Left (Err_Plan_TargetsGone (Set.fromList (filter isGone topo0))) - (topo:_) -> Right topo - _ -> - -- We exclude from 'req0' whatever has been run already. - case Set.difference req0 (Set.fromList ran) of - [] -> Right [] -- Nothing to do. All of 'req0' has been run already. - req1 -> do - -- Our final topological order will be a permutation of 'req1'. - let perms :: [[MigId]] = List.permutations (Set.toList req1) - -- We will only run as many migrations as 'req1' asks, so we - -- discard the rest to keep things simple below. - let topos1 :: [[MigId]] = List.take (Set.size req1) <$> topos0 - -- Select topological orders that matches one of 'perms', if any. - case filter (\topo -> any (== topo) perms) topos1 of - [] -> Left Err_Plan_TargetImpossible - topos2@(topo2:_) -> do - -- Select a topological order with migrations not gone. - case List.find (all (not . isGone)) topos2 of - Just topo -> Right topo - Nothing -> Left (Err_Plan_TargetsGone - (Set.fromList (filter isGone topo2))) - bw :: [[MigId]] -> Either Err_Plan [MigId] - bw [] = error "bw: unreachable" - bw topos0@(_:_) = case req0 of - [] -> - -- No specific migration was requested, so we undo everything not gone. - case filter isGone ran of - [] -> Right ran - xs -> Left (Err_Plan_TargetsGone (Set.fromList xs)) - _ -> - -- We exclude from 'req0' whatever hasn't been run already. - case Set.intersection req0 (Set.fromList ran) of - [] -> Right [] -- Nothing to do. None of 'req0' has run yet. - req1 -> do - -- Our final topological order will be a permutation of 'req1'. - let perms :: [[MigId]] = List.permutations (Set.toList req1) - -- We remove the prefix or ran non-removeable migrations. - let topos1 :: [[MigId]] - topos1 = List.drop (length ran - Set.size req1) <$> topos0 - -- We will only undo as many migrations as 'req1' asks, so we - -- discard the rest to keep things simple below. - let topos2 :: [[MigId]] = List.take (Set.size req1) <$> topos1 - -- Select a topological order that matches one of 'perms', if any. - case filter (\topo -> any (== topo) perms) topos2 of - [] -> Left Err_Plan_TargetImpossible - topos3@(topo3:_) -> - -- Select a topological order with migrations not gone. - case List.find (all (not . isGone)) topos3 of - -- Just topo -> Right (List.reverse topo) -- In forwards order. - Just topo -> Right topo - Nothing -> Left (Err_Plan_TargetsGone - (Set.fromList (filter isGone topo3))) - --- | Like 'mkPlan', but gets the history of ran migrations directly from the --- 'Registry'. -getPlan - :: Di.Df1 - -> Migs graph -- ^ Avaiable migrations. - -> Registry -- ^ Registry representing the current migration history. - -> Target -- ^ Migration target. - -> IO (Either Err_Plan Plan) -getPlan di0 migs_ reg tgt = do - state <- registry_state reg di0 - let ran = map fst (state_committed state) - pure (mkPlan migs_ ran tgt) - --------------------------------------------------------------------------------- - --- | A 'State' can be described as a list of 'Log's ordered chronologically (see --- 'updateState'). -data Log - = Log_Prepare Time.UTCTime MigId Direction - -- ^ A particular migration identified by 'MigId' is going to be executed in - -- the specified 'Direction'. - -- - -- This is the first commit in the two-phase commit approach to registering a - -- migration as executed. - -- - -- The time when this log entry was created is mentioned as well. - | Log_Commit Time.UTCTime - -- ^ The migration most recently prepared for execution with 'Log_Prepare' is - -- being committed. - -- - -- This is the second commit in the two-phase commit approach to registering a - -- migration as executed. - -- - -- The time when this log entry was created is mentioned as well. - | Log_Abort Time.UTCTime - -- ^ The migration most recently prepared for execution with 'Log_Prepare' is - -- being aborted. - -- - -- This undoes the first commit in the two-phase commit approach to - -- registering a migration as executed. - -- - -- The time when this log entry was created is mentioned as well. - deriving (Eq, Show, Read) - --------------------------------------------------------------------------------- - --- | Registry status. -data Status - = Dirty MigId Direction - -- ^ There is an uncommitted migration being run in the specified direction in - -- the registry. - | Clean - -- ^ There are no uncommitted migrations in the registry. - deriving (Eq, Show) - --------------------------------------------------------------------------------- - --- | Internal 'State' of a 'Registry'. --- --- Create with 'emptyState' and 'updateState'. -data State = State Status [(MigId, Time.UTCTime)] - deriving (Eq, Show) - --- | Whether the registry is currently 'Dirty' or 'Clean'. -state_status :: State -> Status -state_status (State x _) = x - --- | Committed migrations, chronologically ordered, with the most recently --- applied first last. -state_committed :: State -> [(MigId, Time.UTCTime)] -state_committed (State _ x) = List.reverse x - --- | A clean 'State' without any committed migrations. -emptyState :: State -emptyState = State Clean [] - --- | Modify a 'State' by applying a 'Log' to it, if possible. --- --- Use 'emptyState' as the initial state. --- --- @ --- 'Data.Foldable.foldlM' 'updateState' 'emptyState' --- :: 'Foldable' t --- => t 'Log' --- -> 'Either' 'Err_UpdateState' 'State' --- @ -updateState :: State -> Log -> Either Err_UpdateState State -updateState (State Clean xs) (Log_Prepare _ mId Forwards) - | elem mId (map fst xs) = Left (Err_UpdateState_Duplicate mId) - | otherwise = Right (State (Dirty mId Forwards) xs) -updateState (State Clean xs) (Log_Prepare _ mId Backwards) - | elem mId (map fst xs) = Right (State (Dirty mId Backwards) xs) - | otherwise = Left (Err_UpdateState_NotFound mId) -updateState (State Clean _) _ - = Left Err_UpdateState_Clean -updateState (State (Dirty mId Forwards) xs) (Log_Commit t) - = Right (State Clean ((mId, t) : xs)) -updateState (State (Dirty _ Forwards) xs) (Log_Abort _) - = Right (State Clean xs) -updateState (State (Dirty mId Backwards) xs) (Log_Commit _) - = Right (State Clean (filter (\(mId', _) -> mId' /= mId) xs)) -updateState (State (Dirty _ Backwards) xs) (Log_Abort _) - = Right (State Clean xs) -updateState (State (Dirty _ _) _) _ - = Left Err_UpdateState_Dirty - --------------------------------------------------------------------------------- - --- | 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 () -cleanRegistry di0 migs_ reg0 = do - let reg = mkRegistrish reg0 - 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." - case lookupMigs mId migs_ of - Nothing -> do - 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." - Ex.throwM (Err_CleanRegistry_MigGone mId) - Just (_, UMig (st :: Store x) _ (Change ch)) -> do - store_load st di1 mId $ \x -> do - Ex.uninterruptibleMask $ \restore -> do - restore (ch di1 (opposite d1) Recovery x) - registrish_abort reg di1 mId d1 - --------------------------------------------------------------------------------- - -run :: Di.Df1 -> Registry -> Plan -> IO () -run di0 reg0 (Plan d0 s0) = do - let reg = mkRegistrish reg0 - fmap state_status (registrish_state reg di0) >>= \case - Dirty mId d1 -> Ex.throwM (Err_Run_Dirty mId d1) - 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 - when (d0 == Forwards) $ do - ba di1 (store_save st di1 mId) - -- If 'ioDelete' is 'True' when we finish processing our migration, - -- then we will delete the data for 'mId' from the 'Store'. - ioDelete :: IORef Bool <- newIORef False - -- We run 'store_load' even if we already know what the recovery data - -- is, to ensure that it can be loaded later in case of catastrophe. - Ex.finally - (store_load st di1 mId $ \x -> do - registrish_prepare reg di1 mId d0 - Ex.uninterruptibleMask $ \restore -> do - Ex.onException - (restore (ch di1 d0 Normal x)) - (do ch di1 (opposite d0) Recovery x - registrish_abort reg di1 mId d0 - when (d0 == Forwards) - (writeIORef ioDelete True)) - registrish_commit reg di1 mId d0 - when (d0 == Backwards) - (writeIORef ioDelete True)) - (readIORef ioDelete >>= \case - True -> store_delete st di1 mId - False -> pure ()) - --------------------------------------------------------------------------------- - --- | Migrations registry, keeping track of what migrations have been run so far, --- as well as those that are running. --- --- Consider using 'Moto.Registry.newAppendOnlyRegistry' as an easy way to --- create a 'Registry'. -data Registry = Registry - { registry_state :: Di.Df1 -> IO State - -- ^ Current registry state. - -- - -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and - -- "Di.Df1"), but please don't log exceptions nor messages telling whether - -- this function succeeds or fails, since this library already does that for - -- you. - , registry_prepare :: Di.Df1 -> MigId -> Direction - -> IO (Either Err_Prepare Log) - -- ^ Register a new pending change in the registry. - -- - -- Returns the 'Log_Prepare' that describes this change to the registry. - -- - -- * This is the first commit in the two-phase commit mechanism to - -- registering migrations as executed ('registry_commit' is the second). - -- - -- * If 'Forwards', then the given 'MigId' shall be recorded in the - -- registry as fully exceuted after a subsequent 'registry_commit'. If the - -- given 'MigId' is already present and committed in the registry, then - -- 'registry_prepare' shall return 'Err_Prepare_Duplicate'. - -- - -- * If 'Backwards', then the given 'MigId', which must be already present - -- and committed to the registry, will be removed from the list of currently - -- committed migtrations after a subsequent 'registry_commit'. If the - -- 'MigId' is not already present and committed in the registry, then - -- 'registry_prepare' shall return 'Err_Prepare_NotFound'. - -- - -- * If there is already an uncommitted migration (that is, if the status is - -- 'Dirty'), then 'Err_Prepare_Dirty' shall be returned. This constraint - -- implies that it is impossible to have more than one pending change at a - -- time. - -- - -- * After a successful call to 'registry_prepare', the registry will be - -- left in a 'Dirty' status until one of 'registry_commit' or - -- 'registry_abort' is performed. - -- - -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and - -- "Di.Df1"), but don't log exceptions nor messages telling whether this - -- function succeeds or fails, since this library already does that for you. - , registry_abort :: Di.Df1 -> MigId -> Direction - -> IO (Either Err_Abort Log) - -- ^ Abort the pending change in the given 'Direction' most recently - -- introduced via 'registry_prepare', expected to be identified by the given - -- 'MigId'. - -- - -- Returns the 'Log_Abort' that describes this change to the registry. - -- - -- If there is no pending change to be aborted (that is, if the status is - -- 'Clean'), then 'Err_Abort_Clean' shall be returned. - -- - -- If the currently pending migration's identifier is different from the - -- the given 'MigId', or if its execution was intended for a 'Direction' - -- different than the one specified here, then 'Err_Abort_Dirty' shall be - -- returned. - -- - -- After a successful call to 'registry_abort', the registry will be left - -- in a 'Clean' status. - -- - -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and - -- "Di.Df1"), but don't log exceptions nor messages telling whether this - -- function succeeds or fails, since this library already does that for you. - , registry_commit :: Di.Df1 -> MigId -> Direction - -> IO (Either Err_Commit Log) - -- ^ Commit the pending change in the given 'Direction' most recently - -- introduced via 'registry_prepare', expected to be identified by the given - -- 'MigId'. - -- - -- Returns the 'Log_Commit' that describes this change to the registry. - -- - -- This is the first commit in the two-phase commit mechanism to - -- registering migrations as executed ('registry_prepare' is the first). - -- - -- If there is no pending change to be committed (that is, if the status - -- is 'Clean'), then 'Err_Commit_Clean' shall be returned. - -- - -- If the currently pending migration's identifier is different from the - -- the given 'MigId', or if its execution was intended for a 'Direction' - -- different than the one specified here, then 'Err_Commit_Dirty' shall be - -- returned. - -- - -- After a successful call to 'registry_commit', the registry will be left - -- in a 'Clean' status. - -- - -- The passed in 'Di.Df1' can be used for logging if necessary (see "Di" and - -- "Di.Df1"), but don't log exceptions nor messages telling whether this - -- function succeeds or fails, since this library already does that for you. - } - --- | This is just like 'Registry', except the 'Left' return values are --- propagated as exceptions. -data Registrish = Registrish - { registrish_state :: Di.Df1 -> IO State - , registrish_prepare :: Di.Df1 -> MigId -> Direction -> IO () - , registrish_abort :: Di.Df1 -> MigId -> Direction -> IO () - , registrish_commit :: Di.Df1 -> MigId -> Direction -> IO () - } - --- | Add some extra logging to a 'Registry', and promote the many 'Left' -mkRegistrish :: Registry -> Registrish -mkRegistrish reg = - let f :: Ex.Exception a => Either a b -> IO () - f = either Ex.throwM (const (pure ())) - in Registrish - { registrish_state = registry_state reg - , registrish_prepare = \di0 mId d -> do - let di1 = Di.push "registry" di0 - Di.debug di1 "Adding pending registry change..." - logException di1 (f =<< registry_prepare reg di1 mId d) - 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..." - logException di1 (f =<< registry_abort reg di1 mId d) - 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..." - logException di1 (f =<< registry_commit reg di1 mId d) - Di.debug di1 "Committed change to registry." - } - --------------------------------------------------------------------------------- --- Various errors. - --- | A 'Log' representation was malformed and couldn't be parsed. -data Err_MalformedLog = Err_MalformedLog String deriving (Eq, Show) -instance Ex.Exception Err_MalformedLog - --- | Errors from 'mkPlan'. -data Err_Plan - = Err_Plan_TargetsNotFound (Set MigId) - -- ^ The targeted 'MigId's are not present in the migrations graph. - | Err_Plan_HistoryUnknown - -- ^ The specified migration history is not a known possibility according - -- to the migrations dependency graph, meaning that it is not possible to - -- add new migrations to it. - | Err_Plan_TargetImpossible - -- ^ It is not possible to obtain an execution plan given the requirements and - -- dependency graph. - | Err_Plan_TargetsGone (Set MigId) - -- ^ Some migrations required to obtain an execution plan are 'Gone'. - deriving (Eq, Show) -instance Ex.Exception Err_Plan - --- | Errors from 'cleanRegistry'. --- --- By the time you receive these errors, they have already been logged. -data Err_CleanRegistry - = Err_CleanRegistry_NotFoundInMigs MigId - -- ^ The currently dirty 'MigId', as it appears in the 'Registry' records, is - -- not present in the given 'Migs'. - | Err_CleanRegistry_MigGone MigId - -- ^ The code for the migration identfified 'MigId' is gone. - deriving (Eq, Show) -instance Ex.Exception Err_CleanRegistry - --- | Errors from 'run'. -data Err_Run - = Err_Run_Dirty MigId Direction - -- ^ The migration registry has an unexpected pending migration. - deriving (Eq, Show) -instance Ex.Exception Err_Run - --- | Errors from 'updateState'. -data Err_UpdateState - = Err_UpdateState_Duplicate MigId - | Err_UpdateState_NotFound MigId - | Err_UpdateState_Clean - | Err_UpdateState_Dirty - deriving (Eq, Show) -instance Ex.Exception Err_UpdateState - --- | Errors from 'registry_prepare'. -data Err_Prepare - = Err_Prepare_Duplicate MigId - | Err_Prepare_NotFound MigId - | Err_Prepare_Dirty MigId Direction - deriving (Eq, Show) -instance Ex.Exception Err_Prepare - --- | Errors from 'registry_abort'. -data Err_Abort - = Err_Abort_Clean - | Err_Abort_Dirty MigId Direction - deriving (Eq, Show) -instance Ex.Exception Err_Abort - --- | Errors from 'registry_commit'. -data Err_Commit - = Err_Commit_Clean - | Err_Commit_Dirty MigId Direction - deriving (Eq, Show) -instance Ex.Exception Err_Commit - --------------------------------------------------------------------------------- - --- | Get all the topological orders for the given acyclic graph, in --- depth-first order. --- --- Each node is represented as @k@, and the graph is represented as an --- 'Map' from nodes to an 'Set' of nodes it depends on. For example, the graph --- @1 <- 2 <- 3@ where @1@ must come before @2@ and @2@ must come before @3@ can --- be represented as: --- --- @ --- [(1,[]), (2,[1]), (3,[2])] :: 'Map' 'Int' ('Set' 'Int') --- @ --- --- If there there are cycles in the graph, or if nodes depended upon are --- missing, then @('mempty' :: 'Set')@ is returned. --- --- If the given map is empty, then @('pure' [] :: 'Set')@ is returned. --- --- The length of each @[k]@ equals the size of the given 'Map' (i.e., --- 'Map.size'). -topos :: forall k. Ord k => Map k (Set k) -> [[k]] -topos [] = [[]] -topos m0 = go Set.empty m0 - where - go :: Set k -> Map k (Set k) -> [[k]] - go _ [] = [[]] - go s0 m1 = do - n <- Map.keys (Map.filter (\s1 -> s1 `Set.isSubsetOf` s0) m1) - fmap (n:) (go (Set.insert n s0) (Map.delete n m1)) - --- TODO write more of these, especially for well formed graphs. --- prop_topos :: IntMap IntSet -> Bool --- prop_topos m = all (\y -> length y == IntMap.size m) (topos m) - --------------------------------------------------------------------------------- - --- | Runs the given action, and if some exception happens, then log it to the --- 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!" - diff --git a/lib/moto-internal/Moto/Internal/Cli.hs b/lib/moto-internal/Moto/Internal/Cli.hs deleted file mode 100644 --- a/lib/moto-internal/Moto/Internal/Cli.hs +++ /dev/null @@ -1,411 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StrictData #-} - -module Moto.Internal.Cli - ( RegistryConf(..) - , Opts - , getOpts - , run - ) where - -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 -import qualified System.IO as IO - -import qualified Moto.Internal as I - --------------------------------------------------------------------------------- - --- | Configuration for the 'I.Registry' that we'll use to keep track of the --- migrations we've run so far. -data RegistryConf = forall r. RegistryConf - { registryConf_help :: String - -- ^ Help message for the @--registry@ command line option. - , registryConf_parse :: String -> Either String r - -- ^ Parse the string obtained from the @--registry@ command line option, - -- 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 - -- ^ Given the @r@ obtained from 'registryConf_parse', get a 'I.Registry' - -- that can be used within the given scope. - } - --------------------------------------------------------------------------------- - --- | Run the command-line arguments parser, obtaining the 'Opts' necessary for --- calling 'run' afterwards. --- --- Notice that we can run the executable that calls 'getOpts' with a @--help@ --- command line switch for extensive documentation on how to interact with --- @moto@. -getOpts - :: RegistryConf - -- ^ Configuration for the 'I.Registry' to use. - -- - -- Among other things, this will dictate how we interpret the @--registry@ - -- 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. - -> OA.Parser a - -- ^ This extra parser can be used to read some extra configuration - -- values from the command-line arguments, besides @moto@'s own. - -- - -- For example, we can obtain things such as the name of a configuration - -- file or a database connection string we might want to use in our - -- migrations. - -- - -- If no such extra data is required, then @'pure' ()@ can be used. - -- - -- Notice that @moto@'s own command-line argument's parser has precedence - -- over this parser. Yet, in the command-line, the argument's for the parser - -- for @a@ should come before @moto@'s own subcommand arguments, otherwise the - -- command line program will complain about a malformed command-line. - -> IO (Opts, a) -getOpts rc p_a = OA.customExecParser - (OA.prefs (OA.showHelpOnEmpty <> OA.noBacktrack)) - (let pi0 = oa_pi_Opts rc - in pi0 { OA.infoParser = (,) <$> OA.infoParser pi0 <*> p_a }) - --- | Run @moto@ on the given migrations graph 'I.Migs', according to the --- instructions in 'Opts'. -run - :: Di.Df1 - -- ^ Root logger. If you don't have a 'Di.Df1' for your program yet, you can - -- obtain one using @Di.new@ from the - -- [di](https://hackage.haskell.org/package/di) library. - -> I.Migs graph - -- ^ Avaliable migrations graph. - -> Opts - -- ^ Instructions on how to interact with our migrations. - -- Obtain with 'getOpts'. - -> IO () -run di0 migs opts = do - case opts_sub opts of - Sub_Run x -> run_Run di0 migs x - Sub_ShowMigrations x -> run_ShowMigrations migs x - Sub_CheckMigrations x -> run_CheckMigrations di0 migs x - Sub_ShowRegistry x -> run_ShowRegistry di0 x - Sub_CleanRegistry x -> run_CleanRegistry di0 migs x - Sub_DeleteRecoveryData x -> run_DeleteRecoveryData di0 migs x - -run_Run :: Di.Df1 -> I.Migs graph -> Opts_Run -> IO () -run_Run di0 migs x = do - runWithRegistry (opts_run_withRegistry x) $ \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 - False -> I.run di0 reg p - True -> BB.hPutBuilder IO.stdout (renderPlan p) - -run_ShowMigrations :: I.Migs graph -> Opts_ShowMigrations -> IO () -run_ShowMigrations migs x = do - let gf = opts_showMigrations_graphFormat x - BB.hPutBuilder IO.stdout (renderMigs gf migs) - -run_CheckMigrations :: Di.Df1 -> I.Migs graph -> Opts_CheckMigrations -> IO () -run_CheckMigrations di0 migs x = do - runWithRegistry (opts_checkMigrations_withRegistry x) $ \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 - Right _ -> IO.exitSuccess - -run_ShowRegistry :: Di.Df1 -> Opts_ShowRegistry -> IO () -run_ShowRegistry di0 x = do - runWithRegistry (opts_showRegistry_withRegistry x) $ \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 - 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 () - -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 - 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." - IO.exitFailure - Nothing -> do - Di.error di1 "Migration not unknown." - IO.exitFailure - --------------------------------------------------------------------------------- - -oa_pi_Opts :: RegistryConf -> OA.ParserInfo Opts -oa_pi_Opts rc = OA.info - (oa_p_Opts rc OA.<**> OA.helper) - (OA.fullDesc <> OA.progDesc "Command line interface to migrations.") - -oa_p_Opts :: RegistryConf -> OA.Parser Opts -oa_p_Opts rc = Opts <$> oa_p_Sub rc - --- | This is the input required by 'run', obtained from the command line --- arguments by using 'getOpts'. -data Opts = Opts - { opts_sub :: Sub - -- ^ Subcommand to run. - } - --------------------------------------------------------------------------------- - -oa_p_Sub :: RegistryConf -> OA.Parser Sub -oa_p_Sub rc = OA.hsubparser $ mconcat - [ OA.command "run" - (fmap Sub_Run (oa_pi_Run rc)) - , OA.command "show-migrations" - (fmap Sub_ShowMigrations oa_pi_ShowMigrations) - , OA.command "check-migrations" - (fmap Sub_CheckMigrations (oa_pi_CheckMigrations rc)) - , OA.command "show-registry" - (fmap Sub_ShowRegistry (oa_pi_ShowRegistry rc)) - , OA.command "clean-registry" - (fmap Sub_CleanRegistry (oa_pi_CleanRegistry rc)) - , OA.command "delete-recovery-data" - (fmap Sub_DeleteRecoveryData oa_pi_DeleteRecoveryData) - ] - -data Sub - = Sub_Run Opts_Run - -- ^ Run migrations. - | Sub_ShowMigrations Opts_ShowMigrations - -- ^ Show available migrations. - | Sub_CheckMigrations Opts_CheckMigrations - -- ^ Check that the available migrations are compatible with the registry. - | Sub_ShowRegistry Opts_ShowRegistry - -- ^ Show migrations registry. - | Sub_CleanRegistry Opts_CleanRegistry - -- ^ I.Clean the registry if dirty. - | Sub_DeleteRecoveryData Opts_DeleteRecoveryData - -- ^ Delete content from the store. - --------------------------------------------------------------------------------- - -oa_pi_Run :: RegistryConf -> OA.ParserInfo Opts_Run -oa_pi_Run rc = OA.info (oa_p_Run rc) (OA.progDesc "Run migrations.") - -oa_p_Run :: RegistryConf -> OA.Parser Opts_Run -oa_p_Run rc = Opts_Run - <$> oa_p_WithRegistry rc - <*> oa_p_Target - <*> OA.flag True False - (OA.long "no-dry-run" <> - OA.help "Don't just show the execution plan, run it!") - -data Opts_Run = Opts_Run - { opts_run_withRegistry :: WithRegistry - -- ^ Acquire a 'I.Registry' to use within a limited scope.. - , opts_run_target :: I.Target - -- ^ Migration target. - , opts_run_dryRun :: Bool - -- ^ Don't run migrations, just show the execution plan. - } - --------------------------------------------------------------------------------- - -oa_pi_ShowMigrations :: OA.ParserInfo Opts_ShowMigrations -oa_pi_ShowMigrations = OA.info oa_p_ShowMigrations - (OA.progDesc "Show available migrations.") - -oa_p_ShowMigrations :: OA.Parser Opts_ShowMigrations -oa_p_ShowMigrations = Opts_ShowMigrations <$> oa_p_GraphFormat - -data Opts_ShowMigrations = Opts_ShowMigrations - { opts_showMigrations_graphFormat :: GraphFormat - -- ^ Format in which to render the migrations graph. - } - --------------------------------------------------------------------------------- - -oa_pi_CheckMigrations :: RegistryConf -> OA.ParserInfo Opts_CheckMigrations -oa_pi_CheckMigrations rc = OA.info (oa_p_CheckMigrations rc) - (OA.progDesc "Exit immediately with status 0 if the available \ - \migrations are compatible with the registry. \ - \Otherwise, exit with status 1.") - -oa_p_CheckMigrations :: RegistryConf -> OA.Parser Opts_CheckMigrations -oa_p_CheckMigrations rc = Opts_CheckMigrations <$> oa_p_WithRegistry rc - -data Opts_CheckMigrations = Opts_CheckMigrations - { opts_checkMigrations_withRegistry :: WithRegistry - -- ^ Acquire a 'I.Registry' to use within a limited scope.. - } - --------------------------------------------------------------------------------- - -oa_pi_ShowRegistry :: RegistryConf -> OA.ParserInfo Opts_ShowRegistry -oa_pi_ShowRegistry rc = OA.info - (oa_p_ShowRegistry rc) - (OA.progDesc "Show migrations registry.") - -oa_p_ShowRegistry :: RegistryConf -> OA.Parser Opts_ShowRegistry -oa_p_ShowRegistry rc = Opts_ShowRegistry <$> oa_p_WithRegistry rc - -data Opts_ShowRegistry = Opts_ShowRegistry - { opts_showRegistry_withRegistry :: WithRegistry - -- ^ Acquire a 'I.Registry' to use within a limited scope.. - } - --------------------------------------------------------------------------------- - -oa_pi_CleanRegistry :: RegistryConf -> OA.ParserInfo Opts_CleanRegistry -oa_pi_CleanRegistry rc = OA.info - (oa_p_CleanRegistry rc) - (OA.progDesc "Clean a dirty migrations registry.") - -oa_p_CleanRegistry :: RegistryConf -> OA.Parser Opts_CleanRegistry -oa_p_CleanRegistry rc = Opts_CleanRegistry - <$> oa_p_WithRegistry rc - <*> OA.switch (OA.long "dry-run" <> - 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.") - -data Opts_CleanRegistry = Opts_CleanRegistry - { opts_cleanRegistry_withRegistry :: WithRegistry - -- ^ 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. - } - --------------------------------------------------------------------------------- - -oa_pi_DeleteRecoveryData :: OA.ParserInfo Opts_DeleteRecoveryData -oa_pi_DeleteRecoveryData = OA.info oa_p_DeleteRecoveryData - (OA.progDesc "Delete contents from the migrations data store.") - -oa_p_DeleteRecoveryData :: OA.Parser Opts_DeleteRecoveryData -oa_p_DeleteRecoveryData = Opts_DeleteRecoveryData - <$> fmap Set.fromList (OA.some (OA.option OA.str (OA.long "mig"))) - -data Opts_DeleteRecoveryData = Opts_DeleteRecoveryData - { opts_store_migIds :: Set.Set I.MigId - -- ^ 'I.MigId's for which to remove contents from the data store. - } - --------------------------------------------------------------------------------- - -data WithRegistry = WithRegistry - { runWithRegistry :: forall a. (I.Registry -> IO a) -> IO a } - -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_p_Target :: OA.Parser I.Target -oa_p_Target = I.Target - <$> OA.flag I.Forwards I.Backwards (OA.long "backwards") - <*> fmap Set.fromList (OA.many (OA.option OA.str - (OA.long "mig" <> OA.metavar "ID" <> - OA.help "If specified, only consider running the migration identified \ - \by this ID. Use multiple times for multiple migrations."))) - --------------------------------------------------------------------------------- - -oa_p_GraphFormat :: OA.Parser GraphFormat -oa_p_GraphFormat = - OA.flag GraphFormatText GraphFormatDot - (OA.long "dot" <> OA.help "Render graph in DOT (Graphviz) format.") - -data GraphFormat - = GraphFormatText -- ^ Render as plain text. - | GraphFormatDot -- ^ Render as DOT (Graphviz). - -renderMigs :: GraphFormat -> I.Migs graph -> BB.Builder -renderMigs = \case - GraphFormatText -> renderMigs_Text - GraphFormatDot -> renderMigs_Dot - -renderMigs_Text :: I.Migs graph -> BB.Builder -renderMigs_Text (I.Migs m0) = mconcat $ do - (here, deps) <- Map.toList (fmap (toList . fst) m0) - case deps of - [] -> [ f here <> " has no dependencies.\n" ] - _ -> [ f here <> " depends on:\n" <> - mconcat (map (\mId -> " * " <> f mId <> "\n") deps) ] - where - f :: I.MigId -> BB.Builder - f (I.MigId x) = T.encodeUtf8Builder (T.pack (show x)) - -renderMigs_Dot :: I.Migs graph -> BB.Builder -renderMigs_Dot (I.Migs m0) = mconcat - [ "digraph G {\n" - , mconcat $ do - (here, deps) <- Map.toList (fmap (toList . fst) m0) - dep <- deps - [ " " <> f dep <> " -> " <> f here <> ";\n" ] - , "}\n" - ] - where - f :: I.MigId -> BB.Builder - f (I.MigId x) = T.encodeUtf8Builder (T.pack (show x)) - --------------------------------------------------------------------------------- - -renderState :: I.State -> BB.Builder -renderState s = - "Status: " <> fromString (show (I.state_status s)) <> - "\nCommitted migrations: " <> - fromString (show (length (I.state_committed s))) <> "\n" <> - mconcat (map (\x -> " " <> fromString (show x) <> "\n") - (I.state_committed s)) - --------------------------------------------------------------------------------- - --- | Renders each 'MigId' in the 'Plan' preceded by its direction, and followed --- by a trailing newline. -renderPlan :: I.Plan -> BB.Builder -renderPlan (I.Plan _ []) = "Execution plan is empty. Nothing to do.\n" -renderPlan (I.Plan d s) = mconcat - [ "Execution plan:\n" - , mconcat (map (\(mId,_) -> " Run " <> d' <> f mId <> "\n") (toList s)) - , "\nTo actually run the migrations, add --no-dry-run to " - , "the command-line arguments.\n" ] - where - d' :: BB.Builder - d' = I.direction "backwards " "forwards " d - f :: I.MigId -> BB.Builder - f (I.MigId x) = T.encodeUtf8Builder (T.pack (show x)) - diff --git a/lib/moto/Moto.hs b/lib/moto/Moto.hs deleted file mode 100644 --- a/lib/moto/Moto.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE CPP #-} - -{- | - -@moto@ is a library for describing and running /migrations/. - -A /migration/ is any code that changes the environment somehow. The -stereotypical example of a migration is code that modifies the schema of a -database, but really anything that changes the environment somehow can be seen -as a migration. For example, moving a file to a different directory or host, -installing a package, deploying infrastructure, etc. - -Essentially, a migration is a glorified bash script to which we hold dear because -of how devastating it can be for our project if we get it wrong. @moto@ -understands this, so it is very careful about how, when, where and why it runs -these migrations, paying special attention to what happens when something goes -wrong. Of course, this being Haskell, we are encouraged to use domain specific -tools that can prevent us from accidentally writing the wrong migration code -(e.g., deleting a database rather than modifying it). - -In @moto@ we can specify migrations in such a way that any data that is going -modified or deleted by a migration can be backed up for us in one or more -storages of our choice. If anything goes wrong, or if we latter decide to undo -these changes, then this backup will be automatically made available to us. - -@moto@ is excellent for teams, where multiple collaborators can add new -migrations to the project at the same time, establishing dependencies between -them by saying “this migration needs to run before that other one” as a graph. -At compile time, @moto@ will ensure whether there is at least one way to execute -these migrations graph sequentially, or fail to compile otherwise. And at -runtime, it will execute this graph in any way that's compatible with the -environment where the migrations are being run. We don't need to worry about -serializing the release and deployment of migrations anymore, nor about making -sure that everybody runs migrations in the same order. We can delegate that -responsibility to @moto@. - -Also, @moto@ is an excellent interface to interacting with our migrations and -environment. The final product we obtain as a user of @moto@ is a ready-made -/command line interface/ program that we can deploy and use to run all or some -migrations, undo them, render the dependency graph, compare it with the current -registry of migrations that have been run so far, obtain an execution plan as -well as very detailed logs in human and computer readable formats, etc. - -@moto@ relies on a /registry/ of migrations to understand what has been run so -far and what hasn't. We can decide whether to keep this state locally or in -a remote database. - -Last, but not least, @moto@ encourages us to remove old migrations after some -time, once these migrations are so old that maintaining them in the project is -an unnecessary burden to us. To this end, @moto@ offers us enough vocabulary to -mark said migrations as /gone/. - -This module is inteded to be imported qualified: - -@ -import qualified "Moto" -@ - --} -module Moto - ( - -- * Example - -- - -- $example - - -- * Frequently Asked Questions - -- - -- $faq - - -- * Running - IC.run - , IC.Opts - , IC.getOpts - - -- * Describing individual migrations - , I.Mig(..) - , I.Store(..) - , I.mapStore - , I.Backup(..) - , I.Change(..) - , I.Direction(..) - , I.direction - , I.Mode(..) - , I.MigId(..) - - -- * Describing migrations graph - , I.Migs - , I.migs - , (I.*) - , I.DAG - - -- * Command line help - -- - -- $cli_help - ) where - -import qualified Moto.Internal as I -import qualified Moto.Internal.Cli as IC - -{- $example - -The main interface to running migrations is the command line. As a user of -@moto@, we are expected to create an executable that calls 'I.cli'. This -executable can then be deployed and used to run migrations. - -Usually, the code in this executable will look like this: - -@ -\{\-\# LANGUAGE DataKinds \#\-\} -\{\-\# LANGUAGE PartialTypeSignatures \#\-\} - - --- Our project will be an executable, so we name our module Main as it is --- customary. -module Main (main) where - - --- "Moto" is designed to be imported qualified, as well as "Di", a module that --- provides the logging support required by "Moto". -import qualified "Di" -import qualified "Moto" - --- Moreover, in this example we will use a migrations registry from the --- "Moto.File" module as an example. -import qualified "Moto.File" - - --- Here are some migrations, each of them with a identifier and a set of --- identifiers for other migrations expected to be executed before them when --- going 'Moto.Forwards'. --- --- Optional: It is actually recommended to put each migration in its own module. --- It is not necessary, but GHC takes a longer time and more resources to --- compile big modules. And considering the list of migrations in our project --- will always be growing, it's better to organize things that way from the --- start, as this can quickly become a source of slow compilation times. For --- example, instead of Main.mig_black and Main.mig_blue, we can have --- MyProject.Migs.Black.mig and MyProject.Migs.Blue.mig that we import as --- necessary. -mig_red :: Moto.Mig "red" '["blue"] -mig_red = Moto.Mig ... -- Please see the documentation for 'Moto.Mig'. - -mig_yellow :: Moto.Mig "yellow" '["black","red"] -mig_yellow = Moto.Mig ... -- Please see the documentation for 'Moto.Mig'. - -mig_green :: Moto.Mig "green" '["red"] -mig_green = Moto.Mig ... -- Please see the documentation for 'Moto.Mig'. - -mig_black :: Moto.Mig "black" '["blue"] -mig_black = Moto.Mig ... -- Please see the documentation for 'Moto.Mig'. - -mig_blue :: Moto.Mig "blue" '[] -mig_blue = Moto.Mig ... -- Please see the documentation for 'Moto.Mig'. - - --- All of the 'Mig's that we might want to run need to be put in directed --- acyclic graph where each migration is a node and each edge is a dependency --- between migrations. In "Moto", we use 'Moto.migs' and the infix 'Moto.*' --- function to safely construct the graph of migrations. The way we define our --- 'Moto.Migs' is a bit strange. Let's understand why. --- --- The Moto.* infix function says that the migrations that appear syntactically --- to its right can only mention as their dependencies migrations that appear --- to its syntactic left. This prevents us from mentioning our migrations in --- any order, but on the other hand it ensures at construction that there are no --- cycles nor dangling references in our dependency graph. If we get the order --- wrong, we will get a type-checker error. Moreover, migration identifiers are --- forced to be unique within this graph. The Moto.migs value itself is a dummy --- starting point we use as the leftmost argument to our chain of Moto.* calls. --- --- Observation: Note we avoid giving an explicit type to myMigs. Instead, we --- used the PartialTypeSignatures GHC extension to put an underscore there and --- allow GHC to use the inferred type. This is a desirable thing to do so as to --- prevent type-inference from accidentally inferring an undesired identifier --- for our migrations. This approach forces all of our Moto.Mig values to have --- their identifiers and dependencies fully specified at their definition site. --- We could have accomplished the same by not giving an type signature to our --- top level myMigs, or by simply inlining our definition of myMigs at its use --- site later on. -myMigs :: Moto.Migs _ -myMigs = Moto.migs - Moto.* mig_blue - Moto.* mig_red - Moto.* mig_black - Moto.* mig_green - Moto.* mig_yellow - - --- Finally, we have our main entry point. This program can be run from the --- command line and allows us to run and inspect migrations. -main :: IO () -main = do - - -- Using 'Moto.getOpts' we parse the command-line arguments and obtain the - -- instructions necessary to call 'Moto.run' afterwards. We specify as - -- arguments a 'Moto.Cli.RegistryConf' that describes the migrations - -- registry where we keep track of the migrations that have run so far, as - -- well as any extra command-line parsing needs we may have. In our case, we - -- use a file in the filesystem as our registry, and we don't do any extra - -- command-line argument parsing. Please see the documentation of - -- 'Moto.getOpts' for more details. - (myOpts, ()) <- Moto.getOpts Moto.File.registryConf (pure ()) - - -- @moto@ uses "Di" for its own logging, so we first - -- need to obtain a @'Di.Di' 'Df1.Level' 'Df1.Path' 'Df1.Message'@ value (also - -- known by its 'Di.Df1' synonym). We can do this using 'Di.new'. - Di.new $ \\di -> do - - -- Finally, we 'Moto.run' @moto@ as instructed by @myOpts@, passing in the - -- 'Di.Df1' we just obtained, as well as the migrations graph - Moto.run di myMigs myOpts -@ --} - -{- $faq - -Here are some answers to questions you'll frequently ask yourselves when using -@moto@. - -[Where should we maintain the migrations code for our project?] -Ideally, if you keep your whole project in a single code repository, you should -keep the migrations in that same repository, so that they are always in sync -with the code they cater for. You should create a standalone executable program -for running your migrations. - -[Should my migrations program depend on the code I am migrating?] -Definitely not. That code will change or disappear over time, and it will affect -your migrations code whenever it changes. Your migrations code should stand -alone and have a holistic view of the history of the many environments where -your project runs, without depending on it. - -[Can I use @moto@ to migrate projects not written in Haskell?] -Yes, @moto@ doesn't care about the language your project is written in. However, -the migrations code itself will have to be written Haskell. - -[How do I deploy this?] -The same way you deploy other executables. We recommend packaging the program as -a Nix derivation containing a statically linked executable. Moreover, you can -package the migrations execution as a NixOS module that runs automatically -whenever a new version is deployed. Future versions of @moto@ will provide a web -interface for making migration execution a bit more interactive. - -[How do I make sure my migrations work before deploying them?] -Generally speaking, as much as possible, you should use domain-specific -type-safe DSLs to describe your changes. But still, eventually, try the real -thing locally. Don't try to “mock” scenarios, that doesn't help. @moto@ makes -it quite easy to run migrations backwards afterwards. Moreover, in order to try -recovery scenarios, you try and throw exceptions from the different parts of -your migrations and see what happens. - -[I don't see anything about SQL nor versioned data-types here] -Whether you are modifying an SQL database or moving any other kind of -bits around, @moto@ doesn't care about those details. You can write all the SQL -you want inside your migration, using the SQL-supporting library of your choice, -or version your datatypes as well. - -[Is this ready for production?] -Migrations are a tricky business, and this is a very early release of @moto@, so -use at your own risk. - -[Is the API stable?] -No, and it will never be. We will always break the API as necessary if it allows -us offer better safety and experience. However, we understand the subtle nature -of the projects relying on @moto@ an we will take the necessary steps to ensure -a positive and maintainable experience over time. Please see -the [changelog](https://hackage.haskell.org/package/moto/changelog) to -understand differences between versions and learn about any necessary changes -you'll need to make. In a @moto@ version @x.y.z@, we will always increase one of -@x@ or @y@ whenever a new version introduces backwards incompatible changes. - -[I have more questions!] -We have more answers. Just [ask](https://gitlab.com/k0001/moto/issues). - --} -#include "cli_help.docs" - diff --git a/lib/moto/Moto/File.hs b/lib/moto/Moto/File.hs deleted file mode 100644 --- a/lib/moto/Moto/File.hs +++ /dev/null @@ -1,220 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | This module exports a 'I.Store' that stores 'I.Backup' data as files in the --- filesystem, as well as a 'I.Registry' backed by a file in the filesystem and --- related tools. --- --- Please import as: --- --- @ --- import qualified "Moto.File" --- @ -module Moto.File - ( -- * Registry - registryConf - , withRegistry - - , -- * Store - store - ) where - -import Control.Applicative (empty) -import qualified Control.Exception.Safe as Ex -import qualified Control.Monad.Trans.State.Strict as S -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Trans (lift) -import qualified Data.Aeson as Ae -import qualified Data.Attoparsec.ByteString.Char8 as A8 -import qualified Data.ByteString as B -import qualified Data.ByteString.Builder as BB -import qualified Data.Char as Char -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import GHC.IO.Handle as IO (LockMode(ExclusiveLock), hLock) -import qualified Pipes as P -import qualified Pipes.Attoparsec as Pa -import qualified Pipes.ByteString as Pb -import qualified System.Directory as Dir -import System.FilePath (()) -import qualified System.IO as IO -import qualified System.IO.Error as IO - -import qualified Moto.Internal as I -import qualified Moto.Internal.Cli as IC -import qualified Moto.Registry as R - --------------------------------------------------------------------------------- - --- | Command-line configuration for a 'I.Registry' stored as a file in the --- 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_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 - } - --- | 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 - -- ^ File where to store the registry logs. - -- - -- An exclusive lock will be set on the this file (see 'IO.hLock'), which will - -- stay open until this function returns. This is to prevent other programs to - -- interact with this file while this program is running. - -> (I.Registry -> m a) - -> m a -withRegistry fp = - withRegistryCustom renderLogLine parseLogLine fp - --- | Obtain a 'I.Registry' backed by an append-only file storage as described by --- 'R.newAppendOnlyRegistry'. -withRegistryCustom - :: (MonadIO m, Ex.MonadMask m) - => (I.Log -> BB.Builder) - -- ^ Render a single 'I.Log'. Be sure to add a trailing newline or similar if - -- necessary, in order to separate one 'I.Log' entry from the next. - -> 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. - -> IO.FilePath - -- ^ File where to store the registry logs. - -- - -- An exclusive lock will be set on the this file (see 'IO.hLock'), which will - -- stay open until this function returns. This is to prevent other programs to - -- interact with this file while this program is running. - -> (I.Registry -> m a) - -> m a -withRegistryCustom render parser fp k = do - Ex.bracket - (liftIO $ do - h <- IO.openBinaryFile fp IO.ReadWriteMode - IO.hLock h IO.ExclusiveLock - pure h) - (liftIO . IO.hClose) - (\h -> k =<< liftIO (do - state0 <- do - ea <- flip S.runStateT I.emptyState $ P.runEffect $ do - P.for (Pa.parsed parser (Pb.fromHandle h)) $ \l -> do - s0 <- lift S.get - lift (either Ex.throwM S.put (I.updateState s0 l)) - case ea of - (Left (e,_), _) -> Ex.throwM (I.Err_MalformedLog (show e)) - (Right _, x) -> pure x - R.newAppendOnlyRegistry state0 $ \log' -> do - BB.hPutBuilder h (render log') - IO.hFlush h)) - --------------------------------------------------------------------------------- - --- Renders a 'I.Log' as a line of text with a trailing new line. --- --- Use 'parseLogLine' to undo this rendering. -renderLogLine :: I.Log -> BB.Builder -renderLogLine l = Ae.fromEncoding (Ae.toEncoding (LogV1 l)) <> "\n" - --- Parses a 'I.Log' from a line of text rendered by 'renderLogLine'. --- --- Any leading or trailing newlines are consumed and skipped. -parseLogLine :: A8.Parser I.Log -parseLogLine = do - _ <- A8.skipWhile (== '\n') - s <- A8.takeWhile (/= '\n') - _ <- A8.skipWhile (== '\n') - case Ae.decodeStrict s of - Just (LogV1 l) -> pure l - Nothing -> fail "Malformed Log" - --- | Wrapper around 'I.Log' used for serialization purposes, so that we don't --- expose a 'Ae.ToJSON' instance for 'I.Log'. -newtype LogV1 = LogV1 I.Log - -instance Ae.ToJSON LogV1 where - toJSON (LogV1 l) = case l of - I.Log_Commit t -> Ae.toJSON $ Ae.object - [ "action" Ae..= ("commit" :: T.Text) - , "timestamp" Ae..= t ] - I.Log_Abort t -> Ae.toJSON $ Ae.object - [ "action" Ae..= ("abort" :: T.Text) - , "timestamp" Ae..= t ] - I.Log_Prepare t (I.MigId m) d -> Ae.toJSON $ Ae.object - [ "action" Ae..= ("prepare" :: T.Text) - , "timestamp" Ae..= t - , "migration" Ae..= m - , "direction" Ae..= (I.direction "backwards" "forwards" d :: T.Text) ] - -instance Ae.FromJSON LogV1 where - parseJSON = Ae.withObject "Log" $ \o -> do - a :: T.Text <- o Ae..: "action" - fmap LogV1 $ case a of - "commit" -> I.Log_Commit - <$> (o Ae..: "timestamp") - "abort" -> I.Log_Abort - <$> (o Ae..: "timestamp") - "prepare" -> I.Log_Prepare - <$> (o Ae..: "timestamp") - <*> fmap I.MigId (o Ae..: "migration") - <*> (o Ae..: "direction" >>= \case - "backwards" -> pure I.Backwards - "forwards" -> pure I.Forwards - (_ :: T.Text) -> empty) - _ -> empty - --------------------------------------------------------------------------------- - --- | A 'Store' that keeps data stored as files (one per 'MigId') in a filesystem --- directory. --- --- For maximum memory consumption efficiency, the data is written and read in a --- streaming fasion using a 'P.Producer'. -store - :: FilePath -- ^ Path to a directory where the files are or will be stored. - -> I.Store (P.Producer B.ByteString IO ()) -store fp_dir = I.Store - { I.store_save = \_ mId x -> do - Dir.createDirectoryIfMissing True fp_dir - Ex.bracket - (IO.openBinaryFile (fp mId) IO.WriteMode) - IO.hClose - (\h -> do - IO.hSetFileSize h 0 - IO.hSetBuffering h (IO.BlockBuffering Nothing) - P.runEffect (x P.>-> Pb.toHandle h)) - , I.store_load = \_ mId k -> Ex.bracket - (IO.openBinaryFile (fp mId) IO.ReadMode) - IO.hClose - (k . Pb.fromHandle) - , I.store_delete = \_ mId -> Ex.catch - (Dir.removeFile (fp mId)) - (\case e | IO.isDoesNotExistError e -> pure () - | otherwise -> Ex.throwM e) - } - where - fp :: I.MigId -> FilePath - fp = \mId -> fp_dir TL.unpack (TL.decodeUtf8 (I.migId_sha1Hex mId)) <> - "_" <> escapeFileName (T.unpack (I.unMigId mId)) - escapeFileName :: String -> FilePath - escapeFileName = map (\case c | Char.isAscii c && Char.isAlphaNum c -> c - | otherwise -> '_') - -{- TODO save this to a README file - readme :: BB.Builder - readme = "This directory contains backups made by Moto.File.store.\n\ - \\n\ - \ https://hackage.haskell.org/package/moto/docs/Moto-File.html#v:store\n\n\ - \\n\ - \To backup these backups, it is sufficient to copy the contents\n\ - \of this directory, preserving the file names." --} diff --git a/lib/moto/Moto/Registry.hs b/lib/moto/Moto/Registry.hs deleted file mode 100644 --- a/lib/moto/Moto/Registry.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE LambdaCase #-} - --- | This module exports tools for implementing a registry that @moto@ can use --- in order to keep track of the migrations that have been run so far. --- --- It's unlikely that you'll need to concern yourself with this module as an --- end user of @moto@. --- --- Please import as: --- --- @ --- import qualified "Moto.Registry" as Moto --- @ -module Moto.Registry - ( -- * Command-line support - IC.RegistryConf(..) - - -- * Registry - , I.Registry(..) - , newAppendOnlyRegistry - - -- * State - , I.State - , I.emptyState - , I.updateState - , I.Log(..) - - -- * Errors - , Err_Tainted(..) - , I.Err_Prepare(..) - , I.Err_Abort(..) - , I.Err_Commit(..) - , I.Err_UpdateState(..) - ) where - -import Control.Concurrent (readMVar, putMVar, takeMVar, newMVar) -import qualified Control.Exception.Safe as Ex -import qualified Data.Time as Time - -import qualified Moto.Internal as I -import qualified Moto.Internal.Cli as IC - --------------------------------------------------------------------------------- - --- | Create a 'I.Registry' backed by an append-only 'I.Log' storage. --- --- This registry maintains its internal 'I.State' in memory as long as it is --- possible to successfuly store all the changes in the underlying append-only --- storage. If at some point this fails unrecoverably, then 'Err_Tainted' will --- be thrown by the functions acting on this 'I.Registry'. --- --- It's important to acquire some kind of exclusive lock on the underlying --- storage, so that other applications can't poke it while our 'I.Registry' is --- running. -newAppendOnlyRegistry - :: I.State - -- ^ Initial registry state obtained by reading 'I.Log's from the backing - -- append-only storage and running 'I.updateState' on them. - -> (I.Log -> IO ()) - -- ^ How to store a newly generated 'I.Log' in the backing append-only - -- storage. - -- - -- If this function throws an exception, then the execption will propagated - -- as usual, but also, this registry will be marked as tained and each - -- subsequent operation on it will throw 'Err_Tainted'. - -> IO I.Registry -newAppendOnlyRegistry !state0 putLog = do - mvState <- newMVar (Just state0) - let supdate :: (I.State -> Either e I.Log) -> IO (Either e I.Log) - supdate f = Ex.bracketOnError - (takeMVar mvState) - (\_ -> putMVar mvState Nothing) - (\case Nothing -> Ex.throwM Err_Tainted - Just s0 -> case f s0 of - Left e -> pure (Left e) - Right log_ -> case I.updateState s0 log_ of - Left e -> Ex.throwM e -- This is unreachable code. - Right !s1 -> do - putLog log_ - putMVar mvState (Just s1) - pure (Right log_)) - pure $ I.Registry - { I.registry_state = \_ -> do - maybe (Ex.throwM Err_Tainted) pure =<< readMVar mvState - , I.registry_prepare = \_ mId d -> do - t <- Time.getCurrentTime - supdate $ \s -> case I.state_status s of - I.Dirty mId' d' -> Left (I.Err_Prepare_Dirty mId' d') - I.Clean -> case (d, elem mId (map fst (I.state_committed s))) of - (I.Forwards, True) -> Left (I.Err_Prepare_Duplicate mId) - (I.Backwards, False) -> Left (I.Err_Prepare_NotFound mId) - _ -> Right (I.Log_Prepare t mId d) - , I.registry_abort = \_ mId d -> do - t <- Time.getCurrentTime - supdate $ \s -> case I.state_status s of - I.Clean -> Left I.Err_Abort_Clean - I.Dirty mId' d' - | mId /= mId' || d /= d' -> Left (I.Err_Abort_Dirty mId' d') - | otherwise -> Right (I.Log_Abort t) - , I.registry_commit = \_ mId d -> do - t <- Time.getCurrentTime - supdate $ \s -> case I.state_status s of - I.Clean -> Left I.Err_Commit_Clean - I.Dirty mId' d' - | mId /= mId' || d /= d' -> Left (I.Err_Commit_Dirty mId' d') - | otherwise -> Right (I.Log_Commit t) - } - --- | The 'I.Registry' is tainted, meaning our last attempt to interact with the --- registry's backing storage failed. We can't be certain about the current --- state of the 'I.Registry'. -data Err_Tainted = Err_Tainted deriving (Eq, Show) -instance Ex.Exception Err_Tainted - diff --git a/lib/moto/cli_help.docs b/lib/moto/cli_help.docs deleted file mode 100644 --- a/lib/moto/cli_help.docs +++ /dev/null @@ -1,114 +0,0 @@ -{- $cli_help - -This is the full description of the command line options supported by -'Moto.getOpts', using @Moto.File.fileRegistry@ as the registry. - -Main program (here called @moto-example@): - -@ -Usage: moto-example COMMAND - Command line interface to migrations. - -Available options: - -h,--help Show this help text - -Available commands: - run Run migrations. - show-migrations Show available migrations. - check-migrations Exit immediately with status 0 if the available - migrations are compatible with the registry. - Otherwise, exit with status 1. - show-registry Show migrations registry. - clean-registry Clean a dirty migrations registry. - delete-recovery-data Delete contents from the migrations data store. -@ - - - -Subcommand @run@: - -@ -Usage: moto-example run --registry URI [--backwards] [--mig ID] [--no-dry-run] - Run migrations. - -Available options: - --registry URI File where registry file is stored. E.g., - file:\/\/\/var\/db\/migrations - --mig ID If specified, only consider running the migration - identified by this ID. Use multiple times for - multiple migrations. - --no-dry-run Don't just show the execution plan, run it! - -h,--help Show this help text -@ - - - -Subcommand @show-migrations@: - -@ -Usage: moto-example show-migrations [--dot] - Show available migrations. - -Available options: - --dot Render graph in DOT (Graphviz) format. - -h,--help Show this help text -@ - - - -Subcommand @check-migrations@: - -@ -Usage: moto-example check-migrations --registry URI - 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 - -h,--help Show this help text -@ - - - -Subcommand @show-registry@: - -@ -Usage: moto-example show-registry --registry URI - Show migrations registry. - -Available options: - --registry URI File where registry file is stored. E.g., - file:\/\/\/var\/db\/migrations - -h,--help Show this help text -@ - - - -Subcommand @clean-registry@: - -@ -Usage: moto-example clean-registry --registry URI [--dry-run] - Clean a dirty migrations registry. - -Available options: - --registry URI File where registry file is stored. E.g., - file:\/\/\/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. - -h,--help Show this help text -@ - - - -Subcommand @delete-recovery-data@: - -@ -Usage: moto-example delete-recovery-data --mig ARG - Delete contents from the migrations data store. - -Available options: - -h,--help Show this help text -@ --} diff --git a/moto.cabal b/moto.cabal --- a/moto.cabal +++ b/moto.cabal @@ -1,9 +1,9 @@ name: moto -version: 0.0.2 +version: 0.0.3 synopsis: General purpose migrations library license: Apache-2.0 license-file: LICENSE.txt -extra-source-files: README.md CHANGELOG.md lib/moto/cli_help.docs +extra-source-files: README.md CHANGELOG.md lib/cli_help.docs author: Renzo Carbonara maintainer: ren@ren!zone category: Database @@ -11,18 +11,20 @@ cabal-version: >=2.0 library - hs-source-dirs: lib/moto + hs-source-dirs: lib default-language: Haskell2010 ghc-options: -Wall exposed-modules: Moto Moto.Registry Moto.File + Moto.Internal + Moto.Internal.Cli build-depends: aeson, attoparsec, base, - moto-internal, + base (>=4.6 && <5.0), bytestring, containers, cryptohash-sha1, @@ -31,32 +33,12 @@ di-df1, directory, filepath, - safe-exceptions, mtl, optparse-applicative, pipes, pipes-attoparsec, pipes-bytestring, - text, - time, - transformers - -library moto-internal - hs-source-dirs: lib/moto-internal - default-language: Haskell2010 - ghc-options: -Wall - exposed-modules: - Moto.Internal - Moto.Internal.Cli - build-depends: - base (>=4.6 && <5.0), - bytestring, - containers, - cryptohash-sha1, - df1, - di-df1, safe-exceptions, - optparse-applicative, text, time, transformers @@ -74,7 +56,6 @@ , di-core , directory , filepath - , moto-internal , moto , random , safe-exceptions