diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Daniel Patterson + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Daniel Patterson nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/rivet-core.cabal b/rivet-core.cabal new file mode 100644 --- /dev/null +++ b/rivet-core.cabal @@ -0,0 +1,40 @@ +-- Initial rivet.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: rivet-core +version: 0.1.0.0 +synopsis: Core library for project management tool. +-- description: +homepage: https://github.com/dbp/rivet +license: BSD3 +license-file: LICENSE +author: Daniel Patterson +maintainer: dbp@dbpmail.net +-- copyright: +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: + Rivet.Main + , Rivet.Common + , Rivet.Tasks + , Rivet.TH + , Rivet.Rules + build-depends: base >=4.7 && <5 + , directory >= 1.2.1.0 + , shake + , configurator >= 0.3.0.0 + , text + , process + , time >= 1.5 && < 1.6 + , unordered-containers + , template-haskell + , directory + , directory-tree + , filepath + , postgresql-simple + default-language: Haskell2010 diff --git a/src/Rivet/Common.hs b/src/Rivet/Common.hs new file mode 100644 --- /dev/null +++ b/src/Rivet/Common.hs @@ -0,0 +1,37 @@ +module Rivet.Common where + +import Prelude hiding ((++)) + +import Control.Applicative +import Data.Char +import Data.Configurator.Types +import Data.Monoid +import Development.Shake +import System.Exit +import System.IO +import System.Process + +(++) :: Monoid a => a -> a -> a +(++) = mappend + +data Task = Task { taskName :: String + , taskNumArgs :: Int + , taskBody :: String -> Config -> [String] -> Action () + , taskUsage :: String + } + +exec :: String -> Action ExitCode +exec c = liftIO $ do putStrLn c + system c + +readExec :: String -> Action String +readExec c = liftIO $ do (_,Just out,_, ph) <- createProcess $ (shell c) { std_out = CreatePipe } + waitForProcess ph + hGetContents out + +stripWhitespace :: String -> String +stripWhitespace = reverse . dropWhile isSpace . reverse . dropWhile isSpace + + +getDockerTag :: String -> String -> String -> Action String +getDockerTag proj h env = stripWhitespace <$> readExec ("ssh " ++ h ++ " \"docker ps\" | grep " ++ proj ++ "_" ++ env ++ "_ | awk '{ print $2}' | cut -d ':' -f 2 | head -n1") diff --git a/src/Rivet/Main.hs b/src/Rivet/Main.hs new file mode 100644 --- /dev/null +++ b/src/Rivet/Main.hs @@ -0,0 +1,115 @@ +module Rivet.Main where + +import Prelude hiding ((*>), (++)) + +import Control.Applicative ((<$>)) +import Control.Monad (void, when) +import Data.Char (isSpace) +import Data.Configurator +import Data.Configurator.Types +import qualified Data.HashMap.Strict as M +import Data.List (intercalate, isInfixOf) +import Data.Monoid +import qualified Data.Text as T +import Data.Time.Clock +import Data.Time.Format +import Development.Shake hiding (doesFileExist) +import System.Directory (createDirectoryIfMissing, + doesFileExist, getCurrentDirectory) +import System.Exit +import System.IO +import System.Process + +import Rivet.Common +import qualified Rivet.Rules as Rules +import qualified Rivet.Tasks as Tasks + +opts :: ShakeOptions +opts = shakeOptions { shakeFiles = ".shake/" } + +getProjectName :: IO String +getProjectName = (reverse . takeWhile (/= '/') . reverse) <$> + getCurrentDirectory + +mainWith :: [Task] -> IO () +mainWith tasks = do + proj <- getProjectName + shakeArgsWith opts [] $ \flags targets -> + case targets of + ("init":[]) -> do + e <- doesFileExist "Rivetfile" + if e + then + do putStrLn "Error: Rivetfile already exists. Only run 'rivet init' in empty directory." + return Nothing + else return $ Just $ do want ["init"] + "init" ~> Tasks.init proj + ("init":_) -> do putStrLn "Usage: rivet init" + return Nothing + _ -> do conf <- load [Required "Rivetfile"] + commands <- (map (\(k,String v) -> (T.drop (length "commands.") k, v)) . + filter (\(k,v) -> (T.pack "commands.") `T.isPrefixOf` k) . + M.toList) <$> getMap conf + deps <- lookupDefault [] conf (T.pack "dependencies") + cabal <- lookupDefault "cabal " conf (T.pack "cabal-command") + return $ Just $ do + case targets of + [] -> action $ liftIO $ putStrLn "Need a task. Run `rivet tasks` to see all tasks." + ("test":_) -> want ["test"] + ("db:new":_:[]) -> want ["db:new"] + ("db:new":_) -> action $ liftIO (putStrLn "usage: rivet db:new migration_name") + ("model:new":[]) -> action $ liftIO (putStrLn "usage: rivet model:new ModelName [field_name:field_type]*") + ("model:new":_) -> want ["model:new"] + ("db:migrate":_:[]) -> want ["db:migrate"] + ("db:migrate":_:_) -> action $ liftIO (putStrLn "usage: rivet db:migrate [env]") + ("db:migrate:down":_:[]) -> want ["db:migrate:down"] + ("db:migrate:down":_:_) -> action $ liftIO (putStrLn "usage: rivet db:migrate:down [env]") + ("db:status":_:[]) -> want ["db:status"] + ("db:status":_:_) -> action $ liftIO (putStrLn "usage: rivet db:status [env]") + (target:args) -> + do mapM_ (\t -> + if taskName t == target + then if length args == taskNumArgs t + then want [taskName t] + else action $ liftIO (putStrLn $ + "usage: rivet " ++ + taskName t ++ " " ++ + taskUsage t) + else return ()) + tasks + when (not (target `elem` (map taskName tasks))) $ want targets + Rules.addCommands commands + Rules.addDependencies cabal deps + Rules.addBinary cabal proj + mapM_ (\t -> taskName t ~> taskBody t proj conf (tail targets)) tasks + "cabal.sandbox.config" *> \_ -> cmd "cabal sandbox init" + "run" ~> Tasks.run proj + "test" ~> Tasks.test cabal targets + "db" ~> Tasks.db proj conf + "db:test" ~> Tasks.dbTest proj conf + "db:create" ~> Tasks.dbCreate proj conf + "db:new" ~> Tasks.dbNew targets + "db:migrate" ~> Tasks.dbMigrate cabal proj conf (tail targets) + "db:migrate:down" ~> Tasks.dbMigrateDown cabal proj conf (tail targets) + "db:status" ~> Tasks.dbStatus cabal proj conf (tail targets) + "repl" ~> Tasks.repl cabal + "setup" ~> Tasks.setup cabal + "crypt:edit" ~> Tasks.cryptEdit proj + "crypt:show" ~> Tasks.cryptShow + "crypt:setpass" ~> Tasks.cryptSetPass proj + + "tasks" ~> liftIO (mapM_ (putStrLn . ("rivet " ++)) $ + ["init" + ,"run" + ,"test [pattern]" + ,"db" + ,"db:test" + ,"db:create" + ,"db:new migration_name" + ,"db:migrate" + ,"db:migrate:down" + ,"db:status" + ,"model:new ModelName" + ,"repl" + ,"setup" + ] ++ map taskName tasks) diff --git a/src/Rivet/Rules.hs b/src/Rivet/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Rivet/Rules.hs @@ -0,0 +1,69 @@ +module Rivet.Rules where + +import Prelude hiding ((*>), (++)) + +import Control.Monad (void, when) +import Data.List (isInfixOf) +import qualified Data.Text as T +import Development.Shake + +import Rivet.Common + +addCommands commands = + sequence_ (map (\(cName, cCom) -> (T.unpack cName) ~> void (exec (T.unpack cCom))) + commands) + +addBinary cabal proj = + do let binary = "./.cabal-sandbox/bin/" ++ proj + binary *> \_ -> do files <- getDirectoryFiles "" ["src/Main.hs", "*.cabal"] + need files + cmd $ cabal ++ " install -j -fdevelopment --reorder-goals --force-reinstalls" + +addDependencies cabal deps = + do let depDirs = map ((++ ".d/.rivetclone") . ("deps/" ++) . T.unpack . head . + T.splitOn (T.pack ":") . head . T.splitOn (T.pack "+")) deps + sequence_ (map (\d -> + do let (repo':rest) = T.splitOn (T.pack "+") d + let (repo:branchspec) = T.splitOn (T.pack ":") repo' + let depdir = ("deps/" ++ (T.unpack repo) ++ ".d") + depdir ++ "/.rivetclone" *> \clonedFile -> do + liftIO $ removeFiles depdir ["//*"] + () <- case branchspec of + (branch:_) -> cmd ("git clone --depth=1 -b " ++ (T.unpack branch) ++ + " https://github.com/" ++ (T.unpack repo) ++ " " ++ + depdir) + _ -> cmd ("git clone --depth=1 https://github.com/" + ++ (T.unpack repo) ++ " " ++ depdir) + writeFile' clonedFile "" + let addSource s = do contents <- readFileOrBlank "deps/add-all" + let addstr = cabal ++ " sandbox add-source " ++ s + if addstr `isInfixOf` contents + then return () + else liftIO $ appendFile "deps/add-all" (addstr ++ "\n") + let remstr = cabal ++ " sandbox delete-source " ++ s + if remstr `isInfixOf` contents + then return () + else liftIO $ appendFile "deps/delete-all" (remstr ++ "\n") + -- NOTE(dbp 2015-01-06): This is an imperfect test, but one that is + -- easy to mock up, if your sandbox is structured differently. + hasSandbox <- doesFileExist "cabal.sandbox.config" + if hasSandbox + then cmd addstr :: Action () + else return () + hasHalcyon <- doesDirectoryExist ".halcyon" + when hasHalcyon $ + do contents <- readFileOrBlank ".halcyon/sandbox-sources" + if s `isInfixOf` contents + then return () + else liftIO $ appendFile ".halcyon/sandbox-sources" (s ++ "\n") + + case rest of + (subdirs:_) -> mapM_ (\subdir -> addSource (depdir ++ "/" ++ (T.unpack subdir))) + (T.splitOn (T.pack ",") subdirs) + _ -> addSource depdir) + deps) + "deps" ~> need depDirs + where readFileOrBlank nm = do e <- doesFileExist nm + if e + then liftIO $ readFile nm + else return "" diff --git a/src/Rivet/TH.hs b/src/Rivet/TH.hs new file mode 100644 --- /dev/null +++ b/src/Rivet/TH.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE TemplateHaskell #-} +module Rivet.TH where + +import qualified Data.Foldable as F +import Data.List +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import System.Directory.Tree +import System.FilePath + +type FileData = (String, String) +type DirData = FilePath + +loadFile :: String -> FilePath -> Q [Dec] +loadFile nm pth = do let ident = mkName nm + typeSig <- SigD ident `fmap` [t| String |] + v <- valD (varP ident) (normalB $ lift =<< runIO (readFile pth)) [] + return [typeSig, v] + +loadProjectTemplate :: Q [Dec] +loadProjectTemplate = do let dir = mkName "tDirTemplate" + typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |] + v <- valD (varP dir) (normalB $ dirQ ("template" "project")) [] + return [typeSig, v] + +loadModelTemplate :: Q [Dec] +loadModelTemplate = do let dir = mkName "tModelTemplate" + typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |] + v <- valD (varP dir) (normalB $ dirQ ("template" "model")) [] + return [typeSig, v] + +-- NOTE(dbp 2014-09-27): Much of this code is derived from that used +-- in the Snap project starter. +------------------------------------------------------------------------------ +-- Gets all the directories in a DirTree +-- +getDirs :: [FilePath] -> DirTree a -> [FilePath] +getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) : + concatMap (getDirs (n:prefix)) c +getDirs _ (File _ _) = [] +getDirs _ (Failed _ _) = [] + +------------------------------------------------------------------------------ +-- Reads a directory and returns a tuple of the list of all directories +-- encountered and a list of filenames and content strings. +-- +readTree :: FilePath -> IO ([DirData], [FileData]) +readTree dir = do d <- readDirectory $ dir "." + let ps = zipPaths $ "" :/ (dirTree d) + fd = F.foldr (:) [] ps + dirs = getDirs [] $ dirTree d + return (drop 1 dirs, fd) +------------------------------------------------------------------------------ +-- Calls readTree and returns its value in a quasiquote. +-- +dirQ :: FilePath -> Q Exp +dirQ tplDir = do d <- runIO . readTree $ tplDir + lift d diff --git a/src/Rivet/Tasks.hs b/src/Rivet/Tasks.hs new file mode 100644 --- /dev/null +++ b/src/Rivet/Tasks.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +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 + +-- NOTE(dbp 2014-09-27): These calls load in files from disk using TH. +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 + +-- NOTE(dbp 2014-09-18): Tasks follow +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