Skip to content
This repository has been archived by the owner on Sep 20, 2021. It is now read-only.

Implement abstract interface for log writes #35

Closed
wants to merge 4 commits into from
Closed

Implement abstract interface for log writes #35

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
667ca30
Use MonadIO instead of monomorphic IO
unclechu Sep 28, 2020
da60271
Write errors to stderr in “migrate” executable
unclechu Sep 28, 2020
7610e50
Implement “MigrationVerbosity” abstract logging interface
unclechu Sep 28, 2020
643408c
Add a test for custom “MigrationVerbosity” implementation
unclechu Sep 28, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
62 changes: 33 additions & 29 deletions src/Main.hs → app/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -31,15 +31,17 @@ import Database.PostgreSQL.Simple.Migration (MigrationCommand (..),
runMigration)
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.IO (Handle, hPutStrLn,
stdout, stderr)

import qualified Data.Text as T
import qualified Data.Text.Encoding as T

main :: IO ()
main = getArgs >>= \case
"-h":_ ->
printUsage
"-q":xs ->
x:_ | x `elem` ["-h", "--help"] ->
printUsage stdout
x:xs | x `elem` ["-q", "--quiet"] ->
ppException $ run (parseCommand xs) False
xs ->
ppException $ run (parseCommand xs) True
Expand All @@ -51,7 +53,7 @@ ppException a = catch a ehandler
ehandler e = maybe (throw e) (*> exitFailure)
(pSqlError <$> fromException e)
bsToString = T.unpack . T.decodeUtf8
pSqlError e = mapM_ putStrLn
pSqlError e = mapM_ (hPutStrLn stderr)
[ "SqlError:"
, " sqlState: "
, bsToString $ sqlState e
Expand All @@ -65,8 +67,8 @@ ppException a = catch a ehandler
, bsToString $ sqlErrorHint e
]

run :: Maybe Command -> Bool-> IO ()
run Nothing _ = printUsage >> exitFailure
run :: Maybe Command -> Bool -> IO ()
run Nothing _ = printUsage stderr >> exitFailure
run (Just cmd) verbose =
handleResult =<< case cmd of
Initialize url -> do
Expand All @@ -91,29 +93,31 @@ parseCommand ("migrate":url:dir:_) = Just (Migrate url dir)
parseCommand ("validate":url:dir:_) = Just (Validate url dir)
parseCommand _ = Nothing

printUsage :: IO ()
printUsage = do
putStrLn "migrate [options] <command>"
putStrLn " Options:"
putStrLn " -h Print help text"
putStrLn " -q Enable quiet mode"
putStrLn " Commands:"
putStrLn " init <con>"
putStrLn " Initialize the database. Required to be run"
putStrLn " at least once."
putStrLn " migrate <con> <directory>"
putStrLn " Execute all SQL scripts in the provided"
putStrLn " directory in alphabetical order."
putStrLn " Scripts that have already been executed are"
putStrLn " ignored. If a script was changed since the"
putStrLn " time of its last execution, an error is"
putStrLn " raised."
putStrLn " validate <con> <directory>"
putStrLn " Validate all SQL scripts in the provided"
putStrLn " directory."
putStrLn " The <con> parameter is based on libpq connection string"
putStrLn " syntax. Detailled information is available here:"
putStrLn " <http://www.postgresql.org/docs/9.3/static/libpq-connect.html>"
printUsage :: Handle -> IO ()
printUsage h = do
say "migrate [options] <command>"
say " Options:"
say " -h --help Print help text"
say " -q --quiet Enable quiet mode"
say " Commands:"
say " init <con>"
say " Initialize the database. Required to be run"
say " at least once."
say " migrate <con> <directory>"
say " Execute all SQL scripts in the provided"
say " directory in alphabetical order."
say " Scripts that have already been executed are"
say " ignored. If a script was changed since the"
say " time of its last execution, an error is"
say " raised."
say " validate <con> <directory>"
say " Validate all SQL scripts in the provided"
say " directory."
say " The <con> parameter is based on libpq connection string"
say " syntax. Detailled information is available here:"
say " <http://www.postgresql.org/docs/9.3/static/libpq-connect.html>"
where
say = hPutStrLn h

data Command
= Initialize String
Expand Down
12 changes: 8 additions & 4 deletions postgresql-simple-migration.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -43,11 +43,13 @@ Library
cryptohash >= 0.11 && < 0.12,
directory >= 1.2 && < 1.4,
postgresql-simple >= 0.4 && < 0.7,
time >= 1.4 && < 1.10
text >= 1.2 && < 1.3,
time >= 1.4 && < 1.10,
unliftio >= 0.2 && < 0.3

Executable migrate
main-is: Main.hs
hs-source-dirs: src
hs-source-dirs: app
ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
default-extensions: OverloadedStrings, CPP, LambdaCase
default-language: Haskell2010
Expand All @@ -58,7 +60,8 @@ Executable migrate
directory >= 1.2 && < 1.4,
postgresql-simple >= 0.4 && < 0.7,
time >= 1.4 && < 1.10,
text >= 1.2 && < 1.3
text >= 1.2 && < 1.3,
postgresql-simple-migration -any

test-suite tests
main-is: Main.hs
Expand All @@ -72,4 +75,5 @@ test-suite tests
bytestring >= 0.10 && < 0.11,
postgresql-simple >= 0.4 && < 0.7,
hspec >= 2.2 && < 2.8,
postgresql-simple-migration
text >= 1.2 && < 1.3,
postgresql-simple-migration -any