dbmigrations 0.1.2 → 0.2
raw patch · 4 files changed
+46/−188 lines, 4 filesdep −vtydep −vty-uidep ~containers
Dependencies removed: vty, vty-ui
Dependency ranges changed: containers
Files
- dbmigrations.cabal +23/−13
- src/Database/Schema/Migrations/CycleDetection.hs +1/−1
- src/Database/Schema/Migrations/Filesystem.hs +22/−12
- src/StoreManager.hs +0/−162
dbmigrations.cabal view
@@ -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
src/Database/Schema/Migrations/CycleDetection.hs view
@@ -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
src/Database/Schema/Migrations/Filesystem.hs view
@@ -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 ->
− src/StoreManager.hs
@@ -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 ++ " <store-path>")- 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