module Rivet.Tasks where
import Control.Applicative ((<$>))
import Control.Arrow
import Control.Monad (filterM, void, when)
import Data.Char (isSpace)
import Data.Char
import Data.Configurator
import Data.Configurator.Types
import qualified Data.HashMap.Strict as M
import Data.List (intercalate, intersperse,
isInfixOf, isSuffixOf, sort)
import Data.Maybe (fromMaybe)
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Format
import Database.PostgreSQL.Simple
import Development.Shake hiding (createDirectory',
doesDirectoryExist,
getDirectoryContents, writeFile')
import Prelude hiding ((++))
import System.Console.GetOpt
import System.Directory (copyFile, createDirectory,
createDirectoryIfMissing,
doesDirectoryExist,
getCurrentDirectory,
getDirectoryContents,
getTemporaryDirectory, removeFile)
import System.Environment (lookupEnv)
import System.Exit
import System.Exit
import System.FilePath
import System.IO
import System.Process
import Rivet.Common
import Rivet.TH
createDirectory' d = do putStrLn $ "creating " ++ d
createDirectory d
writeFile' f c = do putStrLn $ "writing " ++ f
writeFile f c
loadProjectTemplate
loadFile "migrationTemplate" "template/migration.hs"
init projName = do liftIO $ do mapM createDirectory' (fst tDirTemplate)
mapM_ write (snd tDirTemplate)
hasGit <- liftIO $ doesDirectoryExist ".git"
if hasGit
then liftIO $ putStrLn "detected existing .git directory, not committing."
else do void $ exec "git init"
void $ exec "git add ."
void $ exec "git commit -m 'initial commit'"
where write (f,c) =
if isSuffixOf "project.cabal" f
then writeFile' (projName ++ ".cabal") (insertProjName c)
else writeFile' f (replace "PROJECT" (dbIfy projName) c)
isNameChar c = isAlphaNum c || c == '-'
insertProjName c = replace "project" (filter isNameChar projName) c
replace old new s = T.unpack . T.replace (T.pack old) (T.pack new) $ T.pack s
run proj =
do let binary = "./.cabal-sandbox/bin/" ++ proj
need [binary]
void $ exec binary
dbIfy = T.unpack . T.replace "-" "_" . T.pack
db proj conf = do pass <- liftIO $ require conf (T.pack "database-password")
port <- liftIO $ lookupDefault 5432 conf (T.pack "database-port") :: Action Int
user <- liftIO $ lookupDefault (dbIfy proj ++ "_user") conf (T.pack "database-user")
let c = "PGPASSWORD=" ++ pass ++ " psql -hlocalhost " ++ dbIfy proj
++ "_devel -U" ++ user ++ " -p " ++ show port
void $ exec c
dbTest proj conf =
do pass <- liftIO $ require conf (T.pack "database-password")
port <- liftIO $ lookupDefault 5432 conf (T.pack "database-port") :: Action Int
user <- liftIO $ lookupDefault (dbIfy proj ++ "_user") conf (T.pack "database-user")
let c = "PGPASSWORD=" ++ pass ++ " psql " ++ dbIfy proj
++ "_test -U" ++ user ++ " -hlocalhost" ++ " -p " ++ show port
void $ exec c
test cabal targets =
do code <- exec $ cabal ++ " exec -- runghc -isrc -ispec spec/Main.hs -m \"" ++ (intercalate " " (tail targets) ++ "\"")
case code of
ExitSuccess -> return ()
_ -> error "rivet test: Test Failure."
dbCreate proj conf =
do pass <- liftIO $ require conf (T.pack "database-password")
user <- liftIO $ lookupDefault (dbIfy proj ++ "_user") conf (T.pack "database-user")
let dbname = dbIfy proj
code <- exec $ "PGPASSWORD=" ++ pass ++ " psql -hlocalhost -U" ++ user ++ " template1 -c 'SELECT 1'"
isSuper <- case code of
ExitFailure _ -> do void $ exec $ "psql template1 -c \"CREATE USER " ++ user ++ " WITH SUPERUSER PASSWORD '" ++ pass ++ "'\""
return True
ExitSuccess -> do res <- readExec $ "psql -hlocalhost -U" ++ user ++ " template1 -c \"SELECT current_setting('is_superuser')\""
return ("on" `isInfixOf` res)
if isSuper
then do exec $ "PGPASSWORD=" ++ pass ++ " psql -hlocalhost -U" ++ user ++ " template1 -c \"CREATE DATABASE " ++ dbname ++ "_devel\""
exec $ "PGPASSWORD=" ++ pass ++ " psql -hlocalhost -U" ++ user ++ " template1 -c \"CREATE DATABASE " ++ dbname ++ "_test\""
return ()
else do void $ exec $ "psql template1 -c \"CREATE DATABASE " ++ dbname ++ "_devel\""
void $ exec $ "psql template1 -c \"CREATE DATABASE " ++ dbname ++ "_test\""
void $ exec $ "psql template1 -c \"GRANT ALL ON DATABASE " ++ dbname ++ "_devel TO " ++ user ++ "\""
void $ exec $ "psql template1 -c \"GRANT ALL ON DATABASE " ++ dbname ++ "_test TO " ++ user ++ "\""
dbNew targets =
do let name = head (tail targets)
liftIO $ genMigration name sqlud
where sqlud = "sql up down\n\n\
\up = \"\"\n\
\\n\
\down = \"\""
genMigration name content =
do now <- getCurrentTime
let modname = (formatTime defaultTimeLocale "M%Y%m%d%H%M%S_" now) ++ name
str = modname ++ ".hs"
putStrLn $ "Writing to migrations/" ++ str ++ "..."
writeFile ("migrations/" ++ str)
(replace "MIGRATION_MODULE" modname . replace "CONTENT" content $ migrationTemplate)
data MigrateMode = Up | Down | Status deriving Show
dbMigrate cabal proj conf [] =
do liftIO $ migrate cabal proj conf "devel" Up
liftIO $ migrate cabal proj conf "test" Up
dbMigrate cabal proj conf (env:_) = liftIO $ migrate cabal proj conf env Up
dbMigrateDown cabal proj conf [] =
do liftIO $ migrate cabal proj conf "devel" Down
liftIO $ migrate cabal proj conf "test" Down
dbMigrateDown cabal proj conf (env:_) = liftIO $ migrate cabal proj conf env Down
dbStatus cabal proj conf [] = do liftIO $ migrate cabal proj conf "devel" Status
liftIO $ migrate cabal proj conf "test" Status
dbStatus cabal proj conf (env:_) = liftIO $ migrate cabal proj conf env Status
migrate cabal proj conf env mode =
do dbuser <- lookupDefault (dbIfy proj ++ "_user") conf "database-user"
dbpass <- require conf "database-password"
dbhost <- lookupDefault "127.0.0.1" conf "database-host"
dbport <- lookupDefault 5432 conf "database-port"
dbname <- lookupDefault (dbIfy proj ++ "_" ++ env) conf "database-name"
c <- connect (ConnectInfo dbhost dbport dbuser dbpass dbname)
execute_ c "CREATE TABLE IF NOT EXISTS migrations (name text NOT NULL PRIMARY KEY, run_at timestamptz NOT NULL DEFAULT now())"
tmp <- getTemporaryDirectory
now <- getCurrentTime
let main = tmp ++ "/migrate_" ++ formatTime defaultTimeLocale "%Y%m%d%H%M%S_" now ++ env ++ ".hs"
migrations <- sort . map stripSuffix . filter isCode <$>
getDirectoryContents "migrations"
run <- case mode of
Up ->
do missing <- filterM (notExists c) migrations
if null missing
then putStrLn "No migrations to run." >> return False
else do putStrLn $ "Writing migration script to " ++ main ++ "..."
writeFile main $
"import Database.PostgreSQL.Simple\nimport Rivet.Migration\n" ++
(unlines $ map createImport missing) ++
"\nmain = do\n" ++
(formatconnect dbhost dbport dbuser dbpass dbname) ++
(unlines $ map (createRun mode) missing)
return True
Down -> do toDown <- dropWhileM (notExists c) $ reverse migrations
case toDown of
(x:_) -> do putStrLn $ "Writing migration script to " ++ main ++ "..."
writeFile main $
"import Database.PostgreSQL.Simple\nimport Rivet.Migration\n" ++
createImport x ++
"\nmain = do\n" ++
(formatconnect dbhost dbport dbuser dbpass dbname) ++
createRun mode x
return True
_ -> putStrLn "No migrations remaining." >> return False
Status -> do mapM_ (\m -> do ne <- notExists c m
if ne
then putStrLn $ m ++ " in " ++ env
else putStrLn $ " APPLIED " ++ m ++ " in " ++ env)
migrations
return False
when run $ do putStrLn $ "Running " ++ main ++ "..."
system $ cabal ++ " exec -- runghc -isrc -imigrations " ++ main
putStrLn $ "Cleaning up... "
removeFile main
where stripSuffix = reverse . drop 3 . reverse
isCode = isSuffixOf ".hs"
dropWhileM :: Monad m => (a -> m Bool) -> [a] -> m [a]
dropWhileM f [] = return []
dropWhileM f (x:xs) = do r <- f x
if r
then dropWhileM f xs
else return (x:xs)
notExists c m =
null <$> liftIO (getMigration c m)
getMigration :: Connection -> String -> IO [(Only String)]
getMigration c m = query c "SELECT name FROM migrations WHERE name = ?" (Only m)
createImport m = "import qualified " ++ m
createRun mode m = " run " ++ w m ++ " c " ++ show mode ++ " " ++ m ++ ".migrate >> putStrLn \"Ran " ++ m ++ "\""
formatconnect h p u ps nm = " c <- connect (ConnectInfo " ++ w h ++ " " ++ show p ++ " " ++ w u ++ " " ++ w ps ++ " " ++ w nm ++ ")\n"
w s = "\"" ++ s ++ "\""
repl cabal = void (exec $ cabal ++ " repl")
setup cabal = do need ["cabal.sandbox.config"]
need ["deps"]
exec $ cabal ++ " install -fdevelopment --only-dependencies --enable-tests --reorder-goals --force-reinstalls"
exec $ cabal ++ " exec -- ghc-pkg expose hspec"
exec $ cabal ++ " exec -- ghc-pkg expose hspec-snap"
void $ exec $ cabal ++ " exec -- ghc-pkg hide resource-pool"
cryptEdit proj =
do e <- doesFileExist ".rivetcrypt"
let decrypted = "/tmp/rivetdecrypted-" ++ proj
editor <- fromMaybe "vi" <$> liftIO (lookupEnv "EDITOR")
if e
then exec $ "openssl enc -aes-256-cbc -d -a -salt -in .rivetcrypt -out " ++ decrypted ++ " -pass file:.rivetpass"
else exec $ "touch " ++ decrypted
exec $ editor ++ " " ++ decrypted
exec $ "openssl enc -aes-256-cbc -e -a -salt -in " ++ decrypted ++ " -out .rivetcrypt -pass file:.rivetpass"
void $ exec $ "rm " ++ decrypted
cryptShow =
do e <- doesFileExist ".rivetcrypt"
if e
then void $ exec $ "openssl enc -aes-256-cbc -d -a -salt -in .rivetcrypt -pass file:.rivetpass"
else liftIO $ putStrLn "No .rivetcrypt."
cryptSetPass proj =
do e <- doesFileExist ".rivetcrypt"
let decrypted = "/tmp/rivetdecrypted-" ++ proj
liftIO $ putStrLn "Enter new passphrase (will be stored in .rivetpass):"
pass <- liftIO getLine
if e
then exec $ "openssl enc -aes-256-cbc -d -a -salt -in .rivetcrypt -out " ++ decrypted ++ " -pass file:.rivetpass"
else exec $ "touch " ++ decrypted
liftIO $ copyFile ".rivetpass" ".rivetpass-0"
liftIO $ writeFile ".rivetpass" pass
exec $ "openssl enc -aes-256-cbc -e -a -salt -in " ++ decrypted ++ " -out .rivetcrypt -pass file:.rivetpass"
void $ exec $ "rm " ++ decrypted