diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009, Josh Hoyt. +Copyright (c) 2009, Jonathan Daugherty. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/MOO.TXT b/MOO.TXT --- a/MOO.TXT +++ b/MOO.TXT @@ -23,6 +23,11 @@ http://www.postgresql.org/docs/8.1/static/libpq.html#LIBPQ-CONNECT + DBM_DATABASE_TYPE=sqlite3: + + The format of this value is a filesystem path to the Sqlite3 + database to be used. + DBM_MIGRATION_STORE The path to the filesystem directory where your migrations will be diff --git a/dbmigrations.cabal b/dbmigrations.cabal --- a/dbmigrations.cabal +++ b/dbmigrations.cabal @@ -1,5 +1,5 @@ Name: dbmigrations -Version: 0.1.1 +Version: 0.1.2 Synopsis: An implementation of relational database "migrations" Description: A library and program for the creation, management, and installation of schema updates @@ -32,14 +32,10 @@ Description: Build for testing Default: False -Flag store-manager - Description: Build the experimental / incomplete store-manager program - Default: False - Library Build-Depends: base >= 4 && < 5, - HDBC, + HDBC >= 2.2.1 && < 2.3, time >= 1.1 && < 1.2, random >= 1.0 && < 1.1, containers >= 0.2 && < 0.3, @@ -65,9 +61,10 @@ Database.Schema.Migrations.Filesystem.Parse Database.Schema.Migrations.Filesystem.Serialize -Executable test +Executable dbmigrations-tests Build-Depends: HDBC-postgresql, + HDBC-sqlite3, HUnit >= 1.2 && < 1.3, process >= 1.0 && < 1.1 @@ -83,7 +80,8 @@ Executable store-manager Build-Depends: - hscurses >= 1.3 && < 1.4 + vty >= 4.0 && < 4.1, + vty-ui == 0.2 if !flag(testing) Buildable: False diff --git a/src/Database/Schema/Migrations/Backend/HDBC.hs b/src/Database/Schema/Migrations/Backend/HDBC.hs --- a/src/Database/Schema/Migrations/Backend/HDBC.hs +++ b/src/Database/Schema/Migrations/Backend/HDBC.hs @@ -4,7 +4,7 @@ () where -import Database.HDBC ( quickQuery, fromSql, toSql, IConnection(getTables, run) ) +import Database.HDBC ( quickQuery', fromSql, toSql, IConnection(getTables, run, runRaw) ) import Database.Schema.Migrations.Backend ( Backend(..) ) @@ -40,7 +40,7 @@ } applyMigration conn m = do - run conn (mApply m) [] + runRaw conn (mApply m) run conn ("INSERT INTO " ++ migrationTableName ++ " (migration_id) VALUES (?)") [toSql $ mId m] return () @@ -48,12 +48,12 @@ revertMigration conn m = do case mRevert m of Nothing -> return () - Just query -> run conn query [] >> return () + Just query -> runRaw conn query -- Remove migration from installed_migrations in either case. run conn ("DELETE FROM " ++ migrationTableName ++ " WHERE migration_id = ?") [toSql $ mId m] return () getMigrations conn = do - results <- quickQuery conn ("SELECT migration_id FROM " ++ migrationTableName) [] + results <- quickQuery' conn ("SELECT migration_id FROM " ++ migrationTableName) [] return $ map (\(h:_) -> fromSql h) results diff --git a/src/Database/Schema/Migrations/Filesystem/Parse.hs b/src/Database/Schema/Migrations/Filesystem/Parse.hs --- a/src/Database/Schema/Migrations/Filesystem/Parse.hs +++ b/src/Database/Schema/Migrations/Filesystem/Parse.hs @@ -25,11 +25,18 @@ parseDepsList :: Parser [String] parseDepsList = - let parseMID = many1 (alphaNum <|> oneOf "-._") - in do - deps <- sepBy parseMID whitespace - eol - return deps + depsList <|> (many whitespace >> eol >> return []) + where + parseMID = many1 (alphaNum <|> oneOf "-._") + separator = discard $ spaces >> many (newline >> spaces) + depsList = do + many whitespace + first <- parseMID + rest <- many $ try $ do + separator + parseMID + eol + return (first : rest) discard :: Parser a -> Parser () discard = (>> return ()) diff --git a/src/Database/Schema/Migrations/Store.hs b/src/Database/Schema/Migrations/Store.hs --- a/src/Database/Schema/Migrations/Store.hs +++ b/src/Database/Schema/Migrations/Store.hs @@ -17,6 +17,8 @@ -- * Miscellaneous Functions , depGraphFromMapping + , validateMigrationMap + , validateSingleMigration ) where @@ -71,6 +73,7 @@ -- ^ An error was encountered when -- constructing the dependency graph for -- this store. + deriving (Eq) instance Show MapValidationError where show (DependencyReferenceError from to) = @@ -117,6 +120,9 @@ validateMigrationMap mMap = do validateSingleMigration mMap =<< snd <$> Map.toList mMap +-- |Validate a single migration. Looks up the migration's +-- dependencies in the specified 'MigrationMap' and returns a +-- 'MapValidationError' for each one that does not exist in the map. validateSingleMigration :: MigrationMap -> Migration -> [MapValidationError] validateSingleMigration mMap m = do depId <- depsOf m diff --git a/src/Moo.hs b/src/Moo.hs --- a/src/Moo.hs +++ b/src/Moo.hs @@ -17,6 +17,7 @@ import Control.Monad.Trans ( liftIO ) import Control.Applicative ( (<$>) ) import Database.HDBC.PostgreSQL ( connectPostgreSQL ) +import Database.HDBC.Sqlite3 ( connectSqlite3 ) import Database.HDBC ( IConnection(commit, rollback, disconnect) , catchSql, seErrorMsg, SqlError ) @@ -194,6 +195,7 @@ -- factory functions. databaseTypes :: [(String, String -> IO AnyIConnection)] databaseTypes = [ ("postgresql", fmap AnyIConnection . connectPostgreSQL) + , ("sqlite3", fmap AnyIConnection . connectSqlite3) ] -- Given a database type string and a database connection string, @@ -204,7 +206,7 @@ makeConnection dbType (DbConnDescriptor connStr) = case lookup dbType databaseTypes of Nothing -> error $ "Unsupported database type " ++ show dbType ++ - "(supported types: " ++ + " (supported types: " ++ intercalate "," (map fst databaseTypes) ++ ")" Just mkConnection -> mkConnection connStr diff --git a/src/StoreManager.hs b/src/StoreManager.hs --- a/src/StoreManager.hs +++ b/src/StoreManager.hs @@ -1,248 +1,136 @@ - +{-# OPTIONS_GHC -fno-warn-orphans #-} module Main where -import Control.Exception +import Control.Applicative ( (<$>) ) import Control.Monad.State -import Data.Maybe ( fromJust, isNothing ) +import Data.Maybe ( catMaybes ) +import Data.List ( intercalate ) import qualified Data.Map as Map import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) -import UI.HSCurses.Widgets -import qualified UI.HSCurses.Curses as Curses -import qualified UI.HSCurses.CursesHelper as CursesH - +import Graphics.Vty +import Graphics.Vty.Widgets.All import Database.Schema.Migrations.Filesystem +import Database.Schema.Migrations.Migration ( Migration(..) ) import Database.Schema.Migrations.Store -title :: String -title = "Migration Manager" - -help :: String -help = "q:quit" - data MMState = MMState { mmStoreData :: StoreData - , mmStatus :: String - , mmStyles :: [CursesH.CursesStyle] , mmStorePath :: FilePath + , mmMigrationList :: SimpleList } type MM = StateT MMState IO -type ToplineWidget = TextWidget -type HelpLineWidget = TextWidget -type StatusBarWidget = TableWidget -type MigrationListWidget = TableWidget - -data MainWidget = MainWidget - { toplineWidget :: ToplineWidget - , helplineWidget :: HelpLineWidget - , statusbarWidget :: StatusBarWidget - , migrationListWidget :: MigrationListWidget - } - -instance Widget MainWidget where - draw pos sz hint w = draw pos sz hint (mkRealMainWidget (Just sz) w) - minSize w = minSize (mkRealMainWidget Nothing w) - -runMM :: FilePath -> StoreData -> [CursesH.CursesStyle] -> MM a -> IO a -runMM sp storeData cstyles mm = - evalStateT mm (MMState { mmStoreData = storeData - , mmStyles = cstyles - , mmStatus = sp ++ " loaded." - , mmStorePath = sp - }) - -getSize :: MM (Int, Int) -getSize = liftIO $ Curses.scrSize - -styles :: [CursesH.Style] -styles = [ CursesH.defaultStyle - , CursesH.AttributeStyle [CursesH.Bold] CursesH.GreenF CursesH.DarkBlueB - ] - -nthStyle :: Int -> MM CursesH.CursesStyle -nthStyle n = - do cs <- gets mmStyles - return $ cs !! n - -defStyle :: MM CursesH.CursesStyle -defStyle = nthStyle 0 - -lineStyle :: MM CursesH.CursesStyle -lineStyle = nthStyle 1 - -lineDrawingStyle :: MM DrawingStyle -lineDrawingStyle = do - s <- lineStyle - return $ mkDrawingStyle s - -lineOptions :: MM TextWidgetOptions -lineOptions = do - sz <- getSize - ds <- lineDrawingStyle - return $ TWOptions { twopt_size = TWSizeFixed (1, getWidth sz) - , twopt_style = ds - , twopt_halign = AlignLeft - } - -mkToplineWidget :: MM ToplineWidget -mkToplineWidget = do - opts <- lineOptions - return $ newTextWidget (opts { twopt_halign = AlignCenter }) title - -mkHelpLineWidget :: MM HelpLineWidget -mkHelpLineWidget = do - opts <- lineOptions - return $ newTextWidget opts help - --- We need to insert a dummy widget at the lower-right corner of the --- window, i.e. at the lower-right corner of the message --- line. Otherwise, an error occurs because drawing a character to --- this position moves the cursor to the next line, which doesn't --- exist. -mkStatusBarWidget :: MM StatusBarWidget -mkStatusBarWidget = do - sz <- getSize - msg <- gets mmStatus - let width = getWidth sz - opts = TWOptions { twopt_size = TWSizeFixed (1, width - 1) - , twopt_style = defaultDrawingStyle - , twopt_halign = AlignLeft - } - tw = newTextWidget opts msg - row = [TableCell tw, TableCell $ EmptyWidget (1,1)] - tabOpts = defaultTBWOptions { tbwopt_minSize = (1, width) } - return $ newTableWidget tabOpts [row] - --- nlines = height of status line + height of help line + height of --- top line -nlines :: Int -nlines = 3 - -migrationListHeight :: (Int, Int) -> Int -migrationListHeight (h, _) = h - nlines +titleAttr :: Attr +titleAttr = def_attr + `with_back_color` blue + `with_fore_color` bright_white -migrationListOptions :: MM TableWidgetOptions -migrationListOptions = do - sz <- getSize - return $ TBWOptions { tbwopt_fillCol = Nothing - , tbwopt_fillRow = None - , tbwopt_activeCols = [0] - , tbwopt_minSize = (migrationListHeight sz, getWidth sz) - } +bodyAttr :: Attr +bodyAttr = def_attr + `with_back_color` black + `with_fore_color` bright_white -mkMigrationListWidget :: MM MigrationListWidget -mkMigrationListWidget = do - storeData <- gets mmStoreData - sz <- getSize - let rows = map (migrationRow $ getWidth sz) (Map.keys $ storeDataMapping storeData) - opts <- migrationListOptions - return $ newTableWidget opts rows - where migrationRow w s = [TableCell $ newTextWidget - (defaultTWOptions { twopt_size = TWSizeFixed (1, w) }) s] +fieldAttr :: Attr +fieldAttr = def_attr + `with_back_color` black + `with_fore_color` bright_green -validPos :: Pos -> TableWidget -> Bool -validPos pos w = (getWidth pos) `elem` (tbwopt_activeCols $ tbw_options w) && - (getHeight pos) < (length $ tbw_rows w) && - (getHeight pos) >= 0 && - (getWidth pos) >= 0 +selAttr :: Attr +selAttr = def_attr + `with_back_color` yellow + `with_fore_color` black -moveUp :: TableWidget -> TableWidget -moveUp orig = - if isNothing (tbw_pos orig) then orig - else - let oldPos = fromJust $ tbw_pos orig - newPos = ((getHeight $ oldPos) - 1, getWidth oldPos) - in if validPos newPos orig - then orig { tbw_pos = Just newPos } - else orig +scrollListUp :: MMState -> MMState +scrollListUp appst = + appst { mmMigrationList = scrollUp $ mmMigrationList appst } -moveDown :: TableWidget -> TableWidget -moveDown orig = - if isNothing (tbw_pos orig) then orig - else - let oldPos = fromJust $ tbw_pos orig - newPos = ((getHeight $ oldPos) + 1, getWidth oldPos) - in if validPos newPos orig - then orig { tbw_pos = Just newPos } - else orig +scrollListDown :: MMState -> MMState +scrollListDown appst = + appst { mmMigrationList = scrollDown $ mmMigrationList appst } -mkMainWidget :: MM MainWidget -mkMainWidget = do - tlw <- mkToplineWidget - clw <- mkMigrationListWidget - blw <- mkHelpLineWidget - msglw <- mkStatusBarWidget - return $ MainWidget tlw blw msglw clw +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 () -mkRealMainWidget :: Maybe Size -> MainWidget -> TableWidget -mkRealMainWidget msz w = - let cells = [ TableCell $ toplineWidget w - , TableCell $ migrationListWidget w - , TableCell $ helplineWidget w - , TableCell $ statusbarWidget w ] - rows = map singletonRow cells - opts = case msz of - Nothing -> defaultTBWOptions - Just sz -> defaultTBWOptions { tbwopt_minSize = sz } - in newTableWidget opts rows +continue :: MM Bool +continue = return True -updateStateDependentWidgets :: MainWidget -> MM MainWidget -updateStateDependentWidgets w = do - statusbar <- mkStatusBarWidget -- update the message line with the - -- state's status - return $ w { statusbarWidget = statusbar } +stop :: MM Bool +stop = return False -updateStatus :: String -> MM () -updateStatus msg = do - st <- get - put st { mmStatus = msg } +handleEvent :: Event -> MM Bool +handleEvent (EvKey KUp []) = modify scrollListUp >> continue +handleEvent (EvKey KDown []) = modify scrollListDown >> continue +handleEvent (EvKey (KASCII 'q') []) = stop +handleEvent _ = continue -move :: Direction -> MainWidget -> MM MainWidget -move dir w = do - let listWidget = case dir of - DirUp -> moveUp orig - DirDown -> moveDown orig - _ -> orig - orig = migrationListWidget w - w' <- updateStateDependentWidgets w - return $ w' { migrationListWidget = listWidget } +instance Widget Migration where + growHorizontal _ = False + growVertical _ = False + primaryAttribute _ = bodyAttr + withAttribute w _ = w -resize :: Widget w => MM w -> MM () -resize f = do - liftIO $ do Curses.endWin - Curses.resetParams - Curses.cursSet Curses.CursorInvisible - Curses.refresh - w <- f - redraw 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) -redraw :: Widget w => w -> MM () -redraw w = do - sz <- getSize - liftIO $ do draw (0, 0) sz DHNormal w - Curses.refresh +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 -eventloop :: MainWidget -> MM () -eventloop w = do - k <- CursesH.getKey (resize mkMainWidget) - case k of - Curses.KeyChar 'q' -> return () - Curses.KeyUp -> process $ move DirUp w - Curses.KeyDown -> process $ move DirDown w - _ -> eventloop w - where process f = do - w' <- f - redraw w' - eventloop w' +uiFromState :: MM Box +uiFromState = buildUi <$> get -mmMain :: MM () -mmMain = do - w <- mkMainWidget - redraw w - eventloop w +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 @@ -264,9 +152,11 @@ exitFailure Right theStoreData -> return theStoreData - runCurses theStorePath storeData `finally` CursesH.end - where runCurses sp storeData = do - CursesH.start - cstyles <- CursesH.convertStyles styles - Curses.cursSet Curses.CursorInvisible - runMM sp storeData cstyles mmMain + vty <- mkVty + evalStateT + (eventloop vty uiFromState handleEvent) + (mkState theStorePath storeData) + + -- Clear the screen. + reserve_display $ terminal vty + shutdown vty diff --git a/test/TestDriver.hs b/test/TestDriver.hs --- a/test/TestDriver.hs +++ b/test/TestDriver.hs @@ -12,22 +12,24 @@ import qualified FilesystemParseTest import qualified FilesystemTest import qualified CycleDetectionTest +import qualified StoreTest import Control.Monad ( forM ) import Control.Exception ( finally, catch, SomeException ) import Database.HDBC ( IConnection(disconnect) ) ---import Database.HDBC.Sqlite3 ( connectSqlite3 ) +import Database.HDBC.Sqlite3 ( connectSqlite3 ) import qualified Database.HDBC.PostgreSQL as PostgreSQL loadTests :: IO [Test] loadTests = do --- sqliteConn <- connectSqlite3 ":memory:" + sqliteConn <- connectSqlite3 ":memory:" pgConn <- setupPostgresDb - let backends = [ -- ("Sqlite", BackendTest.tests sqliteConn) - ("PostgreSQL", BackendTest.tests pgConn `finally` + let backends = [ ("Sqlite", (BackendTest.tests sqliteConn) `finally` + (disconnect sqliteConn)) + , ("PostgreSQL", (BackendTest.tests pgConn) `finally` (disconnect pgConn >> teardownPostgresDb)) ] @@ -45,6 +47,7 @@ , FilesystemSerializeTest.tests , MigrationsTest.tests , CycleDetectionTest.tests + , StoreTest.tests ] tempPgDatabase :: String