packages feed

relocant (empty) → 1.0.0

raw patch · 34 files changed

+2514/−0 lines, 34 filesdep +aesondep +basedep +bytestringbuild-type:Customsetup-changed

Dependencies added: aeson, base, bytestring, crypton, directory, envparse, filepath, hspec, memory, optparse-applicative, postgresql-simple, process, random, relocant, temporary, text, time

Files

+ CHANGELOG.markdown view
@@ -0,0 +1,5 @@+1.0.0+=====++  * Initial release.+
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright Matvey Aksenov (c) 2024++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE..+
+ README.markdown view
@@ -0,0 +1,104 @@+relocant+===++A PostgreSQL migration CLI tool and library.++Synopsis+---++  - The user tells _relocant_ that there is a directory containing migration scripts;+  - _relocant_ (advisory-)locks the database;+  - _relocant_ figures out which scripts haven't yet been applied;+  - _relocant_ sorts unapplied scripts lexicographically, creating a migration plan;+  - _relocant_ runs each script in a separate transaction;+  - _relocant_ either records a successfully applied migration or aborts the migration plan on a failure;+  - _relocant_ (advisory-)unlocks the database.++CLI Workflow+---++The _relocant_ CLI tool attempts to provide a simple and reliable way to+apply migration scripts and track them. A migration script is any file with an `sql` extension.+The longest alpha-numeric prefix of the migration script is its ID. The tool requires all migration+scripts to reside inside a single directory.++> [!NOTE]+> The path to the scripts directory can be configured by+>+>   - either setting the `RELOCANT_SCRIPTS_DIR` environment variable,+>   - or providing the path to the `--scripts` option++If we run `relocant list-unapplied` we'll get back a migration plan, listing those scripts+that haven't yet been recorded as applied in the database, in the order they will be applied:++```shell+% ls ./migration+001-initial-schema.sql+002-description.sql+% relocant list-unapplied --scripts ./migration+001     001-initial-schema      dfde7438+002     002-description         74f8a76e+```++Now, if we like this plan, we can run `relocant apply` to actually apply the scripts to our database.++> [!IMPORTANT]+> Each script is run in a separate transaction and recorded as part of it.+> Unfortunately, this means that there are restrictions on what you can put+> in a migration script, including these:+>+>   1. Using `BEGIN`, `ROLLBACK`, and `COMMIT` will likely break _relocant_.+>   2. Running `CREATE INDEX CONCURRENTLY` will cause the migration script to fail immediately.++> [!NOTE]+> Successfully running _relocant_ commands needing access to the DB would require+>+>   - either setting `PG*` variables up,+>   - or providing a connection string to the `--connection-string` option+>+> Here, I'm running _relocant_ inside a _nix-shell_ where the environment has been already set up+> correctly.++```shell+% relocant apply --scripts ./migration+001     001-initial-schema      dfde7438+001     001-initial-schema      dfde7438        2024-10-24 15:04:09 +0000       0.01+002     002-description         74f8a76e+002     002-description         74f8a76e        2024-10-24 15:04:09 +0000       0.01+```++By running `relocant list-applied`, we can check that the applied scripts have been recorded correctly.+Naturally, the recorded migrations will be sorted in the order of application:++```shell+% relocant list-applied+001     001-initial-schema      dfde7438        2024-10-24 15:04:09 +0000       0.01s+002     002-description         74f8a76e        2024-10-24 15:04:09 +0000       0.00s+```++Once we have another migration script to apply, we put it in the `migration` directory and re-run `relocant apply`:++```shell+% relocant list-unapplied --scripts ./migration+003     003-fix-typo            a7032e4f+% relocant apply+003     003-fix-typo            a3582319+003     003-fix-typo            a3582319        2024-10-24 15:24:09 +0000       0.00s+% relocant list-applied --scripts ./migration+001     001-initial-schema      dfde7438        2024-10-24 15:04:09 +0000       0.01s+002     002-description         74f8a76e        2024-10-24 15:04:09 +0000       0.00s+003     003-fix-typo            a3582319        2024-10-24 15:24:09 +0000       0.00s+```++Library docs+---++See https://supki.github.io/relocant++Acknowledgements+---++I've been using a (very) similar workflow for a while now and it worked great for me, but I wouldn't have+bothered to make it a standalone tool if I haven't stumbled upon [_pgmigrate_][0] by Peter Downs.++  [0]: https://github.com/peterldowns/pgmigrate
+ Setup.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE NamedFieldPuns #-}+module Main (main) where++import Data.Char qualified as Char+import Data.List qualified as List+import Distribution.Package (PackageIdentifier(..), unPackageName)+import Distribution.PackageDescription (PackageDescription(package))+import Distribution.Pretty (prettyShow)+import Distribution.Simple (defaultMainWithHooks, simpleUserHooks, buildHook)+import Distribution.Simple.BuildPaths (autogenPackageModulesDir)+import Distribution.Simple.LocalBuildInfo (LocalBuildInfo, localPkgDescr)+import Distribution.Simple.Setup (BuildFlags(buildVerbosity), fromFlag)+import Distribution.Simple.Utils (notice, rewriteFileEx)+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>), (<.>))+import System.IO.Error (catchIOError)+import System.Process (readProcess)+++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+  { buildHook = \pd lbi uh bf -> do generateMeta lbi bf; buildHook simpleUserHooks pd lbi uh bf+  }++generateMeta :: LocalBuildInfo -> BuildFlags -> IO ()+generateMeta lbi bf = let+    verbosity = fromFlag (buildVerbosity bf)+    PackageIdentifier {pkgName, pkgVersion} = package (localPkgDescr lbi)+    metaName = "Meta_" ++ replace '-' '_' (unPackageName pkgName)+    metaPath = autogen </> metaName <.> "hs"+  in do+    hash <- gitHash+    createDirectoryIfMissing True autogen+    notice verbosity ("Generating " ++ metaPath ++ " ...")+    rewriteFileEx verbosity metaPath (unlines+      [ "module " ++ metaName+      , "  ( name"+      , "  , version"+      , "  ) where"+      , ""+      , "import Data.String (IsString(fromString))"+      , ""+      , "name :: IsString str => str"+      , "name = fromString " ++ show (unPackageName pkgName)+      , ""+      , "version :: IsString str => str"+      , "version = fromString " ++ show (prettyShow pkgVersion ++ "-" ++ hash)+      ])+ where+  autogen = autogenPackageModulesDir lbi+  replace x y =+    map (\c -> if c == x then y else c)++gitHash :: IO String+gitHash =+  catchIOError (fmap sanitize (readProcess "git" ["describe", "--always", "--dirty=-dirty"] ""))+               (\_ -> return "unknown")+ where+  sanitize = List.dropWhileEnd Char.isSpace+
+ driver/Main.hs view
@@ -0,0 +1,8 @@+module Main (main) where++import Relocant.App qualified as App+++main :: IO ()+main =+  App.run
+ relocant.cabal view
@@ -0,0 +1,135 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.36.0.+--+-- see: https://github.com/sol/hpack++name:           relocant+version:        1.0.0+synopsis:       A PostgreSQL migration CLI tool and library+description:    relocant documentation is at https://github.com/supki/relocant+author:         Matvey Aksenov+maintainer:     matvey.aksenov@gmail.com+copyright:      2024 Matvey Aksenov+license:        BSD2+license-file:   LICENSE+build-type:     Custom+extra-doc-files:+    README.markdown+    CHANGELOG.markdown++custom-setup+  setup-depends:+      Cabal ==3.10.*+    , base >=4.18 && <5+    , directory+    , filepath+    , process++library+  exposed-modules:+      Relocant+      Relocant.App+      Relocant.App.Env+      Relocant.App.Log+      Relocant.App.Opts+      Relocant.App.Opts.Fmt+      Relocant.App.Opts.Internal+      Relocant.App.Opts.Option+      Relocant.App.ToText+      Relocant.Applied+      Relocant.At+      Relocant.Checksum+      Relocant.Content+      Relocant.DB+      Relocant.DB.Table+      Relocant.Duration+      Relocant.ID+      Relocant.Merge+      Relocant.Name+      Relocant.Script+      Meta_relocant+  other-modules:+      Paths_relocant+  autogen-modules:+      Paths_relocant+      Meta_relocant+  hs-source-dirs:+      src+  default-extensions:+      ImportQualifiedPost+      NoFieldSelectors+      OverloadedStrings+      OverloadedRecordDot+      StrictData+  ghc-options: -funbox-strict-fields -Wall -Wno-incomplete-uni-patterns+  build-depends:+      aeson+    , base >=4.18 && <5+    , bytestring+    , crypton+    , directory+    , envparse+    , filepath+    , memory+    , optparse-applicative+    , postgresql-simple+    , process+    , text+    , time+  default-language: Haskell2010++executable relocant+  main-is: Main.hs+  other-modules:+      Paths_relocant+  autogen-modules:+      Paths_relocant+  hs-source-dirs:+      driver+  default-extensions:+      ImportQualifiedPost+      NoFieldSelectors+      OverloadedStrings+      OverloadedRecordDot+      StrictData+  ghc-options: -Wall -Wno-incomplete-uni-patterns -threaded -with-rtsopts=-N+  build-depends:+      base >=4.18 && <5+    , relocant+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      Relocant.App.ToTextSpec+      Relocant.AppliedSpec+      Relocant.DurationSpec+      Relocant.MergeSpec+      Relocant.ScriptSpec+      Spec+      SpecHelper.DB+      Paths_relocant+  autogen-modules:+      Paths_relocant+  hs-source-dirs:+      test+  default-extensions:+      ImportQualifiedPost+      NoFieldSelectors+      OverloadedStrings+      OverloadedRecordDot+      StrictData+  ghc-options: -freduction-depth=0 -Wall -Wno-incomplete-uni-patterns -threaded -with-rtsopts=-N+  build-depends:+      base >=4.18 && <5+    , bytestring+    , filepath+    , hspec+    , postgresql-simple+    , random+    , relocant+    , temporary+    , text+  default-language: Haskell2010
+ src/Relocant.hs view
@@ -0,0 +1,73 @@+-- | A PostgreSQL migration library+module Relocant+  ( Script(..)+  , readScripts+  , readScript++  , DB.ConnectionString+  , DB.connect+  , DB.withLock+  , DB.withTryLock++  , Applied(..)+  , ID+  , Name+  , Content+  , Duration+  , DB.Table+  , DB.defaultTable+  , getApplied+  , getAppliedByID++  , Relocant.merge+  , mergeAll+  , Relocant.Merge.Merged(..)+  , Relocant.Merge.ContentMismatch(..)+  , Relocant.Merge.canApply+  , Relocant.Merge.converged++  , Script.apply+  , Applied.record+  , applyAll+  -- * Re-exports (postgresql-simple)+  --+  -- Generally, I'm against re-exports for convenience, but here I feel+  -- it really improves the user experience, so it goes:+  , Connection+  , withTransaction+  ) where++import Data.Foldable (for_)+import Database.PostgreSQL.Simple (Connection, withTransaction)++import Relocant.Applied (Applied, getApplied, getAppliedByID)+import Relocant.Applied qualified as Applied+import Relocant.Content (Content)+import Relocant.DB qualified as DB (ConnectionString, connect, withLock, withTryLock)+import Relocant.DB.Table qualified as DB (Table, defaultTable)+import Relocant.Duration (Duration)+import Relocant.ID (ID)+import Relocant.Merge qualified as Relocant (merge)+import Relocant.Merge qualified+import Relocant.Name (Name)+import Relocant.Script (Script(..), readScripts, readScript)+import Relocant.Script qualified as Script+++-- | A convenience function that gets all applied migrations' records from+-- the DB and merges them together with the migration scripts from a given directory.+mergeAll :: FilePath -> DB.Table -> Connection -> IO Relocant.Merge.Merged+mergeAll dir table conn = do+  applieds <- getApplied table conn+  scripts <- readScripts dir+  pure (Relocant.Merge.merge applieds scripts)++-- | A convenience function that applies all unapplied migrations' scripts+-- and records their application in the DB. Each script is run in a separate+-- transaction.+applyAll :: Relocant.Merge.Merged -> DB.Table -> Connection -> IO ()+applyAll merged table conn =+  for_ merged.unapplied $ \script -> do+    withTransaction conn $ do+      applied <- Script.apply script conn+      Applied.record applied table conn
+ src/Relocant/App.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# OPTIONS_HADDOCK hide #-}+module Relocant.App+  ( run+  ) where++import Control.Monad (guard, unless)+import Data.Aeson ((.=))+import Data.Aeson qualified as Aeson+import Data.ByteString.Char8 qualified as ByteString (putStr)+import Data.ByteString.Lazy.Char8 qualified as ByteString.Lazy (putStrLn)+import Data.Foldable (for_, traverse_)+import Data.Text.IO qualified as Text+import Database.PostgreSQL.Simple qualified as DB (Connection, withTransaction)+import GHC.Records (HasField)+import Prelude hiding (id, log)+import System.Exit (exitFailure)++import Relocant qualified+import Relocant.App.Env qualified as Env+import Relocant.App.Log (Log)+import Relocant.App.Log qualified as Log+import Relocant.App.Opts qualified as Opts+import Relocant.App.Opts.Fmt (Fmt)+import Relocant.App.Opts.Fmt qualified as Fmt+import Relocant.App.ToText (ToText(..))+import Relocant.Applied qualified as Applied+import Relocant.DB qualified as DB (ConnectionString, Table, connect, dumpSchema, withLock, withTryLock)+import Relocant.Script (readScript)+import Relocant.Script qualified as Script+import Relocant.Merge qualified as Merge+++run :: IO ()+run = do+  env <- Env.parse+  (cfg, cmd) <- Opts.parse env+  runCmd (Log.make cfg.minSeverity) cmd++runCmd :: Log -> Opts.Cmd -> IO ()+runCmd log = \case+  Opts.ListUnapplied opts -> do+    Log.debug log+      [ "action" .= ("list-unapplied" :: String)+      , "opts" .= opts+      ]+    runListUnapplied log opts+  Opts.ListApplied opts -> do+    Log.debug log+      [ "action" .= ("list-applied" :: String)+      , "opts" .= opts+      ]+    runListApplied log opts+  Opts.ShowApplied opts -> do+    Log.debug log+      [ "action" .= ("show-applied" :: String)+      , "opts" .= opts+      ]+    runShowApplied log opts+  Opts.Verify opts -> do+    Log.debug log+      [ "action" .= ("verify" :: String)+      , "opts" .= opts+      ]+    runVerify log opts+  Opts.Apply opts -> do+    Log.debug log+      [ "action" .= ("apply" :: String)+      , "opts" .= opts+      ]+    runApply log opts+  Opts.Version version ->+    putStrLn version+  Opts.Internal internalCmd ->+    runInternalCmd log internalCmd++runInternalCmd :: Log -> Opts.InternalCmd -> IO ()+runInternalCmd log = \case+  Opts.DumpSchema opts -> do+    Log.debug log+      [ "action" .= ("dump-schema" :: String)+      , "opts" .= opts+      ]+    runDumpSchema opts+  Opts.MarkApplied opts -> do+    Log.debug log+      [ "action" .= ("mark-applied" :: String)+      , "opts" .= opts+      ]+    runMarkApplied log opts+  Opts.Delete opts -> do+    Log.debug log+      [ "action" .= ("delete" :: String)+      , "opts" .= opts+      ]+    runDelete log opts+  Opts.DeleteAll opts -> do+    Log.debug log+      [ "action" .= ("delete-all" :: String)+      , "opts" .= opts+      ]+    runDeleteAll log opts++runListUnapplied :: Log -> Opts.ListUnapplied -> IO ()+runListUnapplied log opts = do+  withTryLock log opts $ \conn -> do+    migrations <- Relocant.mergeAll opts.scripts opts.table conn+    traverse_ (println opts.format) migrations.unapplied++runListApplied :: Log -> Opts.ListApplied -> IO ()+runListApplied log opts = do+  withTryLock log opts $ \conn -> do+    migrations <- Applied.getApplied opts.table conn+    traverse_ (println opts.format) migrations++runShowApplied :: Log -> Opts.ShowApplied -> IO ()+runShowApplied log opts = do+  withTryLock log opts $ \conn -> do+    applied <- Applied.getAppliedByID opts.id opts.table conn+    maybe exitFailure (\a -> ByteString.putStr a.bytes) applied++runVerify :: Log -> Opts.Verify -> IO ()+runVerify log opts = do+  withTryLock log opts $ \conn -> do+    verify log opts.scripts (opts.format <$ guard (not opts.quiet)) opts.table conn++runApply :: Log -> Opts.Apply -> IO ()+runApply log opts = do+  withLock log opts $ \conn -> do+    apply log opts.scripts opts.format opts.table conn+    verify log opts.scripts Nothing opts.table conn++runDumpSchema :: Opts.DumpSchema -> IO ()+runDumpSchema opts =+  DB.dumpSchema opts.table++runMarkApplied :: Log -> Opts.MarkApplied -> IO ()+runMarkApplied log opts = do+  withTryLock log opts $ \conn -> do+    script <- readScript opts.script+    DB.withTransaction conn $ do+      Log.debug log+        [ "action" .= ("mark-applied" :: String)+        , "delete" .= script.id+        ]+      _deleted <- Applied.deleteByID script.id opts.table conn+      Log.debug log+        [ "action" .= ("mark-applied" :: String)+        , "record" .= script.id+        ]+      markApplied <- Script.markApplied script+      Applied.record markApplied opts.table conn++runDelete :: Log -> Opts.Delete -> IO ()+runDelete log opts = do+  withTryLock log opts $ \conn -> do+    deleted <- Applied.deleteByID opts.id opts.table conn+    unless deleted $ do+      Log.notice log+        [ "action" .= ("delete" :: String)+        , "result" .= ("couldn't delete the recorded migration, typo in the ID?" :: String)+        ]+      exitFailure++runDeleteAll :: Log -> Opts.DeleteAll -> IO ()+runDeleteAll log opts = do+  withTryLock log opts $ \conn -> do+    Applied.deleteAll opts.table conn++verify :: Log -> FilePath -> Maybe Fmt -> DB.Table -> DB.Connection -> IO ()+verify log dir formatQ table conn = do+  migrations <- Relocant.mergeAll dir table conn+  unless (Merge.converged migrations) $ do+    Log.debug log+      [ "action" .= ("apply" :: String)+      , "unrecorded" .= map (.id) migrations.unrecorded+      , "script-missing" .= map (.id) migrations.scriptMissing+      , "content-mismatch" .= map (\cm -> (cm.expected.id, cm.butGot.id)) migrations.contentMismatch+      , "unapplied" .= map (.id) migrations.unapplied+      ]+    for_ formatQ $ \format -> do+      println format migrations+    exitFailure++apply :: Log -> FilePath -> Fmt -> DB.Table -> DB.Connection -> IO ()+apply log scripts format table conn = do+  merged <- Relocant.mergeAll scripts table conn+  unless (Merge.canApply merged) $ do+    Log.error log+      [ "action" .= ("apply" :: String)+      , "result" .= ("not ready to apply the scripts, run `verify' first" :: String)+      ]+    exitFailure+  Log.debug log+    [ "action" .= ("apply" :: String)+    , "migrations" .= map (.id) merged.unapplied+    ]+  for_ merged.unapplied $ \script -> do+    println format script+    DB.withTransaction conn $ do+      Log.debug log+        [ "action" .= ("apply" :: String)+        , "apply" .= script.id+        ]+      applied <- Script.apply script conn+      Log.debug log+        [ "action" .= ("apply" :: String)+        , "record" .= script.id+        , "duration" .= applied.durationS+        ]+      Applied.record applied table conn+      println format applied++withLock+  :: (HasField "table" cfg DB.Table, HasField "connString" cfg DB.ConnectionString)+  => Log+  -> cfg+  -> (DB.Connection -> IO b)+  -> IO b+withLock log cfg m = do+  conn <- DB.connect cfg.connString cfg.table+  Log.debug log+    [ "action" .= ("acquire-lock" :: String)+    , "table" .= cfg.table+    ]+  DB.withLock cfg.table conn $ do+    Log.debug log+      [ "action" .= ("try-to-acquire-lock" :: String)+      , "table" .= cfg.table+      , "result" .= ("acquired" :: String)+      ]+    m conn++withTryLock+  :: (HasField "table" cfg DB.Table, HasField "connString" cfg DB.ConnectionString)+  => Log+  -> cfg+  -> (DB.Connection -> IO b) -> IO b+withTryLock log cfg m = do+  conn <- DB.connect cfg.connString cfg.table+  Log.debug log+    [ "action" .= ("try-to-acquire-lock" :: String)+    , "table" .= cfg.table+    ]+  DB.withTryLock cfg.table conn $ \locked -> do+    unless locked $ do+      Log.error log+        [ "action" .= ("try-to-acquire-lock" :: String)+        , "table" .= cfg.table+        , "result" .= ("couldn't lock the database, migration in progress?" :: String)+        ]+      exitFailure+    Log.debug log+      [ "action" .= ("try-to-acquire-lock" :: String)+      , "table" .= cfg.table+      , "result" .= ("acquired" :: String)+      ]+    m conn++println :: (Aeson.ToJSON a, ToText a) => Fmt -> a -> IO ()+println = \case+  Fmt.Json ->+    ByteString.Lazy.putStrLn . Aeson.encode+  Fmt.Text ->+    Text.putStrLn . toText
+ src/Relocant/App/Env.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_HADDOCK hide #-}+module Relocant.App.Env+  ( Env(..)+  , Relocant.App.Env.parse+  , Meta.name+  , Meta.version+  ) where++import Env+import Meta_relocant qualified as Meta++import Relocant.DB (defaultTable)+import Relocant.DB.Table (Table)+++data Env = Env+  { scripts :: Maybe FilePath+  , table   :: Table+  } deriving (Show, Eq)++parse :: IO Env+parse =+  Env.parse (header usageHeader) parser++parser :: Parser Error Env+parser =+  prefixed "RELOCANT_" $ do+    scripts <-+      optional+        (var str "SCRIPTS_DIR"+          (help "Directory containing .sql scripts"))+    table <-+      var str "MIGRATIONS_TABLE_NAME"+        ( def defaultTable+       <> help "Name of the table containing applied migrations"+        )+    pure Env {..}++usageHeader :: String+usageHeader =+  unwords [Meta.name, Meta.version]
+ src/Relocant/App/Log.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_HADDOCK hide #-}+-- | A very basic logger implementation sufficient for our needs in the CLI tool.+--+-- This logger simply writes JSON messages to stderr if their severity is higher than+-- min severity, attaching a timestamp and the running app's version.+module Relocant.App.Log+  ( Log+  , Severity(..)+  , make+  , debug+  , info+  , notice+  , warning+  , error+  ) where++import Control.Monad (when)+import Data.Aeson ((.=))+import Data.Aeson qualified as Aeson+import Data.Aeson.Types qualified as Aeson (Pair)+import Data.ByteString.Lazy.Char8 qualified as ByteString.Lazy+import Data.Time (getZonedTime)+import Prelude hiding (error, log)+import System.IO qualified as IO+++data Severity+  = Debug+  | Info+  | Notice+  | Warning+  | Error+    deriving (Show, Eq, Ord)++instance Aeson.ToJSON Severity where+  toJSON =+    Aeson.toJSON . \case+      Debug -> "debug"+      Info -> "info"+      Notice -> "notice"+      Warning -> "warning"+      Error -> "error" :: String++newtype Log = Log (Severity -> [Aeson.Pair] -> IO ())++make :: Severity -> Log+make minSeverity =+  Log $ \severity kvs ->+    when (severity >= minSeverity) $ do+      at <- getZonedTime+      let+        object =+          Aeson.object $+              "_at" .= at+            : "_severity" .= severity+            : kvs+      ByteString.Lazy.hPutStrLn IO.stderr (Aeson.encode object)++message :: Log -> Severity -> [Aeson.Pair] -> IO ()+message (Log f) severity =+  f severity++debug, info, notice, warning, error :: Log -> [Aeson.Pair] -> IO ()+debug log =+  message log Debug+info log =+  message log Info+notice log =+  message log Notice+warning log =+  message log Warning+error log =+  message log Error
+ src/Relocant/App/Opts.hs view
@@ -0,0 +1,190 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_HADDOCK hide #-}+module Relocant.App.Opts+  ( Cfg(..)+  , Cmd(..)+  , InternalCmd(..)+  , parse+  , ListUnapplied(..)+  , ListApplied(..)+  , ShowApplied(..)+  , Verify(..)+  , Apply(..)+  , Internal.DumpSchema(..)+  , Internal.MarkApplied(..)+  , Internal.Delete(..)+  , Internal.DeleteAll(..)+  ) where++import Data.Aeson qualified as Aeson+import GHC.Generics (Generic, Rep)+import Options.Applicative+import Prelude hiding (id)++import Meta_relocant qualified as Meta+import Relocant.App.Env (Env)+import Relocant.App.Log qualified as Log+import Relocant.App.Opts.Fmt (Fmt)+import Relocant.App.Opts.Option qualified as O+import Relocant.App.Opts.Internal (InternalCmd(..))+import Relocant.App.Opts.Internal qualified as Internal+import Relocant.DB (ConnectionString, Table)+import Relocant.ID (ID)+++data Cfg = Cfg+  { minSeverity :: Log.Severity+  } deriving (Show, Eq)++data Cmd+  = ListUnapplied ListUnapplied+  | ListApplied ListApplied+  | ShowApplied ShowApplied+  | Verify Verify+  | Apply Apply+  | Version String+  | Internal InternalCmd+    deriving (Show, Eq)++data ListUnapplied = MkListUnapplied+  { connString :: ConnectionString+  , table      :: Table+  , scripts    :: FilePath+  , format     :: Fmt+  } deriving (Show, Eq, Generic)++instance Aeson.ToJSON ListUnapplied where+  toJSON = toJSONG++data ListApplied = MkListApplied+  { connString :: ConnectionString+  , table      :: Table+  , format     :: Fmt+  } deriving (Show, Eq, Generic)++instance Aeson.ToJSON ListApplied where+  toJSON = toJSONG++data ShowApplied = MkShowApplied+  { connString :: ConnectionString+  , table      :: Table+  , id         :: ID+  } deriving (Show, Eq, Generic)++instance Aeson.ToJSON ShowApplied where+  toJSON = toJSONG++data Verify = MkVerify+  { connString :: ConnectionString+  , table      :: Table+  , scripts    :: FilePath+  , quiet      :: Bool+  , format     :: Fmt+  } deriving (Show, Eq, Generic)++instance Aeson.ToJSON Verify where+  toJSON = toJSONG++data Apply = MkApply+  { connString :: ConnectionString+  , table      :: Table+  , scripts    :: FilePath+  , format     :: Fmt+  } deriving (Show, Eq, Generic)++instance Aeson.ToJSON Apply where+  toJSON = toJSONG++toJSONG :: (Generic a, Aeson.GToJSON' Aeson.Value Aeson.Zero (Rep a)) => a -> Aeson.Value+toJSONG =+  Aeson.genericToJSON Aeson.defaultOptions+    { Aeson.fieldLabelModifier = \case+        "table" -> "migrations-table-name"+        "connString" -> "connection-string"+        label -> label+    }++parse :: Env -> IO (Cfg, Cmd)+parse env =+  customExecParser defaultPrefs {prefShowHelpOnError = True}+    (info+      (parser env <**> helper)+      (fullDesc <> progDesc "Migrate PostgreSQL database" <> header "relocant - migrating utility"))++parser :: Env -> Parser (Cfg, Cmd)+parser env = do+  cfg <- cfgP+  cmd <- hsubparser+    ( command "list-unapplied"+      (info (listUnappliedP env) (progDesc "list unapplied migrations"))+   <> command "list-applied"+      (info (listAppliedP env) (progDesc "list applied migrations"))+   <> command "show-applied"+      (info (showAppliedP env) (progDesc "show the contents of an applied migration"))+   <> command "verify"+      (info (verifyP env) (progDesc "verify that there are no unapplied migrations"))+   <> command "apply"+      (info (applyP env) (progDesc "apply the unapplied migrations"))+   <> command "version"+      (info versionP (progDesc "see library's version"))+   <> command "internal"+      (info (internalP env) (progDesc "internal subcomamnds"))+    )+  pure (cfg, cmd)++cfgP :: Parser Cfg+cfgP = do+  minSeverity <- O.minSeverity+  pure Cfg {..}++listUnappliedP :: Env -> Parser Cmd+listUnappliedP env = do+  connString <- O.connectionString+  table <- O.table env+  scripts <- O.scripts env+  format <- O.fmt+  pure (ListUnapplied MkListUnapplied {..})++listAppliedP :: Env -> Parser Cmd+listAppliedP env = do+  connString <- O.connectionString+  table <- O.table env+  format <- O.fmt+  pure (ListApplied MkListApplied {..})++showAppliedP :: Env -> Parser Cmd+showAppliedP env = do+  connString <- O.connectionString+  table <- O.table env+  id <- O.id+  pure (ShowApplied MkShowApplied {..})++verifyP :: Env -> Parser Cmd+verifyP env = do+  connString <- O.connectionString+  table <- O.table env+  scripts <- O.scripts env+  quiet <- switch (short 'q' <> long "quiet" <> help "do not output the problems")+  format <- O.fmt+  pure (Verify MkVerify {..})++applyP :: Env -> Parser Cmd+applyP env = do+  connString <- O.connectionString+  table <- O.table env+  scripts <- O.scripts env+  format <- O.fmt+  pure (Apply MkApply {..})++versionP :: Parser Cmd+versionP =+  pure (Version Meta.version)++internalP :: Env -> Parser Cmd+internalP =+  fmap Internal . Internal.parser
+ src/Relocant/App/Opts/Fmt.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_HADDOCK hide #-}+module Relocant.App.Opts.Fmt+  ( Fmt(..)+  , reader+  ) where++import Data.Aeson qualified as Aeson+import Data.Text (Text)+import Options.Applicative (ReadM, eitherReader)+++data Fmt+  = Text+  | Json+    deriving (Show, Eq)++instance Aeson.ToJSON Fmt where+  toJSON =+    Aeson.toJSON . \case+      Text -> "text" :: Text+      Json -> "json"++reader :: ReadM Fmt+reader =+  eitherReader $ \case+    "text" ->+      pure Text+    "json" ->+      pure Json+    _ ->+      Left "unknown format; possible values: text, json"
+ src/Relocant/App/Opts/Internal.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_HADDOCK hide #-}+module Relocant.App.Opts.Internal+  ( InternalCmd(..)+  , parser+  , DumpSchema(..)+  , MarkApplied(..)+  , Delete(..)+  , DeleteAll(..)+  ) where++import Data.Aeson qualified as Aeson+import GHC.Generics (Generic, Rep)+import Options.Applicative+import Prelude hiding (id)++import Relocant.App.Env (Env)+import Relocant.App.Opts.Option qualified as O+import Relocant.DB (ConnectionString, Table)+import Relocant.ID (ID)+++data InternalCmd+  = DumpSchema DumpSchema+  | MarkApplied MarkApplied+  | Delete Delete+  | DeleteAll DeleteAll+    deriving (Show, Eq)++parser :: Env -> Parser InternalCmd+parser env =+  hsubparser+    ( command "dump-schema"+      (info (dumpSchemaP env) (progDesc "dump db schema"))+   <> command "mark-applied"+      (info (markAppliedP env)+        (progDesc "mark a migration applied without running its script"))+   <> command "delete"+      (info (deleteP env) (progDesc "delete an applied migration from the database"))+   <> command "delete-all"+      (info (deleteAllP env) (progDesc "delete all applied migrations from the database"))+    )++data DumpSchema = MkDumpSchema+  { connString :: ConnectionString+  , table      :: Table+  } deriving (Show, Eq, Generic)++instance Aeson.ToJSON DumpSchema where+  toJSON = toJSONG++data MarkApplied = MkMarkApplied+  { connString :: ConnectionString+  , table      :: Table+  , script     :: FilePath+  } deriving (Show, Eq, Generic)++instance Aeson.ToJSON MarkApplied where+  toJSON = toJSONG++data Delete = MkDelete+  { connString :: ConnectionString+  , table      :: Table+  , id         :: ID+  } deriving (Show, Eq, Generic)++instance Aeson.ToJSON Delete where+  toJSON = toJSONG++data DeleteAll = MkDeleteAll+  { connString :: ConnectionString+  , table      :: Table+  } deriving (Show, Eq, Generic)++instance Aeson.ToJSON DeleteAll where+  toJSON = toJSONG++toJSONG :: (Generic a, Aeson.GToJSON' Aeson.Value Aeson.Zero (Rep a)) => a -> Aeson.Value+toJSONG =+  Aeson.genericToJSON Aeson.defaultOptions+    { Aeson.fieldLabelModifier = \case+        "table" -> "migrations-table-name"+        "connString" -> "connection-string"+        label -> label+    }++dumpSchemaP :: Env -> Parser InternalCmd+dumpSchemaP env = do+  connString <- O.connectionString+  table <- O.table env+  pure (DumpSchema MkDumpSchema {..})++markAppliedP :: Env -> Parser InternalCmd+markAppliedP env = do+  connString <- O.connectionString+  table <- O.table env+  script <- O.script+  pure (MarkApplied MkMarkApplied {..})++deleteP :: Env -> Parser InternalCmd+deleteP env = do+  connString <- O.connectionString+  table <- O.table env+  id <- O.id+  pure (Delete MkDelete {..})++deleteAllP :: Env -> Parser InternalCmd+deleteAllP env = do+  connString <- O.connectionString+  table <- O.table env+  pure (DeleteAll MkDeleteAll {..})
+ src/Relocant/App/Opts/Option.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE LambdaCase #-}+{-# OPTIONS_HADDOCK hide #-}+module Relocant.App.Opts.Option+  ( fmt+  , minSeverity+  , connectionString+  , table+  , scripts+  , script+  , id+  ) where++import Options.Applicative+import Prelude hiding (id)++import Relocant.App.Env (Env(..))+import Relocant.App.Log qualified as Log+import Relocant.App.Opts.Fmt (Fmt)+import Relocant.App.Opts.Fmt qualified as Fmt+import Relocant.DB (ConnectionString, Table)+import Relocant.ID (ID)+++fmt :: Parser Fmt+fmt =+  option Fmt.reader+    ( long "format"+   <> value Fmt.Text+    )++minSeverity :: Parser Log.Severity+minSeverity =+  option severityR+    ( long "log-min-severity"+   <> value Log.Info+   <> showDefaultWith (\_ -> "info")+    )+ where+  severityR =+    eitherReader $ \case+      "debug" ->+        pure Log.Debug+      "info" ->+        pure Log.Info+      "notice" ->+        pure Log.Notice+      "warning" ->+        pure Log.Warning+      "error" ->+        pure Log.Error+      _ ->+        Left "unknown severity; possible values: debug, info, notice, warning, error"++connectionString :: Parser ConnectionString+connectionString =+  strOption+    ( short 'c'+   <> long "connection-string"+   <> metavar "CONNECTION_STRING"+   <> value ""+   <> help "PostgreSQL connection string"+    )++table :: Env -> Parser Table+table env =+  strOption+    ( short 't'+   <> long "migration-table-name"+   <> metavar "IDENTIFIER"+   <> value env.table+   <> showDefault+   <> help "Name of the table containing applied migrations"+    )++scripts :: Env -> Parser String+scripts env =+  strOption+    ( short 's'+   <> long "scripts"+   <> metavar "PATH"+   <> foldMap value env.scripts+   <> help "Directory containing .sql scripts"+    )++script :: Parser String+script =+  strOption+    ( short 'f'+   <> long "file"+   <> metavar "PATH"+   <> help "Path to an .sql script"+    )++id :: Parser ID+id =+  strOption+    ( long "id"+   <> metavar "ID"+   <> help "Migration ID"+    )
+ src/Relocant/App/ToText.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS_HADDOCK hide #-}+module Relocant.App.ToText+  ( ToText(..)+  , arbitraryNameLengthCutOff+  ) where++import Control.Monad (guard)+import Data.String (fromString)+import Data.Text (Text)+import Data.Text qualified as Text+import Text.Printf (printf)++import Relocant.Applied (Applied(..))+import Relocant.At qualified as At+import Relocant.Merge (Merged(..), ContentMismatch(..))+import Relocant.Name (Name(..))+import Relocant.Script (Script(..))+++class ToText t where+  toText :: t -> Text++instance ToText Name where+  toText (Name name) =+    case Text.compareLength name arbitraryNameLengthCutOff of+      LT ->+        Text.justifyLeft arbitraryNameLengthCutOff ' ' name+      EQ ->+        name+      GT ->+        Text.take (arbitraryNameLengthCutOff - 1) name `Text.snoc` '…'++arbitraryNameLengthCutOff :: Int+arbitraryNameLengthCutOff = 20++instance ToText Script where+  toText s =+    fromString (printf "%s\t%s\t%s" s.id (toText s.name) (take 8 (show s.checksum)))++instance ToText Applied where+  toText a =+    fromString+      (printf "%s\t%s\t%s\t%s\t%.2fs"+        a.id+        (toText a.name)+        (take 8 (show a.checksum))+        (At.format "%F %T %z" a.appliedAt)+        a.durationS)++instance ToText Merged where+  toText r =+    Text.intercalate "\n" $ concat+      [ do guard (not (null r.unrecorded)); "unrecorded:" : map toText r.unrecorded+      , do guard (not (null r.scriptMissing)); "script missing:" : map toText r.scriptMissing+      , do guard (not (null r.contentMismatch)); "content mismatch:" : map toText r.contentMismatch+      , do guard (not (null r.unapplied)); "unapplied:" : map toText r.unapplied+      ]++instance ToText ContentMismatch where+  toText cm =+    fromString (printf "expected: %s\n but got: %s" (toText cm.expected) (toText cm.butGot))
+ src/Relocant/Applied.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}+-- | This module deals with applied migrations and their records in the DB.+module Relocant.Applied+  ( Applied(..)+  , getApplied+  , getAppliedByID+  , record+  , deleteAll+  , deleteByID+  ) where++import Data.Aeson qualified as Aeson+import Data.Aeson ((.=))+import Data.ByteString (ByteString)+import Data.Maybe (listToMaybe)+import Database.PostgreSQL.Simple qualified as DB+import Database.PostgreSQL.Simple.FromRow qualified as DB (RowParser, field)+import Database.PostgreSQL.Simple.SqlQQ qualified as DB (sql)+import GHC.Records (HasField(getField))+import Prelude hiding (id, readFile)++import Relocant.DB qualified as DB (Table)+import Relocant.At (At)+import Relocant.Checksum (Checksum(..))+import Relocant.Content (Content(..))+import Relocant.ID (ID)+import Relocant.Name (Name)+import Relocant.Duration (Duration)+++-- | An applied migration. Generally, it's created be either running a+-- migration 'Relocant.Script' with 'Relocant.apply' or getting the records+-- from the DB with 'getApplied' or 'getAppliedByID'.+data Applied = Applied+  { id        :: ID+  , name      :: Name+  , content   :: Content+  , appliedAt :: At+  , durationS :: Duration -- ^ how long it took to apply the migration script+  } deriving (Show, Eq)++-- | The content (as in actual bytes) is skipped.+instance Aeson.ToJSON Applied where+  toJSON a =+    Aeson.object+      [ "id" .= a.id+      , "name" .= a.name+      , "checksum" .= show a.checksum+      , "applied_at" .= a.appliedAt+      , "duration_s" .= a.durationS+      ]++instance HasField "bytes" Applied ByteString where+  getField s =+    s.content.bytes++instance HasField "checksum" Applied Checksum where+  getField s =+    s.content.checksum++-- | Retrieve all 'Applied' migrations' records from the DB.+getApplied :: DB.Table -> DB.Connection -> IO [Applied]+getApplied table conn = do+  DB.queryWith appliedP conn [DB.sql|+    SELECT id+         , name+         , bytes+         , checksum+         , applied_at+         , EXTRACT(epoch FROM duration_s) :: REAL+      FROM ?+  ORDER BY id+  |] (DB.Only table)++-- | Retrieve the specific 'Applied' migration's record from the DB.+getAppliedByID :: ID -> DB.Table -> DB.Connection -> IO (Maybe Applied)+getAppliedByID id table conn = do+  ms <- DB.queryWith appliedP conn [DB.sql|+    SELECT id+         , name+         , bytes+         , checksum+         , applied_at+         , EXTRACT(epoch FROM duration_s) :: REAL+      FROM ?+     WHERE id = ?+  |] (table, id)+  pure (listToMaybe ms)++-- | Record a successfully 'Applied' migration.+--+-- /Note:/ You probably want to run this together with 'Relocant.Script.apply'+-- in a single transaction.+record :: Applied -> DB.Table -> DB.Connection -> IO ()+record a table conn = do+  1 <- DB.execute conn [DB.sql|+    INSERT INTO ?+              ( id+              , name+              , bytes+              , checksum+              , applied_at+              , duration_s+              )+         SELECT ?+              , ?+              , ?+              , ?+              , ?+              , make_interval(secs := ?)+  |] ( table+     , a.id+     , a.name+     , DB.Binary a.bytes+     , a.checksum+     , a.appliedAt+     , a.durationS+     )+  pure ()++-- | Delete all 'Applied' migrations' records from the DB.+deleteAll :: DB.Table -> DB.Connection -> IO ()+deleteAll table conn = do+  _rows <- DB.execute conn [DB.sql|+    TRUNCATE ?+  |] (DB.Only table)+  pure ()++-- | Delete the specific 'Applied' migration's record from the DB.+deleteByID :: ID -> DB.Table -> DB.Connection -> IO Bool+deleteByID id table conn = do+  rows <- DB.execute conn [DB.sql|+    DELETE FROM ?+          WHERE id = ?+  |] (table, id)+  pure (rows > 0)++appliedP :: DB.RowParser Applied+appliedP = do+  id <- DB.field+  name <- DB.field+  DB.Binary bytes <- DB.field+  checksum <- DB.field+  appliedAt <- DB.field+  durationS <- DB.field+  pure Applied+    { content = Content {..}+    , ..+    }
+ src/Relocant/At.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- | This module deals with getting the moment of time something's happened.+module Relocant.At+  ( At+  , format+  , now+  , epoch+  ) where++import Data.Aeson qualified as Aeson+import Data.Time+  ( ZonedTime+  , formatTime+  , defaultTimeLocale+  , getZonedTime+  , zonedTimeToUTC+  , utcToZonedTime+  , utc+  )+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Database.PostgreSQL.Simple.FromField qualified as DB (FromField)+import Database.PostgreSQL.Simple.ToField qualified as DB (ToField)+++-- | The moment of time something's happened. (This is a newtype over 'ZonedTime')+newtype At = At ZonedTime+    deriving+      ( Show+      , Aeson.ToJSON+      , DB.FromField+      , DB.ToField+      )++-- | Convert to UTC, then check equality.+instance Eq At where+  At x == At y =+    zonedTimeToUTC x == zonedTimeToUTC y++-- | Format 'At' as a 'String', using the usual /time/ format string.+format :: String -> At -> String+format fmt (At at) =+  formatTime defaultTimeLocale fmt at++-- | Get current time.+now :: IO At+now =+  fmap At getZonedTime++-- | Get '1970-01-01 00:00:00 UTC' as an 'At'.+epoch :: At+epoch =+  At (utcToZonedTime utc (posixSecondsToUTCTime 0))
+ src/Relocant/Checksum.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_HADDOCK hide #-}+module Relocant.Checksum+  ( Checksum(..)+  ) where++import Control.Applicative (empty)+import "crypton" Crypto.Hash (Digest, SHA1, hash, digestFromByteString)+import Data.ByteArray (convert)+import Data.ByteString (ByteString)+import Data.String (IsString(..))+import Database.PostgreSQL.Simple qualified as DB (Binary(..))+import Database.PostgreSQL.Simple.FromField qualified as DB (FromField(..))+import Database.PostgreSQL.Simple.ToField qualified as DB (ToField(..))+++-- | SHA1 checksum.+newtype Checksum = Checksum (Digest SHA1)+    deriving Show via Digest SHA1 -- just show the digest+    deriving Eq++instance IsString Checksum where+  fromString str =+    Checksum (hash @ByteString @SHA1 (fromString str))++instance DB.FromField Checksum where+  fromField conv f = do+    DB.Binary bytes <- DB.fromField conv f+    case digestFromByteString @_ @ByteString bytes of+      Nothing ->+        empty+      Just digest ->+        pure (Checksum digest)++instance DB.ToField Checksum where+  toField (Checksum digest) = do+    DB.toField (DB.Binary (convert @_ @ByteString digest))
+ src/Relocant/Content.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_HADDOCK hide #-}+module Relocant.Content where++import Data.ByteString (ByteString)+import Data.String (IsString(..))++import Relocant.Checksum (Checksum)+++-- | Migration content and its checksum.+data Content = Content+  { bytes    :: ByteString+  , checksum :: Checksum+  } deriving (Show, Eq)++instance IsString Content where+  fromString str = Content+    { bytes = fromString str+    , checksum = fromString str+    }
+ src/Relocant/DB.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE QuasiQuotes #-}+-- | This module manages PostgreSQL connections and /relocant/'s DB schema.+module Relocant.DB+  ( ConnectionString+  , Table+  , defaultTable+  , connect+  , init+  , withLock+  , withTryLock+  , lock+  , tryLock+  , unlock+  , dumpSchema+  ) where++import Control.Exception (bracket, bracket_)+import Control.Monad (when)+import Data.Aeson qualified as Aeson+import Data.ByteString (ByteString)+import Data.String (IsString)+import Data.Text.Encoding qualified as Text+import Database.PostgreSQL.Simple qualified as DB+import Database.PostgreSQL.Simple.FromRow qualified as DB (field)+import Database.PostgreSQL.Simple.SqlQQ qualified as DB (sql)+import Prelude hiding (init)+import System.Process (callProcess)++import Relocant.DB.Table (Table, defaultTable)+++-- | PostgreSQL connection string. (This is a newtype over 'ByteString')+--+-- for syntax, see: https://hackage.haskell.org/package/postgresql-simple/docs/Database-PostgreSQL-Simple.html#v:connectPostgreSQL+newtype ConnectionString = ConnectionString ByteString+    deriving+      ( Show+      , Eq+      , IsString+      )++instance Aeson.ToJSON ConnectionString where+  toJSON (ConnectionString connString) =+    Aeson.toJSON (Text.decodeUtf8Lenient connString)++-- | Connect to the DB using the given 'ConnectionString' and+-- initialize the migrations table.+--+-- /Note:/ If you get your 'DB.Connection' from elsewhere,+-- remember to call 'init' yourself.+connect :: ConnectionString -> Table -> IO DB.Connection+connect (ConnectionString str) table = do+  conn <- DB.connectPostgreSQL str+  init table conn+  pure conn++-- | Initialize the migrations table.+init :: Table -> DB.Connection -> IO ()+init table conn = do+  setLessVerboseLogging conn+  ensureMigrationTableExists table conn++setLessVerboseLogging :: DB.Connection -> IO ()+setLessVerboseLogging conn = do+  _ <- DB.execute_ conn [DB.sql|+    SET client_min_messages TO 'warning'+  |]+  pure ()++ensureMigrationTableExists :: Table -> DB.Connection -> IO ()+ensureMigrationTableExists table conn = do+  _ <- DB.execute conn [DB.sql|+    CREATE TABLE IF NOT EXISTS ?+    ( id         TEXT NOT NULL+    , name       TEXT NOT NULL+    , bytes      BYTEA NOT NULL+    , checksum   BYTEA NOT NULL+    , applied_at TIMESTAMPTZ NOT NULL+    , duration_s INTERVAL NOT NULL+    , PRIMARY KEY (id)+    )+  |] (DB.Only table)+  pure ()++-- | Use /pg_advisory_{lock,unlock}/ to restrict access to+-- the migrations table. The given table is used to+-- generate the lock's ID, so that in the unlikely case where+-- you have multiple migrations tables in your database you can+-- lock them separately.+withLock :: Table -> DB.Connection -> IO a -> IO a+withLock table conn m =+  bracket_ (lock table conn) (unlock table conn) m++-- | A non-blocking version of 'withLock'. 'True' is passed+-- to the callback if the lock was successfully acquired, 'False' otherwise.+withTryLock :: Table -> DB.Connection -> (Bool -> IO a) -> IO a+withTryLock table conn m =+  bracket (tryLock table conn) release m+ where+  release locked =+    when locked $ do+      _ <- unlock table conn+      pure ()++-- | Use /pg_advisory_lock/ to lock the database, restricting+-- access to the migrations table. The given table is used to+-- generate the lock's ID, so that in the unlikely case where+-- you have multiple migrations tables in your database you can+-- lock them separately.+lock :: Table -> DB.Connection -> IO ()+lock table conn = do+  [()] <- DB.queryWith DB.field conn [DB.sql|+    SELECT pg_advisory_lock(hashtext('?'))+  |] (DB.Only table)+  pure ()++-- | A non-blocking version of 'lock'. Returns 'True' if the+-- lock was successfully acquired, 'False' otherwise.+tryLock :: Table -> DB.Connection -> IO Bool+tryLock table conn = do+  [locked] <- DB.queryWith DB.field conn [DB.sql|+    SELECT pg_try_advisory_lock(hashtext('?'))+  |] (DB.Only table)+  pure locked++-- | Use /pg_advisory_unlock/ to unlock the database.+unlock :: Table -> DB.Connection -> IO Bool+unlock table conn = do+  [unlocked] <- DB.queryWith DB.field conn [DB.sql|+    SELECT pg_advisory_unlock(hashtext('?'))+  |] (DB.Only table)+  pure unlocked++dumpSchema :: Table -> IO ()+dumpSchema table =+  callProcess "pg_dump" ["--schema-only", "--no-owner", "--no-acl", "--exclude-table", show table]
+ src/Relocant/DB/Table.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_HADDOCK hide #-}+module Relocant.DB.Table+  ( Table+  , defaultTable+  ) where++import Data.Aeson qualified as Aeson+import Data.String (IsString(..))+import Database.PostgreSQL.Simple.ToField qualified as DB (ToField)+import Database.PostgreSQL.Simple.Types qualified as DB (QualifiedIdentifier(..))+import Text.Printf (printf)+++-- | /relocant's/ migration table name.+newtype Table = Table DB.QualifiedIdentifier+    deriving+      ( Eq+      , IsString+      , DB.ToField+      )++-- | Return a 'String' that can be 'fromString'ed back to a 'Table'.+instance Show Table where+  show (Table (DB.QualifiedIdentifier q i)) =+    case q of+      Just s ->+        printf "%s.%s" s i+      Nothing ->+        printf "%s" i++instance Aeson.ToJSON Table where+  toJSON =+    Aeson.toJSON . show++-- | The default table name, which is "public.relocant_migration".+defaultTable :: Table+defaultTable =+  "public.relocant_migration"
+ src/Relocant/Duration.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeApplications #-}+-- | This module deals with timing actions.+module Relocant.Duration+  ( Duration(..)+  , measure+  , measure_+  ) where++import Data.Aeson qualified as Aeson+import Data.Time+  ( getCurrentTime+  , diffUTCTime+  )+import Database.PostgreSQL.Simple.FromField qualified as DB (FromField(..))+import Database.PostgreSQL.Simple.ToField qualified as DB (ToField(..))+import Text.Printf (PrintfArg)+++-- | How long something took, in seconds. Use 'mempty' for a 0 seconds 'Duration'.+newtype Duration = Duration Double+    deriving+      ( Show+      , Eq+      , PrintfArg+      , Aeson.ToJSON+      , DB.FromField+      , DB.ToField+      )++instance Semigroup Duration where+  (Duration d0) <> (Duration d1) =+    Duration (d0 + d1)++instance Monoid Duration where+  mempty = Duration 0++-- | Time an action.+measure :: IO a -> IO (Duration, a)+measure m = do+  t0 <- getCurrentTime+  a <- m+  t1 <- getCurrentTime+  pure (Duration (realToFrac (t1 `diffUTCTime` t0)), a)++-- | Time an action and ignore its result.+measure_ :: IO x -> IO Duration+measure_ m = do+  (t, _x) <- measure m+  pure t
+ src/Relocant/ID.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_HADDOCK hide #-}+module Relocant.ID+  ( ID(..)+  ) where++import Data.Aeson qualified as Aeson+import Data.String (IsString)+import Database.PostgreSQL.Simple.FromField qualified as DB (FromField)+import Database.PostgreSQL.Simple.ToField qualified as DB (ToField)+import Text.Printf (PrintfArg)+++-- | Migration 'ID'.+newtype ID = ID String+    deriving+      ( Show+      , Eq+      , Ord+      , IsString+      , PrintfArg+      , DB.FromField+      , DB.ToField+      , Aeson.ToJSON+      )
+ src/Relocant/Merge.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# OPTIONS_HADDOCK hide #-}+-- | This modules deals with merging scripts and applied migrations,+-- and discovering inconsistencies.+module Relocant.Merge+  ( Merged(..)+  , ContentMismatch(..)+  , merge+  , canApply+  , converged+  ) where++import Data.Aeson qualified as Aeson+import Data.Aeson ((.=))+import Relocant.Applied (Applied(..))+import Relocant.Script (Script(..))+++-- | The result of merging 'Script's and 'Applied' migrations.+data Merged = Merged+  { unrecorded      :: [Script]+    -- ^ A script that does not have a corresponding+    -- recorded migration, when there is a recorded migration+    -- with a higher ID+  , scriptMissing   :: [Applied]+    -- ^ A recorded migration that does not have a+    -- corresponding script+  , contentMismatch :: [ContentMismatch]+    -- ^ A recorded migration and a script have the same ID but+    -- different content+  , unapplied       :: [Script]+    -- ^ An unapplied script that has a higher ID than any+    -- recorded migration+  } deriving (Show, Eq)++instance Aeson.ToJSON Merged where+  toJSON r =+    Aeson.object+       [ "unrecorded" .= r.unrecorded+       , "script-missing" .= r.scriptMissing+       , "content-mismatch" .= r.contentMismatch+       , "unapplied" .= r.unapplied+       ]++-- | The applied migration and its purported script differ in content.+data ContentMismatch = ContentMismatch+  { expected :: Applied+  , butGot   :: Script+  } deriving (Show, Eq)++instance Aeson.ToJSON ContentMismatch where+  toJSON cm =+    Aeson.object+       [ "expected" .= cm.expected+       , "but-got" .= cm.butGot+       ]++-- | No problems have been discovered after the merge.+canApply :: Merged -> Bool+canApply = \case+  Merged {unrecorded = [], scriptMissing = [], contentMismatch = []} -> True+  _ -> False++-- | No problems have been discovered after the merge, and there are no migration scripts to apply.+converged :: Merged -> Bool+converged = \case+  Merged {unrecorded = [], scriptMissing = [], contentMismatch = [], unapplied = []} -> True+  _ -> False++-- | Merge scripts and applied migrations, trying to discover inconsistencies and/or+-- migration scripts to apply.+merge :: [Applied] -> [Script] -> Merged+merge applieds scripts =+  fromAcc (go ([], [], []) applieds scripts)+ where+  go+    :: ([Script], [Applied], [ContentMismatch])+    -> [Applied]+    -> [Script]+    -> ([Script], [Applied], [ContentMismatch], [Script])+  go (unrecorded, scriptMissing, contentMismatch) [] ss =+    (unrecorded, scriptMissing, contentMismatch, ss)+  go (unrecorded, scriptMissing, contentMismatch) as [] =+    (unrecorded, scriptMissing <> as, contentMismatch, [])+  go (unrecorded, scriptMissing, contentMismatch) (a : as) (s : ss) =+    case compare a.id s.id of+      LT ->+        go (unrecorded, a : scriptMissing, contentMismatch) as (s : ss)+      EQ+        | a.checksum == s.checksum ->+          go (unrecorded, scriptMissing, contentMismatch) as ss+        | otherwise ->+          go (unrecorded, scriptMissing, ContentMismatch a s : contentMismatch) as ss+      GT ->+        go (s : unrecorded, scriptMissing, contentMismatch) (a : as) ss++  fromAcc (unrecorded, unscripted, contentMismatch, unapplied) = Merged+    { unrecorded = reverse unrecorded+    , scriptMissing = reverse unscripted+    , contentMismatch = reverse contentMismatch+    , unapplied+    }
+ src/Relocant/Name.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_HADDOCK hide #-}+module Relocant.Name+  ( Name(..)+  ) where++import Data.Aeson qualified as Aeson+import Data.String (IsString)+import Data.Text (Text)+import Database.PostgreSQL.Simple.FromField qualified as DB (FromField)+import Database.PostgreSQL.Simple.ToField qualified as DB (ToField)+import Text.Printf (PrintfArg)+++-- | Migration 'Name'.+newtype Name = Name Text+    deriving+      ( Show+      , Eq+      , IsString+      , PrintfArg+      , Aeson.ToJSON+      , DB.FromField+      , DB.ToField+      )
+ src/Relocant/Script.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}+-- | This module deals with migrations that haven't yet been applied.+module Relocant.Script+  ( Script(..)+  , readScripts+  , readScript+  , apply+  , markApplied+    -- * Extra+  , parseFilePath+  , readContent+  ) where++import "crypton" Crypto.Hash (hash)+import Data.Aeson qualified as Aeson+import Data.Aeson ((.=))+import Data.ByteString (ByteString)+import Data.ByteString qualified as ByteString+import Data.Char qualified as Char+import Data.List qualified as List+import Data.String (IsString(..))+import Database.PostgreSQL.Simple qualified as DB+import Database.PostgreSQL.Simple.Types qualified as DB (Query(..))+import GHC.Records (HasField(getField))+import Prelude hiding (id)+import System.Directory qualified as D+import System.FilePath ((</>), isExtensionOf, takeBaseName)++import Relocant.Applied (Applied(..))+import Relocant.At (At)+import Relocant.At qualified as At+import Relocant.ID (ID)+import Relocant.Checksum (Checksum(..))+import Relocant.Content (Content(..))+import Relocant.Duration (Duration)+import Relocant.Duration qualified as Duration+import Relocant.Name (Name)+++-- | A migration script. Most users would get them by running 'readScripts',+-- but those wanting a more fine-grained control would use 'readScript'.+data Script = Script+  { id      :: ID      -- ^ if XXX-YYYY.sql is the whole filename, then XXX is the id; see 'parseFilePath'+  , name    :: Name    -- ^ if XXX-YYYY.sql is the whole filename, then XXX-YYYY is the name+  , content :: Content+  } deriving (Show, Eq)++-- | The content (as in actual bytes) is skipped.+instance Aeson.ToJSON Script where+  toJSON s =+    Aeson.object+      [ "id" .= s.id+      , "name" .= s.name+      , "checksum" .= show s.checksum+      ]++instance HasField "bytes" Script ByteString where+  getField s =+    s.content.bytes++instance HasField "checksum" Script Checksum where+  getField s =+    s.content.checksum++-- | Read migration 'Script's from a directory. It only tries to read paths+-- ending with the /.sql/ extension and doesn't recurse into subdirectories.+--+-- /Note/: the directory must exist+readScripts :: FilePath -> IO [Script]+readScripts dir = do+  paths <- D.listDirectory dir+  scripts <- traverse (\path -> readScript (dir </> path)) (filter (isExtensionOf ".sql") paths)+  pure (List.sortOn (\script -> script.id) scripts)++-- | Read migration 'Script's from a file. Useful when you need a more fine-grained+-- control over which paths are read then what 'readScripts' provides.+readScript :: FilePath -> IO Script+readScript path = do+  let+    (id, name) =+      parseFilePath path+  content <- readContent path+  pure Script+    { id+    , name+    , content+    }++-- | Get XXX as the 'ID' and XXX-YYYY as the 'Name' from XXX-YYYY.sql+--+-- Basically, the longest alphanumeric prefix of the basename is the 'ID',+-- and the basename is the 'Name'.+parseFilePath :: FilePath -> (ID, Name)+parseFilePath path = do+  let+    basename =+      takeBaseName path+    (id, _rest) =+      span Char.isAlphaNum basename+  (fromString id, fromString basename)++-- | Get migration 'Script'\'s content and its checksum.+readContent :: FilePath -> IO Content+readContent path = do+  bytes <- ByteString.readFile path+  pure Content+    { bytes+    , checksum = Checksum (hash bytes)+    }++applyWith :: (ByteString -> IO Duration) -> Script -> IO Applied+applyWith f s = do+  appliedAt <- At.now+  durationS <- f s.bytes+  pure (applied s appliedAt durationS)++-- | Run a 'Script' against the database, get an 'Applied' migration back if successful.+--+-- /Note:/ You probably want to run this together with 'Relocant.Applied.record'+-- in a single transaction.+apply :: Script -> DB.Connection -> IO Applied+apply s conn = do+  applyWith (Duration.measure_ . DB.execute_ conn . DB.Query) s++-- | Get an 'Applied' migration from a 'Script', without running it. This should not+-- be normally used, but can be useful for fixing checksums after cosmetics updates+-- of migration 'Script's (such as adding comments, for example).+markApplied :: Script -> IO Applied+markApplied =+  applyWith (\_bytes -> pure mempty)++applied :: Script -> At -> Duration -> Applied+applied s appliedAt durationS = Applied+  { id = s.id+  , name = s.name+  , content = s.content+  , appliedAt+  , durationS+  }
+ test/Main.hs view
@@ -0,0 +1,12 @@+module Main where++import Control.Exception (bracket_)+import Test.Hspec.Runner (hspec)+import Spec qualified++import SpecHelper.DB qualified as DB+++main :: IO ()+main = do+  bracket_ DB.createTemplate DB.dropTemplate (hspec Spec.spec)
+ test/Relocant/App/ToTextSpec.hs view
@@ -0,0 +1,35 @@+module Relocant.App.ToTextSpec where++import Data.Text qualified as Text+import Test.Hspec++import Relocant.Name (Name(..))+import Relocant.App.ToText+  ( ToText(..)+  , arbitraryNameLengthCutOff+  )+++spec :: Spec+spec =+  describe "Name" $ do+    it "length smaller than arbitraryNameLengthCutOff" $ do+      let+        name =+          Text.replicate 7 "a"+      toText (Name name) `shouldBe`+        name <> Text.replicate (arbitraryNameLengthCutOff - 7) " "++    it "length exactly the arbitraryNameLengthCutOff" $ do+      let+        name =+          Text.replicate arbitraryNameLengthCutOff "a"+      toText (Name name) `shouldBe`+        name++    it "length larger than arbitraryNameLengthCutOff" $ do+      let+        name =+          Text.replicate (arbitraryNameLengthCutOff + 5) "a"+      toText (Name name) `shouldBe`+        Text.take 19 name <> "…"
+ test/Relocant/AppliedSpec.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}+module Relocant.AppliedSpec (spec) where++import Prelude hiding (id)+import Test.Hspec++import Relocant.Applied qualified as Applied+import Relocant.Script (Script(..))+import Relocant.Script qualified as Script (markApplied)+import Relocant.DB qualified as DB++import SpecHelper.DB qualified as DB+++spec :: Spec+spec =+  around DB.withTemplateCloned $ do+    describe "selectAll" $+      it "select all applied migrations" $ \conn -> do+        let+          script0 = Script+            { id = "00"+            , name = "00-foo"+            , content = "CREATE TABLE foo ()"+            }+          script1 = Script+            { id = "01"+            , name = "00-bar"+            , content = "CREATE TABLE bar ()"+            }+        applied0 <- Script.markApplied script0+        applied1 <- Script.markApplied script1+        Applied.record applied0 DB.defaultTable conn+        Applied.record applied1 DB.defaultTable conn+        [a0, a1] <- Applied.getApplied DB.defaultTable conn+        a0.id `shouldBe` "00"+        a0.bytes `shouldBe` "CREATE TABLE foo ()"+        a1.id `shouldBe` "01"+        a1.bytes `shouldBe` "CREATE TABLE bar ()"++    describe "selectByID" $+      it "select an applied migration by ID" $ \conn -> do+        let+          script = Script+            { id = "00"+            , name = "00-foo"+            , content = "CREATE TABLE foo ()"+            }+        applied <- Script.markApplied script+        Applied.record applied DB.defaultTable conn+        Just a <- Applied.getAppliedByID "00" DB.defaultTable conn+        a.id `shouldBe` "00"+        a.bytes `shouldBe` "CREATE TABLE foo ()"+        Nothing <- Applied.getAppliedByID "01" DB.defaultTable conn+        pure ()++    describe "record" $+      it "stores the script in the DB" $ \conn -> do+        let+          script = Script+            { id = "00"+            , name = "00-oops"+            , content = "CREATE TABLE foo ()"+            }+        applied <- Script.markApplied script+        Applied.record applied DB.defaultTable conn+        [a] <- Applied.getApplied DB.defaultTable conn+        a.id `shouldBe` "00"+        a.bytes `shouldBe` "CREATE TABLE foo ()"++    describe "deleteAll" $+      it "deletes all applied migrations" $ \conn -> do+        let+          script0 = Script+            { id = "00"+            , name = "00-foo"+            , content = "CREATE TABLE foo ()"+            }+          script1 = Script+            { id = "01"+            , name = "00-bar"+            , content = "CREATE TABLE bar ()"+            }+        applied0 <- Script.markApplied script0+        applied1 <- Script.markApplied script1+        Applied.record applied0 DB.defaultTable conn+        Applied.record applied1 DB.defaultTable conn+        Applied.deleteAll DB.defaultTable conn+        Applied.getApplied DB.defaultTable conn `shouldReturn` []++    describe "deleteByID" $+      it "deletes an applied migration by ID" $ \conn -> do+        let+          script0 = Script+            { id = "00"+            , name = "00-foo"+            , content = "CREATE TABLE foo ()"+            }+          script1 = Script+            { id = "01"+            , name = "00-bar"+            , content = "CREATE TABLE bar ()"+            }+        applied0 <- Script.markApplied script0+        applied1 <- Script.markApplied script1+        Applied.record applied0 DB.defaultTable conn+        Applied.record applied1 DB.defaultTable conn+        True <- Applied.deleteByID "00" DB.defaultTable conn+        [a] <- Applied.getApplied DB.defaultTable conn+        a.id `shouldBe` "01"+        a.bytes `shouldBe` "CREATE TABLE bar ()"
+ test/Relocant/DurationSpec.hs view
@@ -0,0 +1,16 @@+module Relocant.DurationSpec (spec) where++import Test.Hspec++import Relocant.Duration (Duration(..), measure)+++spec :: Spec+spec = do+  it "times moves forward" $ do+    (Duration s, ()) <- measure (pure ())+    s `shouldSatisfy` (> 0)++  it "outer > inner" $ do+    (Duration s1, (Duration s0, ())) <- measure (measure (pure ()))+    s1 `shouldSatisfy` (> s0)
+ test/Relocant/MergeSpec.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeApplications #-}+module Relocant.MergeSpec (spec) where++import Test.Hspec++import Relocant.Applied (Applied(..))+import Relocant.At (epoch)+import Relocant.Merge (Merged(..), ContentMismatch(..), merge)+import Relocant.Script (Script(..))+++spec :: Spec+spec = do+  let+    a1 = Applied+      { id = "01"+      , name = "01-m1"+      , content = "m1"+      , appliedAt = epoch+      , durationS = mempty+      }+    a2 = Applied+      { id = "02"+      , name = "02-m2"+      , content = "m2"+      , appliedAt = epoch+      , durationS = mempty+      }+    s0 = Script+      { id = "000"+      , name = "000-m0"+      , content = "m0"+      }+    s1 = Script+      { id = "01"+      , name = "01-s1"+      , content = "s1"+      }+    s3 = Script+      { id = "03"+      , name = "03-s3"+      , content = "s3"+      }++  it "merges unapplied and applied migrations" $ do+    let+      result =+        merge [a1, a2] [s0, s1, s3]+    result `shouldBe` Merged+      { unrecorded = [s0]+      , scriptMissing = [a2]+      , contentMismatch = [ContentMismatch a1 s1]+      , unapplied = [s3]+      }
+ test/Relocant/ScriptSpec.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}+module Relocant.ScriptSpec (spec) where++import Prelude hiding (id)+import System.FilePath ((</>))+import System.IO.Temp+import Test.Hspec++import Relocant.App.Env qualified as Env+import Relocant.Script+  ( Script(..)+  , parseFilePath+  , readContent+  , readScripts+  , readScript+  , apply+  )++import SpecHelper.DB qualified as DB+++spec :: Spec+spec = do+  describe "parseFilePath" $ do+    it "empty ID/name is an ID/name" $+      parseFilePath ".sql" `shouldBe` ("", "")++    it "parses a bare migration ID" $+      parseFilePath "0001.sql" `shouldBe` ("0001", "0001")++    it "parses a migration ID separated from the rest of the name" $+      parseFilePath "0001-migration-name.sql" `shouldBe` ("0001", "0001-migration-name")++    it "migration ID can be arbitrary (alphanumeric value)" $ do+      parseFilePath "abc4-migration-name.sql" `shouldBe` ("abc4", "abc4-migration-name")+      parseFilePath "a%&#-migration-name.sql" `shouldBe` ("a", "a%&#-migration-name")++    it "the .sql extenstion is optional (but recommended (for your sanity))" $+      parseFilePath "abc4-migration-name" `shouldBe` ("abc4", "abc4-migration-name")++  describe "readContent" $ do+    it "reads the file and returns the content and its hash" $+      withSystemTempDirectory Env.name $ \tmpDir -> do+        let+          path =+            tmpDir </> "a"+        writeFile path "abc"+        readContent path `shouldReturn` "abc"++  describe "readScript" $ do+    it "combines parseFilePath and readContent" $+      withSystemTempDirectory Env.name $ \tmpDir -> do+        let+          path =+            tmpDir </> "0001-migration-name.sql"+        writeFile path "abc"+        readScript path `shouldReturn`+          Script+            { id = "0001"+            , name = "0001-migration-name"+            , content = "abc"+            }++  describe "readScripts" $+    it "lists all .sql files in a directory, ordered by ID" $+      withSystemTempDirectory Env.name $ \tmpDir -> do+        let+          file name =+            tmpDir </> name+        writeFile (file "01-abc.sql") "abc"+        writeFile (file "02-def.sql") "def"+        writeFile (file "00-oops.sql") "oops"+        readScripts tmpDir `shouldReturn`+          [ Script+            { id = "00"+            , name = "00-oops"+            , content = "oops"+            }+          , Script+            { id = "01"+            , name = "01-abc"+            , content = "abc"+            }+          , Script+            { id = "02"+            , name = "02-def"+            , content = "def"+            }+          ]++  around DB.withTemplateCloned $ do+    describe "apply" $+      it "runs a migration script" $ \conn -> do+        let+          script = Script+            { id = "00"+            , name = "00-oops"+            , content = "CREATE TABLE foo ()"+            }+        _durationS <- apply script conn+        pure ()
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec -optF --no-main #-}
+ test/SpecHelper/DB.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeApplications #-}+module SpecHelper.DB+  ( createTemplate+  , dropTemplate+  , withTemplateCloned+  ) where++import Control.Exception (bracket, bracket_)+import Data.ByteString (ByteString)+import Data.Int (Int32)+import Data.String (fromString)+import Database.PostgreSQL.Simple qualified as DB+import Database.PostgreSQL.Simple.SqlQQ qualified as DB (sql)+import Database.PostgreSQL.Simple.Types qualified as DB (QualifiedIdentifier)+import System.Random (randomIO)+import Text.Printf (printf)++import Relocant.DB qualified as DB (init)+++createTemplate :: IO ()+createTemplate = do+  withDB "relocant" (createDatabase "relocant_base")+  withDB "relocant_base" $ \conn -> do+    DB.init "public.relocant_migration" conn+    setTemplate "relocant_base" conn+    DB.close conn++dropTemplate :: IO ()+dropTemplate =+  withDB "relocant" $ \conn -> do+    unsetTemplate "relocant_base" conn+    dropDatabase "relocant_base" conn++withTemplateCloned :: (DB.Connection -> IO a) -> IO a+withTemplateCloned f = do+  n <- randomIO @Int32+  withClonedDB "relocant_base" (fromString (printf "relocant_test_%d" n)) f++withClonedDB :: String -> String -> (DB.Connection -> IO a) -> IO a+withClonedDB base cloned f = do+  bracket_+    (withDB (dbname base) (cloneTemplate (ident base) (ident cloned)))+    (withDB (dbname base) (dropDatabase (ident cloned)))+    (withDB (dbname cloned) f)+ where+  dbname :: String -> ByteString+  dbname = fromString+  ident :: String -> DB.QualifiedIdentifier+  ident = fromString++withDB :: ByteString -> (DB.Connection -> IO a) -> IO a+withDB name =+  bracket (DB.connectPostgreSQL ("dbname=" <> name)) DB.close++createDatabase :: DB.QualifiedIdentifier -> DB.Connection -> IO ()+createDatabase base conn = do+  _ <- DB.execute conn [DB.sql|+    CREATE DATABASE ?+  |] (DB.Only base)+  pure ()++setTemplate :: DB.QualifiedIdentifier -> DB.Connection -> IO ()+setTemplate base conn = do+  _ <- DB.execute conn [DB.sql|+    ALTER DATABASE ? IS_TEMPLATE = true;+  |] (DB.Only base)+  pure ()++unsetTemplate :: DB.QualifiedIdentifier -> DB.Connection -> IO ()+unsetTemplate base conn = do+  _ <- DB.execute conn [DB.sql|+    ALTER DATABASE ? IS_TEMPLATE = false;+  |] (DB.Only base)+  pure ()++cloneTemplate :: DB.QualifiedIdentifier -> DB.QualifiedIdentifier -> DB.Connection -> IO ()+cloneTemplate base cloned conn = do+  _ <- DB.execute conn [DB.sql|+    CREATE DATABASE ? TEMPLATE ?+  |] (cloned, base)+  pure ()++dropDatabase :: DB.QualifiedIdentifier -> DB.Connection -> IO ()+dropDatabase name conn = do+  _ <- DB.execute conn [DB.sql|+    DROP DATABASE ?+  |] (DB.Only name)+  pure ()