postgresql-orm 0.1 → 0.2
raw patch · 8 files changed
+166/−31 lines, 8 filesdep +aesondep +old-locale
Dependencies added: aeson, old-locale
Files
- Database/PostgreSQL/Devel.hs +19/−10
- Database/PostgreSQL/Migrate.hs +28/−11
- Database/PostgreSQL/ORM/DBSelect.hs +74/−0
- Database/PostgreSQL/ORM/Model.hs +14/−6
- Database/PostgreSQL/ORM/Validations.hs +5/−1
- pg_migrate.hs +4/−0
- postgresql-orm.cabal +7/−3
- static/migration.hs +15/−0
Database/PostgreSQL/Devel.hs view
@@ -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 = ""
Database/PostgreSQL/Migrate.hs view
@@ -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)
Database/PostgreSQL/ORM/DBSelect.hs view
@@ -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
Database/PostgreSQL/ORM/Model.hs view
@@ -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
Database/PostgreSQL/ORM/Validations.hs view
@@ -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)
pg_migrate.hs view
@@ -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 ()
postgresql-orm.cabal view
@@ -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
+ static/migration.hs view
@@ -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+