{-# 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 , unsafeCleanRegistry , OnDirty(..) -- * 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" 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 -------------------------------------------------------------------------------- -- | See 'unsafeCleanRegistry'. data OnDirty = OnDirty_Abort | OnDirty_Commit deriving (Eq, Show) -- | If the 'Registry' is currently 'Dirty', clean it up by __unsafely__ -- aborting or commiting the pending migration, as requested by 'OnDirty'. unsafeCleanRegistry :: Di.Df1 -> Registry -> OnDirty -> IO () unsafeCleanRegistry di0 reg0 od = do let reg = mkRegistrish reg0 fmap state_status (registrish_state reg di0) >>= \case Clean -> pure () Dirty mId d -> do let di1 = Di.attr "dir" d $ Di.attr "mig" mId $ Di.push "unsafe-clean" di0 Di.warning_ di1 "Migration registry is dirty." case od of OnDirty_Abort -> do Di.warning_ di1 "Unsafely aborting pending migration, as requested." registrish_abort reg di1 mId d OnDirty_Commit -> do Di.warning_ di1 "Unsafely commiting pending migration, as requested." registrish_commit reg di1 mId d -- | If the 'Registry' is currently 'Dirty', clean it up by running -- the dirty migration in the direction opposite than originally intended. cleanRegistry :: Di.Df1 -> Migs graph -> Registry -> IO () 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 "dir" d1 $ Di.attr "mig" mId $ Di.push "clean" di0 Di.warning_ di1 "Migration registry is dirty." case lookupMigs mId migs_ of Nothing -> do Di.alert_ di1 "MigId in Registry but not in Plan." 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 Di.notice_ di1 "Cleaning up by undoing..." store_load st di1 mId $ \x -> do Ex.uninterruptibleMask $ \restore -> do restore (ch di1 (opposite d1) Recovery x) 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" 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 -> Di.error di0 (se :: Ex.SomeException)