rivet-core 0.1.0.1 → 0.2.0.0

raw patch · 12 files changed

+181/−569 lines, 12 filesdep +rivet-coredep −configuratordep −directorydep −directory-treedep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: rivet-core

Dependencies removed: configurator, directory, directory-tree, filepath, postgresql-simple, process, shake, template-haskell, time, unordered-containers

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• LICENSE +2/−2
• rivet-core.cabal +24/−28
• src/Database/Rivet.hs +38/−0
• src/Database/Rivet/Main.hs +44/−0
• src/Database/Rivet/V0.hs +71/−0
• src/Rivet/Common.hs +0/−37
• src/Rivet/Main.hs +0/−115
• src/Rivet/Rules.hs +0/−69
• src/Rivet/TH.hs +0/−58
• src/Rivet/Tasks.hs +0/−253
• template/migration.hs +0/−7
• test/Spec.hs +2/−0

@@ -1,4 +1,4 @@-Copyright (c) 2014, Daniel Patterson+Copyright (c) 2015  All rights reserved. @@ -13,7 +13,7 @@       disclaimer in the documentation and/or other materials provided       with the distribution. -    * Neither the name of Daniel Patterson nor the names of other+    * Neither the name of Your name here nor the names of other       contributors may be used to endorse or promote products derived       from this software without specific prior written permission. 

@@ -1,40 +1,36 @@--- Initial rivet.cabal generated by cabal init.  For further documentation,---  see http://haskell.org/cabal/users-guide/- name:                rivet-core-version:             0.1.0.1-synopsis: Core library for project management tool.--- description:-homepage:            https://github.com/dbp/rivet+version:             0.2.0.0+synopsis:            Database migration library; core functionality.+description:         Please see README.md+homepage:            http://github.com/dbp/rivet license:             BSD3 license-file:        LICENSE author:              Daniel Patterson maintainer:          dbp@dbpmail.net--- copyright:-category:            Web+category:            Database build-type:          Simple-extra-source-files: template/migration.hs+-- 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+  exposed-modules:     Database.Rivet+                     , Database.Rivet.Main+                     , Database.Rivet.V0+  build-depends:       base >= 4.7 && < 5                      , text-                     , process-                     , time >= 1.5 && < 1.6-                     , unordered-containers-                     , template-haskell-                     , directory-                     , directory-tree-                     , filepath-                     , postgresql-simple   default-language:    Haskell2010+  ghc-options: -Wall++test-suite rivet-core-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , rivet-core+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/dbp/rivet

@@ -0,0 +1,38 @@+module Database.Rivet where++import           Data.Text (Text)++data Direction = Up | Down++data Syntax m = SQL Text Text | App (m ()) (m ())++data Migration m v = Migration { migValue :: v+                               , migSteps :: [Syntax m]}++instance Functor (Migration m) where+  fmap f m = m { migValue = f (migValue m) }++instance Applicative (Migration m) where+  pure v = Migration v []+  (<*>) (Migration f ss) (Migration v ss') = Migration (f v) (ss ++ ss')++instance Monad (Migration m) where+  (>>=) (Migration v ss) f = let (Migration v' ss') = f v+                             in Migration v' (ss ++ ss')+  return v = Migration v []++data Adaptor m = Adaptor { runHandler     :: m () -> IO ()+                         , runSQL         :: Text -> IO ()+                         , checkMigration :: Text -> IO Bool+                         , markMigration  :: Text -> Direction -> IO ()+                         }++runMigration :: Direction -> Adaptor m -> Text -> Migration m () -> IO ()+runMigration dir ad n m = do sequence_ (map (runStep dir ad) (migSteps m))+                             markMigration ad n dir++runStep :: Direction -> Adaptor m -> Syntax m -> IO ()+runStep Up   (Adaptor h _ _ _) (App up _)   = h up+runStep Down (Adaptor h _ _ _) (App _ down) = h down+runStep Up   (Adaptor _ s _ _) (SQL up _)   = s up+runStep Down (Adaptor _ s _ _) (SQL _ down) = s down

@@ -0,0 +1,44 @@+{-# LANGUAGE OverloadedStrings #-}++module Database.Rivet.Main where++import           Control.Monad+import           Data.Monoid+import           Data.Text      (Text)+import qualified Data.Text.IO   as T+import           Database.Rivet++data Mode = MigrateUp | MigrateDown | MigrateStatus++main :: Monad m =>+        Adaptor m ->+        Mode ->+        [(Text, Migration m ())] ->+        IO ()+main adaptor mode migrations = do+  let notRun m = fmap not $ checkMigration adaptor m+  case mode of+    MigrateUp ->+      do toRun <- filterM (notRun . fst) migrations+         mapM_ (\(name, m) -> do runMigration Up adaptor name m+                                 T.putStrLn ("Ran " <> name))+               toRun+    MigrateDown ->+      do toDown <- dropWhileM (notRun . fst)+                              (reverse migrations)+         case toDown of+           ((name, m) :_) -> do runMigration Down adaptor name m+                                T.putStrLn ("Reverted " <> name)+           [] -> putStrLn "No migrations remaining."+    MigrateStatus ->+      mapM_ (\(m,_) ->+        do r <- checkMigration adaptor m+           if r+             then T.putStrLn $ " APPLIED " <> m+             else T.putStrLn m)+        migrations+  where dropWhileM _ [] = return []+        dropWhileM f (x:xs) = do x' <- f x+                                 if x'+                                    then dropWhileM f xs+                                    else return (x:xs)

@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.Rivet.V0 (+    Migration+  , createTable+  , dropTable+  , renameColumn+  , addColumn+  , dropColumn+  , sql+  , ColumnSpec(..)+  )  where++import           Data.Maybe     (fromMaybe)+import           Data.Monoid+import           Data.Text      (Text)++import           Database.Rivet++data ColumnSpec = ColumnSpec { colName        :: Text+                             , colType        :: Text+                             , colDefault     :: Maybe Text+                             , colConstraints :: Maybe Text+                             }++swap :: Syntax m -> Syntax m+swap (SQL up down) = SQL down up+swap (App up down) = App down up++add :: Monad m => (Text, Text) -> Migration m ()+add (up, down) = Migration () [SQL up down]++invert :: Monad m => Migration m () -> Migration m ()+invert (Migration () ps) = Migration () (map swap ps)++stripDown :: Monad m => Migration m () -> Migration m ()+stripDown (Migration () ps) = Migration () (map elimDown ps)+  where elimDown (SQL up _) = SQL up ""+        elimDown (App up _) = App up (return ())++createTable :: Monad m => Text -> [ColumnSpec] -> Migration m ()+createTable tab cols =+  do add ("CREATE TABLE " <> tab <> "()", "DROP TABLE " <> tab)+     stripDown $ mapM_ (addColumn tab) cols++-- NOTE(dbp 2014-10-18): To make this invertable, you need to pass in+-- the spec for how the table should be recreated. Obviously this is+-- reasonably unsafe, as we aren't checking that it looks like that+-- currently (so up and down may not be inverses if you mess that up).+dropTable :: Monad m => Text -> [ColumnSpec] -> Migration m ()+dropTable tab = invert . createTable tab++renameColumn :: Monad m => Text -> Text -> Text -> Migration m ()+renameColumn tab old new =+  add ("ALTER TABLE " <> tab <> " RENAME COLUMN " <> old <> " TO " <> new+      ,"ALTER TABLE " <> tab <> " RENAME COLUMN " <> new <> " TO " <> old)++addColumn :: Monad m => Text -> ColumnSpec -> Migration m ()+addColumn tab (ColumnSpec nm ty def constr) =+  add ("ALTER TABLE " <> tab <> " ADD COLUMN " <> nm <>+       " " <> ty <> maybe "" (" DEFAULT " <>) def <> " " <>+       fromMaybe "" constr,+       "ALTER TABLE " <> tab <> " DROP COLUMN " <> nm)++-- NOTE(dbp 2014-10-18): Like with 'dropTable', we have to specify+-- what the column should look like when you re-add it in order to+-- build the inverse.+dropColumn :: Monad m => Text -> ColumnSpec -> Migration m ()+dropColumn tab = invert . addColumn tab++sql :: Monad m => Text -> Text -> Migration m ()+sql up down = Migration () [SQL up down]

@@ -1,37 +0,0 @@-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")

@@ -1,115 +0,0 @@-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)

@@ -1,69 +0,0 @@-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 ""

@@ -1,58 +0,0 @@-{-# 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

@@ -1,253 +0,0 @@-{-# 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

@@ -1,7 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module MIGRATION_MODULE where--import           Control.Monad-import           Rivet.Migration.V0--migrate = CONTENT

@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"