dbmigrations 0.1.1 → 0.1.2
raw patch · 9 files changed
+154/−243 lines, 9 filesdep +HDBC-sqlite3dep +vtydep +vty-uidep −hscursesdep ~HDBCnew-component:exe:dbmigrations-tests
Dependencies added: HDBC-sqlite3, vty, vty-ui
Dependencies removed: hscurses
Dependency ranges changed: HDBC
Files
- LICENSE +1/−1
- MOO.TXT +5/−0
- dbmigrations.cabal +6/−8
- src/Database/Schema/Migrations/Backend/HDBC.hs +4/−4
- src/Database/Schema/Migrations/Filesystem/Parse.hs +12/−5
- src/Database/Schema/Migrations/Store.hs +6/−0
- src/Moo.hs +3/−1
- src/StoreManager.hs +110/−220
- test/TestDriver.hs +7/−4
LICENSE view
@@ -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
MOO.TXT view
@@ -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
dbmigrations.cabal view
@@ -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
src/Database/Schema/Migrations/Backend/HDBC.hs view
@@ -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
src/Database/Schema/Migrations/Filesystem/Parse.hs view
@@ -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 ())
src/Database/Schema/Migrations/Store.hs view
@@ -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
src/Moo.hs view
@@ -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
src/StoreManager.hs view
@@ -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
test/TestDriver.hs view
@@ -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