Add migration compiler

.travis.yml

@@ -10,27 +10,27 @@ matrix:
   include:
     - env: BUILD=cabal CABALVER=1.18 GHCVER=7.8.4
       compiler: ": #GHC 7.8.4"
-      addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
+      addons: {apt: {packages: [happy-1.19.5,cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
 
     - env: BUILD=cabal CABALVER=1.22 GHCVER=7.10.1
       compiler: ": #GHC 7.10.1"
-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1], sources: [hvr-ghc]}}
+      addons: {apt: {packages: [happy-1.19.5,cabal-install-1.22,ghc-7.10.1], sources: [hvr-ghc]}}
 
     - env: BUILD=cabal CABALVER=1.22 GHCVER=7.10.2
       compiler: ": #GHC 7.10.2"
-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}
+      addons: {apt: {packages: [happy-1.19.5,cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}}
 
     - env: BUILD=cabal CABALVER=1.22 GHCVER=7.10.3
       compiler: ": #GHC 7.10.3"
-      addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}
+      addons: {apt: {packages: [happy-1.19.5,cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}
 
     - env: BUILD=cabal CABALVER=1.24 GHCVER=8.0.1
       compiler: ": #GHC 8.0.1"
-      addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
+      addons: {apt: {packages: [happy-1.19.5,cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}}
 
     - env: BUILD=cabal CABALVER=head GHCVER=head
       compiler: ": #GHC head"
-      addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}}
+      addons: {apt: {packages: [happy-1.19.5,cabal-install-head,ghc-head], sources: [hvr-ghc]}}
 
   allow_failures:
     - env: BUILD=cabal CABALVER=head GHCVER=head
@@ -40,7 +40,8 @@ matrix:
 # - in install we install (haskell) dependencies
 before_install:
   - unset CC
-  - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
+  - export HAPPYVER=1.19.5
+  - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:/opt/happy/$HAPPYVER/bin:$PATH
 
 install:
   - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
@@ -62,4 +63,3 @@ script:
       echo "expected '$SRC_TGZ' not found";
       exit 1;
    fi
-

pg_migrate.hs

@@ -1,6 +1,6 @@
 import Database.PostgreSQL.Migrate
 import System.Environment
-import System.Exit 
+import System.Exit
 import System.FilePath
 import System.IO
 
@@ -19,14 +19,16 @@ main = do
     "new":name:[] -> newMigration name defaultMigrationsDir >>
                       return ExitSuccess
     "new":name:dir:[] -> newMigration name dir >> return ExitSuccess
+    "compile":out:[] -> compileMigrationsForDir defaultMigrationsDir out
+    "compile":out:dir:[] -> compileMigrationsForDir dir out
     _ -> do
       progName <- getProgName
       putStrLn $ "Usage: " ++ progName ++ " migrate|rollback [DIRECTORY]"
+      putStrLn $ "       " ++ progName ++ " compile [PROGRAM] [DIRECTORY]"
       putStrLn $ "       " ++ progName ++ " init"
       putStrLn $ "       " ++ progName ++ " dump [FILE]"
       putStrLn $ "       " ++ progName ++ " new NAME [DIRECTORY]"
       return $ ExitFailure 1
   if ec == ExitSuccess then
     return ()
     else exitWith ec
-

postgresql-orm.cabal

@@ -8,7 +8,7 @@ author: Amit Levy and David Mazieres
 maintainer: [email protected]
 category: Database
 synopsis: An ORM (Object Relational Mapping) and migrations DSL for PostgreSQL.
-data-files: man/man1/pg_migrate.1 man/man5/pg_migrate.5 static/migration.hs
+data-files: man/man1/pg_migrate.1 man/man5/pg_migrate.5 static/migration.hs static/CompilerUtils.hs
 description:
   An ORM (Object Relational Mapping) and migrations DSL for PostgreSQL. See
   "Database.PostgreSQL.ORM" for documentation.
@@ -33,10 +33,12 @@ library
                , directory
                , filepath
                , ghc-prim
+               , haskell-src-exts
                , mtl
                , old-locale
                , postgresql-simple
                , process
+               , temporary
                , text
                , time
                , transformers
@@ -72,4 +74,3 @@ library
 source-repository  head
   type:         git
   location:     https://github.com/alevy/postgresql-orm.git
-

src/Database/PostgreSQL/Migrate.hs

@@ -9,9 +9,11 @@ module Database.PostgreSQL.Migrate
   ( initializeDb
   , runMigrationsForDir
   , runRollbackForDir
+  , compileMigrationsForDir
   , dumpDb
   , newMigration
   , defaultMigrationsDir
+  , getDirectoryMigrations
   , MigrationDetails(..)
   ) where
 
@@ -21,13 +23,19 @@ import Data.Time
 import Database.PostgreSQL.Simple hiding (connect)
 import qualified Data.ByteString.Char8 as S8
 import Database.PostgreSQL.Migrations
-import System.Exit 
+import Language.Haskell.Exts
+  (parseFile, fromParseResult,
+   Module(..), ModuleHead(..), ModuleName(..),
+   Decl(..), Pat(..), Name(..))
+import Language.Haskell.Exts.Pretty (prettyPrint)
+import System.Exit
 import GHC.IO.Handle
 import System.Process
 import System.Directory
 import System.FilePath
 import System.Environment
 import System.IO
+import System.IO.Temp (withTempDirectory)
 #if !MIN_VERSION_time(1,5,0)
 import System.Locale
 #endif
@@ -148,7 +156,7 @@ getDirectoryMigrations dir = do
   return $ map (splitFileVersionName dir) files
 
 splitFileVersionName :: FilePath -> FilePath -> MigrationDetails
-splitFileVersionName dir file = 
+splitFileVersionName dir file =
   let fileName = takeBaseName file
       parts    = foldr (\chr (hd:result) ->
                           if chr == '_' then
@@ -170,3 +178,77 @@ newMigration baseName dir = do
   origFile <- getDataFileName "static/migration.hs"
   copyFile origFile (dir </> filePath)
 
+
+compileMigrationsForDir :: FilePath -> FilePath -> IO ExitCode
+compileMigrationsForDir dir exe = do
+  migrations <- getDirectoryMigrations dir
+
+  -- Make temporary working directory.
+  withTempDirectory "." "migration-compile-" $ \tmpdir -> do
+--  ($ "migration-compile") $ \tmpdir -> do
+
+    -- Iterate over migrations in input directory, copying migration
+    -- file to working directory, modifying as:
+    --   - Add "module Migration<datestamp> (up, down) where" line at
+    --     beginning of file, after any LANGUAGE options.
+    --   - Remove any main function.
+    --   - Collect (label, MigrationYYMMDD) pairs.
+    moduleNames <- mapM (fixModule tmpdir) migrations
+
+    -- Copy main program text to working directory, including
+    -- migration list.
+    makeMain tmpdir $ zip moduleNames migrations
+
+    -- Copy compiler utilities.
+    utils <- getDataFileName "static/CompilerUtils.hs"
+    copyFile utils (tmpdir </> "CompilerUtils.hs")
+
+    -- Compile migrater, writing executable outside temporary
+    -- directory.
+    cwd <- getCurrentDirectory
+    system $ "cd " ++ tmpdir ++ "; ghc -o " ++ (cwd </> exe) ++ " Main.hs"
+
+-- | Turn migration scripts into valid modules.
+fixModule :: FilePath -> MigrationDetails -> IO String
+fixModule tmpdir (MigrationDetails path ver _) = do
+  let modulename = "Migration" ++ ver
+  modin <- parseFile path
+  let modout = removeMain $ addModuleHeader modulename $ fromParseResult modin
+  writeFile (tmpdir </> modulename <.> "hs") $ prettyPrint modout
+  return modulename
+
+-- | Add "MigrationYYYYMMDDHHMMSS" module header.
+addModuleHeader :: String -> Module l -> Module l
+addModuleHeader name (Module sinfo _ pragmas imports decls) =
+  Module sinfo (Just header) pragmas imports decls
+  where header = ModuleHead sinfo (ModuleName sinfo name) Nothing Nothing
+addModuleHeader _ _ = error "Something wrong..."
+
+-- | Remove main function.
+removeMain :: Module l -> Module l
+removeMain (Module sinfo header pragmas imports decls) =
+  Module sinfo header pragmas imports $ filter (not . isMain) decls
+  where isMain :: Decl l -> Bool
+        isMain (TypeSig _ [Ident _ "main"] _) = True
+        isMain (PatBind _ (PVar _ (Ident _ "main")) _ _) = True
+        isMain _ = False
+removeMain _ = error "Something wrong..."
+
+-- | Write main program.
+makeMain :: FilePath -> [(String, MigrationDetails)] -> IO ()
+makeMain tmpdir migrations =
+  withFile (tmpdir </> "Main.hs") WriteMode $ \h -> do
+    hPutStrLn h "module Main where\n"
+    hPutStrLn h "import CompilerUtils\n"
+    forM_ migrations $ \(modname, _) -> hPutStrLn h $ "import qualified " ++ modname
+    hPutStrLn h "\nmigrations :: MigrationMap"
+    hPutStrLn h "migrations = fromList"
+    let migs = zipWith (++) ("  [ " : repeat "  , ") $ map doone migrations
+    hPutStrLn h $ unlines migs
+    hPutStrLn h "  ]\n"
+    hPutStrLn h "main :: IO ()"
+    hPutStrLn h "main = compiledMain migrations"
+    where doone (modname, MigrationDetails _ ver name) =
+            "(\"" ++ ver ++ "\",\n" ++
+            "     Migration \"" ++ ver ++ "_" ++ name ++ "\" " ++
+            modname ++ ".up " ++ modname ++ ".down)"

static/CompilerUtils.hs

@@ -0,0 +1,90 @@
+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
+module CompilerUtils (
+  fromList, Migration(..), MigrationMap, compiledMain
+) where
+
+import Control.Exception (SomeException, catch)
+import Control.Monad (forM_, void)
+import Data.Map (Map, fromList)
+import qualified Data.Map as M
+import Database.PostgreSQL.Simple
+  (Connection, Only(..), execute, query_, begin, commit)
+import Database.PostgreSQL.Migrations (connectEnv)
+import System.Environment (getArgs)
+
+type Version = String
+
+data Migration = Migration { migName :: String
+                           , migUp :: Connection -> IO ()
+                           , migDown :: Connection -> IO ()
+                           }
+
+type MigrationMap = Map Version Migration
+
+compiledMain :: MigrationMap -> IO ()
+compiledMain migrations = do
+  args <- getArgs
+  case args of
+    "list":[] -> listMigrations migrations
+    "migrate":[] -> runMigrations migrations
+    "rollback":[] -> runRollback migrations
+
+listMigrations :: MigrationMap -> IO ()
+listMigrations migrations =
+  forM_ (M.toAscList migrations) $ \(_, Migration name _ _) -> putStrLn name
+
+-- | Runs all new migrations in a given directory and dumps the
+-- resulting schema to a file \"schema.sql\" in the migrations
+-- directory.
+--
+-- Determining which migrations to run is done by querying the database for the
+-- largest version in the /schema_migrations/ table, and choosing all
+-- migrations in the given directory with higher versions.
+runMigrations :: MigrationMap -> IO ()
+runMigrations migrationsIn = do
+  conn <- connectEnv
+  res <- query_ conn
+         "select version from schema_migrations order by version desc limit 1"
+  let latestVersion = case res of
+                        [] -> ""
+                        (Only latest):_ -> latest
+  let migrations = M.toAscList $
+        M.filterWithKey (\k _ -> k > latestVersion) migrationsIn
+  forM_ migrations (doone conn)
+  where doone conn (version, Migration name up down) = do
+          putStrLn $ "=== Running Migration " ++ name
+          ok <- catch
+            (do
+                begin conn
+                void $ execute conn "insert into schema_migrations values(?)"
+                  (Only version)
+                up conn
+                commit conn
+                return True)
+            (\(e :: SomeException) -> return False)
+          if ok
+            then putStrLn "=== Success"
+            else putStrLn "=== Migration Failed!"
+
+runRollback :: MigrationMap -> IO ()
+runRollback migrations = do
+  conn <- connectEnv
+  res <- query_ conn
+          "select version from schema_migrations order by version desc limit 1"
+  case res of
+    [] -> putStrLn "=== DB Fully Rolled Back!"
+    (Only latest):_ -> do
+      let (Migration name _ down) = migrations M.! latest
+      putStrLn $ "=== Running Rollback " ++ name
+      ok <- catch
+        (do
+            begin conn
+            down conn
+            void $ execute conn "delete from schema_migrations where version = ?"
+              (Only latest)
+            commit conn
+            return True)
+        (\(e :: SomeException) -> return False)
+      if ok
+        then putStrLn "=== Success"
+        else putStrLn "=== Migration Failed!"