diff --git a/Database/PostgreSQL/Devel.hs b/Database/PostgreSQL/Devel.hs --- a/Database/PostgreSQL/Devel.hs +++ b/Database/PostgreSQL/Devel.hs @@ -61,24 +61,30 @@ let conf = unlines $ addDirectives directives oldconf length conf `seq` writeFile confpath conf +singleQuote :: String -> String +singleQuote ('\'':t) = "''" ++ singleQuote t +singleQuote (h:t) = h : singleQuote t +singleQuote [] = "" + pgDirectives :: FilePath -> [(String, String)] pgDirectives dir = [ - ("unix_socket_directory", "unix_socket_directory = '" ++ q dir ++ "'") + ("unix_socket_directories" + , "unix_socket_directories = '" ++ singleQuote dir ++ "'") , ("logging_collector", "logging_collector = yes") , ("listen_addresses", "listen_addresses = ''")] - where q ('\'':t) = "''" ++ q t - q (h:t) = h : q t - q [] = "" +pgDirectives92 :: FilePath -> [(String, String)] +pgDirectives92 dir = map depluralize $ pgDirectives dir + where depluralize ("unix_socket_directories", _) = + ("unix_socket_directory" + , "unix_socket_directory = '" ++ singleQuote dir ++ "'") + depluralize kv = kv + -- | Create a directory for a local database cluster entirely -- self-contained within one directory. This is accomplished by -- creating a new PostgreSQL database cluster in the directory and -- setting the following configuration options in @postgresql.conf@: -- --- * @unix_socket_directory@ is set to the database directory itself, --- so that no permissions are required on global directories such as --- @\/var\/run@. --- -- * @listen_address@ is set to empty (i.e., @\'\'@), so that no TCP -- socket is bound, avoiding conflicts with any other running instaces -- of PostgreSQL. @@ -103,7 +109,10 @@ "## IMPORTANT: Run the following command before deleting this " ++ "directory ##\n\n" ++ "pg_ctl -D " ++ showCommandForUser dir' [] ++ " stop -m immediate\n\n" - configLocalDB dir $ pgDirectives dir' + version <- readFile (dir "PG_VERSION") + case reads version of + [(v, _)] | v < (9.3 :: Double) -> configLocalDB dir $ pgDirectives92 dir + _ -> configLocalDB dir $ pgDirectives dir systemNoStdout :: String -> [String] -> IO ExitCode systemNoStdout prog args = @@ -122,7 +131,7 @@ dir <- canonicalizePath dir0 (e0, _, _) <- readProcessWithExitCode "pg_ctl" ["status", "-D", dir] "" when (e0 /= ExitSuccess) $ do - e1 <- systemNoStdout "pg_ctl" ["start", "-w", "-D", dir] + e1 <- systemNoStdout "pg_ctl" [ "start", "-w", "-D", dir ] when (e1 /= ExitSuccess) $ fail "could not start postgres" return defaultConnectInfo { connectHost = dir , connectUser = "" diff --git a/Database/PostgreSQL/Migrate.hs b/Database/PostgreSQL/Migrate.hs --- a/Database/PostgreSQL/Migrate.hs +++ b/Database/PostgreSQL/Migrate.hs @@ -10,12 +10,14 @@ , runMigrationsForDir , runRollbackForDir , dumpDb + , newMigration , defaultMigrationsDir , MigrationDetails(..) ) where import Control.Monad import Data.List +import Data.Time import Database.PostgreSQL.Simple hiding (connect) import qualified Data.ByteString.Char8 as S8 import Database.PostgreSQL.Migrations @@ -26,9 +28,12 @@ import System.Directory import System.FilePath import System.Environment +import System.Locale import System.IO --- | The default relative path containing migrations: \".\/dir\/migrations\" +import Paths_postgresql_orm + +-- | The default relative path containing migrations: @\"db\/migrations\"@ defaultMigrationsDir :: FilePath defaultMigrationsDir = "db" "migrations" @@ -38,9 +43,12 @@ -- Therefore, /pg_dump/ must be installed on the system. dumpDb :: Handle -> IO ExitCode dumpDb outputFile = do - dbUrl <- getEnvironment >>= return . maybe "" id . lookup "DATABASE_URL" - (_, out, err, ph) <- runInteractiveProcess "pg_dump" - [dbUrl, "--schema-only", "-O", "-x"] Nothing Nothing + let opts = ["--schema-only", "-O", "-x"] + e <- getEnvironment + let args = case lookup "DATABASE_URL" e of + Just dburl -> dburl:opts + Nothing -> opts + (_, out, err, ph) <- runInteractiveProcess "pg_dump" args Nothing Nothing exitCode <- waitForProcess ph if exitCode /= ExitSuccess then do S8.hGetContents err >>= S8.hPut stderr @@ -57,7 +65,8 @@ initializeDb :: IO () initializeDb = do conn <- connectEnv - void $ execute_ conn "create table schema_migrations (version VARCHAR(28))" + void $ execute_ conn + "create table if not exists schema_migrations (version VARCHAR(28))" -- | Runs all new migrations in a given directory and dumps the -- resulting schema to a file \"schema.sql\" in the migrations @@ -93,9 +102,9 @@ -- | Run a migration. The returned exit code denotes the success or failure of -- the migration. runMigration :: MigrationDetails -> IO ExitCode -runMigration (MigrationDetails file version _) = do +runMigration (MigrationDetails file vers _) = do rawSystem "runghc" - [file, "up", version, "--with-db-commit"] + [file, "up", vers, "--with-db-commit"] runRollbackForDir :: FilePath -> IO ExitCode runRollbackForDir dir = do @@ -122,9 +131,9 @@ -- | Run a migration. The returned exit code denotes the success or failure of -- the migration. runRollback :: MigrationDetails -> IO ExitCode -runRollback (MigrationDetails file version _) = do +runRollback (MigrationDetails file vers _) = do rawSystem "runghc" - [file, "down", version, "--with-db-commit"] + [file, "down", vers, "--with-db-commit"] data MigrationDetails = MigrationDetails { migrationPath :: FilePath , migrationVersion :: String @@ -145,10 +154,18 @@ "":hd:result else ((chr:hd):result)) [""] fileName - version = head parts + vers = head parts name = concat $ intersperse "_" $ tail parts - in MigrationDetails (dir file) version name + in MigrationDetails (dir file) vers name isVersion :: (String -> Bool) -> MigrationDetails -> Bool isVersion cond (MigrationDetails _ v _) = cond v + +newMigration :: FilePath -> FilePath -> IO () +newMigration baseName dir = do + now <- getZonedTime + let filePath = (formatTime defaultTimeLocale "%Y%m%d%H%M%S" now) ++ + "_" ++ baseName ++ ".hs" + origFile <- getDataFileName "static/migration.hs" + copyFile origFile (dir filePath) diff --git a/Database/PostgreSQL/ORM/DBSelect.hs b/Database/PostgreSQL/ORM/DBSelect.hs --- a/Database/PostgreSQL/ORM/DBSelect.hs +++ b/Database/PostgreSQL/ORM/DBSelect.hs @@ -4,12 +4,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE RecordWildCards #-} module Database.PostgreSQL.ORM.DBSelect ( -- * The DBSelect structure DBSelect(..), FromClause(..) -- * Executing DBSelects , dbSelectParams, dbSelect + , Cursor(..), curSelect, curNext + , dbFold, dbFoldM, dbFoldM_ , renderDBSelect, buildDBSelect -- * Creating DBSelects , emptyDBSelect, expressionDBSelect @@ -21,6 +24,7 @@ , addWhere_, addWhere, setOrderBy, setLimit, setOffset, addExpression ) where +import Control.Monad.IO.Class import Blaze.ByteString.Builder import Blaze.ByteString.Builder.Char.Utf8 (fromChar) import qualified Data.ByteString as S @@ -28,7 +32,9 @@ import Data.Functor import Data.Monoid import Data.String +import Data.IORef import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import GHC.Generics @@ -286,6 +292,74 @@ dbSelect c dbs = map lookupRow <$> query_ c q where {-# NOINLINE q #-} q = renderDBSelect dbs + +-- | Datatype that represents a connected cursor +data Cursor a = Cursor { curConn :: !Connection + , curName :: !Query + , curChunkSize :: !Query + , curCache :: IORef [a] } + +-- | Create a 'Cursor' for the given 'DBSelect' +curSelect :: Model a => Connection -> DBSelect a -> IO (Cursor a) +curSelect c dbs = do + name <- newTempName c + execute_ c $ + mconcat [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ] + cacheRef <- newIORef [] + return $ Cursor c name "256" cacheRef + where q = renderDBSelect dbs + +-- | Fetch the next 'Model' for the underlying 'Cursor'. If the cache has +-- prefetched values, dbNext will return the head of the cache without querying +-- the database. Otherwise, it will prefetch the next 256 values, return the +-- first, and store the rest in the cache. +curNext :: Model a => Cursor a -> IO (Maybe a) +curNext Cursor{..} = do + cache <- readIORef curCache + case cache of + x:xs -> do + writeIORef curCache xs + return $ Just x + [] -> do + res <- map lookupRow <$> query_ curConn (mconcat + [ "FETCH FORWARD ", curChunkSize, " FROM ", curName]) + case res of + [] -> return Nothing + x:xs -> do + writeIORef curCache xs + return $ Just x + +-- | Streams results of a 'DBSelect' and consumes them using a left-fold. Uses +-- default settings for 'Cursor' (batch size is 256 rows). +dbFold :: Model model + => Connection -> (b -> model -> b) -> b -> DBSelect model -> IO b +dbFold c act initial dbs = do + cur <- curSelect c dbs + go cur initial + where go cur accm = do + mres <- curNext cur + case mres of + Nothing -> return accm + Just res -> go cur (act accm res) + +-- | Streams results of a 'DBSelect' and consumes them using a monadic +-- left-fold. Uses default settings for 'Cursor' (batch size is 256 rows). +dbFoldM :: (MonadIO m, Model model) + => Connection -> (b -> model -> m b) -> b -> DBSelect model -> m b +dbFoldM c act initial dbs = do + cur <- liftIO $ curSelect c dbs + go cur initial + where go cur accm = do + mres <- liftIO $ curNext cur + case mres of + Nothing -> return accm + Just res -> act accm res >>= go cur + +-- | Streams results of a 'DBSelect' and consumes them using a monadic +-- left-fold. Uses default settings for 'Cursor' (batch size is 256 rows). +dbFoldM_ :: (MonadIO m, Model model) + => Connection -> (model -> m ()) -> DBSelect model -> m () +dbFoldM_ c act dbs = dbFoldM c (const act) () dbs -- | Create a join of the 'selFields', 'selFrom', and 'selWhere' -- clauses of two 'DBSelect' queries. Other fields are simply taken diff --git a/Database/PostgreSQL/ORM/Model.hs b/Database/PostgreSQL/ORM/Model.hs --- a/Database/PostgreSQL/ORM/Model.hs +++ b/Database/PostgreSQL/ORM/Model.hs @@ -31,9 +31,9 @@ -- If these three conditions hold and your database naming scheme -- follows the conventions of 'defaultModelInfo'--namely that the -- table name is the same as the type name with the first character --- downcased, and the field names are the same as the column names-- --- then it is reasonable to have a completely empty (default) instance --- declaration: +-- downcased, and the field names are the same as the column +-- names--then it is reasonable to have a completely empty (default) +-- instance declaration: -- -- > data MyType = MyType { myKey :: !DBKey -- > , myName :: !S.ByteString @@ -107,6 +107,7 @@ import Control.Applicative import Control.Exception import Control.Monad +import qualified Data.Aeson as A import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import Data.Char @@ -155,6 +156,10 @@ -- to convert the `Model`'s primary key to a foreign key reference. data DBKey = DBKey !DBKeyType | NullKey deriving (Data, Typeable) +instance A.ToJSON DBKey where + toJSON NullKey = A.Null + toJSON (DBKey k) = A.toJSON k + instance Eq DBKey where (DBKey a) == (DBKey b) = a == b _ == _ = error "compare NullKey" @@ -188,6 +193,9 @@ newtype GDBRef reftype table = DBRef DBKeyType deriving (Eq, Data, Typeable, Num, Integral, Real, Ord, Enum, Bounded) +instance A.ToJSON (GDBRef t a) where + toJSON (DBRef k) = A.toJSON k + instance (Model t) => Show (GDBRef rt t) where showsPrec n (DBRef k) = showsPrec n k instance (Model t) => Read (GDBRef rt t) where @@ -655,9 +663,9 @@ -- If these three conditions hold and your database naming scheme -- follows the conventions of 'defaultModelInfo'--namely that the -- table name is the same as the type name with the first character --- downcased, and the field names are the same as the column names-- --- then it is reasonable to have a completely empty (default) instance --- declaration: +-- downcased, and the field names are the same as the column +-- names--then it is reasonable to have a completely empty (default) +-- instance declaration: -- -- > data MyType = MyType { myKey :: !DBKey -- > , myName :: !S.ByteString diff --git a/Database/PostgreSQL/ORM/Validations.hs b/Database/PostgreSQL/ORM/Validations.hs --- a/Database/PostgreSQL/ORM/Validations.hs +++ b/Database/PostgreSQL/ORM/Validations.hs @@ -1,7 +1,8 @@ -{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts, DeriveDataTypeable, OverloadedStrings #-} module Database.PostgreSQL.ORM.Validations where import Control.Exception +import Data.Aeson import qualified Data.Text as T import Data.Typeable import qualified Data.ByteString.Char8 as S8 @@ -9,6 +10,9 @@ data InvalidError = InvalidError { invalidColumn :: !S8.ByteString , invalidError :: !S8.ByteString } deriving (Show) + +instance ToJSON InvalidError where + toJSON ie = object ["column" .= invalidColumn ie, "error" .= invalidError ie] newtype ValidationError = ValidationError [InvalidError] deriving (Show, Typeable) diff --git a/pg_migrate.hs b/pg_migrate.hs --- a/pg_migrate.hs +++ b/pg_migrate.hs @@ -16,11 +16,15 @@ "migrate":dir:[] -> runMigrationsForDir stdout dir "rollback":[] -> runRollbackForDir defaultMigrationsDir "rollback":dir:[] -> runRollbackForDir dir + "new":name:[] -> newMigration name defaultMigrationsDir >> + return ExitSuccess + "new":name:dir:[] -> newMigration name dir >> return ExitSuccess _ -> do progName <- getProgName putStrLn $ "Usage: " ++ progName ++ " migrate|rollback [DIRECTORY]" putStrLn $ " " ++ progName ++ " init" putStrLn $ " " ++ progName ++ " dump [FILE]" + putStrLn $ " " ++ progName ++ " new NAME [DIRECTORY]" return $ ExitFailure 1 if ec == ExitSuccess then return () diff --git a/postgresql-orm.cabal b/postgresql-orm.cabal --- a/postgresql-orm.cabal +++ b/postgresql-orm.cabal @@ -1,14 +1,14 @@ name: postgresql-orm -version: 0.1 +version: 0.2 cabal-version: >= 1.14 build-type: Simple license: GPL license-file: LICENSE author: Amit Levy and David Mazieres maintainer: amit@amitlevy.com -category: Databases +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 +data-files: man/man1/pg_migrate.1 man/man5/pg_migrate.5 static/migration.hs description: An ORM (Object Relational Mapping) and migrations DSL for PostgreSQL. See "Database.PostgreSQL.ORM" for documentation. @@ -24,18 +24,22 @@ , filepath , ghc-prim , mtl + , old-locale , postgresql-simple , process + , time library default-language: Haskell2010 build-depends: base < 6 + , aeson , blaze-builder , bytestring , directory , filepath , ghc-prim , mtl + , old-locale , postgresql-simple , process , text diff --git a/static/migration.hs b/static/migration.hs new file mode 100644 --- /dev/null +++ b/static/migration.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} +import Database.PostgreSQL.Migrations +import Database.PostgreSQL.Simple + +up :: Connection -> IO () +up = migrate $ + error "Not implemented" + +down :: Connection -> IO () +down = migrate $ do + error "Not implemented" + +main :: IO () +main = defaultMain up down +