module Moo.CommandUtils
( apply
, confirmCreation
, interactiveAskDeps
, lookupMigration
, revert
, withBackend
, makeBackend
, getCurrentTimestamp
) where
import Control.Exception ( bracket )
import Control.Monad ( when, forM_, unless )
import Control.Monad.Reader ( asks )
import Control.Monad.Trans ( liftIO )
import Data.List ( intercalate, sortBy, isPrefixOf )
import Data.Time.Clock (getCurrentTime)
import Data.Maybe ( fromJust, isJust )
import System.Exit ( exitWith, ExitCode(..) )
import System.IO ( stdout, hFlush, hGetBuffering
, hSetBuffering, stdin, BufferMode(..) )
import Database.Schema.Migrations ( migrationsToApply, migrationsToRevert )
import Database.Schema.Migrations.Backend (Backend(..))
import Database.Schema.Migrations.Migration ( Migration(..) )
import Database.Schema.Migrations.Store ( StoreData
, storeLookup
, storeMigrations
)
import Moo.Core
getCurrentTimestamp :: IO String
getCurrentTimestamp =
replace ":" "-" . replace " " "_" . take 19 . show <$> getCurrentTime
apply :: Migration -> StoreData -> Backend -> Bool -> IO [Migration]
apply m storeData backend complain = do
toApply <- migrationsToApply storeData backend m
if null toApply then
nothingToDo >> return [] else
mapM_ (applyIt backend) toApply >> return toApply
where
nothingToDo =
when complain $
putStrLn $ "Nothing to do; " ++
mId m ++
" already installed."
applyIt conn it = do
putStr $ "Applying: " ++ mId it ++ "... "
applyMigration conn it
putStrLn "done."
revert :: Migration -> StoreData -> Backend -> IO [Migration]
revert m storeData backend = do
toRevert <- liftIO $ migrationsToRevert storeData backend m
if null toRevert then
nothingToDo >> return [] else
mapM_ (revertIt backend) toRevert >> return toRevert
where
nothingToDo =
putStrLn $ "Nothing to do; " ++
mId m ++
" not installed."
revertIt conn it = do
putStr $ "Reverting: " ++ mId it ++ "... "
revertMigration conn it
putStrLn "done."
lookupMigration :: StoreData -> String -> IO Migration
lookupMigration storeData name = do
let theMigration = storeLookup storeData name
case theMigration of
Nothing -> do
putStrLn $ "No such migration: " ++ name
exitWith (ExitFailure 1)
Just m' -> return m'
makeBackend :: String -> DbConnDescriptor -> IO Backend
makeBackend dbType (DbConnDescriptor connStr) =
case lookup dbType databaseTypes of
Nothing -> error $ "Unsupported database type " ++ show dbType ++
" (supported types: " ++
intercalate "," (map fst databaseTypes) ++ ")"
Just mkBackend -> mkBackend connStr
withBackend :: (Backend -> IO a) -> AppT a
withBackend act = do
dbPath <- asks _appDatabaseConnStr
dbType <- asks _appDatabaseType
liftIO $ bracket (makeBackend dbType dbPath) disconnectBackend act
confirmCreation :: String -> [String] -> IO Bool
confirmCreation migrationId deps = do
putStrLn ""
putStrLn $ "Confirm: create migration '" ++ migrationId ++ "'"
if null deps then putStrLn " (No dependencies)"
else putStrLn "with dependencies:"
forM_ deps $ \d -> putStrLn $ " " ++ d
prompt "Are you sure?" [ ('y', (True, Nothing))
, ('n', (False, Nothing))
]
prompt :: (Eq a) => String -> PromptChoices a -> IO a
prompt _ [] = error "prompt requires a list of choices"
prompt message choiceMap = do
putStr $ message ++ " (" ++ choiceStr ++ helpChar ++ "): "
hFlush stdout
c <- unbufferedGetChar
case lookup c choiceMap of
Nothing -> do
when (c /= '\n') $ putStrLn ""
when (c == 'h') $ putStr $ mkPromptHelp choiceMapWithHelp
retry
Just (val, _) -> putStrLn "" >> return val
where
retry = prompt message choiceMap
choiceStr = intercalate "" $ map (return . fst) choiceMap
helpChar = if hasHelp choiceMap then "h" else ""
choiceMapWithHelp = choiceMap ++ [('h', (undefined, Just "this help"))]
mkPromptHelp :: PromptChoices a -> String
mkPromptHelp choices =
intercalate "" [ [c] ++ ": " ++ fromJust msg ++ "\n" |
(c, (_, msg)) <- choices, isJust msg ]
hasHelp :: PromptChoices a -> Bool
hasHelp = (> 0) . length . filter hasMsg
where hasMsg (_, (_, m)) = isJust m
type PromptChoices a = [(Char, (a, Maybe String))]
unbufferedGetChar :: IO Char
unbufferedGetChar = do
bufferingMode <- hGetBuffering stdin
hSetBuffering stdin NoBuffering
c <- getChar
hSetBuffering stdin bufferingMode
return c
data AskDepsChoice = Yes | No | View | Done | Quit
deriving (Eq)
interactiveAskDeps :: StoreData -> IO [String]
interactiveAskDeps storeData = do
let sorted = sortBy compareTimestamps $ storeMigrations storeData
interactiveAskDeps' storeData (map mId sorted)
where
compareTimestamps m1 m2 = compare (mTimestamp m2) (mTimestamp m1)
interactiveAskDeps' :: StoreData -> [String] -> IO [String]
interactiveAskDeps' _ [] = return []
interactiveAskDeps' storeData (name:rest) = do
result <- prompt ("Depend on '" ++ name ++ "'?") askDepsChoices
if result == Done then return [] else
case result of
Yes -> do
next <- interactiveAskDeps' storeData rest
return $ name:next
No -> interactiveAskDeps' storeData rest
View -> do
let Just m = storeLookup storeData name
when (isJust $ mDesc m)
(putStrLn $ " Description: " ++
fromJust (mDesc m))
putStrLn $ " Created: " ++ show (mTimestamp m)
unless (null $ mDeps m)
(putStrLn $ " Deps: " ++
intercalate "\n " (mDeps m))
interactiveAskDeps' storeData (name:rest)
Quit -> do
putStrLn "cancelled."
exitWith (ExitFailure 1)
Done -> return []
askDepsChoices :: PromptChoices AskDepsChoice
askDepsChoices = [ ('y', (Yes, Just "yes, depend on this migration"))
, ('n', (No, Just "no, do not depend on this migration"))
, ('v', (View, Just "view migration details"))
, ('d', (Done, Just "done, do not ask me about more dependencies"))
, ('q', (Quit, Just "cancel this operation and quit"))
]
spanList :: ([a] -> Bool) -> [a] -> ([a], [a])
spanList _ [] = ([],[])
spanList func list@(x:xs) =
if func list
then (x:ys,zs)
else ([],list)
where (ys,zs) = spanList func xs
breakList :: ([a] -> Bool) -> [a] -> ([a], [a])
breakList func = spanList (not . func)
replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace old new = intercalate new . split old
split :: Eq a => [a] -> [a] -> [[a]]
split _ [] = []
split delim str =
let (firstline, remainder) = breakList (isPrefixOf delim) str
in firstline : case remainder of
[] -> []
x -> if x == delim
then [[]]
else split delim (drop (length delim) x)