Merge pull request #2 from mfine/mfine-recurse

mfine · mfine · commit c29287e26ee3 · 2015-09-12T15:50:22.000-07:00
Recurse
diff --git a/main/Apply.hs b/main/Apply.hs
@@ -14,10 +14,12 @@ import Database.PostgreSQL.Schema ( bootstrap, converge )
 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 @@ args =
     <> 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,23 +41,27 @@ args =
           <> 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 =
   execParser args >>= call where
     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
diff --git a/postgresql-schema.cabal b/postgresql-schema.cabal
@@ -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-add
 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
diff --git a/src/Database/PostgreSQL/Schema.hs b/src/Database/PostgreSQL/Schema.hs
@@ -23,6 +23,11 @@ import Formatting         ( (%), sformat, stext )
 import Shelly
 
 
+-- types
+
+type Migration = (FilePath, FilePath)
+
+
 -- psql
 
 psqlCommand :: Text -> Text -> Sh Text
@@ -77,10 +82,13 @@ checkSchema schema url = do
   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 @@ ls_f dir = do
   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 @@ add migration file dir = do
   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 @@ add migration file dir = do
 -- 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
