postgresql-schema 0.1.5 → 0.1.6
raw patch · 4 files changed
+79/−83 lines, 4 filesdep +basic-preludedep +postgresql-simpledep −base-preludedep −formattingPVP ok
version bump matches the API change (PVP)
Dependencies added: basic-prelude, postgresql-simple
Dependencies removed: base-prelude, formatting
API changes (from Hackage documentation)
Files
- main/Add.hs +10/−6
- main/Apply.hs +6/−5
- postgresql-schema.cabal +6/−6
- src/Database/PostgreSQL/Schema.hs +57/−66
main/Add.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} -- | -- Module: Add -- Copyright: (c) 2015 Mark Fine@@ -8,14 +9,17 @@ -- -- Tool for adding PostgreSQL migrations. -import BasePrelude-import Data.Text ( pack )-import Data.Time.Clock ( getCurrentTime )-import Data.Time.Format ( formatTime )-import Database.PostgreSQL.Schema ( add )+import BasicPrelude hiding ( FilePath )+import Data.Text ( pack )+import Data.Time.Clock+import Data.Time.Format+import Database.PostgreSQL.Schema import Options.Applicative import Shelly-import System.Locale ( defaultTimeLocale )+#if MIN_VERSION_time(1,5,0)+#else+import System.Locale+#endif data Args = Args { aFile :: String
main/Apply.hs view
@@ -8,13 +8,14 @@ -- -- Tool for applying PostgreSQL migrations. -import BasePrelude hiding ( FilePath )-import Data.Text ( Text, pack )-import Database.PostgreSQL.Schema ( bootstrap, converge )+import BasicPrelude hiding ( FilePath )+import Data.Text ( pack )+import Database.PostgreSQL.Schema import Options.Applicative-import Paths_postgresql_schema ( getDataFileName )+import Paths_postgresql_schema import Shelly-import System.IO hiding ( FilePath )+import System.IO hiding ( FilePath )+import System.Environment data Args = Args { aRecur :: Bool
postgresql-schema.cabal view
@@ -1,5 +1,5 @@ name: postgresql-schema-version: 0.1.5+version: 0.1.6 synopsis: PostgreSQL Schema Management description: Please see README.md homepage: https://github.com/mfine/postgresql-schema@@ -20,8 +20,8 @@ hs-source-dirs: src ghc-options: -Wall -fno-warn-orphans build-depends: base >= 4.7 && < 5- , base-prelude- , formatting+ , basic-prelude+ , postgresql-simple , shelly , text default-extensions: NoImplicitPrelude@@ -33,13 +33,13 @@ ghc-options: -Wall default-language: Haskell2010 build-depends: base >= 4.7 && < 5- , base-prelude- , time+ , basic-prelude , old-locale , optparse-applicative , postgresql-schema , shelly , text+ , time default-extensions: NoImplicitPrelude OverloadedStrings RecordWildCards@@ -51,7 +51,7 @@ ghc-options: -Wall default-language: Haskell2010 build-depends: base >= 4.7 && < 5- , base-prelude+ , basic-prelude , optparse-applicative , postgresql-schema , shelly
src/Database/PostgreSQL/Schema.hs view
@@ -17,80 +17,78 @@ , converge ) where -import BasePrelude hiding ( FilePath, (%), intercalate, lines )-import Data.Text ( Text, intercalate, lines, strip )-import Formatting ( (%), sformat, stext )+import BasicPrelude hiding ( FilePath, (</>) )+import Data.Text ( unpack )+import Database.PostgreSQL.Simple import Shelly - -- types type Migration = (FilePath, FilePath) +-- SQL --- psql+countSchemaSQL :: Text+countSchemaSQL =+ " SELECT count(*) \+ \ FROM pg_namespace \+ \ WHERE nspname = ? " -psqlCommand :: Text -> Text -> Sh Text-psqlCommand c url =- run "psql" [ "--no-align"- , "--tuples-only"- , "--command"- , c- , url ]+selectMigrationsSQL :: Text -> Text -> Text+selectMigrationsSQL table schema =+ " SELECT filename \+ \ FROM " <> schema <> "." <> table <>+ " WHERE filename IN ? " -psqlFile :: FilePath -> Text -> Sh ()-psqlFile f url =+insertMigrationSQL :: FilePath -> Text -> Text -> Text+insertMigrationSQL migration table schema =+ " INSERT INTO " <> schema <> "." <> table <> " (filename) \+ \ SELECT '" <> toTextIgnore migration <> "' \+ \ WHERE NOT EXISTS \+ \ ( SELECT TRUE FROM " <> schema <> "." <> table <>+ " WHERE filename = '" <> toTextIgnore migration <> "' ) "++-- psql++psql :: FilePath -> Text -> Sh ()+psql migration url = run_ "psql" [ "--no-align" , "--tuples-only" , "--quiet" , "--file"- , toTextIgnore f+ , toTextIgnore migration , url ] ---- SQL+-- queries -countSchema :: Text -> Text-countSchema =- sformat ( " SELECT count(*) " %- " FROM pg_namespace " %- " WHERE nspname = '" % stext % "' " )+query' :: (FromRow f, ToRow t) => Text -> t -> Text -> IO [f]+query' q p url =+ bracket (connectPostgreSQL (encodeUtf8 url)) close $ \c ->+ query c (fromString $ unpack q) p -insertMigration :: FilePath -> Text -> Text -> Text-insertMigration migration table schema =- sformat ( " INSERT INTO " % stext % "." % stext % " (filename) " %- " SELECT '" % stext % "' " %- " WHERE NOT EXISTS " %- " ( SELECT TRUE FROM " % stext % "." % stext %- " WHERE filename = '" % stext % "') " )- schema table (toTextIgnore migration) schema table (toTextIgnore migration)+countSchema :: Text -> Text -> IO [Only Int]+countSchema schema =+ query' countSchemaSQL $ Only schema -selectMigrations :: [FilePath] -> Text -> Text -> Text+selectMigrations :: [FilePath] -> Text -> Text -> Text -> IO [Only Text] selectMigrations migrations table schema =- sformat ( " SELECT filename " %- " FROM " % stext % "." % stext %- " WHERE filename IN ( " % stext % " ) " )- schema table $- intercalate ", " $ flip map migrations $ \migration ->- sformat ("'" % stext % "'") (toTextIgnore migration)-+ query' (selectMigrationsSQL table schema) $ Only $ In $ map toTextIgnore migrations --- psql + SQL+-- interpreted queries -checkSchema :: Text -> Text -> Sh Bool+checkSchema :: Text -> Text -> IO Bool checkSchema schema url = do- r <- psqlCommand (countSchema schema) url- return $ strip r == "0"+ result <- countSchema schema url+ return $ maybe False ((== 0) . fromOnly) (listToMaybe result) -filterMigrations :: [Migration] -> Text -> Text -> Text -> Sh [Migration]+filterMigrations :: [Migration] -> Text -> Text -> Text -> IO [Migration] filterMigrations migrations table schema url = do- r <- psqlCommand (selectMigrations (map snd migrations) table schema) url- return $ removes ((==) . snd) migrations (map fromText (lines r)) where+ results <- selectMigrations (map snd migrations) table schema url+ return $ removes ((==) . snd) migrations (map (fromText . fromOnly) results) where removes p = foldr remove where remove x = foldr f [] where f a b = if p a x then b else a : b - -- migrations ls_f :: FilePath -> Sh [FilePath]@@ -118,18 +116,14 @@ migrate migrations table schema url = forM_ migrations $ uncurry $ \dir migration -> chdir dir $ do- echo $ out migration+ echo $ "M " <> toTextIgnore migration <> " -> " <> table contents <- readfile migration 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-+ appendfile migration $ insertMigrationSQL migration table schema+ psql migration url -- API @@ -137,11 +131,8 @@ -- migration file or migrations directory do not exist. add :: FilePath -> FilePath -> FilePath -> Sh () add migration file dir = do- echo out- mv file (dir </> migration) where- out =- sformat ( "A " % stext % " -> " % stext )- (toTextIgnore file) (toTextIgnore (dir </> migration))+ echo $ "A " <> toTextIgnore file <> " -> " <> toTextIgnore (dir </> migration)+ mv file (dir </> migration) -- | Apply bootstrap migrations to a database. Checks if a database -- has been previously bootstrapped, and applies all bootstrap@@ -151,22 +142,22 @@ bootstrap :: FilePath -> Text -> Text -> Text -> Sh () bootstrap dir table schema url = do migrations <- lsMigrations dir- check <- checkSchema schema url- when check $ do+ check <- liftIO $ checkSchema schema url+ if check then 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-+ else do+ migrations' <- liftIO $ 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 :: Bool -> FilePath -> Text -> Text -> Text -> Sh () converge recur dir table schema url = do migrations <- searchMigrations recur dir- migrations' <- filterMigrations migrations table schema url+ migrations' <- liftIO $ filterMigrations migrations table schema url unless (null migrations') $ do echo "Migrating..." migrate migrations' table schema url