diff --git a/dbmigrations.cabal b/dbmigrations.cabal index cd4adcb..18e2fa2 100644 --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -62,6 +62,7 @@ Source-Repository head Library default-language: Haskell2010 + default-extensions: OverloadedStrings if impl(ghc >= 6.12.0) ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind @@ -81,6 +82,7 @@ Library template-haskell, yaml-light >= 0.1, bytestring >= 0.9, + string-conversions >= 0.4, text >= 0.11, configurator >= 0.2, split >= 0.2.2, @@ -106,6 +108,7 @@ Library test-suite dbmigrations-tests default-language: Haskell2010 + default-extensions: OverloadedStrings type: exitcode-stdio-1.0 Build-Depends: base >= 4 && < 5, @@ -119,6 +122,7 @@ test-suite dbmigrations-tests template-haskell, yaml-light >= 0.1, bytestring >= 0.9, + string-conversions >= 0.4, MissingH, HDBC >= 2.2.1, HUnit >= 1.2, diff --git a/src/Database/Schema/Migrations.hs b/src/Database/Schema/Migrations.hs index 024cc68..252a2c6 100644 --- a/src/Database/Schema/Migrations.hs +++ b/src/Database/Schema/Migrations.hs @@ -9,6 +9,7 @@ module Database.Schema.Migrations ) where +import Data.Text ( Text ) import qualified Data.Set as Set import Data.Maybe ( catMaybes ) @@ -25,7 +26,7 @@ import Database.Schema.Migrations.Migration -- |Given a 'B.Backend' and a 'S.MigrationMap', query the backend and -- return a list of migration names which are available in the -- 'S.MigrationMap' but which are not installed in the 'B.Backend'. -missingMigrations :: B.Backend -> S.StoreData -> IO [String] +missingMigrations :: B.Backend -> S.StoreData -> IO [Text] missingMigrations backend storeData = do let storeMigrationNames = map mId $ S.storeMigrations storeData backendMigrations <- B.getMigrations backend diff --git a/src/Database/Schema/Migrations/Backend.hs b/src/Database/Schema/Migrations/Backend.hs index 0da1289..5a086c4 100644 --- a/src/Database/Schema/Migrations/Backend.hs +++ b/src/Database/Schema/Migrations/Backend.hs @@ -4,13 +4,15 @@ module Database.Schema.Migrations.Backend ) where +import Data.Text ( Text ) + import Database.Schema.Migrations.Migration ( Migration(..) ) -- |Backend instances should use this as the name of the migration -- returned by getBootstrapMigration; this migration is special -- because it cannot be reverted. -rootMigrationName :: String +rootMigrationName :: Text rootMigrationName = "root" -- |A Backend represents a database engine backend such as MySQL or @@ -55,7 +57,7 @@ data Backend = -- does not supply a revert instruction, this has no effect -- other than bookkeeping. - , getMigrations :: IO [String] + , getMigrations :: IO [Text] -- ^ Returns a list of installed migration names from the -- backend. @@ -71,4 +73,4 @@ data Backend = } instance Show Backend where - show _ = show "dbmigrations backend" + show _ = "dbmigrations backend" diff --git a/src/Database/Schema/Migrations/Backend/HDBC.hs b/src/Database/Schema/Migrations/Backend/HDBC.hs index a7a2589..da80df5 100644 --- a/src/Database/Schema/Migrations/Backend/HDBC.hs +++ b/src/Database/Schema/Migrations/Backend/HDBC.hs @@ -22,22 +22,25 @@ import Database.Schema.Migrations.Migration , newMigration ) +import Data.Text ( Text ) +import Data.String.Conversions ( cs, (<>) ) + import Control.Applicative ( (<$>) ) import Data.Time.Clock (getCurrentTime) -migrationTableName :: String +migrationTableName :: Text migrationTableName = "installed_migrations" -createSql :: String -createSql = "CREATE TABLE " ++ migrationTableName ++ " (migration_id TEXT)" +createSql :: Text +createSql = "CREATE TABLE " <> migrationTableName <> " (migration_id TEXT)" -revertSql :: String -revertSql = "DROP TABLE " ++ migrationTableName +revertSql :: Text +revertSql = "DROP TABLE " <> migrationTableName -- |General Backend constructor for all HDBC connection implementations. hdbcBackend :: (IConnection conn) => conn -> Backend hdbcBackend conn = - Backend { isBootstrapped = elem migrationTableName <$> getTables conn + Backend { isBootstrapped = elem (cs migrationTableName) <$> getTables conn , getBootstrapMigration = do ts <- getCurrentTime @@ -49,22 +52,22 @@ hdbcBackend conn = } , applyMigration = \m -> do - runRaw conn (mApply m) - _ <- run conn ("INSERT INTO " ++ migrationTableName ++ + runRaw conn (cs $ mApply m) + _ <- run conn (cs $ "INSERT INTO " <> migrationTableName <> " (migration_id) VALUES (?)") [toSql $ mId m] return () , revertMigration = \m -> do case mRevert m of Nothing -> return () - Just query -> runRaw conn query + Just query -> runRaw conn (cs query) -- Remove migration from installed_migrations in either case. - _ <- run conn ("DELETE FROM " ++ migrationTableName ++ + _ <- run conn (cs $ "DELETE FROM " <> migrationTableName <> " WHERE migration_id = ?") [toSql $ mId m] return () , getMigrations = do - results <- quickQuery' conn ("SELECT migration_id FROM " ++ migrationTableName) [] + results <- quickQuery' conn (cs $ "SELECT migration_id FROM " <> migrationTableName) [] return $ map (fromSql . head) results , commitBackend = commit conn diff --git a/src/Database/Schema/Migrations/Dependencies.hs b/src/Database/Schema/Migrations/Dependencies.hs index 6a1a385..6ea67f9 100644 --- a/src/Database/Schema/Migrations/Dependencies.hs +++ b/src/Database/Schema/Migrations/Dependencies.hs @@ -11,7 +11,9 @@ module Database.Schema.Migrations.Dependencies ) where +import Data.Text ( Text ) import Data.Maybe ( fromJust ) +import Data.Monoid ( (<>) ) import Data.Graph.Inductive.Graph ( Graph(..), nodes, edges, Node, suc, pre, lab ) import Data.Graph.Inductive.PatriciaTree ( Gr ) @@ -21,9 +23,9 @@ import Database.Schema.Migrations.CycleDetection ( hasCycle ) -- and a list of other objects upon which they depend. class (Eq a, Ord a) => Dependable a where -- |The identifiers of the objects on which @a@ depends. - depsOf :: a -> [String] + depsOf :: a -> [Text] -- |The identifier of a 'Dependable' object. - depId :: a -> String + depId :: a -> Text -- |A 'DependencyGraph' represents a collection of objects together -- with a graph of their dependency relationships. This is intended @@ -31,14 +33,14 @@ class (Eq a, Ord a) => Dependable a where data DependencyGraph a = DG { depGraphObjectMap :: [(a, Int)] -- ^ A mapping of 'Dependable' objects to -- their graph vertex indices. - , depGraphNameMap :: [(String, Int)] + , depGraphNameMap :: [(Text, Int)] -- ^ A mapping of 'Dependable' object -- identifiers to their graph vertex -- indices. - , depGraph :: Gr String String + , depGraph :: Gr Text Text -- ^ A directed 'Gr' (graph) of the -- 'Dependable' objects' dependency - -- relationships, with 'String' vertex and + -- relationships, with 'Text' vertex and -- edge labels. } @@ -65,14 +67,14 @@ mkDepGraph objects = if hasCycle theGraph n = [ (fromJust $ lookup o ids, depId o) | o <- objects ] e = [ ( fromJust $ lookup o ids , fromJust $ lookup d ids - , depId o ++ " -> " ++ depId d) | o <- objects, d <- depsOf' o ] + , depId o <> " -> " <> depId d) | o <- objects, d <- depsOf' o ] depsOf' o = map (\i -> fromJust $ lookup i objMap) $ depsOf o objMap = map (\o -> (depId o, o)) objects ids = zip objects [1..] names = map (\(o,i) -> (depId o, i)) ids -type NextNodesFunc = Gr String String -> Node -> [Node] +type NextNodesFunc = Gr Text Text -> Node -> [Node] cleanLDups :: (Eq a) => [a] -> [a] cleanLDups [] = [] @@ -82,16 +84,16 @@ cleanLDups (e:es) = if e `elem` es then (cleanLDups es) else (e:cleanLDups es) -- |Given a dependency graph and an ID, return the IDs of objects that -- the object depends on. IDs are returned with least direct -- dependencies first (i.e., the apply order). -dependencies :: (Dependable d) => DependencyGraph d -> String -> [String] +dependencies :: (Dependable d) => DependencyGraph d -> Text -> [Text] dependencies g m = reverse $ cleanLDups $ dependenciesWith suc g m -- |Given a dependency graph and an ID, return the IDs of objects that -- depend on it. IDs are returned with least direct reverse -- dependencies first (i.e., the revert order). -reverseDependencies :: (Dependable d) => DependencyGraph d -> String -> [String] +reverseDependencies :: (Dependable d) => DependencyGraph d -> Text -> [Text] reverseDependencies g m = reverse $ cleanLDups $ dependenciesWith pre g m -dependenciesWith :: (Dependable d) => NextNodesFunc -> DependencyGraph d -> String -> [String] +dependenciesWith :: (Dependable d) => NextNodesFunc -> DependencyGraph d -> Text -> [Text] dependenciesWith nextNodes dg@(DG _ nMap theGraph) name = let lookupId = fromJust $ lookup name nMap depNodes = nextNodes theGraph lookupId diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs index bdc3e38..dd74ad5 100644 --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -13,7 +13,11 @@ import Prelude import System.Directory ( getDirectoryContents, doesFileExist ) import System.FilePath ( (), takeExtension, dropExtension, takeBaseName ) -import Data.ByteString.Char8 ( unpack ) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.ByteString.Char8 as BSC +import Data.String.Conversions ( cs, (<>) ) import Data.Typeable ( Typeable ) import Data.Time.Clock ( UTCTime ) @@ -33,7 +37,7 @@ import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Filesystem.Serialize import Database.Schema.Migrations.Store -type FieldProcessor = String -> Migration -> Maybe Migration +type FieldProcessor = Text -> Migration -> Maybe Migration data FilesystemStoreSettings = FSStore { storePath :: FilePath } @@ -62,39 +66,39 @@ filesystemStore s = let migrationFilenames = [ f | f <- contents, isMigrationFilename f ] fullPaths = [ (f, storePath s f) | f <- migrationFilenames ] existing <- filterM (\(_, full) -> doesFileExist full) fullPaths - return [ dropExtension short | (short, _) <- existing ] + return [ cs $ dropExtension short | (short, _) <- existing ] , saveMigration = \m -> do filename <- fsFullMigrationName s $ mId m - writeFile (addNewMigrationExtension filename) $ serializeMigration m + BSC.writeFile (cs $ addNewMigrationExtension filename) $ serializeMigration m } addNewMigrationExtension :: FilePath -> FilePath -addNewMigrationExtension path = path ++ filenameExtension +addNewMigrationExtension path = path <> filenameExtension addMigrationExtension :: FilePath -> String -> FilePath -addMigrationExtension path ext = path ++ ext +addMigrationExtension path ext = path <> ext -- |Build path to migrations without extension. -fsFullMigrationName :: FilesystemStoreSettings -> FilePath -> IO FilePath -fsFullMigrationName s name = return $ storePath s name +fsFullMigrationName :: FilesystemStoreSettings -> Text -> IO FilePath +fsFullMigrationName s name = return $ storePath s cs name -isMigrationFilename :: FilePath -> Bool -isMigrationFilename path = takeExtension path `elem` [filenameExtension, filenameExtensionTxt] +isMigrationFilename :: String -> Bool +isMigrationFilename path = (cs $ takeExtension path) `elem` [filenameExtension, filenameExtensionTxt] -- |Given a store and migration name, read and parse the associated -- migration and return the migration if successful. Otherwise return -- a parsing error message. -migrationFromFile :: FilesystemStoreSettings -> String -> IO (Either String Migration) +migrationFromFile :: FilesystemStoreSettings -> Text -> IO (Either String Migration) migrationFromFile store name = - fsFullMigrationName store name >>= migrationFromPath + fsFullMigrationName store (cs name) >>= migrationFromPath -- |Given a filesystem path, read and parse the file as a migration -- return the 'Migration' if successful. Otherwise return a parsing -- error message. migrationFromPath :: FilePath -> IO (Either String Migration) migrationFromPath path = do - let name = takeBaseName path + let name = cs $ takeBaseName path (Right <$> process name) `catch` (\(FilesystemStoreError s) -> return $ Left $ "Could not parse migration " ++ path ++ ":" ++ s) where @@ -119,14 +123,14 @@ migrationFromPath path = do Just m -> return m _ -> throwFS $ "Error in " ++ (show path) ++ ": missing required field(s): " ++ (show missing) -getFields :: YamlLight -> [(String, String)] +getFields :: YamlLight -> [(Text, Text)] getFields (YMap mp) = map toPair $ Map.assocs mp where - toPair (YStr k, YStr v) = (unpack k, unpack v) + toPair (YStr k, YStr v) = (T.decodeUtf8 k, T.decodeUtf8 v) toPair (k, v) = throwFS $ "Error in YAML input; expected string key and string value, got " ++ (show (k, v)) getFields _ = throwFS "Error in YAML input; expected mapping" -missingFields :: [(String, String)] -> [String] +missingFields :: [(Text, Text)] -> [Text] missingFields fs = [ k | k <- requiredFields, not (k `elem` inputStrings) ] where @@ -134,19 +138,19 @@ missingFields fs = -- |Given a migration and a list of parsed migration fields, update -- the migration from the field values for recognized fields. -migrationFromFields :: Migration -> [(String, String)] -> Maybe Migration +migrationFromFields :: Migration -> [(Text, Text)] -> Maybe Migration migrationFromFields m [] = Just m migrationFromFields m ((name, value):rest) = do processor <- lookup name fieldProcessors newM <- processor value m migrationFromFields newM rest -requiredFields :: [String] +requiredFields :: [Text] requiredFields = [ "Apply" , "Depends" ] -fieldProcessors :: [(String, FieldProcessor)] +fieldProcessors :: [(Text, FieldProcessor)] fieldProcessors = [ ("Created", setTimestamp ) , ("Description", setDescription ) , ("Apply", setApply ) @@ -161,8 +165,8 @@ setTimestamp value m = do _ -> fail "expected one valid parse" return $ m { mTimestamp = Just ts } -readTimestamp :: String -> [(UTCTime, String)] -readTimestamp = reads +readTimestamp :: Text -> [(UTCTime, String)] +readTimestamp = reads . cs setDescription :: FieldProcessor setDescription desc m = Just $ m { mDesc = Just desc } @@ -174,4 +178,4 @@ setRevert :: FieldProcessor setRevert revert m = Just $ m { mRevert = Just revert } setDepends :: FieldProcessor -setDepends depString m = Just $ m { mDeps = words depString } +setDepends depString m = Just $ m { mDeps = T.words depString } diff --git a/src/Database/Schema/Migrations/Filesystem/Serialize.hs b/src/Database/Schema/Migrations/Filesystem/Serialize.hs index fa18877..22e4113 100644 --- a/src/Database/Schema/Migrations/Filesystem/Serialize.hs +++ b/src/Database/Schema/Migrations/Filesystem/Serialize.hs @@ -3,15 +3,20 @@ module Database.Schema.Migrations.Filesystem.Serialize ) where +import Data.ByteString ( ByteString ) +import qualified Data.ByteString as BS +import Data.Text ( Text ) +import qualified Data.Text as T +import Data.String.Conversions ( cs ) import Data.Time () -- for UTCTime Show instance import Data.Maybe ( catMaybes ) -import Data.List ( intercalate ) +import Data.Monoid ( (<>) ) import Database.Schema.Migrations.Migration ( Migration(..) ) -type FieldSerializer = Migration -> Maybe String +type FieldSerializer = Migration -> Maybe ByteString fieldSerializers :: [FieldSerializer] fieldSerializers = [ serializeDesc @@ -25,48 +30,48 @@ serializeDesc :: FieldSerializer serializeDesc m = case mDesc m of Nothing -> Nothing - Just desc -> Just $ "Description: " ++ desc + Just desc -> Just . cs $ "Description: " <> desc serializeTimestamp :: FieldSerializer serializeTimestamp m = case mTimestamp m of Nothing -> Nothing - Just ts -> Just $ "Created: " ++ (show ts) + Just ts -> Just $ "Created: " <> (cs . show $ ts) serializeDepends :: FieldSerializer -serializeDepends m = Just $ "Depends: " ++ (intercalate " " $ mDeps m) +serializeDepends m = Just . cs $ "Depends: " <> (T.intercalate " " $ mDeps m) serializeRevert :: FieldSerializer serializeRevert m = case mRevert m of Nothing -> Nothing - Just revert -> Just $ "Revert: |\n" ++ + Just revert -> Just $ "Revert: |\n" <> (serializeMultiline revert) serializeApply :: FieldSerializer -serializeApply m = Just $ "Apply: |\n" ++ (serializeMultiline $ mApply m) +serializeApply m = Just $ "Apply: |\n" <> (serializeMultiline $ mApply m) -commonPrefix :: String -> String -> String -commonPrefix a b = map fst $ takeWhile (uncurry (==)) (zip a b) +commonPrefix :: Text -> Text -> Text +commonPrefix a b = cs . map fst $ takeWhile (uncurry (==)) (T.zip a b) -commonPrefixLines :: [String] -> String +commonPrefixLines :: [Text] -> Text commonPrefixLines [] = "" commonPrefixLines theLines = foldl1 commonPrefix theLines -serializeMultiline :: String -> String +serializeMultiline :: Text -> ByteString serializeMultiline s = - let sLines = lines s - prefix = case commonPrefixLines sLines of + let sLines = T.lines s + prefix = case T.head $ commonPrefixLines sLines of -- If the lines already have a common prefix that -- begins with whitespace, no new prefix is -- necessary. - (' ':_) -> "" + ' ' -> "" -- Otherwise, use a new prefix of two spaces. _ -> " " - in unlines $ map (prefix ++) sLines + in cs . T.unlines $ map (prefix <>) sLines -serializeMigration :: Migration -> String -serializeMigration m = intercalate "\n" fields +serializeMigration :: Migration -> ByteString +serializeMigration m = BS.intercalate "\n" fields where fields = catMaybes [ f m | f <- fieldSerializers ] diff --git a/src/Database/Schema/Migrations/Migration.hs b/src/Database/Schema/Migrations/Migration.hs index ff74763..06db5f5 100644 --- a/src/Database/Schema/Migrations/Migration.hs +++ b/src/Database/Schema/Migrations/Migration.hs @@ -7,15 +7,16 @@ where import Database.Schema.Migrations.Dependencies +import Data.Text ( Text ) import Data.Time () -- for UTCTime Show instance import qualified Data.Time.Clock as Clock data Migration = Migration { mTimestamp :: Maybe Clock.UTCTime - , mId :: String - , mDesc :: Maybe String - , mApply :: String - , mRevert :: Maybe String - , mDeps :: [String] + , mId :: Text + , mDesc :: Maybe Text + , mApply :: Text + , mRevert :: Maybe Text + , mDeps :: [Text] } deriving (Eq, Show, Ord) @@ -23,7 +24,7 @@ instance Dependable Migration where depsOf = mDeps depId = mId -emptyMigration :: String -> Migration +emptyMigration :: Text -> Migration emptyMigration name = Migration { mTimestamp = Nothing , mId = name @@ -33,7 +34,7 @@ emptyMigration name = , mDeps = [] } -newMigration :: String -> Migration +newMigration :: Text -> Migration newMigration theId = (emptyMigration theId) { mApply = "(Apply SQL here.)" diff --git a/src/Database/Schema/Migrations/Store.hs b/src/Database/Schema/Migrations/Store.hs index 2660e12..e60247f 100644 --- a/src/Database/Schema/Migrations/Store.hs +++ b/src/Database/Schema/Migrations/Store.hs @@ -23,6 +23,7 @@ module Database.Schema.Migrations.Store ) where +import Data.Text ( Text ) import Data.Maybe ( isJust ) import Control.Monad ( mzero ) import Control.Applicative ( (<$>) ) @@ -41,7 +42,7 @@ import Database.Schema.Migrations.Dependencies -- |A mapping from migration name to 'Migration'. This is exported -- for testing purposes, but you'll want to interface with this -- through the encapsulating 'StoreData' type. -type MigrationMap = Map.Map String Migration +type MigrationMap = Map.Map Text Migration data StoreData = StoreData { storeDataMapping :: MigrationMap , storeDataGraph :: DependencyGraph Migration @@ -51,17 +52,17 @@ data StoreData = StoreData { storeDataMapping :: MigrationMap -- facility in which new migrations can be created, and from which -- existing migrations can be loaded. data MigrationStore = - MigrationStore { loadMigration :: String -> IO (Either String Migration) + MigrationStore { loadMigration :: Text -> IO (Either String Migration) -- ^ Load a migration from the store. , saveMigration :: Migration -> IO () -- ^ Save a migration to the store. - , getMigrations :: IO [String] + , getMigrations :: IO [Text] -- ^ Return a list of all available migrations' -- names. - , fullMigrationName :: String -> IO String + , fullMigrationName :: Text -> IO FilePath -- ^ Return the full representation of a given -- migration name; mostly for filesystem stores, -- where the full representation includes the store @@ -69,7 +70,7 @@ data MigrationStore = } -- |A type for types of validation errors for migration maps. -data MapValidationError = DependencyReferenceError String String +data MapValidationError = DependencyReferenceError Text Text -- ^ A migration claims a dependency on a -- migration that does not exist. | DependencyGraphError String @@ -96,7 +97,7 @@ storeMigrations storeData = -- |A convenience function for looking up a 'Migration' by name in the -- specified 'StoreData'. -storeLookup :: StoreData -> String -> Maybe Migration +storeLookup :: StoreData -> Text -> Maybe Migration storeLookup storeData migrationName = Map.lookup migrationName $ storeDataMapping storeData @@ -153,6 +154,6 @@ depGraphFromMapping mapping = mkDepGraph $ Map.elems mapping -- |Finds migrations that no other migration depends on (effectively finds all -- vertices with in-degree equal to zero). -leafMigrations :: StoreData -> [String] +leafMigrations :: StoreData -> [Text] leafMigrations s = [l | (n, l) <- labNodes g, indeg g n == 0] where g = depGraph $ storeDataGraph s diff --git a/src/Database/Schema/Migrations/Test/BackendTest.hs b/src/Database/Schema/Migrations/Test/BackendTest.hs index 29d492f..a5a7c45 100644 --- a/src/Database/Schema/Migrations/Test/BackendTest.hs +++ b/src/Database/Schema/Migrations/Test/BackendTest.hs @@ -9,6 +9,8 @@ module Database.Schema.Migrations.Test.BackendTest , tests ) where +import Data.ByteString ( ByteString ) + import Control.Monad ( forM_ ) import Test.HUnit @@ -30,7 +32,7 @@ class BackendConnection c where withTransaction :: c -> (c -> IO a) -> IO a -- | Retrieves a list of all tables in the current database/scheme. - getTables :: c -> IO [String] + getTables :: c -> IO [ByteString] catchAll :: c -> (IO a -> IO a -> IO a) diff --git a/src/Moo/CommandHandlers.hs b/src/Moo/CommandHandlers.hs index 6ab7dc8..91428a4 100644 --- a/src/Moo/CommandHandlers.hs +++ b/src/Moo/CommandHandlers.hs @@ -3,6 +3,8 @@ {-# LANGUAGE OverloadedStrings #-} module Moo.CommandHandlers where +import Data.String.Conversions (cs, (<>)) + import Moo.Core import Moo.CommandUtils import Control.Monad ( when, forM_ ) @@ -23,10 +25,10 @@ newCommand storeData = do store <- asks _appStore linear <- asks _appLinearMigrations timestamp <- asks _appTimestampFilenames - timeString <- (++"_") <$> liftIO getCurrentTimestamp + timeString <- (<>"_") <$> liftIO getCurrentTimestamp let [migrationId] = if timestamp - then fmap (timeString++) required + then fmap (timeString<>) required else required noAsk <- _noAsk <$> asks _appOptions @@ -34,15 +36,15 @@ newCommand storeData = do fullPath <- fullMigrationName store migrationId when (isJust $ storeLookup storeData migrationId) $ do - putStrLn $ "Migration " ++ (show fullPath) ++ " already exists" + putStrLn $ "Migration " <> (show fullPath) ++ " already exists" exitWith (ExitFailure 1) -- Default behavior: ask for dependencies if linear mode is disabled deps <- if linear then (return $ leafMigrations storeData) else if noAsk then (return []) else do - putStrLn $ "Selecting dependencies for new \ - \migration: " ++ migrationId + putStrLn . cs $ "Selecting dependencies for new \ + \migration: " <> migrationId interactiveAskDeps storeData result <- if noAsk then (return True) else @@ -90,7 +92,7 @@ upgradeListCommand storeData = do putStrLn "Database is up to date." exitSuccess putStrLn "Migrations to install:" - forM_ migrationNames (putStrLn . (" " ++)) + forM_ migrationNames (putStrLn . cs . (" " <>)) reinstallCommand :: CommandHandler reinstallCommand storeData = do @@ -119,7 +121,7 @@ listCommand _ = do ensureBootstrappedBackend backend >> commitBackend backend ms <- getMigrations backend forM_ ms $ \m -> - when (not $ m == rootMigrationName) $ putStrLn m + when (not $ m == rootMigrationName) $ putStrLn . cs $ m applyCommand :: CommandHandler applyCommand storeData = do diff --git a/src/Moo/CommandUtils.hs b/src/Moo/CommandUtils.hs index 937d535..7bd88e5 100644 --- a/src/Moo/CommandUtils.hs +++ b/src/Moo/CommandUtils.hs @@ -9,6 +9,10 @@ module Moo.CommandUtils , getCurrentTimestamp ) where +import Data.Text ( Text ) +import qualified Data.Text as T +import Data.String.Conversions ( cs, (<>) ) + import Control.Exception ( finally ) import Control.Monad ( when, forM_, unless ) import Control.Monad.Reader ( asks ) @@ -29,9 +33,9 @@ import Database.Schema.Migrations.Store ( StoreData ) import Moo.Core -getCurrentTimestamp :: IO String +getCurrentTimestamp :: IO Text getCurrentTimestamp = - replace ":" "-" . replace " " "_" . take 19 . show <$> getCurrentTime + cs . replace ":" "-" . replace " " "_" . take 19 . show <$> getCurrentTime apply :: Migration -> StoreData -> Backend -> Bool -> IO [Migration] apply m storeData backend complain = do @@ -46,12 +50,12 @@ apply m storeData backend complain = do where nothingToDo = when complain $ - putStrLn $ "Nothing to do; " ++ - mId m ++ + putStrLn . cs $ "Nothing to do; " <> + mId m <> " already installed." applyIt conn it = do - putStr $ "Applying: " ++ mId it ++ "... " + putStr . cs $ "Applying: " <> mId it <> "... " applyMigration conn it putStrLn "done." @@ -67,22 +71,22 @@ revert m storeData backend = do where nothingToDo = - putStrLn $ "Nothing to do; " ++ - mId m ++ + putStrLn . cs $ "Nothing to do; " <> + mId m <> " not installed." revertIt conn it = do - putStr $ "Reverting: " ++ mId it ++ "... " + putStr . cs $ "Reverting: " <> mId it <> "... " revertMigration conn it putStrLn "done." -lookupMigration :: StoreData -> String -> IO Migration +lookupMigration :: StoreData -> Text -> IO Migration lookupMigration storeData name = do let theMigration = storeLookup storeData name case theMigration of Nothing -> do - putStrLn $ "No such migration: " ++ name + putStrLn . cs $ "No such migration: " <> name exitWith (ExitFailure 1) Just m' -> return m' @@ -96,13 +100,13 @@ withBackend act = do -- Given a migration name and selected dependencies, get the user's -- confirmation that a migration should be created. -confirmCreation :: String -> [String] -> IO Bool +confirmCreation :: Text -> [Text] -> IO Bool confirmCreation migrationId deps = do putStrLn "" - putStrLn $ "Confirm: create migration '" ++ migrationId ++ "'" + putStrLn . cs $ "Confirm: create migration '" <> migrationId <> "'" if null deps then putStrLn " (No dependencies)" else putStrLn "with dependencies:" - forM_ deps $ \d -> putStrLn $ " " ++ d + forM_ deps $ \d -> putStrLn . cs $ " " <> d prompt "Are you sure?" [ ('y', (True, Nothing)) , ('n', (False, Nothing)) ] @@ -161,7 +165,7 @@ data AskDepsChoice = Yes | No | View | Done | Quit -- Interactively ask the user about which dependencies should be used -- when creating a new migration. -interactiveAskDeps :: StoreData -> IO [String] +interactiveAskDeps :: StoreData -> IO [Text] interactiveAskDeps storeData = do -- For each migration in the store, starting with the most recently -- added, ask the user if it should be added to a dependency list @@ -173,10 +177,10 @@ interactiveAskDeps storeData = do -- Recursive function to prompt the user for dependencies and let the -- user view information about potential dependencies. Returns a list -- of migration names which were selected. -interactiveAskDeps' :: StoreData -> [String] -> IO [String] +interactiveAskDeps' :: StoreData -> [Text] -> IO [Text] interactiveAskDeps' _ [] = return [] interactiveAskDeps' storeData (name:rest) = do - result <- prompt ("Depend on '" ++ name ++ "'?") askDepsChoices + result <- prompt ("Depend on '" ++ cs name ++ "'?") askDepsChoices if result == Done then return [] else case result of Yes -> do @@ -188,12 +192,12 @@ interactiveAskDeps' storeData (name:rest) = do let Just m = storeLookup storeData name -- print out description, timestamp, deps when (isJust $ mDesc m) - (putStrLn $ " Description: " ++ + (putStrLn . cs $ " Description: " <> fromJust (mDesc m)) putStrLn $ " Created: " ++ show (mTimestamp m) unless (null $ mDeps m) - (putStrLn $ " Deps: " ++ - intercalate "\n " (mDeps m)) + (putStrLn . cs $ " Deps: " <> + T.intercalate "\n " (mDeps m)) -- ask again interactiveAskDeps' storeData (name:rest) Quit -> do diff --git a/src/Moo/Core.hs b/src/Moo/Core.hs index 3a7d391..979908d 100644 --- a/src/Moo/Core.hs +++ b/src/Moo/Core.hs @@ -13,6 +13,8 @@ module Moo.Core , envStoreName , loadConfiguration) where +import Data.Text ( Text ) + import Control.Monad.Reader (ReaderT) import qualified Data.Configurator as C import Data.Configurator.Types (Config, Configured) @@ -33,8 +35,8 @@ type CommandHandler = StoreData -> AppT () -- |Application state which can be accessed by any command handler. data AppState = AppState { _appOptions :: CommandOptions , _appCommand :: Command - , _appRequiredArgs :: [String] - , _appOptionalArgs :: [String] + , _appRequiredArgs :: [Text] + , _appOptionalArgs :: [Text] , _appBackend :: Backend , _appStore :: MigrationStore , _appStoreData :: StoreData diff --git a/src/Moo/Main.hs b/src/Moo/Main.hs index 4ec907a..bc8c97f 100644 --- a/src/Moo/Main.hs +++ b/src/Moo/Main.hs @@ -12,6 +12,8 @@ where import Control.Monad.Reader (forM_, runReaderT, when) import Database.HDBC (SqlError, catchSql, seErrorMsg) import Prelude hiding (lookup) +import Data.Text (Text) +import Data.String.Conversions (cs) import System.Environment (getProgName) import System.Exit (ExitCode (ExitFailure), exitWith) @@ -77,8 +79,8 @@ mainWithParameters args parameters = do Right storeData -> do let st = AppState { _appOptions = opts , _appCommand = command - , _appRequiredArgs = required - , _appOptionalArgs = ["" :: String] + , _appRequiredArgs = map cs required + , _appOptionalArgs = ["" :: Text] , _appBackend = _parametersBackend parameters , _appStore = store , _appStoreData = storeData diff --git a/test/Common.hs b/test/Common.hs index 43009f3..51e17f0 100644 --- a/test/Common.hs +++ b/test/Common.hs @@ -8,6 +8,8 @@ module Common ) where +import Data.Text ( Text ) + import CommonTH import System.FilePath ( () ) import Language.Haskell.TH.Syntax (lift) @@ -25,8 +27,8 @@ instance Dependable TestDependable where depId = tdId depsOf = tdDeps -data TestDependable = TD { tdId :: String - , tdDeps :: [String] +data TestDependable = TD { tdId :: Text + , tdDeps :: [Text] } deriving (Show, Eq, Ord) diff --git a/test/DependencyTest.hs b/test/DependencyTest.hs index 64110c4..b53cac9 100644 --- a/test/DependencyTest.hs +++ b/test/DependencyTest.hs @@ -3,6 +3,8 @@ module DependencyTest ) where +import Data.Text ( Text ) + import Test.HUnit import Data.Graph.Inductive.Graph ( Graph(..) ) @@ -39,7 +41,7 @@ mkDepGraphTest :: DepGraphTestCase -> Test mkDepGraphTest (input, expected) = expected ~=? mkDepGraph input data Direction = Forward | Reverse deriving (Show) -type DependencyTestCase = ([TestDependable], String, Direction, [String]) +type DependencyTestCase = ([TestDependable], Text, Direction, [Text]) dependencyTestCases :: [DependencyTestCase] dependencyTestCases = [ ([TD "first" []], "first", Forward, []) @@ -76,4 +78,4 @@ mkDependencyTest testCase@(deps, a, dir, expected) = in (show testCase) ~: expected ~=? f (fromRight $ mkDepGraph deps) a dependencyTests :: [Test] -dependencyTests = map mkDependencyTest dependencyTestCases \ No newline at end of file +dependencyTests = map mkDependencyTest dependencyTestCases diff --git a/test/FilesystemParseTest.hs b/test/FilesystemParseTest.hs index ceae6f7..55d34ba 100644 --- a/test/FilesystemParseTest.hs +++ b/test/FilesystemParseTest.hs @@ -6,6 +6,7 @@ where import Test.HUnit import Data.Time.Clock ( UTCTime ) import System.FilePath ( () ) +import Data.String.Conversions ( cs ) import Common @@ -111,7 +112,7 @@ migrationParsingTestCases = [ ("valid_full", Right valid_full) mkParsingTest :: MigrationParsingTestCase -> IO Test mkParsingTest (fname, expected) = do let store = FSStore { storePath = testStorePath } - actual <- migrationFromFile store fname + actual <- migrationFromFile store (cs fname) return $ test $ expected ~=? actual migrationParsingTests :: IO [Test] diff --git a/test/FilesystemSerializeTest.hs b/test/FilesystemSerializeTest.hs index 73f1d0d..34e81cb 100644 --- a/test/FilesystemSerializeTest.hs +++ b/test/FilesystemSerializeTest.hs @@ -4,6 +4,8 @@ module FilesystemSerializeTest where import Test.HUnit +import Data.ByteString ( ByteString ) +import Data.String.Conversions ( (<>), cs ) import Data.Time.Clock ( UTCTime ) import Database.Schema.Migrations.Filesystem.Serialize @@ -12,7 +14,7 @@ import Database.Schema.Migrations.Migration tests :: [Test] tests = serializationTests -mkSerializationTest :: (Migration, String) -> Test +mkSerializationTest :: (Migration, ByteString) -> Test mkSerializationTest (m, expectedString) = test $ expectedString ~=? serializeMigration m tsStr :: String @@ -31,9 +33,9 @@ valid_full = Migration { , mRevert = Just "DROP TABLE test;" } -serializationTestCases :: [(Migration, String)] -serializationTestCases = [ (valid_full, "Description: A valid full migration.\n\ - \Created: " ++ tsStr ++ "\n\ +serializationTestCases :: [(Migration, ByteString)] +serializationTestCases = [ (valid_full, cs $ "Description: A valid full migration.\n\ + \Created: " <> tsStr <> "\n\ \Depends: another_migration\n\ \Apply: |\n\ \ CREATE TABLE test (\n\ @@ -42,7 +44,7 @@ serializationTestCases = [ (valid_full, "Description: A valid full migration.\n\ \Revert: |\n\ \ DROP TABLE test;\n") , (valid_full { mDesc = Nothing } - , "Created: " ++ tsStr ++ "\n\ + , cs $ "Created: " <> tsStr <> "\n\ \Depends: another_migration\n\ \Apply: |\n\ \ CREATE TABLE test (\n\ @@ -51,8 +53,8 @@ serializationTestCases = [ (valid_full, "Description: A valid full migration.\n\ \Revert: |\n\ \ DROP TABLE test;\n") , (valid_full { mDeps = ["one", "two"] } - , "Description: A valid full migration.\n\ - \Created: " ++ tsStr ++ "\n\ + , cs $ "Description: A valid full migration.\n\ + \Created: " <> tsStr <> "\n\ \Depends: one two\n\ \Apply: |\n\ \ CREATE TABLE test (\n\ @@ -61,8 +63,8 @@ serializationTestCases = [ (valid_full, "Description: A valid full migration.\n\ \Revert: |\n\ \ DROP TABLE test;\n") , (valid_full { mRevert = Nothing } - , "Description: A valid full migration.\n\ - \Created: " ++ tsStr ++ "\n\ + , cs $ "Description: A valid full migration.\n\ + \Created: " <> tsStr <> "\n\ \Depends: another_migration\n\ \Apply: |\n\ \ CREATE TABLE test (\n\ diff --git a/test/InMemoryStore.hs b/test/InMemoryStore.hs index 8653c78..96b906a 100644 --- a/test/InMemoryStore.hs +++ b/test/InMemoryStore.hs @@ -1,10 +1,13 @@ module InMemoryStore (inMemoryStore) where +import Data.Text ( Text ) +import Data.String.Conversions ( cs ) + import Control.Concurrent.MVar import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Store -type InMemoryData = [(String, Migration)] +type InMemoryData = [(Text, Migration)] -- |Builds simple in-memory store that uses 'MVar' to preserve a list of -- migrations. @@ -15,10 +18,10 @@ inMemoryStore = do loadMigration = loadMigrationInMem store , saveMigration = saveMigrationInMem store , getMigrations = getMigrationsInMem store - , fullMigrationName = return + , fullMigrationName = return . cs } -loadMigrationInMem :: MVar InMemoryData -> String -> IO (Either String Migration) +loadMigrationInMem :: MVar InMemoryData -> Text -> IO (Either String Migration) loadMigrationInMem store migId = withMVar store $ \migrations -> do let mig = lookup migId migrations return $ case mig of @@ -28,5 +31,5 @@ loadMigrationInMem store migId = withMVar store $ \migrations -> do saveMigrationInMem :: MVar InMemoryData -> Migration -> IO () saveMigrationInMem store m = modifyMVar_ store $ return . ((mId m, m):) -getMigrationsInMem :: MVar InMemoryData -> IO [String] +getMigrationsInMem :: MVar InMemoryData -> IO [Text] getMigrationsInMem store = withMVar store $ return . fmap fst diff --git a/test/LinearMigrationsTest.hs b/test/LinearMigrationsTest.hs index 982cf2c..1e7d747 100644 --- a/test/LinearMigrationsTest.hs +++ b/test/LinearMigrationsTest.hs @@ -5,6 +5,7 @@ import Test.HUnit import Common import Control.Monad.Reader (runReaderT) +import Data.Text (Text) import Data.Either (isRight) import Database.Schema.Migrations.Migration import Database.Schema.Migrations.Store @@ -60,13 +61,13 @@ addTestMigration state = do runReaderT (newCommand $ _appStoreData state) state loadMigration store migrationId -addTestMigrationWithDeps :: AppState -> [String] -> IO () +addTestMigrationWithDeps :: AppState -> [Text] -> IO () addTestMigrationWithDeps state deps = do let store = _appStore state let [migrationId] = _appRequiredArgs state saveMigration store (newMigration migrationId) { mDeps = deps } -prepareState :: String -> IO AppState +prepareState :: Text -> IO AppState prepareState m = do store <- inMemoryStore Right storeData <- loadMigrations store @@ -82,12 +83,12 @@ prepareState m = do , _appTimestampFilenames = False } -prepareStateWith :: AppState -> String -> IO AppState +prepareStateWith :: AppState -> Text -> IO AppState prepareStateWith state m = do Right storeData <- loadMigrations $ _appStore state return state { _appRequiredArgs = [m], _appStoreData = storeData } -prepareNormalState :: String -> IO AppState +prepareNormalState :: Text -> IO AppState prepareNormalState m = do state <- prepareState m return $ state { _appLinearMigrations = False }