diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,219 @@ +Copyright 2018, Renzo Carbonara . + +Except where otherwise explicitly mentioned, all of contents of the +"moto" project are licensed under the Apache License, Version 2.0 (the +"License"); you may not use this file except in compliance with the +License. You may obtain a copy of the License at the end of this file or at +http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + + +------------------------------------------------------------------------------- + + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lib/moto-internal/Moto/Internal.hs b/lib/moto-internal/Moto/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/moto-internal/Moto/Internal.hs @@ -0,0 +1,1062 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/lib/moto-internal/Moto/Internal/Cli.hs @@ -0,0 +1,411 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/lib/moto/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/Moto/File.hs b/lib/moto/Moto/File.hs new file mode 100644 --- /dev/null +++ b/lib/moto/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/Moto/Registry.hs b/lib/moto/Moto/Registry.hs new file mode 100644 --- /dev/null +++ b/lib/moto/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/moto.cabal b/moto.cabal new file mode 100644 --- /dev/null +++ b/moto.cabal @@ -0,0 +1,85 @@ +name: moto +version: 0.0.1 +synopsis: General purpose migrations library +license: Apache-2.0 +license-file: LICENSE.txt +author: Renzo Carbonara +maintainer: ren@ren!zone +category: Database +build-type: Simple +cabal-version: >=2.0 + +library + hs-source-dirs: lib/moto + default-language: Haskell2010 + ghc-options: -Wall + exposed-modules: + Moto + Moto.Registry + Moto.File + build-depends: + aeson, + attoparsec, + base, + moto-internal, + bytestring, + containers, + cryptohash-sha1, + df1, + di-core, + 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 + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base + , bytestring + , containers + , di + , di-core + , directory + , filepath + , moto-internal + , moto + , random + , safe-exceptions + , text + , tasty + , tasty-hunit + , tasty-quickcheck + , time + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,651 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import Control.Concurrent +import qualified Control.Exception as Ex (evaluate) +import qualified Control.Exception.Safe as Ex +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Data.Either (isRight) +import Data.Foldable (toList) +import Data.Function (fix) +import Data.Maybe (isNothing) +import Data.String (fromString) +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Data.Word (Word64) +import qualified Di +import qualified Di.Core +import qualified System.Directory as Dir +import qualified System.Environment (getEnv) +import System.FilePath (()) +import qualified System.IO.Error as IO +import qualified System.Random +import qualified Test.Tasty as Tasty +import Test.Tasty.HUnit ((@?=), (@=?)) +import qualified Test.Tasty.HUnit as HU +import qualified Test.Tasty.QuickCheck as QC +import Test.Tasty.QuickCheck ((===)) +import qualified Test.Tasty.Runners as Tasty + +import qualified Moto.Internal as U +import qualified Moto.File + +-------------------------------------------------------------------------------- + +data Fail = Fail String deriving (Show) +instance Ex.Exception Fail + +fail_sync :: String -> IO a +fail_sync s = Ex.throwM (Fail s) + +-------------------------------------------------------------------------------- + +backup_noop :: x -> U.Backup x +backup_noop x = U.Backup (\_ k -> k x) + +backup_fail_sync :: String -> U.Backup x +backup_fail_sync s = U.Backup (\_ _ -> fail_sync s) + +-------------------------------------------------------------------------------- + +store_noop :: x -> U.Store x +store_noop x = + U.Store (\_ _ _ -> pure ()) (\_ _ k -> k x) (\_ _ -> pure ()) + +store_fail_sync_save :: x -> String -> U.Store x +store_fail_sync_save x s = + U.Store (\_ _ _ -> fail_sync s) (\_ _ k -> k x) (\_ _ -> pure ()) + +store_fail_sync_load :: String -> U.Store x +store_fail_sync_load s = + U.Store (\_ _ _ -> pure ()) (\_ _ k -> fail_sync s) (\_ _ -> pure ()) + +store_fail_sync_delete :: x -> String -> U.Store x +store_fail_sync_delete x s = + U.Store (\_ _ _ -> pure ()) (\_ _ k -> k x) (\_ _ -> fail_sync s) + +-------------------------------------------------------------------------------- + +change_noop :: U.Change x +change_noop = U.Change (\_ _ _ _ -> pure ()) + +change_fail_sync :: String -> U.Change x +change_fail_sync s = U.Change (\_ _ _ _ -> fail_sync s) + +-------------------------------------------------------------------------------- + +mig_noop :: x -> U.Mig id deps +mig_noop x = U.Mig (store_noop x) (backup_noop x) change_noop + +-------------------------------------------------------------------------------- +-- Here we just write some things that we expect to compile over time. + +_migs_0 :: U.Migs '[] +_migs_0 = U.migs + +_migs_1 :: U.Migs '[ '("a",'[])] +_migs_1 = U.migs U.* mig_noop () + +-- Type inferred +_migs_1' = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + +_migs_2 :: U.Migs '[ '("b",'[]), '("a",'[])] +_migs_2 = U.migs U.* mig_noop () U.* mig_noop () + +_migs_2' :: U.Migs '[ '("b",'["a"]), '("a",'[])] +_migs_2' = U.migs U.* mig_noop () U.* mig_noop () + +_migs_3 :: U.Migs '[ '("c",'[]), '("b",'[]), '("a",'[])] +_migs_3 = U.migs U.* mig_noop () U.* mig_noop () U.* mig_noop () + +_migs_3' :: U.Migs '[ '("c",'["a"]), '("b",'["a"]), '("a",'[])] +_migs_3' = U.migs U.* mig_noop () U.* mig_noop () U.* mig_noop () + +_migs_3'' :: U.Migs '[ '("c",'["b"]), '("b",'["a"]), '("a",'[])] +_migs_3'' = U.migs U.* mig_noop () U.* mig_noop () U.* mig_noop () + +_migs_3''' :: U.Migs '[ '("c",'["b","a"]), '("b",'["a"]), '("a",'[])] +_migs_3''' = U.migs U.* mig_noop () U.* mig_noop () U.* mig_noop () + +-------------------------------------------------------------------------------- + +main :: IO () +main = Di.new $ \di -> do + Tasty.defaultMainWithIngredients + [ Tasty.consoleTestReporter + , Tasty.listingTests + ] (tt di) + +-------------------------------------------------------------------------------- + +tt :: Di.Df1 -> Tasty.TestTree +tt di = Tasty.testGroup "main" + [ ttPlan + , ttRun + ] + +ttPlan :: Tasty.TestTree +ttPlan = Tasty.testGroup "plan" + [ HU.testCase "empty migs, empty ran, forwards implicit" $ do + True @=? isRight (U.mkPlan U.migs [] (U.Target U.Forwards [])) + + , QC.testProperty "empty migs, empty ran, explicit targets" $ do + let g = (,) <$> genDirection + <*> fmap Set.fromList (QC.listOf1 genMigId) + QC.forAll g $ \(d, mIds) -> do + qcEqLeft (U.Err_Plan_TargetsNotFound mIds) + (U.mkPlan U.migs [] (U.Target d mIds)) + + , HU.testCase "empty migs, empty ran, backwards implicit" $ do + True @=? isRight (U.mkPlan U.migs [] (U.Target U.Backwards [])) + + , QC.testProperty "empty migs, some ran, forwards implicit" $ do + let g = (,) <$> genDirection <*> QC.listOf1 genMigId + QC.forAll g $ \(d, mIds) -> do + qcEqLeft U.Err_Plan_HistoryUnknown + (U.mkPlan U.migs mIds (U.Target d [])) + + , QC.testProperty "one mig, different ran" $ do + let g = (,) <$> genDirection + <*> QC.suchThat (QC.listOf1 genMigId) (/= ["a"]) + QC.forAll g $ \(d, mIds) -> do + qcEqLeft U.Err_Plan_HistoryUnknown + (U.mkPlan U.migs mIds (U.Target d [])) + + , HU.testCase "one mig, empty ran, forwards implicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + Right (U.Forwards, ["a"]) + @=? fmap plan_bits + (U.mkPlan migs [] (U.Target U.Forwards [])) + + , HU.testCase "one mig, empty ran, forwards explicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + Right (U.Forwards, ["a"]) + @=? fmap plan_bits + (U.mkPlan migs [] (U.Target U.Forwards ["a"])) + + , HU.testCase "one mig, same ran, forwards implicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + Right (U.Forwards, []) + @=? fmap plan_bits + (U.mkPlan migs ["a"] (U.Target U.Forwards [])) + + , HU.testCase "one mig, same ran, forwards explicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + Right (U.Forwards, []) + @=? fmap plan_bits + (U.mkPlan migs ["a"] (U.Target U.Forwards ["a"])) + + , HU.testCase "one mig, empty ran, backwards implicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + Right (U.Backwards, []) + @=? fmap plan_bits + (U.mkPlan migs [] (U.Target U.Backwards [])) + + , HU.testCase "one mig, empty ran, backwards explicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + Right (U.Backwards, []) + @=? fmap plan_bits + (U.mkPlan migs [] (U.Target U.Backwards ["a"])) + + , HU.testCase "one mig, same ran, backwards implicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + Right (U.Backwards, ["a"]) + @=? fmap plan_bits + (U.mkPlan migs ["a"] (U.Target U.Backwards [])) + + , HU.testCase "one mig, same ran, backwards explicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + Right (U.Backwards, ["a"]) + @=? fmap plan_bits + (U.mkPlan migs ["a"] (U.Target U.Backwards ["a"])) + + , HU.testCase "five migs, empty ran, forwards implicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + Right (U.Forwards, ["a","b","c","d","e"]) + @=? fmap plan_bits + (U.mkPlan migs [] (U.Target U.Forwards [])) + + , HU.testCase "five migs, empty ran, forwards explicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + Right (U.Forwards, ["b","c","e"]) + @=? fmap plan_bits + (U.mkPlan migs [] (U.Target U.Forwards ["e","b","c"])) + + , HU.testCase "five migs, empty ran, forwards impossible" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + huEqLeft U.Err_Plan_TargetImpossible + (U.mkPlan migs [] (U.Target U.Forwards ["e","c"])) + + , HU.testCase "five migs, empty ran, backwards implicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + Right (U.Backwards, []) + @=? fmap plan_bits + (U.mkPlan migs [] (U.Target U.Backwards [])) + + , HU.testCase "five migs, empty ran, backwards explicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + Right (U.Backwards, []) + @=? fmap plan_bits + (U.mkPlan migs [] (U.Target U.Backwards ["e","b","c"])) + + , HU.testCase "five migs, empty ran, backwards for impossible forwards" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + Right (U.Backwards, []) + @=? fmap plan_bits + (U.mkPlan migs [] (U.Target U.Backwards ["d","a"])) + + , QC.testProperty "five migs, bad ran all" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + let g = (,) <$> genDirection + <*> fmap Set.fromList (QC.sublistOf ["a","b","c","d","e"]) + QC.forAll g $ \(d, mIds) -> do + qcEqLeft U.Err_Plan_HistoryUnknown + (U.mkPlan migs ["a","e","c","b","d"] (U.Target d mIds)) + + , QC.testProperty "five migs, bad ran some" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + let g = (,) <$> genDirection + <*> fmap Set.fromList (QC.sublistOf ["a","b","c","d","e"]) + QC.forAll g $ \(d, mIds) -> do + qcEqLeft U.Err_Plan_HistoryUnknown + (U.mkPlan migs ["a","d"] (U.Target d mIds)) + + , HU.testCase "five migs, same ran, forwards implicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + Right (U.Forwards, []) + @=? fmap plan_bits + (U.mkPlan migs ["b","a","c","e","d"] + (U.Target U.Forwards [])) + + , HU.testCase "five migs, same ran, forwards explicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + Right (U.Forwards, []) + @=? fmap plan_bits + (U.mkPlan migs ["a","b","c","e","d"] + (U.Target U.Forwards ["e","b","c"])) + + , HU.testCase "five migs, same ran, backwards implicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + Right (U.Backwards, ["b","a","c","e","d"]) + @=? fmap plan_bits + (U.mkPlan migs ["b","a","c","e","d"] + (U.Target U.Backwards [])) + + , HU.testCase "five migs, same ran, some backwards explicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + Right (U.Backwards, ["a","d"]) + @=? fmap plan_bits + (U.mkPlan migs ["a","b","c","e","d"] + (U.Target U.Backwards ["a","d"])) + + , HU.testCase "five migs, same ran, backwards impossible" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + huEqLeft U.Err_Plan_TargetImpossible + (U.mkPlan migs ["a","b","c","d","e"] + (U.Target U.Backwards ["b"])) + + , HU.testCase "five migs, some ran, one backwards explicit" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + Right (U.Backwards, ["c"]) + @=? fmap plan_bits + (U.mkPlan migs ["a","b","c"] + (U.Target U.Backwards ["c"])) + + , HU.testCase "five migs, some ran, forwards impossible" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + huEqLeft U.Err_Plan_TargetImpossible + (U.mkPlan migs ["a","b"] (U.Target U.Forwards ["e"])) + + , HU.testCase "five migs, some ran, backwards impossible" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (mig_noop () :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + huEqLeft U.Err_Plan_TargetImpossible + (U.mkPlan migs ["a","b","c"] (U.Target U.Backwards ["b"])) + + , HU.testCase "five migs, some ran, one backwards explicit gone" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (U.Gone :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + huEqLeft (U.Err_Plan_TargetsGone ["c"]) + (U.mkPlan migs ["a","b","c"] (U.Target U.Backwards ["c"])) + + , HU.testCase "five migs, some ran, some backwards explicit gone" $ do + let migs = U.migs U.* (U.Gone :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (U.Gone :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + huEqLeft (U.Err_Plan_TargetsGone ["c"]) + (U.mkPlan migs ["a","b","c"] (U.Target U.Backwards ["c","b"])) + + , HU.testCase "five migs, some ran, one backwards explicit one path gone" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (U.Gone :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + Right (U.Backwards, ["a"]) + @=? fmap plan_bits + (U.mkPlan migs ["a","b","c","d"] (U.Target U.Backwards ["a"])) + + , HU.testCase "five migs, some ran, two backwards explicit gone" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (U.Gone :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + huEqLeft (U.Err_Plan_TargetsGone ["c"]) + (U.mkPlan migs ["a","b","c"] (U.Target U.Backwards ["c","b"])) + + , HU.testCase "five migs, some ran, backwards implicit gone" $ do + let migs = U.migs U.* (U.Gone :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (U.Gone :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + huEqLeft (U.Err_Plan_TargetsGone ["c","a"]) + (U.mkPlan migs ["a","b","c"] (U.Target U.Backwards [])) + + , HU.testCase "five migs, some ran, backwards diamond implicit gone" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (U.Gone :: U.Mig "b" '["a"]) + U.* (U.Gone :: U.Mig "c" '["a"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + huEqLeft (U.Err_Plan_TargetsGone ["b","c"]) + (U.mkPlan migs ["a","b","c"] (U.Target U.Backwards [])) + + , HU.testCase "five migs, some ran, one forwards explicit gone" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (U.Gone :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + huEqLeft (U.Err_Plan_TargetsGone ["c"]) + (U.mkPlan migs ["a","b"] (U.Target U.Forwards ["c"])) + + , HU.testCase "five migs, some ran, some forwards explicit gone" $ do + let migs = U.migs U.* (U.Gone :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (U.Gone :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + huEqLeft (U.Err_Plan_TargetsGone ["c","a"]) + (U.mkPlan migs ["b"] (U.Target U.Forwards ["c","b","a"])) + + , HU.testCase "five migs, some ran, one forwards explicit one path gone" $ do + let migs = U.migs U.* (mig_noop () :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (U.Gone :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","b"]) + U.* (mig_noop () :: U.Mig "e" '["d"]) + Right (U.Forwards, ["a","b","d","e"]) + @=? fmap plan_bits + (U.mkPlan migs [] (U.Target U.Forwards ["a","b","d","e"])) + + , HU.testCase "five migs, some ran, forwards implicit gone" $ do + let migs = U.migs U.* (U.Gone :: U.Mig "a" '[]) + U.* (mig_noop () :: U.Mig "b" '[]) + U.* (U.Gone :: U.Mig "c" '["b"]) + U.* (mig_noop () :: U.Mig "d" '["a","c"]) + U.* (mig_noop () :: U.Mig "e" '["c"]) + huEqLeft (U.Err_Plan_TargetsGone ["c","a"]) + (U.mkPlan migs ["b"] (U.Target U.Forwards [])) + + ] + + +ttRun :: Tasty.TestTree +ttRun = Tasty.testGroup "run" + [ HU.testCase "empty registry, empty migs, forwards implicit" $ + withTestDi $ \di -> + withExpectedTestRegistry di U.Clean [] $ \reg -> + huExpect [] $ \f -> do + Right plan <- U.getPlan di U.migs reg (U.Target U.Forwards []) + U.run di reg plan + + , HU.testCase "empty registry, two migs, forwards implicit" $ + withTestDi $ \di -> + withExpectedTestRegistry di U.Clean ["a","b"] $ \reg -> + huExpect [4,1,2,5] $ \f -> do + let migs = U.migs + U.* (mig_noop () :: U.Mig "a" '[]) + U.* (U.Mig (U.Store (\_ _ () -> f 1) + (\_ _ k -> f 2 >> k ()) + (\_ _ -> f 3)) + (U.Backup (\_ k -> f 4 >> k ())) + (U.Change (\_ _ _ _ -> f 5)) + :: U.Mig "b" '["a"]) + Right plan <- U.getPlan di migs reg (U.Target U.Forwards []) + U.run di reg plan + + , HU.testCase "empty registry, two migs, fail sync backup, forwards implicit" $ + withTestDi $ \di -> + withExpectedTestRegistry di U.Clean ["a"] $ \reg -> + huExpectFailSync "x" [] $ \f -> do + let migs = U.migs + U.* (mig_noop () :: U.Mig "a" '[]) + U.* (U.Mig (U.Store (\_ _ () -> f 1) + (\_ _ k -> f 2 >> k ()) + (\_ _ -> f 3)) + (U.Backup (\_ k -> fail_sync "x" >> f 4 >> k ())) + (U.Change (\_ _ _ _ -> f 5)) + :: U.Mig "b" '[]) + Right plan <- U.getPlan di migs reg (U.Target U.Forwards []) + U.run di reg plan + + , HU.testCase "empty registry, two migs, fail sync save, forwards implicit" $ + withTestDi $ \di -> + withExpectedTestRegistry di U.Clean ["a"] $ \reg -> + huExpectFailSync "x" [4] $ \f -> do + let migs = U.migs + U.* (mig_noop () :: U.Mig "a" '[]) + U.* (U.Mig (U.Store (\_ _ () -> fail_sync "x" >> f 1) + (\_ _ k -> f 2 >> k ()) + (\_ _ -> f 3)) + (U.Backup (\_ k -> f 4 >> k ())) + (U.Change (\_ _ _ _ -> f 5)) + :: U.Mig "b" '[]) + Right plan <- U.getPlan di migs reg (U.Target U.Forwards []) + U.run di reg plan + + , HU.testCase "empty registry, two migs, fail sync load, forwards implicit" $ + withTestDi $ \di -> + withExpectedTestRegistry di U.Clean ["a"] $ \reg -> + huExpectFailSync "x" [4,1] $ \f -> do + let migs = U.migs + U.* (mig_noop () :: U.Mig "a" '[]) + U.* (U.Mig (U.Store (\_ _ () -> f 1) + (\_ _ k -> fail_sync "x" >> f 2 >> k ()) + (\_ _ -> f 3)) + (U.Backup (\_ k -> f 4 >> k ())) + (U.Change (\_ _ _ _ -> f 5)) + :: U.Mig "b" '[]) + Right plan <- U.getPlan di migs reg (U.Target U.Forwards []) + U.run di reg plan + + , HU.testCase "empty registry, two migs, fail sync change normal, forwards implicit" $ + withTestDi $ \di -> + withExpectedTestRegistry di U.Clean ["a"] $ \reg -> + huExpectFailSync "x" [4,1,2,6,3] $ \f -> do + let migs = U.migs + U.* (mig_noop () :: U.Mig "a" '[]) + U.* (U.Mig (U.Store (\_ _ () -> f 1) + (\_ _ k -> f 2 >> k ()) + (\_ _ -> f 3)) + (U.Backup (\_ k -> f 4 >> k ())) + (U.Change (\_ d m _ -> case (d,m) of + (U.Forwards, U.Normal) -> + fail_sync "x" >> f 5 + (U.Backwards, U.Recovery) -> f 6 + _ -> error "impossible")) + :: U.Mig "b" '[]) + Right plan <- U.getPlan di migs reg (U.Target U.Forwards []) + U.run di reg plan + + , HU.testCase "empty registry, two migs, fail sync change normal and recovery, forwards implicit" $ + withTestDi $ \di -> + withExpectedTestRegistry di (U.Dirty "b" U.Forwards) ["a"] $ \reg -> + huExpectFailSync "x" [4,1,2] $ \f -> do + let migs = U.migs + U.* (mig_noop () :: U.Mig "a" '[]) + U.* (U.Mig (U.Store (\_ _ () -> f 1) + (\_ _ k -> f 2 >> k ()) + (\_ _ -> f 3)) + (U.Backup (\_ k -> f 4 >> k ())) + (U.Change (\_ d m _ -> case (d,m) of + (U.Forwards, U.Normal) -> + fail_sync "x" >> f 5 + (U.Backwards, U.Recovery) -> + fail_sync "y" >> f 6 + _ -> error "impossible")) + :: U.Mig "b" '[]) + Right plan <- U.getPlan di migs reg (U.Target U.Forwards []) + U.run di reg plan + ] + +-------------------------------------------------------------------------------- +huExpect :: [Int] -> ((Int -> IO ()) -> IO x) -> IO x +huExpect as0 k = do + mv <- newMVar [] + x <- k (\a -> modifyMVar_ mv (\as -> pure $! (a:as))) + as <- takeMVar mv + as0 @=? reverse as + pure x + +huExpectFailSync :: String -> [Int] -> ((Int -> IO ()) -> IO ()) -> IO () +huExpectFailSync s as0 k = do + mv <- newMVar [] + x <- Ex.catch + (k (\a -> modifyMVar_ mv (\as -> pure $! (a:as)))) + (\e@(Fail s') -> when (s' /= s) (Ex.throwM e)) + as <- takeMVar mv + as0 @=? reverse as + pure x + +withTestDi :: (Di.Core.Di level path message -> IO a) -> IO a +withTestDi = Di.Core.new (\_ -> pure ()) + +withExpectedTestRegistry + :: forall a. Di.Df1 -> U.Status -> [U.MigId] -> (U.Registry -> IO a) -> IO a +withExpectedTestRegistry di sex idsex k = do + dir <- getTempDir + Moto.File.withRegistry (dir ++ "/reg") $ \reg -> do + Ex.finally (k reg) $ do + s <- Ex.evaluate =<< U.registry_state reg di + (sex, idsex) @=? (U.state_status s, map fst (U.state_committed s)) + +getTempDir :: IO FilePath +getTempDir = do + tmp_dir <- Dir.getTemporaryDirectory + fix $ \k -> do + w :: Word64 <- System.Random.randomIO + let fn :: FilePath = tmp_dir ('d' : show w) + Ex.try (Dir.createDirectory fn) >>= \case + Right () -> pure fn + Left e | IO.isAlreadyExistsError e -> k + | otherwise -> Ex.throwM e + +plan_bits :: U.Plan -> (U.Direction, [U.MigId]) +plan_bits (U.Plan d s) = (d, toList (fmap fst s)) + +state_bits :: U.State -> (U.Status, [U.MigId]) +state_bits s = (U.state_status s, fst <$> U.state_committed s) + +genDirection :: QC.Gen U.Direction +genDirection = QC.oneof [ pure U.Backwards, pure U.Forwards ] + +genMigId :: QC.Gen U.MigId +genMigId = do c <- QC.arbitrary + cs <- QC.arbitrary + pure (fromString (c:cs)) + +-------------------------------------------------------------------------------- + +-- Compare some @'Left' a@ without requiring constraints on @b@. +huEqLeft :: forall a b. (Eq a, Show a) => a -> Either a b -> HU.Assertion +huEqLeft a (Left a') = Left a @=? (Left a' :: Either a ()) +huEqLeft a _ = fail (show (Left a :: Either a ()) ++ " /= Right _") + +-- Compare some @'Left' a@ without requiring constraints on @b@. +qcEqLeft :: forall a b. (Eq a, Show a) => a -> Either a b -> QC.Property +qcEqLeft a (Left a') = Left a === (Left a' :: Either a ()) +qcEqLeft a _ = show (Left a :: Either a ()) === "Right _" +