moto (empty) → 0.0.1

raw patch · 9 files changed

+3041/−0 lines, 9 filesdep +aesondep +attoparsecdep +basesetup-changed

Dependencies added: aeson, attoparsec, base, bytestring, containers, cryptohash-sha1, df1, di, di-core, di-df1, directory, filepath, moto, mtl, optparse-applicative, pipes, pipes-attoparsec, pipes-bytestring, random, safe-exceptions, tasty, tasty-hunit, tasty-quickcheck, text, time, transformers

Files

• LICENSE.txt +219/−0
• Setup.hs +2/−0
• lib/moto-internal/Moto/Internal.hs +1062/−0
• lib/moto-internal/Moto/Internal/Cli.hs +411/−0
• lib/moto/Moto.hs +276/−0
• lib/moto/Moto/File.hs +220/−0
• lib/moto/Moto/Registry.hs +115/−0
• moto.cabal +85/−0
• test/Main.hs +651/−0

@@ -0,0 +1,219 @@+Copyright 2018, Renzo Carbonara <renλren.zone>.++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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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!"+

@@ -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))+

@@ -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"+

@@ -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."+-}

@@ -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+

@@ -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+

@@ -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 _"+