mallard 0.5.0.1 → 0.6.0.0
raw patch · 6 files changed
+139/−38 lines, 6 files
Files
- app/Mallard.hs +5/−1
- lib/Database/Mallard/File.hs +18/−11
- lib/Database/Mallard/Parser.hs +87/−25
- lib/Database/Mallard/Postgre.hs +11/−0
- lib/Database/Mallard/Types.hs +17/−0
- mallard.cabal +1/−1
app/Mallard.hs view
@@ -30,6 +30,7 @@ = AppOptions { _optionsRootDirectory :: Text , _optionsPostgreSettings :: Sql.Settings+ , _optionsRunTests :: Bool } deriving (Show) @@ -39,6 +40,7 @@ appOptionsParser = AppOptions <$> argument text (metavar "ROOT") <*> connectionSettings Nothing+ <*> flag False True (long "test" <> short 't' <> help "Run tests after migration.") data AppState = AppState@@ -76,7 +78,7 @@ appOpts <- ask root <- parseRelOrAbsDir (appOpts ^. optionsRootDirectory . unpacked) --- mPlanned <- importMigrationDirectory root+ (mPlanned, mTests) <- importDirectory root -- mApplied <- getAppliedMigrations --@@ -90,3 +92,5 @@ toApply <- inflateMigrationIds mPlanned unapplied applyMigrations toApply --+ when (appOpts ^. optionsRunTests) $+ runTests (Map.elems mTests)
lib/Database/Mallard/File.hs view
@@ -2,8 +2,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} module Database.Mallard.File- ( importMigrationDirectory- , importMigrationFile+ ( importDirectory+ , importFile ) where import Control.Exception@@ -11,6 +11,7 @@ import Control.Monad.Catch import Control.Monad.Reader import qualified Data.ByteString as BS+import Data.Foldable import qualified Data.HashMap.Strict as Map import Database.Mallard.Parser import Database.Mallard.Types@@ -21,19 +22,25 @@ scanDirectoryForFiles :: (MonadIO m, MonadThrow m) => Path Abs Dir -> m [Path Abs File] scanDirectoryForFiles dir = concat <$> walkDirAccum Nothing (\_ _ c -> return [c]) dir -importMigrationDirectory :: (MonadIO m, MonadThrow m) => Path Abs Dir -> m MigrationTable-importMigrationDirectory root = do+importDirectory :: (MonadIO m, MonadThrow m) => Path Abs Dir -> m (MigrationTable, TestTable)+importDirectory root = do files <- scanDirectoryForFiles root- migrations <- mapM importMigrationFile' files- return $ Map.fromList (fmap (\m -> (m ^. migrationName, m)) (concat migrations))+ migrations <- mapM importFile' files+ return $ sortActions $ concat migrations -importMigrationFile :: (MonadIO m, MonadThrow m) => Path Abs File -> m MigrationTable-importMigrationFile file = Map.fromList . fmap (\m -> (m ^. migrationName, m)) <$> importMigrationFile' file+importFile :: (MonadIO m, MonadThrow m) => Path Abs File -> m (MigrationTable, TestTable)+importFile = fmap sortActions . importFile' -importMigrationFile' :: (MonadIO m, MonadThrow m) => Path Abs File -> m [Migration]-importMigrationFile' file = do+sortActions :: [Action] -> (MigrationTable, TestTable)+sortActions actions = foldl' sortFn (Map.empty, Map.empty) actions+ where+ sortFn (mm, tm) (ActionMigration m) = (Map.insert (m ^. migrationName) m mm, tm)+ sortFn (mm, tm) (ActionTest t) = (mm, Map.insert (t ^. testName) t tm)++importFile' :: (MonadIO m, MonadThrow m) => Path Abs File -> m [Action]+importFile' file = do fileContent <- liftIO $ BS.readFile (toFilePath file)- let parseResult = runParser parseMigrations (toFilePath file) fileContent+ let parseResult = runParser parseActions (toFilePath file) fileContent case parseResult of Left er -> throw $ ParserException file er Right m -> return m
lib/Database/Mallard/Parser.hs view
@@ -5,12 +5,13 @@ module Database.Mallard.Parser ( ParserException (..)+ , Action (..)+ , parseActions , parseMigration- , parseMigrations+ , parseTest ) where -import Control.Exception-import Control.Lens hiding (noneOf)+import Control.Exception hiding (try) import Control.Monad import Crypto.Hash import Data.HashMap.Strict (HashMap)@@ -20,13 +21,16 @@ import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T-import Data.Text.Lens import Database.Mallard.Types import Path-import Text.Megaparsec hiding (tab)+import Text.Megaparsec hiding (parseTest, tab) import Text.Megaparsec.ByteString import qualified Text.Megaparsec.Lexer as L +data Action+ = ActionMigration Migration+ | ActionTest Test+ type Description = Text type Requires = MigrationId @@ -34,25 +38,87 @@ = TextField Text | ListField [Text] +-- Lexer+ spaceConsumer :: Parser ()-spaceConsumer = L.space (void spaceChar) (L.skipLineComment "#") (L.skipBlockComment "##" "##")+spaceConsumer = L.space space' (L.skipLineComment "@") (L.skipBlockComment "@@" "@@")+ where+ space' = void (try spaceChar <|> char '-') symbol :: String -> Parser String symbol = L.symbol spaceConsumer +symbol' :: String -> Parser String+symbol' = L.symbol' spaceConsumer+ brackets :: Parser a -> Parser a brackets = between (symbol "[") (symbol "]") -comma :: Parser ()-comma = char ',' >> space+comma :: Parser String+comma = symbol "," -parseMigrations :: Parser [Migration]-parseMigrations = manyTill (space >> parseMigration) eof+colon :: Parser String+colon = symbol ":" +semiColon :: Parser String+semiColon = symbol ";"++migrationS :: Parser String+migrationS = symbol' "migration"++testS :: Parser String+testS = symbol' "test"++sbang :: Parser String+sbang = symbol "#!"++sbangOrEof :: Parser ()+sbangOrEof = try (void sbang) <|> eof++atom :: Parser String+atom = do+ val <- many alphaNumChar+ spaceConsumer+ return val++-- Parser++parseActions :: Parser [Action]+parseActions = spaceConsumer >> sbang >> manyTill parseAction eof+ where+ parseAction =+ try (ActionMigration <$> parseMigration)+ <|> (ActionTest <$> parseTest)+++parseTest :: Parser Test+parseTest = do+ (name, description) <- parseTestHeader+ content <- T.pack <$> manyTill anyChar sbangOrEof+ return $ Test+ { _testName = name+ , _testDescription = description+ , _testScript = content+ }++parseTestHeader :: Parser (TestId, Description)+parseTestHeader = do+ testS+ fields <- parseHeaderFields+ semiColon+ case Map.lookup "name" fields of+ Nothing -> fail "The name field was not provided in the header."+ Just (ListField _) -> fail "The name field cannot be a list."+ Just (TextField name) ->+ case Map.lookup "description" fields of+ Nothing -> fail "The description field was not provided in the header."+ Just (ListField _) -> fail "The description field cannot be a list."+ Just (TextField description) -> return (TestId name, description)+ parseMigration :: Parser Migration parseMigration = do- (name, description, requires) <- parseHeader- content <- T.pack <$> manyTill anyChar (string "--/")+ (name, description, requires) <- parseMigrationHeader+ content <- T.pack <$> manyTill anyChar sbangOrEof return $ Migration { _migrationName = name , _migrationDescription = description@@ -61,9 +127,11 @@ , _migrationScript = content } -parseHeader :: Parser (MigrationId, Description, [Requires])-parseHeader = do+parseMigrationHeader :: Parser (MigrationId, Description, [Requires])+parseMigrationHeader = do+ migrationS fields <- parseHeaderFields+ semiColon case Map.lookup "name" fields of Nothing -> fail "The name field was not provided in the header." Just (ListField _) -> fail "The name field cannot be a list."@@ -84,24 +152,18 @@ parseListValue = ListField <$> brackets (parseQuotedText `sepBy` comma) parseHeaderFields :: Parser (HashMap Text FieldValue)-parseHeaderFields = Map.fromList <$> between (symbol "--/") (symbol "--|") (field `sepBy` newline)+parseHeaderFields = Map.fromList <$> field `sepBy` comma where field :: Parser (Text, FieldValue) field = do- string "-- "- name <- many (noneOf (" :"::String))- space- char ':'- space+ name <- atom+ colon value <- parseFieldValue return (T.pack name, value) parseQuotedText :: Parser Text-parseQuotedText = do- char '"'- val <- many (noneOf ("\""::String))- char '"'- return $ val ^. packed+parseQuotedText = T.pack <$> between (symbol "\"") (symbol "\"") (many (noneOf ("\""::String)))+ -- Exceptions
lib/Database/Mallard/Postgre.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Database.Mallard.Postgre ( HasPostgreConnection (..)@@ -10,6 +11,8 @@ , getAppliedMigrations , applyMigration , applyMigrations+ , runTests+ , runTest ) where import Control.Exception@@ -111,6 +114,14 @@ contramap _migrationScript (E.value E.text) decoder = D.unit +runTests :: (MonadIO m, MonadState s m, HasPostgreConnection s) => [Test] -> m ()+runTests = mapM_ runTest++runTest :: (MonadIO m, MonadState s m, HasPostgreConnection s) => Test -> m ()+runTest t = do+ runDB $ HT.transaction Serializable Write $ do+ HT.sql (T.encodeUtf8 (t ^. testScript))+ HT.condemn applyMigrationSchemaMigraiton :: (Int64, ByteString) -> Transaction () applyMigrationSchemaMigraiton (version, script) = do
lib/Database/Mallard/Types.hs view
@@ -51,6 +51,23 @@ $(makeClassy ''Migration) +type TestTable = HashMap TestId Test++newtype TestId = TestId { unTestId :: Text }+ deriving (Eq, Ord, Hashable)++instance Show TestId where+ show (TestId txt) = txt ^. unpacked++data Test+ = Test+ { _testName :: TestId+ , _testDescription :: Text+ , _testScript :: Text+ }++$(makeClassy ''Test)+ scriptsMigrationSchema :: [(Int64, ByteString)] scriptsMigrationSchema = [ (0, $(embedFile "sql/mallard/0000-setup.sql"))
mallard.cabal view
@@ -1,5 +1,5 @@ name: mallard-version: 0.5.0.1+version: 0.6.0.0 synopsis: Database migration and testing as a library. description: Please see README.md homepage: https://github.com/AndrewRademacher/mallard