drifter (empty) → 0.1.0.0

raw patch · 5 files changed

+194/−0 lines, 5 filesdep +basedep +bytestringdep +postgresql-simplesetup-changed

Dependencies added: base, bytestring, postgresql-simple, text, time

Files

• LICENSE +20/−0
• Setup.hs +2/−0
• drifter.cabal +31/−0
• src/Drifter/PostgreSQL.hs +120/−0
• src/Drifter/Types.hs +21/−0

@@ -0,0 +1,20 @@+Copyright (c) 2015 AndrewRademacher++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,31 @@++name:                drifter+version:             0.1.0.0+synopsis:            Simple schema management for arbitrary databases.+description:         Simple support for migrating database schemas, which allows+                     haskell functions to be run as a part of the migration.+license:             MIT+license-file:        LICENSE+author:              AndrewRademacher+maintainer:          andrewrademacher@gmail.com+category:            Database+build-type:          Simple+cabal-version:       >=1.10+homepage:            https://github.com/AndrewRademacher/drifter++source-repository head+    type:     git+    location: git@github.com:AndrewRademacher/drifter.git++library+    hs-source-dirs:     src+    default-language:   Haskell2010++    build-depends:      base                >=4.7   && <4.8+                    ,   postgresql-simple   >=0.4   && <0.5+                    ,   bytestring          >=0.10  && <0.11+                    ,   time                >=1.4   && <1.5+                    ,   text                >=1.2   && <1.3++    exposed-modules:    Drifter.PostgreSQL+                    ,   Drifter.Types

@@ -0,0 +1,120 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE QuasiQuotes                #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}++module Drifter.PostgreSQL+    ( Postgres+    , Method (..)+    , DBConnection (..)+    ) where++import           Control.Applicative+import           Control.Exception+import           Data.ByteString                      (ByteString)+import           Data.Int+import           Data.Time+import           Database.PostgreSQL.Simple+import           Database.PostgreSQL.Simple.FromField+import           Database.PostgreSQL.Simple.FromRow+import           Database.PostgreSQL.Simple.SqlQQ+import           Database.PostgreSQL.Simple.Types++import           Drifter.Types++data Postgres++data instance Method Postgres = Script ByteString+                              | Function (Connection -> IO (Either String ()))++data instance DBConnection Postgres = DBConnection Connection++newtype ChangeId = ChangeId { unChangeId :: Int } deriving (Eq, Ord, Show, FromField)++data ChangeHistory = ChangeHistory+        { histId          :: ChangeId+        , histName        :: Name+        , histDescription :: Maybe Description+        , histTime        :: UTCTime+        } deriving (Show)++instance Eq ChangeHistory where+    a == b = (histName a) == (histName b)++instance Ord ChangeHistory where+    compare a b = compare (histId a) (histId b)++instance FromRow ChangeHistory where+    fromRow = ChangeHistory <$> field <*> field <*> field <*> field++instance Drifter Postgres where+    migrate (DBConnection conn) changes = do+        _ <- bootstrap conn+        hist :: [(ChangeHistory)] <- query_ conn "SELECT id, name, description, time FROM drifter.changelog ORDER BY id"+        start <- findNext hist changes+        migratePostgres conn start++findNext :: [ChangeHistory] -> [Change Postgres] -> IO [Change Postgres]+findNext    []     cs                                   = return cs+findNext (h:hs) (c:cs) | (histName h) == (changeName c) = do putStrLn $ "Skipping: " ++ show (changeName c)+                                                             findNext hs cs+                       | otherwise                      = return (c:cs)+findNext     _      _                                   = do putStrLn "Change Set Exhausted"+                                                             return []++bootstrap :: Connection -> IO Int64+bootstrap conn = execute_ conn [sql|+BEGIN;++CREATE SCHEMA IF NOT EXISTS drifter;++CREATE TABLE IF NOT EXISTS drifter.changelog (+    id              serial                      NOT NULL,+    name            text                        NOT NULL,+    description     text,+    time            timestamp with time zone    NOT NULL,++    PRIMARY KEY (id),+    UNIQUE (name)+);++COMMIT;+|]++migratePostgres :: Connection -> [Change Postgres] -> IO (Either String ())+migratePostgres    _                [] = return $ Right ()+migratePostgres conn (Change n d m:cs) = do+        res <- handleChange conn m+        now <- getCurrentTime++        case res of+            Left  er -> return $ Left er+            Right  _ -> do _ <- logChange conn n d now+                           putStrLn $ "Committed: " ++ show n+                           migratePostgres conn cs++errorHandlers :: [Handler (Either String b)]+errorHandlers = [ Handler (\(ex::SqlError) -> return $ Left $ show ex)+                , Handler (\(ex::FormatError) -> return $ Left $ show ex)+                , Handler (\(ex::ResultError) -> return $ Left $ show ex)+                , Handler (\(ex::QueryError) -> return $ Left $ show ex)+                ]++handleChange :: Connection -> Method Postgres -> IO (Either String ())+handleChange conn (Script q) = (execute_ conn (Query q) >>= \_ -> return $ Right ())+    `catches` errorHandlers+handleChange conn (Function f) = (f conn >>= \_ -> return $ Right ())+    `catches` errorHandlers++logChange :: Connection -> Name -> Maybe Description -> UTCTime -> IO (Either String ())+logChange conn n d now = (execute conn insLog (n, d, now) >>= \_ -> return $ Right ())+    `catches` errorHandlers+    where insLog = [sql|+BEGIN;++INSERT INTO drifter.changelog (name, description, time)+    VALUES (?, ?, ?);++COMMIT;+|]

@@ -0,0 +1,21 @@+{-# LANGUAGE TypeFamilies #-}++module Drifter.Types where++import           Data.Text++type Name        = Text+type Description = Text++data Change a = Change+        { changeName        :: Name+        , changeDescription :: Maybe Description+        , changeMethod      :: Method a+        }++data family Method a++data family DBConnection a++class Drifter a where+    migrate :: DBConnection a -> [Change a] -> IO (Either String ())