diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2010, Mark Hibberd +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. 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. + 3. Neither the name of the nor the names of its 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 HOLDER 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,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/database-migrate.cabal b/database-migrate.cabal new file mode 100644 --- /dev/null +++ b/database-migrate.cabal @@ -0,0 +1,58 @@ +Name: database-migrate +Version: 0.0.1 +License: BSD3 +License-File: LICENSE +Author: Mark Hibberd +Maintainer: Mark Hibberd +Copyright: (c) 2012 Mark Hibberd +Synopsis: Database versioning and migration +Category: Database +Homepage: https://github.com/markhibberd/database-migrate +Bug-reports: https://github.com/markhibberd/database-migrate/issues +Cabal-Version: >= 1.6 +Build-Type: Simple +Description: + A database versioning and migration library. + . + /Note/: that this library is under heavy development, currently + the PostgreSQL implementation is functional, but + expected to change. It is intended that a type safe + migration api and command line tools be added to this + library before it be considered stable. + +Source-Repository head + Type: git + Location: https://github.com/markhibberd/migrate.git + +Flag small_base + Description: Choose the new, split-up base package. + +Library + Build-Depends: + base >= 3 && < 5 + , text >= 0.11 && < 0.12 + , directory >= 1.0 && < 2.0 + , filepath >= 1.0 && < 2.0 + , bytestring >= 0.9 && < 0.10 + , time >= 1.0 && < 2.0 + , postgresql-simple >= 0.1 && < 1.0 + , containers >= 0.4 && < 0.5 + , either >= 3.0.2 && < 4.0 + , transformers >= 0.2 && < 0.4 + + GHC-Options: + -Wall -fno-warn-orphans + + Hs-Source-Dirs: + src + + Exposed-Modules: + Database.Migrate + Database.Migrate.Core + Database.Migrate.PostgreSQL + + Extensions: + MultiParamTypeClasses + OverloadedStrings + + diff --git a/src/Database/Migrate.hs b/src/Database/Migrate.hs new file mode 100644 --- /dev/null +++ b/src/Database/Migrate.hs @@ -0,0 +1,21 @@ +-- | +-- Module: Database.Migrate +-- Copyright: (c) 2012 Mark Hibberd +-- License: BSD3 +-- Maintainer: Mark Hibberd +-- Portability: portable +-- +-- A library to assist with managing database versioning +-- and migration. +-- +-- Note: This library is under heavy development, currently +-- the PostgreSQL implementation is functional, but +-- expected to change. It is intended that a type safe +-- migration api and command line tools be added to this +-- library before it be considered stable. +module Database.Migrate (module X) where + +import Database.Migrate.Core as X +-- import Database.Migrate.MySQL as X +import Database.Migrate.PostgreSQL as X + diff --git a/src/Database/Migrate/Core.hs b/src/Database/Migrate/Core.hs new file mode 100644 --- /dev/null +++ b/src/Database/Migrate/Core.hs @@ -0,0 +1,72 @@ +{-#LANGUAGE OverloadedStrings #-} +module Database.Migrate.Core where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Either + +import qualified Data.Set as S +import Data.Text hiding (foldr, filter, reverse, length) + +import System.FilePath +import System.Directory +import System.IO + +type MigrationId = Text +type Ddl = Text + +data Migration = + Migration { + migration :: MigrationId + , up :: Text + , down :: Text + , upsource :: Maybe FilePath + , downsource :: Maybe FilePath + } + +data Context = Context { + succeeded :: [MigrationId] + , failed :: MigrationId + , msg :: Text + , rolledback :: Bool + } deriving (Eq, Show) + +type MigrationResultT = EitherT Context + +class Monad m => MigrateDatabase m c where + initialize :: c -> m () + runMigrations :: c -> (Migration -> Ddl) -> [Migration] -> MigrationResultT m [MigrationId] + getMigrations :: c -> m [MigrationId] + +pick :: [Migration] -> [MigrationId] -> [Migration] +pick ms ids = + let available = foldr (S.insert . migration) S.empty ms + installed = S.fromList ids + torun = S.difference available installed + in filter (\m -> S.member (migration m) torun) ms + +latest :: MigrateDatabase m c => c -> [Migration] -> MigrationResultT m [MigrationId] +latest c migrations = + lift (getMigrations c) >>= \installed -> runMigrations c up (pick migrations installed) + +find :: FilePath -> EitherT String IO [Migration] +find b = liftIO (getDirectoryContents b) >>= \fs -> liftIO (migrationids b fs) >>= + mapM (\p -> + do downexists <- liftIO $ doesFileExist (b p <.> "down.sql") + unless downexists (left $ "no down.sql for migration [" ++ p ++ "]") + u <- liftIO . readFile $ b p <.> "up.sql" + d <- liftIO . readFile $ b p <.> "down.sql" + right (Migration (pack p) (pack u) (pack d) (Just $ b p <.> "up.sql") (Just $ b p <.> "down.sql"))) + +migrationids :: FilePath -> [FilePath] -> IO [String] +migrationids b ps = + filterM (\p -> doesFileExist (b p)) ps >>= \files -> + return (filter (\p -> takeExtensions p == ".up.sql" ) files) >>= \ups -> return (fmap dropExtensions ups) + +readFile' :: FilePath -> IO String +readFile' p = withFile p ReadMode hGetContents + +hGetContents' :: Handle -> IO String +hGetContents' h = hGetContents h >>= \s -> length s `seq` return s + diff --git a/src/Database/Migrate/PostgreSQL.hs b/src/Database/Migrate/PostgreSQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/Migrate/PostgreSQL.hs @@ -0,0 +1,37 @@ +{-#LANGUAGE OverloadedStrings #-} +module Database.Migrate.PostgreSQL where + +import Control.Exception (SomeException(..), handle) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Either + +import Data.Text hiding (filter, reverse) +import Data.String (IsString(..)) + +import Database.PostgreSQL.Simple +import Database.Migrate.Core + +instance MigrateDatabase IO Connection where + initialize c = void $ execute_ c "CREATE TABLE IF NOT EXISTS MIGRATION_INFO (MIGRATION VARCHAR(50) PRIMARY KEY)" + runMigrations = runall + getMigrations c = fmap (fmap fromOnly) (query_ c "SELECT MIGRATION FROM MIGRATION_INFO") + +record :: Connection -> MigrationId -> IO () +record conn mid = void $ execute conn "INSERT INTO MIGRATION_INFO VALUES (?)" (Only mid) + +runall :: Connection -> (Migration -> Ddl) -> [Migration] -> MigrationResultT IO [MigrationId] +runall c f ms = + liftIO (begin c) >> + (foldM (\rs m -> + EitherT $ + do e <- runEitherT (saferun c f m) + case e of + Left emsg -> rollback c >> (return . Left $ Context (reverse rs) (migration m) emsg True) + Right r -> return . Right $ r:rs) [] ms) >>= \result -> liftIO (commit c) >> return (reverse result) + +saferun :: Connection -> (Migration -> Ddl) -> Migration -> EitherT Text IO MigrationId +saferun c f m = EitherT $ handle (\e -> return (Left (pack . show $ (e :: SomeException)))) (fmap Right $ run c f m) + +run :: Connection -> (Migration -> Ddl) -> Migration -> IO MigrationId +run c f m = execute_ c (fromString . unpack $ f m) >> record c (migration m) >> return (migration m)