diff --git a/dbmigrations.cabal b/dbmigrations.cabal --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -1,5 +1,5 @@ Name: dbmigrations -Version: 0.1.2 +Version: 0.2 Synopsis: An implementation of relational database "migrations" Description: A library and program for the creation, management, and installation of schema updates @@ -33,12 +33,18 @@ Default: False Library + if impl(ghc >= 6.12.0) + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + -fno-warn-unused-do-bind + else + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + Build-Depends: base >= 4 && < 5, HDBC >= 2.2.1 && < 2.3, time >= 1.1 && < 1.2, random >= 1.0 && < 1.1, - containers >= 0.2 && < 0.3, + containers >= 0.2 && < 0.4, mtl >= 1.1 && < 1.2, parsec >= 2.1 && < 2.2, filepath >= 1.1 && < 1.2, @@ -68,6 +74,12 @@ HUnit >= 1.2 && < 1.3, process >= 1.0 && < 1.1 + if impl(ghc >= 6.12.0) + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + -fno-warn-unused-do-bind -Wwarn + else + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + if !flag(testing) Buildable: False end @@ -75,17 +87,15 @@ Main-is: TestDriver.hs Executable moo - Hs-Source-Dirs: src - Main-is: Moo.hs - -Executable store-manager Build-Depends: - vty >= 4.0 && < 4.1, - vty-ui == 0.2 + HDBC-postgresql, + HDBC-sqlite3 - if !flag(testing) - Buildable: False - end + if impl(ghc >= 6.12.0) + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + -fno-warn-unused-do-bind + else + ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2 + Hs-Source-Dirs: src - Main-is: StoreManager.hs - Ghc-options: -Werror + Main-is: Moo.hs diff --git a/src/Database/Schema/Migrations/CycleDetection.hs b/src/Database/Schema/Migrations/CycleDetection.hs --- a/src/Database/Schema/Migrations/CycleDetection.hs +++ b/src/Database/Schema/Migrations/CycleDetection.hs @@ -24,7 +24,7 @@ hasCycle g = evalState (hasCycle' g) [(n, White) | n <- nodes g] getMark :: Int -> State CycleDetectionState Mark -getMark n = gets (fromJust . lookup n) >>= return +getMark n = gets (fromJust . lookup n) replace :: [a] -> Int -> a -> [a] replace elems index val diff --git a/src/Database/Schema/Migrations/Filesystem.hs b/src/Database/Schema/Migrations/Filesystem.hs --- a/src/Database/Schema/Migrations/Filesystem.hs +++ b/src/Database/Schema/Migrations/Filesystem.hs @@ -1,14 +1,17 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} -- |This module provides a type for interacting with a -- filesystem-backed 'MigrationStore'. module Database.Schema.Migrations.Filesystem ( FilesystemStore(..) , migrationFromFile + , migrationFromPath ) where import System.Directory ( getDirectoryContents, doesFileExist ) -import System.FilePath ( (), takeExtension, dropExtension ) +import System.FilePath ( (), takeExtension, dropExtension + , takeFileName, takeBaseName ) +import Control.Monad.Trans ( MonadIO, liftIO ) import Data.Time.Clock ( UTCTime ) import Data.Time () -- for UTCTime Show instance @@ -32,37 +35,44 @@ filenameExtension :: String filenameExtension = ".txt" -instance MigrationStore FilesystemStore IO where +instance (MonadIO m) => MigrationStore FilesystemStore m where fullMigrationName s name = return $ storePath s name ++ filenameExtension loadMigration s theId = do - result <- migrationFromFile s theId + result <- liftIO $ migrationFromFile s theId return $ case result of Left _ -> Nothing Right m -> Just m getMigrations s = do - contents <- getDirectoryContents $ storePath s + contents <- liftIO $ getDirectoryContents $ storePath s let migrationFilenames = [ f | f <- contents, isMigrationFilename f ] fullPaths = [ (f, storePath s f) | f <- migrationFilenames ] - existing <- filterM (\(_, full) -> doesFileExist full) fullPaths + existing <- liftIO $ filterM (\(_, full) -> doesFileExist full) fullPaths return [ dropExtension short | (short, _) <- existing ] saveMigration s m = do filename <- fullMigrationName s $ mId m - writeFile filename $ serializeMigration m + liftIO $ writeFile filename $ serializeMigration m isMigrationFilename :: FilePath -> Bool isMigrationFilename path = takeExtension path == filenameExtension --- |Given a file path, read and parse the migration at the specified --- path and, if successful, return the migration and its claimed --- dependencies. Otherwise return a parsing error message. +-- |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 :: FilesystemStore -> String -> IO (Either String Migration) -migrationFromFile store name = do - path <- fullMigrationName store name +migrationFromFile store name = + fullMigrationName store 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 contents <- readFile path + let name = takeBaseName $ takeFileName path case parse migrationParser path contents of Left _ -> return $ Left $ "Could not parse migration file " ++ (show path) Right fields -> diff --git a/src/StoreManager.hs b/src/StoreManager.hs deleted file mode 100644 --- a/src/StoreManager.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Main where - -import Control.Applicative ( (<$>) ) -import Control.Monad.State -import Data.Maybe ( catMaybes ) -import Data.List ( intercalate ) -import qualified Data.Map as Map -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure) - -import Graphics.Vty -import Graphics.Vty.Widgets.All -import Database.Schema.Migrations.Filesystem -import Database.Schema.Migrations.Migration ( Migration(..) ) -import Database.Schema.Migrations.Store - -data MMState = MMState - { mmStoreData :: StoreData - , mmStorePath :: FilePath - , mmMigrationList :: SimpleList - } - -type MM = StateT MMState IO - -titleAttr :: Attr -titleAttr = def_attr - `with_back_color` blue - `with_fore_color` bright_white - -bodyAttr :: Attr -bodyAttr = def_attr - `with_back_color` black - `with_fore_color` bright_white - -fieldAttr :: Attr -fieldAttr = def_attr - `with_back_color` black - `with_fore_color` bright_green - -selAttr :: Attr -selAttr = def_attr - `with_back_color` yellow - `with_fore_color` black - -scrollListUp :: MMState -> MMState -scrollListUp appst = - appst { mmMigrationList = scrollUp $ mmMigrationList appst } - -scrollListDown :: MMState -> MMState -scrollListDown appst = - appst { mmMigrationList = scrollDown $ mmMigrationList appst } - -eventloop :: (Widget a) => Vty -> MM a -> (Event -> MM Bool) -> MM () -eventloop vty uiBuilder handle = do - w <- uiBuilder - evt <- liftIO $ do - (img, _) <- mkImage vty w - update vty $ pic_for_image img - next_event vty - next <- handle evt - if next then - eventloop vty uiBuilder handle else - return () - -continue :: MM Bool -continue = return True - -stop :: MM Bool -stop = return False - -handleEvent :: Event -> MM Bool -handleEvent (EvKey KUp []) = modify scrollListUp >> continue -handleEvent (EvKey KDown []) = modify scrollListDown >> continue -handleEvent (EvKey (KASCII 'q') []) = stop -handleEvent _ = continue - -instance Widget Migration where - growHorizontal _ = False - growVertical _ = False - primaryAttribute _ = bodyAttr - withAttribute w _ = w - - render sz m = - renderMany Vertical $ map (render sz) ws - where - ws = catMaybes fieldWidgets - fieldWidgets = map mkWidget [ ("Timestamp", Just . show . mTimestamp) - , ("Description", mDesc) - , ("Dependencies", Just . (intercalate "\n ") . mDeps) - , ("Apply", Just . mApply) - , ("Revert", mRevert) - ] - mkWidget (label, f) = do - val <- f m - return $ (text fieldAttr $ label ++ ":") - <++> (text bodyAttr " ") - <++> (wrappedText bodyAttr val) - -buildUi :: MMState -> Box -buildUi appst = - let Just selectedMigration = Map.lookup (fst $ getSelected list) mMap - mMap = storeDataMapping $ mmStoreData appst - currentItem = selectedIndex list + 1 - borderWithCounter = (text titleAttr $ " " ++ (show currentItem) ++ "/" ++ - (show $ length $ listItems list) ++ " ") - <++> hFill titleAttr '-' 1 - list = mmMigrationList appst - header = text titleAttr (" " ++ (mmStorePath appst) ++ " ") - <++> hFill titleAttr '-' 1 - <++> text titleAttr " Store Manager " - status = text bodyAttr "Status." - helpBar = text titleAttr "q:quit up/down:show migration " - <++> hFill titleAttr '-' 1 - in header - <--> list - <--> borderWithCounter - <--> (bottomPadded selectedMigration) - <--> helpBar - <--> status - -uiFromState :: MM Box -uiFromState = buildUi <$> get - -mkState :: FilePath -> StoreData -> MMState -mkState sp storeData = - MMState { mmStoreData = storeData - , mmStorePath = sp - , mmMigrationList = migrationList - } - where - migrationList = mkSimpleList bodyAttr selAttr 5 migrationNames - migrationNames = Map.keys $ storeDataMapping storeData - -main :: IO () -main = do - args <- getArgs - let theStorePath = args !! 0 - storeData <- - if length args /= 1 - then do p <- getProgName - putStrLn ("Usage: " ++ p ++ " ") - exitFailure - else do - let store = FSStore { storePath = theStorePath } - result <- loadMigrations store - case result of - Left es -> do - putStrLn "There were errors in the migration store:" - forM_ es $ \err -> do - putStrLn $ " " ++ show err - exitFailure - Right theStoreData -> return theStoreData - - vty <- mkVty - evalStateT - (eventloop vty uiFromState handleEvent) - (mkState theStorePath storeData) - - -- Clear the screen. - reserve_display $ terminal vty - shutdown vty