diff --git a/app/Mallard.hs b/app/Mallard.hs --- a/app/Mallard.hs +++ b/app/Mallard.hs @@ -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) diff --git a/lib/Database/Mallard/File.hs b/lib/Database/Mallard/File.hs --- a/lib/Database/Mallard/File.hs +++ b/lib/Database/Mallard/File.hs @@ -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 diff --git a/lib/Database/Mallard/Parser.hs b/lib/Database/Mallard/Parser.hs --- a/lib/Database/Mallard/Parser.hs +++ b/lib/Database/Mallard/Parser.hs @@ -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 diff --git a/lib/Database/Mallard/Postgre.hs b/lib/Database/Mallard/Postgre.hs --- a/lib/Database/Mallard/Postgre.hs +++ b/lib/Database/Mallard/Postgre.hs @@ -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 diff --git a/lib/Database/Mallard/Types.hs b/lib/Database/Mallard/Types.hs --- a/lib/Database/Mallard/Types.hs +++ b/lib/Database/Mallard/Types.hs @@ -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")) diff --git a/mallard.cabal b/mallard.cabal --- a/mallard.cabal +++ b/mallard.cabal @@ -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