postgresql-schema 0.1.4 → 0.1.5

raw patch · 3 files changed

+76/−47 lines, 3 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• main/Apply.hs +19/−10
• postgresql-schema.cabal +2/−1
• src/Database/PostgreSQL/Schema.hs +55/−36

@@ -14,10 +14,12 @@ import Options.Applicative import Paths_postgresql_schema    ( getDataFileName ) import Shelly+import System.IO           hiding ( FilePath )  data Args = Args-  { aDir :: Maybe String-  , aUrl :: Maybe String+  { aRecur :: Bool+  , aDir   :: Maybe String+  , aUrl   :: Maybe String   } deriving ( Eq, Read, Show )  args :: ParserInfo Args@@ -27,7 +29,10 @@     <> header   "schema-apply: Apply Schema to PostgreSQL Database"     <> progDesc "Apply Schema" ) where     args' = Args-      <$> optional ( strOption+      <$> switch+          (  long    "recurse"+          <> help    "Recurse Migrations Directory" )+      <*> optional ( strOption           (  long    "dir"           <> metavar "DIR"           <> help    "Migrations Directory" ) )@@ -36,18 +41,18 @@           <> metavar "URL"           <> help    "Database URL" ) ) -apply :: FilePath -> FilePath -> Text -> Sh ()-apply bootstrapDir dir url = do+apply :: Bool -> FilePath -> FilePath -> Text -> Sh ()+apply recur bootstrapDir dir url = do   bootstrap bootstrapDir bootstrapTable schema url-  converge dir table schema url where+  converge recur dir table schema url where     bootstrapTable = "bootstrap_scripts"     table = "scripts"     schema = "schema_evolution_manager" -exec :: String -> String -> String -> IO ()-exec bootstrapDir dir url =+exec :: Bool -> String -> String -> String -> IO ()+exec recur bootstrapDir dir url =   shelly $-    apply (fromText (pack bootstrapDir)) (fromText (pack dir)) (pack url)+    apply recur (fromText (pack bootstrapDir)) (fromText (pack dir)) (pack url)  main :: IO () main =@@ -55,4 +60,8 @@     call Args{..} = do       url <- lookupEnv "DATABASE_URL"       bootstrapDir <- getDataFileName "migrations"-      maybe (return ()) (exec bootstrapDir (fromMaybe "migrations" aDir)) (aUrl <|> url)+      maybe+        (err "No Database URL")+        (exec aRecur bootstrapDir (fromMaybe "migrations" aDir))+        (aUrl <|> url) where+          err = hPutStrLn stderr

@@ -1,5 +1,5 @@ name:                  postgresql-schema-version:               0.1.4+version:               0.1.5 synopsis:              PostgreSQL Schema Management description:           Please see README.md homepage:              https://github.com/mfine/postgresql-schema@@ -47,6 +47,7 @@ executable schema-apply   hs-source-dirs:      main   main-is:             Apply.hs+  other-modules:       Paths_postgresql_schema   ghc-options:         -Wall   default-language:    Haskell2010   build-depends:       base >= 4.7 && < 5

@@ -23,6 +23,11 @@ import Shelly  +-- types++type Migration = (FilePath, FilePath)++ -- psql  psqlCommand :: Text -> Text -> Sh Text@@ -77,10 +82,13 @@   r <- psqlCommand (countSchema schema) url   return $ strip r == "0" -filterMigrations :: [FilePath] -> Text -> Text -> Text -> Sh [FilePath]+filterMigrations :: [Migration] -> Text -> Text -> Text -> Sh [Migration] filterMigrations migrations table schema url = do-  r <- psqlCommand (selectMigrations migrations table schema) url-  return $ migrations \\ map fromText (lines r)+  r <- psqlCommand (selectMigrations (map snd migrations) table schema) url+  return $ removes ((==) . snd) migrations (map fromText (lines r)) where+    removes p = foldr remove where+      remove x = foldr f [] where+        f a b = if p a x then b else a : b   -- migrations@@ -90,24 +98,37 @@   items <- ls dir   filterM test_f items -findMigrations :: FilePath -> Sh [FilePath]-findMigrations dir = do+lsMigrations :: FilePath -> Sh [Migration]+lsMigrations dir = do   migrations <- ls_f dir-  forM migrations $ relativeTo dir+  migrations' <- forM migrations $ relativeTo dir+  return $ sortBy (comparing snd) $ zip (repeat dir) migrations' -migrate :: [FilePath] -> Text -> Text -> Text -> Sh ()+findMigrations :: FilePath -> Sh [Migration]+findMigrations dir = do+  dirs <- findWhen test_d dir+  migrations <- forM (dir : dirs) lsMigrations+  return $ sortBy (comparing snd) $ concat migrations++searchMigrations :: Bool -> FilePath -> Sh [Migration]+searchMigrations recur =+  if recur then findMigrations else lsMigrations++migrate :: [Migration] -> Text -> Text -> Text -> Sh () migrate migrations table schema url =-  withTmpDir $ \dir ->-    forM_ migrations $ \migration -> do+  forM_ migrations $ uncurry $ \dir migration ->+    chdir dir $ do       echo $ out migration       contents <- readfile migration-      appendfile (dir </> migration) "\\set ON_ERROR_STOP true\n\n"-      appendfile (dir </> migration) contents-      appendfile (dir </> migration) $ insertMigration migration table schema-      psqlFile (dir </> migration) url where-        out migration =-          sformat ( "M " % stext % " -> " % stext )-            (toTextIgnore migration) table+      withTmpDir $ \dir' ->+        chdir dir' $ do+          appendfile migration "\\set ON_ERROR_STOP true\n\n"+          appendfile migration contents+          appendfile migration $ insertMigration migration table schema+          psqlFile migration url where+            out migration =+              sformat ( "M " % stext % " -> " % stext )+                (toTextIgnore migration) table   -- API@@ -120,8 +141,7 @@   mv file (dir </> migration) where     out =       sformat ( "A " % stext % " -> " % stext )-        (toTextIgnore file)-        (toTextIgnore (dir </> migration))+        (toTextIgnore file) (toTextIgnore (dir </> migration))  -- | Apply bootstrap migrations to a database. Checks if a database -- has been previously bootstrapped, and applies all bootstrap@@ -130,24 +150,23 @@ -- their application. bootstrap :: FilePath -> Text -> Text -> Text -> Sh () bootstrap dir table schema url = do-  migrations <- findMigrations dir-  chdir dir $ do-    check <- checkSchema schema url-    when check $ do-      echo "Bootstrapping..."-      migrate migrations table schema url-    migrations' <- filterMigrations migrations table schema url-    unless (null migrations') $ do-      echo "Bootstrap migrating..."-      migrate migrations' table schema url+  migrations <- lsMigrations dir+  check <- checkSchema schema url+  when check $ do+    echo "Bootstrapping..."+    migrate migrations table schema url+  migrations' <- filterMigrations migrations table schema url+  unless (null migrations') $ do+    echo "Bootstrap migrating..."+    migrate migrations' table schema url + -- | Apply migrations to a database. Applies all migrations that have -- not been applied yet and records their application.-converge :: FilePath -> Text -> Text -> Text -> Sh ()-converge dir table schema url = do-  migrations <- findMigrations dir-  chdir dir $ do-    migrations' <- filterMigrations migrations table schema url-    unless (null migrations') $ do-      echo "Migrating..."-      migrate migrations' table schema url+converge :: Bool -> FilePath -> Text -> Text -> Text -> Sh ()+converge recur dir table schema url = do+  migrations <- searchMigrations recur dir+  migrations' <- filterMigrations migrations table schema url+  unless (null migrations') $ do+    echo "Migrating..."+    migrate migrations' table schema url