diff --git a/Data/GetField.hs b/Data/GetField.hs deleted file mode 100644 --- a/Data/GetField.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# LANGUAGE Safe #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -#if __GLASGOW_HASKELL__ < 710 -{-# LANGUAGE OverlappingInstances #-} -#endif -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE AllowAmbiguousTypes #-} --- ^ Enables the default implementation of Extractor as of GHC 8.0 -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Functions to extract a field of a particular type from a --- 'Generic' data structure, when the data structure contains exactly --- one field of the given type. Only works for types with exactly one --- constructor (not variant types). --- --- An example of usage: --- --- > data MyType = MyType { myString :: String -- position 0 --- > , myInt :: Int -- position 1 --- > , myBool :: Bool -- position 2 --- > , myMaybeChar :: Maybe Char -- position 3 --- > , myMaybeString :: Maybe String -- position 4 --- > } deriving (Show, Generic) --- > --- > myType :: MyType --- > myType = MyType "my type" 21 True Nothing (Just "maybe string") --- --- >>> getFieldVal ExtractId myType :: String --- "my type" --- >>> getFieldVal ExtractId myType :: Int --- 21 --- >>> getFieldVal ExtractMaybe myType :: Maybe Char --- Nothing --- >>> getFieldVal ExtractMaybe myType :: Maybe Int --- Just 21 --- >>> getFieldVal ExtractMaybe myType :: Maybe String -- ambiguous --- :5:1: Couldn't match type `THasMany' with `THasOne' --- >>> getFieldPos' ExtractId (undefined :: MyType) (undefined :: Bool) --- 2 --- >>> getFieldPos' ExtractMaybe (undefined :: MyType) (undefined :: Maybe Bool) --- 2 --- >>> getFieldPos' ExtractMaybe myType () -- No field has type () --- :8:1: Couldn't match type `THasNone' with `THasOne' -module Data.GetField ( - GetField(..), ExtractId(..), ExtractMaybe(..), getFieldPos' - -- * Internals - , THasOne(..), THasNone(..), THasMany(..), Extractor(..), GGetField(..) - ) where - -import GHC.Generics - --- | Dirty trick to construct "less specific" overlapping instances by --- making a class argument a simple type variable, but constraining --- that variable to be a particular type. E.g., neither of the --- following two instances is more specific than the other, because --- @NO@ is not more general than @YES@: --- --- > class MyClass a b c | a b -> c where myClass :: a -> b -> c () --- > instance MyClass a a YES where myClass _ _ = YES () --- > instance MyClass a b NO where myClass _ _ = NO () --- --- Hence, attempting to use the first instance will generate a --- compilation error rather than inferring the type of c as YES. On --- the other hand, of the following two instances, the first is more --- specific than the second: --- --- > instance MyClass a a YES where --- > myClass _ _ = YES () --- > instance (TypeGCast NO c) => MyClass a b c where --- > myClass _ _ = typeGCast $ NO () --- --- That's because @c@ is more general than @YES@. The key to this --- working is that an instance context--i.e., @(TypeGCast NO c)@--is --- never consulted during instance selection, only to validate an --- already-selected most-specific instance. --- --- Note that @YES@ and @NO@ in these examples have kind @* -> *@. --- Hence the @G@ in @TypeGCast@. The same trick is equally applicable --- to types of kind @*@, we just don't happen to need that in this --- module. -class TypeGCast f g | f -> g where - typeGCast :: f p -> g p -instance TypeGCast f f where - typeGCast = id - --- | Exactly one matching field has been found. -newtype THasOne a = THasOne { fromTHasOne :: a } deriving (Show) --- | Zero matching fields have been found. -data THasNone a = THasNone deriving (Show) --- | More than one matching field has been found. -newtype THasMany a = THasMany { fromTHasMany :: [a] } deriving (Show) - -class GCombine a b c | a b -> c where - gCombine :: a p -> b p -> c p -instance GCombine THasOne THasNone THasOne where - {-# INLINE gCombine #-} - gCombine j _ = j -instance GCombine THasNone THasOne THasOne where - {-# INLINE gCombine #-} - gCombine _ j = j -instance GCombine THasNone THasNone THasNone where - -- Should never be evaluated, so no need to inline it - gCombine _ _ = THasNone -instance GCombine THasOne THasOne THasMany where - {-# INLINE gCombine #-} - gCombine (THasOne a) (THasOne b) = THasMany [a,b] -instance GCombine THasMany THasMany THasMany where - {-# INLINE gCombine #-} - gCombine (THasMany as) (THasMany bs) = THasMany (as ++ bs) -instance GCombine THasNone THasMany THasMany where - {-# INLINE gCombine #-} - gCombine _ hm = hm -instance GCombine THasMany THasNone THasMany where - {-# INLINE gCombine #-} - gCombine hm _ = hm -instance GCombine THasOne THasMany THasMany where - {-# INLINE gCombine #-} - gCombine (THasOne a) (THasMany as) = THasMany (a:as) -instance GCombine THasMany THasOne THasMany where - {-# INLINE gCombine #-} - gCombine (THasMany as) (THasOne a) = THasMany (as++[a]) - -class GCount f where gCount :: f p -> (Int, [Int]) -instance GCount THasOne where gCount _ = (1, [0]) -instance GCount THasMany where gCount _ = (1, [0]) -instance GCount THasNone where gCount _ = (1, []) - --- | Class of types used as tag arguments to 'gGetFieldVal' and --- 'gGetFieldPos'. @f@ should be a new unit type of kind @* -> *@, --- used to designate the type of extraction you want. Then instances --- should be defined to transform each type @a@ you want to extract to --- some type @r@, with @g@ set to 'THasOne'. --- --- For example, 'ExtractMaybe' is a type to convert types @a@ and --- @Maybe a@ both to type @Maybe a@ (i.e., type argument @r@ is @Maybe --- a@). --- --- > data ExtractMaybe a = ExtractMaybe --- > instance Extractor ExtractMaybe a (Maybe a) THasOne where --- > extract _ = THasOne . Just --- > instance Extractor ExtractMaybe (Maybe a) (Maybe a) THasOne where --- > extract _ = THasOne --- --- Note that there is already a default general instance returning --- 'THasNone'. Hence, you do not need to define one. Otherwise, you --- would have to define an overlapping instance such as: --- --- > instance Extractor ExtractMaybe a b THasZero where -- Incorrect --- > extract _ = THasNone --- --- (Except the above wouldn't quite work anyway given the rules for --- overlapping instances.) So just assume that any instance you don't --- explicitly define for your 'Extractor' will automatically fall back --- to 'THasNone'. -class Extractor f a r g | f a r -> g where - extract :: f r -> a -> g r - extractCount :: f r -> a -> (Int, [Int]) - default extractCount :: (GCount g) => f r -> a -> (Int, [Int]) - extractCount fr a = gCount (extract fr a) -instance - {-# OVERLAPPABLE #-} - (TypeGCast THasNone g) => Extractor f a r g where - extract _ _ = typeGCast THasNone - extractCount _ _ = gCount THasNone - --- | Generlized extraction of a field from a 'Generic' data structure. --- Argument @rep@ should generally be the type @'Rep' t@ for some data --- type @t@ whose fields you want to extract. @r@ is the result type --- you want back from the extraction. @f@ should be defined such that --- there is an instance of @'Extractor' f a r THasOne@ for each type --- @a@ you want to convert to @r@ and extract. -class GGetField f rep r g | f rep r -> g where - gGetFieldVal :: f r -> rep p -> g r - -- ^ Returns zero, one, or multiple values of type @f@ wrapped in - -- 'THasOne', 'THasNone', or 'THasMany' respectively. - gGetFieldPos :: f r -> rep p -> (Int, [Int]) - -- ^ Returns @(total, positions)@ where @total@ is the total number - -- of fields (matching or not) in the structure and @positions@ is a - -- list of zero-based field numbers of the fields matching target - -- type @f r@. -instance (Extractor f c r g) => GGetField f (K1 i c) r g where - {-# INLINE gGetFieldVal #-} - gGetFieldVal f (K1 c) = extract f c - gGetFieldPos f (K1 c) = extractCount f c -instance (GGetField f a1 r g1, GGetField f a2 r g2, GCombine g1 g2 g) => - GGetField f (a1 :*: a2) r g where - {-# INLINE gGetFieldVal #-} - gGetFieldVal f (a1 :*: a2) = - gCombine (gGetFieldVal f a1) (gGetFieldVal f a2) - gGetFieldPos f ~(a1 :*: a2) = (n1 + n2, p1 ++ map (n1 +) p2) - where (n1, p1) = gGetFieldPos f a1 - (n2, p2) = gGetFieldPos f a2 -instance (GGetField f a r g) => GGetField f (M1 i c a) r g where - {-# INLINE gGetFieldVal #-} - gGetFieldVal f (M1 a) = gGetFieldVal f a - gGetFieldPos f ~(M1 a) = gGetFieldPos f a - - -class (Generic a, GGetField f (Rep a) r THasOne) => GetField f a r where - -- | Extract the single field matching 'Extractor' @f r@ from a - -- 'Generic' data structure @a@ with exactly one constructor. - getFieldVal :: f r -> a -> r - -- | Extract the 0-based position of the single field matching - -- 'Extractor' @f r@ within 'Generic' data structure @a@. - -- Non-strict in both arguments. - getFieldPos :: f r -> a -> Int -instance (Generic a, GGetField f (Rep a) r THasOne) => GetField f a r where - {-# INLINE getFieldVal #-} - getFieldVal f a = fromTHasOne $ gGetFieldVal f (from a) - getFieldPos f a = head $ snd $ gGetFieldPos f (from a) - --- | A variant of 'getFieldPos' in which the type of the field is --- supplied as a non-strict argument. This may be easier than --- typecasting the extractor argument. For example, to extract the --- 'Int' from a structure with a single 'Int' field: --- --- @ --- getFieldPos' 'ExtractId' myStruct ('undefined' :: 'Int') --- @ -getFieldPos' :: (Generic a, GGetField f (Rep a) r THasOne) => - (f ()) -> a -> r -> Int -getFieldPos' f a r = getFieldPos (fixType f r) a - where fixType :: f () -> r -> f r - fixType _ _ = undefined - --- | An extractor that matches an exact field type. -data ExtractId r = ExtractId deriving (Show) -instance Extractor ExtractId a a THasOne where - {-# INLINE extract #-} - extract _ = THasOne - --- | An extractor that matches either type @r@ or type @Maybe r@, and, --- in the former case, wraps @Just@ around the value so as always to --- return type @Maybe r@. -data ExtractMaybe r = ExtractMaybe -instance Extractor ExtractMaybe a (Maybe a) THasOne where - {-# INLINE extract #-} - extract _ = THasOne . Just -instance Extractor ExtractMaybe (Maybe a) (Maybe a) THasOne where - {-# INLINE extract #-} - extract _ = THasOne - diff --git a/Data/RequireSelector.hs b/Data/RequireSelector.hs deleted file mode 100644 --- a/Data/RequireSelector.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances, CPP #-} - -module Data.RequireSelector (RequireSelector) where - -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 800) -import GHC.Generics - --- | There are intentionally no members of this class, so that placing --- it in a context will always cause an error. -class IntentionallyCauseError a -#endif - --- | The point of this class is to ensure that you are using data --- types defined with record selectors (i.e., @data Foo = Foo { unFoo --- :: Int }@ as opposed to @data Foo = Foo Int@). --- --- Unfortunately, "GHC.Generics" makes the 'NoSelector' type a member --- of the 'Selector' class. Hence, if you want to ensure a type @a@ --- is /not/ 'NoSelector', use the context @(RequireSelector a) =>@. --- --- If you see a compilation error involving @RequireSelector@ or --- @IntentionallyCauseError@, it means you failed to define one of --- your datatypes using record selector syntax. -class RequireSelector a -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 800) -instance (IntentionallyCauseError NoSelector) => RequireSelector NoSelector -#endif -instance RequireSelector a diff --git a/Database/PostgreSQL/Describe.hs b/Database/PostgreSQL/Describe.hs deleted file mode 100644 --- a/Database/PostgreSQL/Describe.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Utility function for describing a table in the database. -module Database.PostgreSQL.Describe ( - ColumnInfo(..), describeTable - ) where - -import Control.Monad -import qualified Data.ByteString as S -import Data.Int -import qualified Data.Vector as V -import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PG -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.TypeInfo -import Database.PostgreSQL.Simple.Types - -data ColumnInfo = ColumnInfo { - colNum :: !Int16 - -- ^ Internal column number used by PostgreSQL. Generally these - -- will be consecutive starting from 1, but this may not be the - -- case if you have altered a table to delete columns. - , colName :: S.ByteString - -- ^ Name of the column - , colType :: !TypeInfo - -- ^ Type of the column - , colNotNull :: !Bool - -- ^ If 'True', the database cannot contain null. (This - -- constraint should always be accurate.) - , colPrimary :: !Bool - -- ^ 'True' if this column (and only this column) constitutes the - -- primary key of the table. Always 'False' if the primary key - -- comprises multiple columns (even if this is one of those - -- columns). - , colUnique :: !Bool - -- ^ 'True' if there is a uniqueness constraint on this column. - -- Not 'True' if this column is part of a uniqueness constraint - -- involving multiple columns. (Such multi-column uniqueness - -- constraints are not reported by this interface.) - , colReferences :: !(Maybe S.ByteString) - -- ^ If this there is a foreign key constraint on this column (and - -- the constraint does not span multiple columns), report the - -- table referenced by this column. - } deriving (Show) - -defColInfo :: ColumnInfo -defColInfo = ColumnInfo { - colNum = 0 - , colName = S.empty - , colType = PG.void - , colNotNull = False - , colPrimary = False - , colUnique = False - , colReferences = Nothing - } - --- | Returns a list of 'ColumnInfo' structures for a particular table. --- Not all information about a table is returned. In particular, --- constraints that span columns are ignored. -describeTable :: Connection -> S.ByteString -> IO [ColumnInfo] -describeTable cn t = do - [(Only tbloid)] <- query cn "select oid from pg_class where relname = ?" - (Only t) - cs0 <- query cn "select attnum, attname, atttypid, attnotnull\ - \ from pg_attribute\ - \ where attrelid = ? and attisdropped = 'f' and attnum > 0\ - \ order by attnum" - (Only (tbloid :: Oid)) - cs1 <- forM cs0 $ \ (num, name, typ, notnull) -> do - ti <- getTypeInfo cn typ - return defColInfo { - colNum = num, colName = name, colType = ti, colNotNull = notnull - } - constraints <- query cn "select contype, conkey, relname\ - \ from pg_constraint left join pg_class\ - \ on confrelid = pg_class.oid\ - \ where conrelid = ?" - (Only tbloid) - let _ = constraints :: [(String, V.Vector Int16, Maybe S.ByteString)] - return $ map (\c -> foldl appConstr c constraints) cs1 - where appConstr ci (ct, ck, mn) - | V.length ck == 1, colNum ci == ck V.! 0 = appConstr1 ci ct mn - | otherwise = ci - appConstr1 ci "p" _ = ci { colPrimary = True } - appConstr1 ci "u" _ = ci { colUnique = True } - appConstr1 ci "f" n@(Just _) = ci { colReferences = n } - appConstr1 ci _ _ = ci diff --git a/Database/PostgreSQL/Devel.hs b/Database/PostgreSQL/Devel.hs deleted file mode 100644 --- a/Database/PostgreSQL/Devel.hs +++ /dev/null @@ -1,218 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Functions for initializing self-contained local postgreSQL --- database clusters (useful in development more than production). -module Database.PostgreSQL.Devel ( - createLocalDB, configLocalDB, startLocalDB - , initLocalDB, stopLocalDB, setLocalDB - , withTempDB - , resetConnection - ) where - -import Control.Exception -import Control.Monad -#if __GLASGOW_HASKELL__ < 710 -import Data.Functor -#endif -import Data.List -import Database.PostgreSQL.Simple -import System.Directory -import System.Exit -import System.FilePath -import System.IO -import System.IO.Error -import System.Posix.Env -import System.Posix.Temp -import System.Process - -isNonEmptyDir :: FilePath -> IO Bool -isNonEmptyDir dir = - catchJust (\e -> if isDoesNotExistError e then Just () else Nothing) - ((> 2) . length <$> getDirectoryContents dir) - (const $ return False) - -addDirectives :: [(String, String)] -> [String] -> [String] -addDirectives directives [] = map snd directives -addDirectives directives (cl:cls) - | Just l <- lookup directive directives = - (if comment then [l, cl] else [l]) ++ - addDirectives (directives \\ [(directive,l)]) cls - | otherwise = cl : addDirectives directives cls - where (comment, directive) - | '#':clr <- cl, [(d,_)] <- lex clr = (True, d) - | [(d,_)] <- lex cl = (False, d) - | otherwise = (False, "") - --- | Set configuration parameters on a database by editing the --- @postgresql.conf@ file. Takes the database directory and a list of --- @(@/parameter/@,@ /full-line/@)@ pairs. For example, when creating --- a throw-away database cluster you later intend to discard, you --- might say: --- --- > configLocalDB dbpath [("fsync", "fsync = off")] --- --- Note that the second element of each pair is the complete --- configuration line. It is not correct to say: --- --- > configLocalDB dbpath [("fsync", "off")] -- INCORRECT --- -configLocalDB :: FilePath -> [(String, String)] -> IO () -configLocalDB dir directives = do - let confpath = dir "postgresql.conf" - oldconf <- lines <$> readFile confpath - 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_directories" - , "unix_socket_directories = '" ++ singleQuote dir ++ "'") - , ("logging_collector", "logging_collector = yes") - , ("listen_addresses", "listen_addresses = ''")] - -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@: --- --- * @listen_address@ is set to empty (i.e., @\'\'@), so that no TCP --- socket is bound, avoiding conflicts with any other running instaces --- of PostgreSQL. --- --- * @logging_collector@ is set to @yes@, so that all message logs are --- kept in the @pg_log@ subdirectory of the directory you specified. --- --- Note this function does /not/ start a postgres server after --- creating the directory. You will seperately need to start the --- server using 'startLocalDB' or 'initLocalDB'. (And note that --- 'initLocalDB' already calls @createLocalDB@ if the directory does --- not exist or is empty. Hence the primary use of this function is --- if you want to call 'configLocalDB' between 'createLocalDB' and --- 'startLocalDB'.) -createLocalDB :: FilePath -> IO () -createLocalDB dir = do - (exit, _, err) <- readProcessWithExitCode "pg_ctl" - ["-D", dir, "-o", "--no-locale", "init"] "" - when (exit /= ExitSuccess) $ fail err - dir' <- canonicalizePath dir - writeFile (dir "README_BEFORE_DELETING") $ - "## IMPORTANT: Run the following command before deleting this " ++ - "directory ##\n\n" ++ - "pg_ctl -D " ++ showCommandForUser dir' [] ++ " stop -m immediate\n\n" - 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 = - bracket (openFile "/dev/null" ReadWriteMode) hClose $ \devnull -> do - let cp = (proc prog args) { std_in = UseHandle devnull - , std_out = UseHandle devnull } - (_,_,_,pid) <- createProcess cp - waitForProcess pid - --- | Start a local database if the server is not already running. --- Otherwise, does nothing, but returns a 'ConnectInfo' in either --- case. The database server will continue running after the current --- process exits (but see 'stopLocalDB'). -startLocalDB :: FilePath -> IO ConnectInfo -startLocalDB dir0 = do - dir <- canonicalizePath dir0 - (e0, _, _) <- readProcessWithExitCode "pg_ctl" ["status", "-D", dir] "" - when (e0 /= ExitSuccess) $ do - e1 <- systemNoStdout "pg_ctl" [ "start", "-w", "-D", dir ] - when (e1 /= ExitSuccess) $ fail "could not start postgres" - return defaultConnectInfo { connectHost = dir - , connectUser = "" - , connectDatabase = "postgres" - } - --- | A combination of 'createLocalDB' and 'startLocalDB'. --- --- The parameter is a PostgreSQL data directory. If the directory is --- empty or does not exist, this function creates a new database --- cluster (via 'createLocalDB'). Then, if a database server is not --- already running for the directory, starts a server. No matter --- what, returns a 'ConnectInfo' that will connect to the server --- running on this local database. --- --- Note that if @initLocalDB@ starts a postgres server, the server --- process will continue running after the process that called --- @initLocalDB@ exits. This is normally fine. Since multiple client --- processes may access the same PostgreSQL database, it makes sense --- for the first client to start the database and no one to stop it. --- See 'stopLocalDB' if you wish to stop the server process (which you --- should always do before deleting a test cluster). See also --- 'withTempDB' to create a temporary cluster for the purposes of --- running a test suite. -initLocalDB :: FilePath -> IO ConnectInfo -initLocalDB dir = do - exists <- isNonEmptyDir dir - unless exists $ createLocalDB dir - startLocalDB dir - --- | Stop the server for a local database cluster entirely --- self-contained within one directory. You must call this before --- deleting the directory, or else stray postgres processes will --- linger forever. If the argument is the empty string, looks for the --- database directory in the @PGDATA@ environment variable. -stopLocalDB :: FilePath -> IO () -stopLocalDB dir0 = do - dir <- if not (null dir0) then return dir0 else do - mpgd <- getEnv "PGDATA" - case mpgd of Just pgd -> return pgd - _ -> fail "stopLocalDB: must specify database" - e <- systemNoStdout "pg_ctl" ["stop", "-D", dir, "-m", "fast"] - when (e /= ExitSuccess) $ fail "could not stop postgres" - --- | Set environment variables to make a local database cluster the --- default. Also returns shell commands you can eval or cut-and-paste --- into your shell to make @pg_ctl@ and @psql@ access a local database --- cluster. -setLocalDB :: FilePath -> IO String -setLocalDB dir0 = do - dir1 <- canonicalizePath dir0 - setEnv "PGHOST" dir1 True - setEnv "PGDATA" dir1 True - setEnv "PGDATABASE" "postgres" True - let dir = showCommandForUser dir1 [] - msh <- getEnv "SHELL" - return $ case msh of Just sh | isSuffixOf "csh" sh -> - "setenv PGDATA " ++ dir ++ "; setenv PGHOST " ++ dir - _ -> "export PGDATA=" ++ dir ++ " PGHOST=" ++ dir - --- | Run a function with a completely fresh database cluster that gets --- deleted on return. Since the entire database is blown away when --- the function returns, @withTempDB@ is obviously only useful for --- test suites. -withTempDB :: (ConnectInfo -> IO a) -> IO a -withTempDB f = bracket createdir removeDirectoryRecursive $ \d -> - flip finally (stopLocalDB d) $ do - createLocalDB d - configLocalDB d [("fsync", "fsync = off") - , ("synchronous_commit", "synchronous_commit = off") - , ("full_page_writes", "full_page_writes = off")] - initLocalDB d >>= f - where createdir = do - tmp <- getTemporaryDirectory - mkdtemp $ tmp "db." - --- | Reset a connection to its default state before re-cycling it for --- another thread or request. -resetConnection :: Connection -> IO () -resetConnection c = (void $ execute_ c "DISCARD ALL") `catch` \SqlError{} -> - void $ execute_ c "ROLLBACK" >> execute_ c "DISCARD ALL" diff --git a/Database/PostgreSQL/Escape.hs b/Database/PostgreSQL/Escape.hs deleted file mode 100644 --- a/Database/PostgreSQL/Escape.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE CPP #-} - -#include "MachDeps.h" - --- | This module deals with escaping and sanitizing SQL templates. -module Database.PostgreSQL.Escape ( - fmtSql, quoteIdent - , buildSql, buildSqlFromActions - , buildAction, buildLiteral, buildByteA, buildIdent - ) where - -import Blaze.ByteString.Builder.Internal.Write -import Data.ByteString.Builder -import Data.ByteString.Builder.Internal -import Data.ByteString.Lazy (toStrict) -import qualified Data.ByteString as S -import qualified Data.ByteString.Internal as S -import qualified Data.ByteString.Unsafe as S -import Data.Monoid -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.ToField -import Database.PostgreSQL.Simple.ToRow -import Database.PostgreSQL.Simple.Types -import Foreign.Marshal.Alloc (mallocBytes) -import Foreign.Storable (pokeByteOff) -import Foreign.Ptr -import GHC.Prim (Addr#, and#, geAddr#, geWord#, Int#, int2Word# - , minusAddr#, ord# , plusAddr#, readWord8OffAddr# - , State# , uncheckedShiftRL#, word2Int#, writeWord8OffAddr# - , Word#) -import GHC.Ptr (Ptr(Ptr)) -import GHC.Types (Char(C#), Int(I#), IO(IO)) -import GHC.Word (Word8(W8#)) -import System.IO.Unsafe (unsafeDupablePerformIO) - -{-# INLINE cmpres #-} --- | Newer versions of GHC return an Int# instead of a Bool for --- primitive comparison functions. The @cmpres@ function converts the --- result of such a comparison to a @Bool@. -#if __GLASGOW_HASKELL__ >= 707 -cmpres :: Int# -> Bool -cmpres 0# = False -cmpres _ = True -#else /* __GLASGOW_HASKELL__ < 707 */ -cmpres :: Bool -> Bool -cmpres b = b -#define cmpres(b) b -#endif /* __GLASGOW_HASKELL__ < 707 */ - -c2b :: Char -> Word8 -c2b (C# i) = W8# (int2Word# (ord# i)) - -c2b# :: Char -> Word# -c2b# (C# i) = int2Word# (ord# i) - -inlinePerformIO :: IO a -> a -#if MIN_VERSION_bytestring(0,10,6) -inlinePerformIO = S.accursedUnutterablePerformIO -#else -inlinePerformIO = S.inlinePerformIO -#endif - -fastFindIndex :: (Word# -> Bool) -> S.ByteString -> Maybe Int -{-# INLINE fastFindIndex #-} -fastFindIndex test bs = - inlinePerformIO $ S.unsafeUseAsCStringLen bs $ \(Ptr bsp0, I# bsl0) -> do - let bse = bsp0 `plusAddr#` bsl0 - check bsp = IO $ \rw -> case readWord8OffAddr# bsp 0# rw of - (# rw1, w #) -> (# rw1, test w #) - go bsp | cmpres(bsp `geAddr#` bse) = return Nothing - | otherwise = do - match <- check bsp - if match - then return $ Just $ I# (bsp `minusAddr#` bsp0) - else go (bsp `plusAddr#` 1#) - go bsp0 - -fastBreak :: (Word# -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString) -{-# INLINE fastBreak #-} -fastBreak test bs - | Just n <- fastFindIndex test bs = (S.unsafeTake n bs, S.unsafeDrop n bs) - | otherwise = (bs, S.empty) - -quoter :: S.ByteString -> S.ByteString -> (Word# -> Bool) - -> (Word8 -> Builder) -> S.ByteString -> Builder -{-# INLINE quoter #-} -quoter start end escPred escFn bs0 = - mconcat [byteStringCopy start, escaped bs0, byteStringCopy end] - where escaped bs = case fastBreak escPred bs of - (h, t) | S.null t -> byteString h - | otherwise -> byteString h <> - escFn (S.unsafeHead t) <> - escaped (S.unsafeTail t) - --- | Quote an identifier using unicode quoting syntax. This is --- necessary for identifiers containing a question mark, as otherwise --- "PostgreSQL.Simple"'s naive formatting code will attempt to match --- the question mark to a paremeter. -uBuildIdent :: S.ByteString -> Builder -uBuildIdent ident = quoter " U&\"" "\"" isSpecial esc ident - where isSpecial 34## = True -- '"' - isSpecial 63## = True -- '?' - isSpecial 92## = True -- '\\' - isSpecial _ = False - esc c = byteStringCopy $ case () of - _ | c == c2b '"' -> "\"\"" - | c == c2b '?' -> "\\003f" - | c == c2b '\\' -> "\\\\" - | otherwise -> error "uquoteIdent" - --- | Build a quoted identifier. Generally you will want to use --- 'quoteIdent', and for repeated use it will be faster to use --- @'byteString' . 'quoteIdent'@, but this internal function is --- exposed in case it is useful. -buildIdent :: S.ByteString -> Builder -buildIdent ident - | Just _ <- fastFindIndex isQuestionmark ident = uBuildIdent ident - | otherwise = quoter "\"" "\"" isDQuote (const $ byteStringCopy "\"\"") ident - where isQuestionmark 63## = True - isQuestionmark 0## = error "quoteIdent: illegal NUL character" - isQuestionmark _ = False - isDQuote 34## = True - isDQuote _ = False - --- | Quote an identifier such as a table or column name using --- double-quote characters. Note this has nothing to do with quoting --- /values/, which must be quoted using single quotes. (Anyway, all --- values should be quoted by 'query' or 'fmtSql'.) This function --- uses a unicode escape sequence to escape \'?\' characters, which --- would otherwise be expanded by 'query', 'formatQuery', or 'fmtSql'. --- --- >>> S8.putStrLn $ quoteIdent "hello \"world\"!" --- "hello ""world""!" --- >>> S8.putStrLn $ quoteIdent "hello \"world\"?" --- U&"hello ""world""\003f" --- --- Note that this quoting function is correct only if --- @client_encoding@ is @SQL_ASCII@, @client_coding@ is @UTF8@, or the --- identifier contains no multi-byte characters. For other coding --- schemes, this function may erroneously duplicate bytes that look --- like quote characters but are actually part of a multi-byte --- character code. In such cases, maliciously crafted identifiers --- will, even after quoting, allow injection of arbitrary SQL commands --- to the server. --- --- The upshot is that it is unwise to use this function on identifiers --- provided by untrustworthy sources. Note this is true anyway, --- regardless of @client_encoding@ setting, because certain \"system --- column\" names (e.g., @oid@, @tableoid@, @xmin@, @cmin@, @xmax@, --- @cmax@, @ctid@) are likely to produce unexpected results even when --- properly quoted. --- --- See 'Id' for a convenient way to include quoted identifiers in --- parameter lists. -quoteIdent :: S.ByteString -> S.ByteString -quoteIdent = toStrict . toLazyByteString . buildIdent - -hexNibblesPtr :: Ptr Word8 -{-# NOINLINE hexNibblesPtr #-} -hexNibblesPtr = unsafeDupablePerformIO $ do - ptr <- mallocBytes 16 - sequence_ $ zipWith (\o v -> pokeByteOff ptr o $ c2b v) - [0..] (['0'..'9'] ++ ['a'..'f']) - return ptr - --- | Bad things will happen if the argument is greater than 0xff. -uncheckedWriteNibbles# :: Addr# -> Word# -> State# d -> State# d -{-# INLINE uncheckedWriteNibbles# #-} -uncheckedWriteNibbles# p w rw0 = - case (# word2Int# (w `uncheckedShiftRL#` 4# ) - , word2Int# (w `and#` 0xf## ) #) of { (# h, l #) -> - case readWord8OffAddr# nibbles h rw0 of { (# rw1, hascii #) -> - case writeWord8OffAddr# p 0# hascii rw1 of { rw2 -> - case readWord8OffAddr# nibbles l rw2 of { (# rw3, lascii #) -> - writeWord8OffAddr# p 1# lascii rw3 }}}} - where !(Ptr nibbles) = hexNibblesPtr - -hexCharEscBuilder :: Word8 -> Builder -{-# INLINE hexCharEscBuilder #-} -hexCharEscBuilder (W8# w) = fromWrite $ exactWrite 4 $ \(Ptr p) -> IO $ \rw0 -> - (# uncheckedWriteNibbles# (p `plusAddr#` 2#) w - (writeWord8OffAddr# p 1# (c2b# 'x') - (writeWord8OffAddr# p 0# (c2b# '\\') rw0)) - , () #) - -buildLiteral :: S.ByteString -> Builder -buildLiteral = quoter " E'" "'" isSpecial esc - where isSpecial 39## = True -- '\'' - isSpecial 63## = True -- '?' - isSpecial 92## = True -- '\\' - isSpecial b = cmpres(b `geWord#` 128##) - esc b | b == c2b '\'' = byteStringCopy "''" - | b == c2b '\\' = byteStringCopy "\\\\" - | otherwise = hexCharEscBuilder b - - -copyByteToNibbles :: Addr# -> Addr# -> IO () -{-# INLINE copyByteToNibbles #-} -copyByteToNibbles src dst = IO $ \rw0 -> - case readWord8OffAddr# src 0# rw0 of - (# rw1, w #) -> (# uncheckedWriteNibbles# dst w rw1, () #) - -buildByteA :: S.ByteString -> Builder -buildByteA bs = equote $ - builder $ \cont (BufferRange (Ptr bb0) (Ptr be0)) -> - S.unsafeUseAsCStringLen bs $ \(Ptr inptr0, I# inlen0) -> do - let ine = plusAddr# inptr0 inlen0 - fill oute inp outp - | cmpres(inp `geAddr#` ine) = cont (BufferRange (Ptr outp) (Ptr oute)) - | cmpres(plusAddr# outp 2# `geAddr#` oute) = return $ - bufferFull (2 * (I# (ine `minusAddr#` inp)) + 1) (Ptr outp) $ - \(BufferRange (Ptr bb) (Ptr be)) -> fill be inp bb - | otherwise = do copyByteToNibbles inp outp - fill oute (inp `plusAddr#` 1#) (outp `plusAddr#` 2#) - fill be0 inptr0 bb0 - where equote b = mconcat [byteString " E'\\\\x", b, char8 '\''] - - - -buildAction :: Action -> Builder -buildAction (Plain b) = b -buildAction (Escape bs) = buildLiteral bs -buildAction (EscapeByteA bs) = buildByteA bs -buildAction (EscapeIdentifier bs) = buildIdent bs -buildAction (Many bs) = mconcat $ map buildAction bs - --- | A lower-level function used by 'buildSql' and 'fmtSql'. You --- probably don't need to call it directly. -buildSqlFromActions :: Query -> [Action] -> Builder -buildSqlFromActions (Query template) actions = - intercatlate (split template) (map buildAction $ actions) - where intercatlate (t:ts) (p:ps) = t <> p <> intercatlate ts ps - intercatlate [t] [] = t - intercatlate _ _ = - error $ "buildSql: wrong number of parameters for " ++ show template - split s = case S.break (== c2b '?') s of - (h,t) | S.null t -> [byteString h] - | otherwise -> byteString h : split (S.unsafeTail t) - --- | A builder version of 'fmtSql', possibly useful if you are about --- to concatenate various individually formatted query fragments and --- want to save the work of concatenating each individually. -buildSql :: (ToRow p) => Query -> p -> Builder -{-# INLINE buildSql #-} -buildSql q p = buildSqlFromActions q (toRow p) - --- | Take a SQL template containing \'?\' characters and a list of --- paremeters whose length must match the number of \'?\' characters, --- and format the result as an escaped 'S.ByteString' that can be used --- as a query. --- --- Like 'formatQuery', this function is naive about the placement of --- \'?\' characters and will expand all of them, even ones within --- quotes. To avoid this, you must use 'quoteIdent' on identifiers --- containing question marks. --- --- Also like 'formatQuery', \'?\' characters touching other \'?\' --- characters or quoted strings may do the wrong thing, and end up --- doubling a quote, so avoid substrings such as @\"??\"@ or --- @\"?'string'\"@, as these could get expanded to, e.g., --- @\"\'param''string'\"@, which is a single string containing an --- apostrophe, when you probably wanted two strings. -fmtSql :: (ToRow p) => Query -> p -> Query -{-# INLINE fmtSql #-} -fmtSql q p = Query $ toStrict . toLazyByteString $ buildSql q p diff --git a/Database/PostgreSQL/Migrate.hs b/Database/PostgreSQL/Migrate.hs deleted file mode 100644 --- a/Database/PostgreSQL/Migrate.hs +++ /dev/null @@ -1,172 +0,0 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} - --- | Functions for creating and running database migrations. You should --- probably be using the `pg_migrate` executable to run migrations, however --- these functions are exposed for developers that want to integrate migrations --- more tightly into their applications or utilities. - -module Database.PostgreSQL.Migrate - ( initializeDb - , 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 -import System.Exit -import GHC.IO.Handle -import System.Process -import System.Directory -import System.FilePath -import System.Environment -import System.IO -#if !MIN_VERSION_time(1,5,0) -import System.Locale -#endif - -import Paths_postgresql_orm - --- | The default relative path containing migrations: @\"db\/migrations\"@ -defaultMigrationsDir :: FilePath -defaultMigrationsDir = "db" "migrations" - --- | Dumps the database schema to the given file handle. --- --- This is a wrapper around the utility /pg_dump/ that comes with postgresql. --- Therefore, /pg_dump/ must be installed on the system. -dumpDb :: Handle -> IO ExitCode -dumpDb outputFile = do - 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 - else do - raw <- S8.hGetContents out - let clean = S8.concat $ intersperse "\n" $ - filter ((/= "--") . (S8.take 2)) $ - S8.lines raw - S8.hPut outputFile clean - return exitCode - --- | Initializes the database by creating a \"schema-migrations\" table. --- This table must exist before running any migrations. -initializeDb :: IO () -initializeDb = do - conn <- connectEnv - 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 --- 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. -runMigrationsForDir :: Handle -- ^ Log output (probably stdout) - -> FilePath -- ^ Path to directory containing migrations - -> IO ExitCode -runMigrationsForDir logOut dir = 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 - migrations <- getDirectoryMigrations dir >>= - return . (dropWhile (isVersion (<= latestVersion))) - go migrations - where go [] = withFile (dir ".." "schema.sql") WriteMode dumpDb - go (mig@(MigrationDetails _ _ name):fs) = do - hPutStrLn logOut $ "=== Running Migration " ++ name - exitCode <- runMigration mig - if exitCode == ExitSuccess then do - hPutStrLn logOut "=== Success" - go fs - else do - hPutStrLn logOut "=== Migration Failed!" - return exitCode - --- | Run a migration. The returned exit code denotes the success or failure of --- the migration. -runMigration :: MigrationDetails -> IO ExitCode -runMigration (MigrationDetails file vers _) = do - rawSystem "runghc" - [file, "up", vers, "--with-db-commit"] - -runRollbackForDir :: FilePath -> IO ExitCode -runRollbackForDir dir = do - conn <- connectEnv - res <- query_ conn - "select version from schema_migrations order by version desc limit 1" - case res of - [] -> do - putStrLn "=== DB Fully Rolled Back!" - return ExitSuccess - (Only latest):_ -> do - (Just (mig@(MigrationDetails _ _ name))) <- - getDirectoryMigrations dir >>= - return . (find (isVersion (== latest))) - putStrLn $ "=== Running Rollback " ++ name - exitCode <- runRollback mig - if exitCode == ExitSuccess then do - putStrLn "=== Success" - withFile (dir ".." "schema.sql") WriteMode dumpDb - else do - putStrLn "=== Migration Failed!" - return exitCode - --- | Run a migration. The returned exit code denotes the success or failure of --- the migration. -runRollback :: MigrationDetails -> IO ExitCode -runRollback (MigrationDetails file vers _) = do - rawSystem "runghc" - [file, "down", vers, "--with-db-commit"] - -data MigrationDetails = MigrationDetails { migrationPath :: FilePath - , migrationVersion :: String - , migrationName :: String } - deriving (Show) - -getDirectoryMigrations :: FilePath -> IO [MigrationDetails] -getDirectoryMigrations dir = do - files0 <- getDirectoryContents dir - let files = filter (('.' /=) . head) $ sort files0 - return $ map (splitFileVersionName dir) files - -splitFileVersionName :: FilePath -> FilePath -> MigrationDetails -splitFileVersionName dir file = - let fileName = takeBaseName file - parts = foldr (\chr (hd:result) -> - if chr == '_' then - "":hd:result - else ((chr:hd):result)) - [""] fileName - vers = head parts - name = concat $ intersperse "_" $ tail parts - 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/Migrations.hs b/Database/PostgreSQL/Migrations.hs deleted file mode 100644 --- a/Database/PostgreSQL/Migrations.hs +++ /dev/null @@ -1,415 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -{- | -Functions to help with building database migrations. - -Most users will want to create a database migration using @defaultMain@ as -follows, - -> -> import Database.PostgreSQL.Migrations -> -> main = defaultMain up down -> -> up = migrate $ do -> create_table "posts" -> [ column "title" "VARCHAR(255) NOT NULL" -> , column "author_id" "integer references authors(id)"] -> -> down = migrate $ drop_table "posts" -> --} -module Database.PostgreSQL.Migrations ( - -- * Utilities - defaultMain - , connectEnv - , runSqlFile - -- * DSL - , Migration, migrate - , column - -- ** Adding - , create_table - , add_column - , create_index - , create_unique_index - -- ** Removing - , drop_table - , drop_column - , drop_index - -- ** Modifying - , rename_column - , change_column - -- ** Statements - , create_table_stmt, add_column_stmt, create_index_stmt - , drop_table_stmt, drop_column_stmt, drop_index_stmt - , rename_column_stmt, change_column_stmt - ) where - -import Control.Monad -import Control.Monad.Reader -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import Data.Int -import Data.Maybe -import Database.PostgreSQL.Simple hiding (connect) -import Database.PostgreSQL.Simple.Internal (exec) -import Database.PostgreSQL.Simple.Types -import System.Environment -import System.Exit - -import Database.PostgreSQL.Escape - --- | Creates a PostgreSQL 'Connection' using the /DATABASE_URL/ environment --- variable, if it exists. If it does, it should match the format: --- --- @ --- postgresql:\/\/[[USERNAME\@PASSWORD]HOSTNAME[:PORT]]/[DBNAME] --- @ --- --- If it is not present, the environment variables /PG_DBNAME/ /PG_HOST/ etc, --- are used. -connectEnv :: IO Connection -connectEnv = do - psqlStr <- getEnvironment >>= - return . (fromMaybe "") . (lookup "DATABASE_URL") - connectPostgreSQL $ S8.pack psqlStr - --- --- Migration Monad --- - -type Migration = ReaderT Connection IO - -migrate :: Migration a -> Connection -> IO () -migrate = (void .) . runReaderT - -executeQuery_ :: Query -> Migration Int64 -executeQuery_ q = ask >>= \conn -> liftIO $ execute_ conn q - --- | Runs the SQL file at the given path, relative to the current working --- directory. -runSqlFile :: FilePath -> Migration () -runSqlFile sqlFile = void $ do - conn <- ask - liftIO $ do - rawSql <- S.readFile sqlFile - exec conn rawSql - --- | Returns a column defition by quoting the given name -column :: S8.ByteString -- ^ name - -> S8.ByteString -- ^ type, definition, constraints - -> S8.ByteString -column name def = S8.concat [quoteIdent name, " ", def] - --- | Creates a table. See 'column' for constructing the column list. -create_table :: S8.ByteString - -- ^ Table name - -> [S8.ByteString] - -- ^ Column definitions - -> Migration Int64 -create_table = (executeQuery_ .) . create_table_stmt - --- | Returns a 'Query' that creates a table, for example: --- --- @ --- create_table \"posts\" --- [ column \"title\" \"VARCHAR(255) NOT NULL\" --- , column \"body\" \"text\"] --- @ -create_table_stmt :: S8.ByteString - -- ^ Table name - -> [S8.ByteString] - -- ^ Column definitions - -> Query -create_table_stmt tableName colDefs = Query $ S8.concat $ - [ "create table " - , quoteIdent tableName - , " ("] ++ (S8.intercalate ", " colDefs):([");"]) - --- | Drops a table -drop_table :: S8.ByteString -> Migration Int64 -drop_table = executeQuery_ . drop_table_stmt - --- | Returns a 'Query' that drops a table -drop_table_stmt :: S8.ByteString -> Query -drop_table_stmt tableName = Query $ S8.concat - [ "drop table ", quoteIdent tableName, ";"] - --- | Adds a column to the given table. For example, --- --- @ --- add_column \"posts\" \"title\" \"VARCHAR(255)\" --- @ --- --- adds a varchar column called \"title\" to the table \"posts\". --- -add_column :: S8.ByteString - -- ^ Table name - -> S8.ByteString - -- ^ Column name - -> S8.ByteString - -- ^ Column definition - -> Migration Int64 -add_column = ((executeQuery_ .) .) . add_column_stmt - --- | Returns a 'Query' that adds a column to the given table. For example, --- --- @ --- add_column \"posts\" \"title\" \"VARCHAR(255)\" --- @ --- --- Returns the query --- --- @ --- ALTER TABLE \"posts\" add \"title\" VARCHAR(255); --- @ -add_column_stmt :: S8.ByteString - -- ^ Table name - -> S8.ByteString - -- ^ Column name - -> S8.ByteString - -- ^ Column definition - -> Query -add_column_stmt tableName colName colDef = Query $ S8.concat - [ "alter table ", quoteIdent tableName, " add ", column colName colDef, ";"] - --- | Drops a column from the given table. For example, --- --- @ --- drop_column \"posts\" \"title\" --- @ --- --- drops the column \"title\" from the \"posts\" table. -drop_column :: S8.ByteString - -- ^ Table name - -> S8.ByteString - -- ^ Column name - -> Migration Int64 -drop_column = (executeQuery_ .) . drop_column_stmt - --- | Returns a 'Query' that drops a column from the given table. For example, --- --- @ --- drop_column \"posts\" \"title\" --- @ --- --- Returns the query --- --- @ --- ALTER TABLE \"posts\" add \"title\"; --- @ -drop_column_stmt :: S8.ByteString - -- ^ Table name - -> S8.ByteString - -- ^ Column name - -> Query -drop_column_stmt tableName colName = Query $ S8.concat - ["alter table ", quoteIdent tableName, " drop ", quoteIdent colName, ";"] - --- | Renames a column in the given table. For example, --- --- @ --- rename_column \"posts\" \"title\" \"name\" --- @ --- --- renames the column \"title\" in the \"posts\" table to \"name\". -rename_column :: S8.ByteString - -- ^ Table name - -> S8.ByteString - -- ^ Old column name - -> S8.ByteString - -- ^ New column name - -> Migration Int64 -rename_column = ((executeQuery_ .) .) . rename_column_stmt - --- | Returns a 'Query' that renames a column in the given table. For example, --- --- @ --- rename_column \"posts\" \"title\" \"name\" --- @ --- --- Returns the query --- --- @ --- ALTER TABLE \"posts\" RENAME \"title\" TO \"name\"; --- @ -rename_column_stmt :: S8.ByteString - -- ^ Table name - -> S8.ByteString - -- ^ Old column name - -> S8.ByteString - -- ^ New column name - -> Query -rename_column_stmt tableName colName colNameNew = Query $ S8.concat - [ "alter table ", quoteIdent tableName, " rename " - , quoteIdent colName, " to ", quoteIdent colNameNew, ";"] - --- | Alters a column in the given table. For example, --- --- @ --- change_column \"posts\" \"title\" \"DROP DEFAULT\" --- @ --- --- drops the default constraint for the \"title\" column in the \"posts\" --- table. -change_column :: S8.ByteString - -- ^ Table name - -> S8.ByteString - -- ^ Column name - -> S8.ByteString - -- ^ Action - -> Migration Int64 -change_column = ((executeQuery_ .) .) . change_column_stmt - --- | Returns a 'Query' that alters a column in the given table. For example, --- --- @ --- change_column \"posts\" \"title\" \"DROP DEFAULT\" --- @ --- --- Returns the query --- --- @ --- ALTER TABLE \"posts\" ALTER \"title\" DROP DEFAULT; --- @ -change_column_stmt :: S8.ByteString - -- ^ Table name - -> S8.ByteString - -- ^ Column name - -> S8.ByteString - -- ^ Action - -> Query -change_column_stmt tableName colName action = Query $ S8.concat - [ "alter table ", quoteIdent tableName, " alter " - , quoteIdent colName, " ", action, ";"] - -data CmdArgs = CmdArgs { cmd :: String - , cmdVersion :: String - , cmdCommit :: Bool } - --- | Creates an index for efficient lookup. -create_index :: S8.ByteString - -- ^ Index name - -> S8.ByteString - -- ^ Table name - -> [S8.ByteString] - -- ^ Column names - -> Migration Int64 -create_index = ((executeQuery_ .) .) . (create_index_stmt False) - --- | Creates a unique index for efficient lookup. -create_unique_index :: S8.ByteString - -- ^ Index name - -> S8.ByteString - -- ^ Table name - -> [S8.ByteString] - -- ^ Column names - -> Migration Int64 -create_unique_index = ((executeQuery_ .) .) . (create_index_stmt True) - --- | Returns a 'Query' that creates an index for the given columns on the given --- table. For example, --- --- @ --- create_index_stmt \"post_owner_index\" \"posts\" \"owner\" --- @ --- --- Returns the query --- --- @ --- CREATE INDEX \"post_owner_index\" ON \"posts\" (\"owner\") --- @ -create_index_stmt :: Bool - -- ^ Unique index? - -> S8.ByteString - -- ^ Index name - -> S8.ByteString - -- ^ Table name - -> [S8.ByteString] - -- ^ Column names - -> Query -create_index_stmt unq indexName tableName colNames = Query $ S8.concat - [ "create", unique, " index ", quoteIdent indexName, " on " - , quoteIdent tableName, " (", cols, ")", ";" ] - where cols = S8.intercalate ", " $ map quoteIdent colNames - unique = if unq then " unique" else "" - --- | Drops an index. -drop_index :: S8.ByteString - -- ^ Index name - -> Migration Int64 -drop_index = executeQuery_ . drop_index_stmt - --- | Returns a 'Query' that drops an index. --- --- @ --- drop_index_stmt \"post_owner_index\" --- @ --- --- Returns the query --- --- @ --- DROP INDEX \"post_owner_index\" --- @ -drop_index_stmt :: S8.ByteString - -- ^ Index name - -> Query -drop_index_stmt indexName = Query $ S8.concat - [ "drop index ", quoteIdent indexName, ";" ] - -parseCmdArgs :: [String] -> Maybe CmdArgs -parseCmdArgs args = do - mycmd <- listToMaybe args - let args0 = tail args - myversion <- listToMaybe args0 - return $ go (CmdArgs mycmd myversion False) $ tail args0 - where go res [] = res - go res (arg:as) = - let newRes = case arg of - "--with-db-commit" -> res { cmdCommit = True } - _ -> res - in go newRes as - -defaultMain :: (Connection -> IO ()) -- ^ Migration function - -> (Connection -> IO ()) -- ^ Rollback function - -> IO () -defaultMain up down = do - (Just cmdArgs) <- getArgs >>= return . parseCmdArgs - case cmd cmdArgs of - "up" -> do - conn <- connectEnv - res <- query_ conn - "select version from schema_migrations order by version desc limit 1" - let currentVersion = case res of - [] -> "" - (Only v):_ -> v - let version = cmdVersion cmdArgs - if currentVersion < version then do - begin conn - up conn - void $ execute conn "insert into schema_migrations values(?)" - (Only version) - if cmdCommit cmdArgs then - commit conn - else rollback conn - else exitWith $ ExitFailure 1 - "down" -> do - conn <- connectEnv - res <- query_ conn - "select version from schema_migrations order by version desc limit 1" - let currentVersion = case res of - [] -> "" - (Only v):_ -> v - let version = cmdVersion cmdArgs - if currentVersion == version then do - begin conn - down conn - void $ execute conn "delete from schema_migrations where version = ?" - (Only version) - if cmdCommit cmdArgs then - commit conn - else rollback conn - else - exitWith $ ExitFailure 1 - _ -> exitWith $ ExitFailure 1 - diff --git a/Database/PostgreSQL/ORM.hs b/Database/PostgreSQL/ORM.hs deleted file mode 100644 --- a/Database/PostgreSQL/ORM.hs +++ /dev/null @@ -1,29 +0,0 @@ - -module Database.PostgreSQL.ORM ( - -- * The Model class and related types - Model(modelInfo, modelValid), ModelInfo(..) - , defaultModelInfo, underscoreModelInfo - , DBKey(..), DBRef, DBRefUnique, mkDBRef, primaryKey - , (:.), As(..), RowAlias(..), fromAs - -- ** Single-row operations - , findRow, findAll, save, trySave, destroy, destroyByRef - -- * Abstracted select queries - , DBSelect(..), modelDBSelect, dbSelectParams, dbSelect - , addWhere_, addWhere, setOrderBy, setLimit, setOffset - -- * Associations between models - , Association, assocSelect, assocProject, assocWhere, findAssoc - -- ** Parent-child associations - , GDBRefInfo(..), DBRefInfo, defaultDBRefInfo, dbrefAssocs, has, belongsTo - -- ** Join table associations - , JoinTable(..), defaultJoinTable, jtAssocs, jtAdd, jtRemove, jtRemoveByRef - -- ** Chaining associations - , nestAssoc, chainAssoc - -- ** Validations - , ValidationError(..), validate, validateNotEmpty, validationError - ) where - -import Database.PostgreSQL.ORM.Model -import Database.PostgreSQL.ORM.DBSelect -import Database.PostgreSQL.ORM.Association -import Database.PostgreSQL.ORM.Validations -import Database.PostgreSQL.Simple ((:.)) diff --git a/Database/PostgreSQL/ORM/Association.hs b/Database/PostgreSQL/ORM/Association.hs deleted file mode 100644 --- a/Database/PostgreSQL/ORM/Association.hs +++ /dev/null @@ -1,543 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - -module Database.PostgreSQL.ORM.Association ( - Association(..), assocProject, assocWhere, findAssoc - -- * Associations based on parent-child relationships - , GDBRefInfo(..), DBRefInfo, defaultDBRefInfo, dbrefAssocs, has, belongsTo - -- * Join table Associations - , JoinTable(..), defaultJoinTable, jtAssocs, joinTable - -- ** Operations on join tables - , jtAdd, jtRemove, jtRemoveByRef - -- ** Semi-internal join table functions - , jtAddStatement, jtRemoveStatement, jtParam - , jtFlip, jtAssoc - -- * Nested and chained associations - , nestAssoc, chainAssoc - ) where - -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -#endif -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import Data.List -import Data.Monoid -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.ToField -import Database.PostgreSQL.Simple.Types - -import Data.GetField -import Database.PostgreSQL.Escape -import Database.PostgreSQL.ORM.DBSelect -import Database.PostgreSQL.ORM.Model - - --- | A data structure representing a relationship between a model @a@ --- and a model @b@. At a high level, an @Association a b@ tells you --- how to find rows of type @b@ given rows of type @a@. More --- concretely, this boils down to being able to make two types of --- query. --- --- * You want to look up a bunch of @(a ':.' b)@s, filtering using --- predicates on both @a@ and @b@ (e.g., get a list of recent posts --- and their authors). For this purpose, you can use 'assocSelect', --- which allows you to 'addWhere' predicates mentioning columns in --- both @a@ and @b@. --- --- * You already have an instance of type @a@, and want to find all --- the @b@s associated with it. For that you use either 'assocWhere' --- or 'findAssoc' (which internally access fields 'assocSelectOnlyB', --- 'assocWhereQuery', and 'assocWhereParam'). This type of query is --- strictly less general than the first one, but can be formulated in --- a more efficient way by extracting values directly from a concrete --- instance of @a@ without needing to touch table @a@ in the --- database. --- --- Note that an @Association@ is asymmetric. It tells you how to get --- @b@s from @a@s, but not vice versa. In practice, there will almost --- always be an association in the other direction, too. Functions --- such as 'dbrefAssocs' and 'jtAssocs' therefore create an --- @Association@ and its inverse simultaneously, returning them as a --- pair. -data Association a b = Association { - assocSelect :: !(DBSelect (a :. b)) - -- ^ General select returning all instances of @a@ and @b@ that - -- match according to the association. - , assocSelectOnlyB :: !(DBSelect b) - -- ^ The right-hand side of the 'assocSelect' query. This query - -- makes no mention of type @a@ (but can be combined with the next - -- two fields to form an optimized query). You probably never - -- want to use this directly, and should instead use either - -- 'findAssoc' or 'assocWhere'. Also note this is not useful for - -- selecting all the @b@s in the relation; for that you should use - -- 'assocProject'. - , assocWhereQuery :: !Query - -- ^ A @WHERE@ clause to find all the 'b's associated with a - -- particular @a@. This can often be done more efficiently than - -- through 'assocSelect'. The clause contains @\'?\'@ characters - -- which should be filled in by 'assocWhereParam'. - , assocWhereParam :: !(a -> [Action]) - -- ^ The query parameters for the query returned by - -- 'assocWhereQuery'. - } - -instance Show (Association a b) where - show assoc = - "Association { assocSelect = " ++ show (assocSelect assoc) ++ - ", assocSelectOnlyB = " ++ show (assocSelectOnlyB assoc) ++ - ", assocWhereQuery = " ++ S8.unpack (fromQuery $ assocWhereQuery assoc) ++ - " }" - --- | A projection of 'assocSelect', extracting only the fields of --- model @b@. Note that this query touches table @a@ even if it does --- not return results from @a@. Hence, you can use 'addWhere' to add --- predicates on both @a@ and @b@. (Note the contrast to --- 'assocSelectOnlyB', which does not touch table @a@ at all, and --- hence in the case of an @INNER JOIN@ might return rows of @b@ that --- should not be part of the association. 'assocSelectOnlyB' is --- intended for use only in conjunction with 'assocWhereQuery'.) -assocProject :: (Model b) => Association a b -> DBSelect b -assocProject = dbProject . assocSelect - --- | Returns a 'DBSelect' for all @b@s associated with a particular --- @a@. -assocWhere :: (Model b) => Association a b -> a -> DBSelect b -assocWhere ab a = addWhere (assocWhereQuery ab) (assocWhereParam ab a) - (assocSelectOnlyB ab) - --- | Follow an association to return all of the @b@s associated --- with a particular @a@. The behavior is similar to: --- --- > findAssoc' ab c a = dbSelect c $ assocWhere ab a --- --- But if the first argument is a static association, this function --- may be marginally faster because it pre-renders most of the query. -findAssoc :: (Model b) => Association a b -> Connection -> a -> IO [b] -{-# INLINE findAssoc #-} -findAssoc assoc = \c a -> - map lookupRow <$> query c q (assocWhereParam assoc a) - where {-# NOINLINE q #-} - q = renderDBSelect $ - addWhere_ (assocWhereQuery assoc) $ assocSelectOnlyB assoc - --- | Combine two associations into one. -nestAssoc :: (Model a, Model b) => - Association a b -> Association b c -> Association a (b :. c) -nestAssoc ab bc = ab { assocSelect = dbNest (assocSelect ab) (assocSelect bc) - , assocSelectOnlyB = assocSelect bc } - --- | Combine two associations into one, and project away the middle --- type. (The middle type can still be mentioned in @WHERE@ clauses.) --- --- An example: --- --- > data Author = Author { --- > authorId :: DBKey --- > } deriving (Show, Generic) --- > instance Model Author where modelInfo = underscoreModelInfo "author" --- > --- > data Post = Post { --- > postId :: DBKey --- > , postAuthorId :: DBRef Author --- > } deriving (Show, Generic) --- > instance Model Post where modelInfo = underscoreModelInfo "post" --- > --- > data Comment = Comment { --- > commentId :: DBKey --- > , commentPostId :: DBRef Post --- > } deriving (Show, Generic) --- > instance Model Comment where modelInfo = underscoreModelInfo "comment" --- > --- > author_posts :: Association Author Post --- > post_author :: Association Post Author --- > (post_author, author_posts) = dbrefAssocs defaultDBRefInfo --- > --- > -- Could equally well use dbrefAssocs as above --- > post_comments :: Association Post Comment --- > post_comments = has --- > --- > comment_post :: Association Comment Post --- > comment_post = belongsTo --- > --- > comment_author :: Association Comment Author --- > comment_author = chainAssoc comment_post post_author --- > --- > author_comments :: Association Author Comment --- > author_comments = chainAssoc author_posts post_comments -chainAssoc :: (Model a, Model b, Model c) => - Association a b -> Association b c -> Association a c -chainAssoc ab bc = ab { assocSelect = dbChain (assocSelect ab) (assocSelect bc) - , assocSelectOnlyB = dbProject $ assocSelect bc } - - --- | A common type of association is when one model contains a 'DBRef' --- or 'DBRefUnique' pointing to another model. In this case, the --- model containing the 'DBRef' is known as the /child/, and the --- referenced model is known as the /parent/. --- --- Two pieces of information are required to describe a parent-child --- relationship: First, the field selector that extracts the Haskell --- 'DBRef' from the haskell type @child@, and second the name of the --- database column that stores this 'DBRef' field. --- --- For example, consider the following: --- --- > data Author = Author { --- > authorId :: DBKey --- > } deriving (Show, Generic) --- > instance Model Author --- > --- > data Post = Post { --- > postId :: DBKey --- > , postAuthorId :: DBRef Author --- > } deriving (Show, Generic) --- > instance Model Post --- > --- > post_author_refinfo :: DBRefInfo Post Author --- > post_author_refinfo = DBRefInfo { --- > dbrefSelector = postAuthorId --- > , dbrefQColumn = "\"post\".\"postAuthorId\"" --- > } --- --- Note that the parent-child relationship described by a @GDBRefInfo@ --- is asymmetric, but bidirectional. When a @'DBRefInfo' child --- parent@ exists, the schema should generally /not/ permit the --- existence of a valid @'DBRefInfo' parent child@ structure. --- However, the 'dbrefAssocs' function generates 'Association's in --- both directions from a single 'DBRefInfo'. --- --- Constructing such parent-child 'Association's requires knowing how --- to extract primary keys from the @parent@ type as well as the name --- of the column storing primary keys in @parent@. Fortunately, this --- information is already available from the 'Model' class, and thus --- does not need to be in the @GDBRefInfo@. (Most functions on --- @GDBRefInfo@s require @parent@ and @child@ to be instances of --- 'Model'.) --- --- When your 'Model's are instances of 'Generic' (which will usually --- be the case), a 'DBRefInfo' structure can be computed automatically --- by 'defaultDBRefInfo'. This is the recommended way to produce a --- @GDBRefInfo@. (Alternatively, see 'has' and 'belongsTo' to make --- use of an entirely implicit @DBRefInfo@.) -data GDBRefInfo reftype child parent = DBRefInfo { - dbrefSelector :: !(child -> GDBRef reftype parent) - -- ^ Field selector returning a reference. - , dbrefQColumn :: !S.ByteString - -- ^ Literal SQL for the database column storing the reference. - -- This should be double-quoted and table-qualified, in case the - -- column name is a reserved keyword, contains capital letters, or - -- conflicts with the name of a column in the joined table. An - -- example would be: - -- - -- > dbrefQColumn = "\"table_name\".\"column_name\"" - } - -instance Show (GDBRefInfo rt c p) where - show ri = "DBRefInfo ? " ++ show (dbrefQColumn ri) - --- | @DBRefInfo@ is a type alias for the common case that the --- reference in a 'GDBRefInfo' is a 'DBRef' (as opposed to a --- 'DBRefUnique'). The functions in this library do not care what --- type of reference is used. The type is generalized to 'GDBRefInfo' --- just to make it easier to assign a selector to 'dbrefSelector' when --- the selector returns a 'DBRefUnique'. Note, however, that --- 'defaultDBRefInfo' returns a 'DBRefInfo' regardless of the flavor --- of reference actually encountered. -type DBRefInfo = GDBRefInfo NormalRef - -data ExtractRef a = ExtractRef deriving (Show) -instance Extractor ExtractRef (GDBRef rt a) (DBRef a) THasOne where - extract _ (DBRef k) = THasOne $ DBRef k -instance Extractor ExtractRef (GDBRef rt a) (DBRef (As alias a)) THasOne where - extract _ (DBRef k) = THasOne $ DBRef k -instance Extractor ExtractRef (Maybe (GDBRef rt a)) (DBRef a) THasOne where - extract _ (Just (DBRef k)) = THasOne $ DBRef k - extract _ _ = error "Maybe DBRef is Nothing" -instance Extractor ExtractRef (Maybe (GDBRef rt a)) (DBRef (As alias a)) - THasOne where - extract _ (Just (DBRef k)) = THasOne $ DBRef k - extract _ _ = error "Maybe DBRef is Nothing" - --- | Creates a 'DBRefInfo' from a model @child@ that references --- @parent@. For this to work, the @child@ type must be an instance --- of 'Generic' and must contain exactly one field of the any of the --- following types: --- --- 1. @'GDBRef' rt parent@, which matches both @'DBRef' parent@ and --- @'DBRefUnique' parent@. --- --- 2. @Maybe ('GDBRef' rt parent)@, for cases where the reference --- might be @NULL@. Note, however, that an exception will be thrown --- if you call 'findAssoc' on a child whose reference is 'Nothing'. --- --- A special case arises when a Model contains a 'DBRef' to itself. --- If you just wish to find parents and children given an existing --- structure (i.e., 'findAssoc'), it is okay to declare an --- @'Association' MyType MyType@. However, in this case attempts to --- use 'assocSelect' will then fail. To work around this problem, the --- parent must use a row alias. --- --- Note that currently /aliasing the child will not work/, since the --- 'As' data structure will not contain a 'DBRef' field, only the --- contents of the 'As' data structure. An example of doing this --- correctly (using 'has' and 'belongsTo', both of which wrap --- @defaultDBRefInfo@): --- --- > data Bar = Bar { --- > barId :: !DBKey --- > , barName :: !String --- > , barParent :: !(Maybe (DBRef Bar)) --- > } deriving (Show, Generic) --- > instance Model Bar where modelInfo = underscoreModelInfo "bar" --- > --- > data ParentBar = ParentBar --- > instance RowAlias ParentBar where rowAliasName _ = "parent_bar" --- > --- > toParent :: Association Bar (As ParentBar Bar) --- > toParent = belongsTo --- > --- > toChild :: Association (As ParentBar Bar) Bar --- > toChild = has -defaultDBRefInfo :: forall child parent. - (Model child, Model parent - , GetField ExtractRef child (DBRef parent)) => - DBRefInfo child parent -defaultDBRefInfo = ri - where extractor = (const ExtractRef :: g p -> ExtractRef (DBRef p)) ri - child = undefined :: child - childids = modelIdentifiers :: ModelIdentifiers child - ri = DBRefInfo { - dbrefSelector = getFieldVal extractor - , dbrefQColumn = modelQColumns childids !! getFieldPos extractor child - } - --- | Generate both the child-parent and parent-child 'Association's --- implied by a 'GDBRefInfo'. -dbrefAssocs :: forall child parent rt. - (Model child, Model parent) => - GDBRefInfo rt child parent - -> (Association child parent, Association parent child) -dbrefAssocs ri = (c_p, p_c) - where idp = modelIdentifiers :: ModelIdentifiers parent - on = Query $ "ON " <> modelQPrimaryColumn idp - <> " = " <> dbrefQColumn ri - c_p = Association { - assocSelect = dbJoinModels "JOIN" on - , assocSelectOnlyB = modelDBSelect - , assocWhereQuery = Query $ modelQPrimaryColumn idp <> " = ?" - , assocWhereParam = \child -> [toField $ dbrefSelector ri child] - } - p_c = Association { - assocSelect = dbJoinModels "JOIN" on - , assocSelectOnlyB = modelDBSelect - , assocWhereQuery = Query $ dbrefQColumn ri <> " = ?" - , assocWhereParam = \parent -> [toField $ primaryKey parent] - } - - --- | Short for --- --- > snd $ dbrefAssocs defaultDBRefInfo --- --- Note the inverse 'Association' is given by 'belongsTo'. For --- example, given the @Author@ and @Post@ models described in the --- documentation for 'GDBRefInfo', in which each @Post@ references an --- @Author@, you might say: --- --- > author_post :: Association Author Post --- > author_post = has --- > --- > post_author :: Association Post Author --- > post_author = belongsTo -has :: (Model child, Model parent, GetField ExtractRef child (DBRef parent)) => - Association parent child -has = snd $ dbrefAssocs defaultDBRefInfo - --- | The inverse of 'has'. Short for --- --- > fst $ dbrefAssocs defaultDBRefInfo --- --- See an example at 'has'. -belongsTo :: (Model child, Model parent - , GetField ExtractRef child (DBRef parent)) => - Association child parent -belongsTo = fst $ dbrefAssocs defaultDBRefInfo - --- | A data structure representing a dedicated join table in the --- database. A join table differs from a model in that rows do not --- have primary keys. Hence, model operations do not apply. --- Nonetheless a join table conveys information about a relationship --- between models. --- --- Note that all names in a @JoinTable@ should be unquoted. -data JoinTable a b = JoinTable { - jtTable :: !S.ByteString - -- ^ Name of the join table in the database. (Not quoted.) - , jtColumnA :: !S.ByteString - -- ^ Name of the column in table 'jtTable' that contains a 'DBRef' - -- to model @a@. (Not quoted or table-qualified.) - , jtColumnB :: !S.ByteString - -- ^ Like 'jtColumnA' for model @b@. - } deriving (Show) - --- | The default join table has the following fields: --- --- * 'jtName' is the name of the two models (in alphabetical order), --- separated by an @\'_\'@ character. --- --- * 'jtColumnA' is the name of model @a@, an @\'_\'@ character, and --- the name of the primary key column in table @a@. --- --- * 'jtColumnB' is the name of model @b@, an @\'_\'@ character, and --- the name of the primary key column in table @b@. --- --- Note that 'defaultJoinTable' cannot create a default join table for --- joining a model to itself, as following these rules the two columns --- would have the same name. If you wish to join a table to itself, --- you have two options: First, you can define the join table and --- assign the column names manually. This will permit you to call --- 'findAssoc', but you still will not be able to use 'assocSelect' --- for more complex queries, since SQL does not permit joins between --- two tables with the same name. The second option is to give one of --- the sides of the join table a row alias with 'As'. For example: --- --- > data ParentBar = ParentBar --- > instance RowAlias ParentBar where rowAliasName _ = "parent_bar" --- > --- > selfJoinTable :: JoinTable Bar (As ParentBar Bar) --- > selfJoinTable = defaultJoinTable --- > --- > selfJoin :: Association Bar (As ParentBar Bar) --- > otherSelfJoin :: Association (As ParentBar Bar) Bar --- > (selfJoin, otherSelfJoin) = jtAssocs selfJoinTable -defaultJoinTable :: forall a b. (Model a, Model b) => JoinTable a b -defaultJoinTable - | colA == colB = error "defaultJoinTable has default for self joins" - | otherwise = jti - where a = modelInfo :: ModelInfo a - b = modelInfo :: ModelInfo b - colA = S.intercalate "_" - [modelTable a, modelColumns a !! modelPrimaryColumn a] - colB = S.intercalate "_" - [modelTable b, modelColumns b !! modelPrimaryColumn b] - jti = JoinTable { - jtTable = S.intercalate "_" $ sort [modelTable a, modelTable b] - , jtColumnA = colA - , jtColumnB = colB - } - -jtQTable :: JoinTable a b -> S.ByteString -jtQTable = quoteIdent . jtTable - -jtQColumnA :: JoinTable a b -> S.ByteString -jtQColumnA jt = S.concat [ jtQTable jt, ".", quoteIdent $ jtColumnA jt] - -jtQColumnB :: JoinTable a b -> S.ByteString -jtQColumnB jt = S.concat [ jtQTable jt, ".", quoteIdent $ jtColumnB jt] - --- | Flip a join table. This doesn't change the name of the table --- (since the same join table is used in both directions, and the --- default join table name glues together the two model names in --- alphabetical order anyway). -jtFlip :: JoinTable a b -> JoinTable b a -jtFlip jt = jt { jtColumnA = jtColumnB jt , jtColumnB = jtColumnA jt } - --- | A SQL statement suitable for adding a pair to a join table. Note --- that the statement takes two parameters (i.e., contains two @\'?\'@ --- characters) corresponding to the primary keys of the two models --- being associated. These parameters can be supplied by 'jtParam'. -jtAddStatement :: JoinTable a b -> Query -jtAddStatement jt = Query $ S.concat [ - "INSERT INTO ", jtQTable jt, " (" - , quoteIdent $ jtColumnA jt, ", ", quoteIdent $ jtColumnB jt - , ") VALUES (?, ?) EXCEPT SELECT " - , jtQColumnA jt, ", ", jtQColumnB jt, " FROM ", quoteIdent $ jtTable jt - ] - --- | Add an association between two models to a join table. Returns --- 'True' if the association was not already there. -jtAdd :: (Model a, Model b) => JoinTable a b -> Connection -> a -> b -> IO Bool -{-# INLINE jtAdd #-} -jtAdd jt = \c a b -> (/= 0) <$> execute c q (jtParam jt a b) - where {-# NOINLINE q #-} - q = jtAddStatement jt - --- | A SQL statement for removing a pair from a join table. Like --- 'jtAddStatement', the query is parameterized by two primary keys. -jtRemoveStatement :: JoinTable a b -> Query -jtRemoveStatement jt = Query $ S.concat [ - "DELETE FROM ", quoteIdent $ jtTable jt, " WHERE " - , jtQColumnA jt, " = ? AND ", jtQColumnB jt, " = ?" - ] - --- | Remove an association from a join table. Returns 'True' if the --- association was previously there. -jtRemove :: (Model a, Model b) => - JoinTable a b -> Connection -> a -> b -> IO Bool -{-# INLINE jtRemove #-} -jtRemove jt = \c a b -> (/= 0) <$> execute c q (jtParam jt a b) - where {-# NOINLINE q #-} - q = jtRemoveStatement jt - --- | Remove an assocation from a join table when you don't have the --- target instances of the two models handy, but do have references. -jtRemoveByRef :: (Model a, Model b) => JoinTable a b - -> Connection -> GDBRef rt a -> GDBRef rt b -> IO Bool -{-# INLINE jtRemoveByRef #-} -jtRemoveByRef jt = \c a b -> (/= 0) <$> execute c q (a, b) - where {-# NOINLINE q #-} - q = jtRemoveStatement jt - --- | Generate parameters for 'jtAddStatement' and 'jtRemoveStatement'. --- The returned list is suitable for use as a 'ToRow' instance. For --- example: --- --- > execute conn (jtAddStatement my_join_table) (jtParam a b) -jtParam :: (Model a, Model b) => JoinTable a b -> a -> b -> [Action] -jtParam _ a b = [toField $ primaryKey a, toField $ primaryKey b] - --- | Generate a one-way association from a 'JoinTable'. Use --- 'jtAssocs' instead. -jtAssoc :: forall a b. (Model a, Model b) => JoinTable a b -> Association a b -jtAssoc jt = Association { - assocSelect = dbJoin modelDBSelect "JOIN" onlyB $ Query $ S.concat [ - "ON ", priA, " = ", jtQColumnA jt] - , assocSelectOnlyB = onlyB - , assocWhereQuery = Query $ jtQColumnA jt <> " = ?" - , assocWhereParam = \a -> [toField $ primaryKey a] - } - where priA = modelQPrimaryColumn (modelIdentifiers :: ModelIdentifiers a) - priB = modelQPrimaryColumn (modelIdentifiers :: ModelIdentifiers b) - selB = modelDBSelect :: DBSelect b - fromB = FromJoin - (FromModel (Query $ jtQTable jt) (jtQTable jt)) - "JOIN" (selFrom selB) - (Query $ S.concat ["ON ", jtQColumnB jt, " = ", priB]) - (jtQTable jt <> "->B") - onlyB = selB { selFrom = fromB } - --- | Generate the two associations implied by a 'JoinTable'. -jtAssocs :: (Model a, Model b) => - JoinTable a b -> (Association a b, Association b a) -jtAssocs jt = (jtAssoc jt, jtAssoc $ jtFlip jt) - --- | Generate a one-way association based on the default join table --- naming scheme described at 'defaultJoinTable'. Defined as: --- --- > joinTable = jtAssoc defaultJoinTable --- --- For example: --- --- > aToB :: Association A B --- > aToB = joinTable --- > --- > bToA :: Association B A --- > bToA = joinTable -joinTable :: (Model a, Model b) => Association a b -joinTable = jtAssoc defaultJoinTable diff --git a/Database/PostgreSQL/ORM/CreateTable.hs b/Database/PostgreSQL/ORM/CreateTable.hs deleted file mode 100644 --- a/Database/PostgreSQL/ORM/CreateTable.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedStrings #-} - --- | Functions for creating a table from a model. These are mostly --- useful in development, for very rigid applications, or to compare --- what would be created against what is actually in the database. In --- practice, production settings should create and update tables using --- migrations. --- --- Note that often it is more interesting to see what would be created --- than to create an actual table. For that reason, functions --- creating the statements are exposed. -module Database.PostgreSQL.ORM.CreateTable ( - modelCreateStatement, modelCreate, GDefTypes(..) - , jtCreateStatement, jtCreate - ) where - -import qualified Data.ByteString as S -import qualified Data.ByteString.Char8 as S8 -import Data.Int -import Data.List -import Data.Monoid -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.Types -import GHC.Generics - -import Database.PostgreSQL.ORM.Model -import Database.PostgreSQL.ORM.Association -import Database.PostgreSQL.ORM.SqlType - --- | This is a helper class used to extract the row types. You don't --- need to use this class. If you are creating custom types, just --- declare an instance of 'SqlType'. -class GDefTypes f where - gDefTypes :: f p -> [S.ByteString] -instance (SqlType c) => GDefTypes (K1 i c) where - gDefTypes ~(K1 c) = [sqlType c] -instance (GDefTypes a, GDefTypes b) => GDefTypes (a :*: b) where - gDefTypes ~(a :*: b) = gDefTypes a ++ gDefTypes b -instance (GDefTypes f) => GDefTypes (M1 i c f) where - gDefTypes ~(M1 fp) = gDefTypes fp - -customModelCreateStatement :: forall a. - (Model a, Generic a, GDefTypes (Rep a)) => - [(S.ByteString, S.ByteString)] - -- ^ A list of @(@/field/@,@/type/@)@ pairs to overwrite the default - -- SQL types of fields. - -> [S.ByteString] - -- ^ A list of extra table constraints. - -> a - -- ^ A non-strict argument to specify which model's table you want - -- to create. @(undefined :: YourModel)@ should be fine. - -> Query -customModelCreateStatement except constraints a - | not (null extraneous) = - error $ "customCreateTableStatement: no such columns: " ++ show extraneous - | otherwise = Query $ S.concat [ - "CREATE TABLE ", quoteIdent $ modelTable info, " (" - , S.intercalate ", " (go types names) - , S.concat $ concatMap (\c -> [", ", c]) constraints, ")" - ] - where extraneous = fst (unzip except) \\ names - types = gDefTypes $ from a - info = modelInfo :: ModelInfo a - names = modelColumns info - go (t:ts) (n:ns) - | Just t' <- lookup n except = quoteIdent n <> " " <> t' : go ts ns - | otherwise = quoteIdent n <> " " <> t : go ts ns - go [] [] = [] - go _ _ = error $ "createTable: " ++ S8.unpack (modelTable info) ++ - " has incorrect number of columns" - --- | Statement for creating the table corresponding to a model. Not --- strict in its argument. -modelCreateStatement :: forall a. (Model a, Generic a, GDefTypes (Rep a)) - => a -> Query -modelCreateStatement a = customModelCreateStatement except constraints a - where ModelCreateInfo except constraint = modelCreateInfo :: ModelCreateInfo a - constraints = if S.null constraint then [] else [constraint] - --- | Create a the database table for a model. -modelCreate :: (Model a, Generic a, GDefTypes (Rep a)) => - Connection -> a -> IO Int64 -modelCreate c a = execute_ c (modelCreateStatement a) - --- | Create the database table corresponding to a 'JoinTable'. -jtCreateStatement :: (Model a, Model b) => JoinTable a b -> Query -jtCreateStatement jt = Query $ S.concat [ - "CREATE TABLE ", quoteIdent $ jtTable jt, " (" - , S.intercalate ", " $ sort [typa, typb] - , ", UNIQUE (", S.intercalate ", " $ sort [ida, idb], "))" - ] - where ida = quoteIdent $ jtColumnA jt - idb = quoteIdent $ jtColumnB jt - refa = (undefined :: JoinTable a b -> DBRef a) jt - refb = (undefined :: JoinTable a b -> DBRef b) jt - typa = ida <> " " <> sqlBaseType refa <> " ON DELETE CASCADE NOT NULL" - typb = idb <> " " <> sqlBaseType refb <> " ON DELETE CASCADE NOT NULL" - --- | Create a join table in the database. -jtCreate :: (Model a, Model b) => Connection -> JoinTable a b -> IO Int64 -jtCreate c jt = execute_ c (jtCreateStatement jt) diff --git a/Database/PostgreSQL/ORM/DBSelect.hs b/Database/PostgreSQL/ORM/DBSelect.hs deleted file mode 100644 --- a/Database/PostgreSQL/ORM/DBSelect.hs +++ /dev/null @@ -1,473 +0,0 @@ -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# 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_ - , dbCollect - , renderDBSelect, buildDBSelect - -- * Creating DBSelects - , emptyDBSelect, expressionDBSelect - , modelDBSelect - , dbJoin, dbJoinModels - , dbProject, dbProject' - , dbNest, dbChain - -- * Altering DBSelects - , 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 -import qualified Data.ByteString.Char8 as S8 -#if __GLASGOW_HASKELL__ < 710 -import Data.Functor -#endif -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 - -import Database.PostgreSQL.Escape -import Database.PostgreSQL.ORM.Model - --- | As it's name would suggest, a @FromClause@ is the part of a query --- between the @FROM@ keyword and the @WHERE@ keyword. It can consist --- of simple table names, @JOIN@ operations, and parenthesized --- subqueries. --- --- From clauses are represented in a more structured way than the --- other fields so as to allow the possibility of collapsing join --- relations. For instance, given a @'DBSelect' (A :. B)@ and a --- @'DBSelect' (B :. C)@, it is desirable to be able to generate a --- @'DBSelect' (A :. B :. C)@ in which each pair of terms involving --- @B@ in the three-way relation is constrained according to the --- original two queries. This functionality is provided by 'dbNest' --- and 'dbChain', but it requires the ability to locate and replace --- the instance of type @B@ in one 'DBSelect' with the @FromClause@ of --- the other 'DBSelect'. --- --- The 'fcCanonical' field is a canonical name of each type, which by --- convention is the quoted and fully-qualified table name. Comparing --- 'fcCanonical' is somewhat of a hack, and happens entirely at --- runtime. It would be nicer to do this at compile time, but doing --- so would require language extensions such as @GADTs@ of --- @FunctionalDependencies@. -data FromClause = FromModel { - fcVerbatim :: !Query -- ^ Verbatim SQL for a table, table @AS@ - -- alias, or parenthesized subquery. - , fcCanonical :: !S.ByteString - -- ^ Canonical name of the table or join relation represented by - -- this term. For @JOIN@ terms, this is always the @CROSS JOIN@ - -- of the canonical names of 'fcLeft' and 'fcRight'. This means - -- one can locate a join given only it's type (e.g., the canonical - -- name for @A :. B@ is always @\"a CROSS JOIN b\"@), but it does - -- mean you have to be careful not accidentally to merge two - -- different joins on the same types. For this reason it may be - -- safest always to have type @b@ be a single table in 'dbNest' - -- and 'dbChain'. - } - | FromJoin { - fcLeft :: !FromClause - , fcJoinOp :: !Query -- ^ Usually @\"JOIN\"@ - , fcRight :: !FromClause - , fcOnClause :: !Query -- ^ @ON@ or @USING@ clause (or empty) - , fcCanonical :: !S.ByteString - } - deriving Show - -nullFrom :: FromClause -> Bool -nullFrom (FromModel q _) | qNull q = True -nullFrom _ = False - --- | A deconstructed SQL select statement that allows easier --- manipulation of individual terms. Several functions are provided --- to combine the 'selFields', 'selFrom', and 'selWhere' clauses of --- muliple @DBSelect@ structures. Other clauses may be discarded when --- combining queries with join operations. Hence it is advisable to --- set the other clauses at the end (or, if you set these fields, to --- collapse your 'DBSelect' structure into a subquery using --- `dbProject'`). -data DBSelect a = DBSelect { - selWith :: !Query - , selSelectKeyword :: !Query - -- ^ By default @\"SELECT\"@, but might usefully be set to - -- something else such as @\"SELECT DISTINCT\"@ in some - -- situations. - , selFields :: Query - , selFrom :: !FromClause - , selWhereKeyword :: !Query - -- ^ Empty by default, but set to @\"WHERE\"@ if any @WHERE@ - -- clauses are added to the 'selWhere' field. - , selWhere :: !Query - , selGroupBy :: !Query - , selHaving :: !Query - -- below here, should appear outside any union - , selOrderBy :: !Query - , selLimit :: !Query - , selOffset :: !Query - } deriving (Generic) - -instance Show (DBSelect a) where - show = S8.unpack . fromQuery . renderDBSelect - -space :: Builder -space = fromChar ' ' - -qNull :: Query -> Bool -qNull = S.null . fromQuery - -qBuilder :: Query -> Builder -qBuilder = fromByteString . fromQuery - -toQuery :: Builder -> Query -toQuery = Query . toByteString - -buildFromClause :: FromClause -> Builder -buildFromClause (FromModel q _) | qNull q = mempty -buildFromClause cl0 = fromByteString " FROM " <> go cl0 - where go (FromModel q _) = qBuilder q - go (FromJoin left joinkw right onClause _) = mconcat [ - fromChar '(', go left, space, qBuilder joinkw, space, go right - , if qNull onClause then mempty else space <> qBuilder onClause - , fromChar ')' ] - -class GDBS f where - gdbsDefault :: f p - gdbsQuery :: f p -> Builder -instance GDBS (K1 i Query) where - gdbsDefault = K1 (Query S.empty) - gdbsQuery (K1 q) | qNull q = mempty - | otherwise = space <> qBuilder q -instance GDBS (K1 i FromClause) where - gdbsDefault = K1 (FromModel "" "") - gdbsQuery (K1 fc) = buildFromClause fc -instance (GDBS a, GDBS b) => GDBS (a :*: b) where - gdbsDefault = gdbsDefault :*: gdbsDefault - gdbsQuery (a :*: b) = gdbsQuery a <> gdbsQuery b -instance (GDBS f) => GDBS (M1 i c f) where - gdbsDefault = M1 gdbsDefault - gdbsQuery = gdbsQuery . unM1 - --- | A 'DBSelect' structure with keyword @\"SELECT\"@ and everything --- else empty. -emptyDBSelect :: DBSelect a -emptyDBSelect = (to gdbsDefault) { selSelectKeyword = fromString "SELECT" } - --- | A 'DBSelect' for one or more comma-separated expressions, rather --- than for a table. For example, to issue the query @\"SELECT --- lastval()\"@: --- --- > lastval :: DBSelect (Only DBKeyType) --- > lastval = expressionDBSelect "lastval ()" --- > --- > ... --- > [just_inserted_id] <- dbSelect conn lastval --- --- On the other hand, for such a simple expression, you might as well --- call 'query_' directly. -expressionDBSelect :: (Model r) => Query -> DBSelect r -expressionDBSelect q = emptyDBSelect { selFields = q } - --- | Create a 'Builder' for a rendered version of a 'DBSelect'. This --- can save one string copy if you want to embed one query inside --- another as a subquery, as done by `dbProject'`, and thus need to --- parenthesize it. However, the function is probably not a useful --- for end users. -buildDBSelect :: DBSelect a -> Builder -buildDBSelect dbs = gdbsQuery $ from dbs - --- | Turn a 'DBSelect' into a 'Query' suitable for the 'query' or --- 'query_' functions. -renderDBSelect :: DBSelect a -> Query -renderDBSelect = Query . S.tail . toByteString . buildDBSelect --- S.tail is because the rendering inserts an extra space at the beginning - -catQueries :: Query -> Query -> Query -> Query -catQueries left delim right - | qNull left = right - | qNull right = left - | otherwise = Query $ S.concat $ map fromQuery [left, delim, right] - --- | Add a where clause verbatim to a 'DBSelect'. The clause must --- /not/ contain the @WHERE@ keyword (which is added automatically by --- @addWhere_@ if needed). If the @DBSelect@ has existing @WHERE@ --- clauses, the new clause is appended with @AND@. If the query --- contains any @\'?\'@ characters, they will be rendered into the --- query and matching parameters will later have to be filled in via a --- call to 'dbSelectParams'. -addWhere_ :: Query -> DBSelect a -> DBSelect a -addWhere_ q dbs - | qNull q = dbs - | otherwise = dbs { selWhereKeyword = "WHERE" - , selWhere = catQueries (selWhere dbs) " AND " q } - --- | Add a where clause, and pre-render parameters directly into the --- clause. The argument @p@ must have exactly as many fields as there --- are @\'?\'@ characters in the 'Query'. Example: --- --- > bars <- dbSelect c $ addWhere "bar_id = ?" (Only target_id) $ --- > (modelDBSelect :: DBSelect Bar) -addWhere :: (ToRow p) => Query -> p -> DBSelect a -> DBSelect a -addWhere q p dbs - | qNull q = dbs - | otherwise = dbs { - selWhereKeyword = "WHERE" - , selWhere = if qNull $ selWhere dbs - then toQuery clause - else toQuery $ qBuilder (selWhere dbs) <> - fromByteString " AND " <> clause - } - where clause = mconcat [fromChar '(', buildSql q p, fromChar ')'] - --- | Set the @ORDER BY@ clause of a 'DBSelect'. Example: --- --- > dbSelect c $ setOrderBy "\"employeeName\" DESC NULLS FIRST" $ --- > modelDBSelect -setOrderBy :: Query -> DBSelect a -> DBSelect a -setOrderBy (Query ob) dbs = dbs { selOrderBy = Query $ "ORDER BY " <> ob } - --- | Set the @LIMIT@ clause of a 'DBSelect'. -setLimit :: Int -> DBSelect a -> DBSelect a -setLimit i dbs = dbs { selLimit = fmtSql "LIMIT ?" (Only i) } - --- | Set the @OFFSET@ clause of a 'DBSelect'. -setOffset :: Int -> DBSelect a -> DBSelect a -setOffset i dbs = dbs { selOffset = fmtSql "OFFSET ?" (Only i) } - --- | Add one or more comma-separated expressions to 'selFields' that --- produce column values without any corresponding relation in the --- @FROM@ clause. Type @r@ is the type into which the expression is --- to be parsed. Generally this will be an instance of 'FromRow' that --- is a degenerate model (e.g., 'Only', or a tuple). --- --- For example, to rank results by the field @value@ and compute the --- fraction of overall value they contribute: --- --- > r <- dbSelect c $ addExpression --- > "rank() OVER (ORDER BY value), value::float4/SUM(value) OVER ()" --- > modelDBSelect --- > :: IO [Bar :. (Int, Double)] -addExpression :: (Model r) => Query -> DBSelect a -> DBSelect (a :. r) -addExpression q dbs = dbs { - selFields = if qNull $ selFields dbs then q - else Query $ S.concat $ map fromQuery [selFields dbs, ", ", q] - } - --- | A 'DBSelect' that returns all rows of a model. -modelDBSelect :: forall a. (Model a) => DBSelect a -modelDBSelect = r - where mi = modelIdentifiers :: ModelIdentifiers a - r = emptyDBSelect { - selFields = Query $ S.intercalate ", " $ modelQColumns mi - , selFrom = FromModel (Query $ modelQTable mi) (modelQTable mi) - } - --- | Run a 'DBSelect' query on parameters. The number of @\'?\'@ --- characters embedeed in various fields of the 'DBSelect' must --- exactly match the number of fields in parameter type @p@. Note the --- order of arguments is such that the 'DBSelect' can be pre-rendered --- and the parameters supplied later. Hence, you should use this --- version when the 'DBSelect' is static. For dynamically modified --- 'DBSelect' structures, you may prefer 'dbSelect'. -dbSelectParams :: (Model a, ToRow p) => DBSelect a -> Connection -> p -> IO [a] -{-# INLINE dbSelectParams #-} -dbSelectParams dbs = \c p -> map lookupRow <$> query c q p - where -- {-# NOINLINE q #-} (crashes under GHC 7.8) - q = renderDBSelect dbs - --- | Run a 'DBSelect' query and return the resulting models. -dbSelect :: (Model a) => Connection -> DBSelect a -> IO [a] -{-# INLINE dbSelect #-} -dbSelect c dbs = map lookupRow <$> query_ c q - where -- {-# NOINLINE q #-} (crashes under GHC 7.8) - 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 - --- | Group the returned tuples by unique a's. Expects the query to return a's --- in sequence -- all rows with the same value for a must be grouped together, --- for example, by sorting the result on a's primary key column. -dbCollect :: (Model a, Model b) - => Connection -> DBSelect (a :. b) -> IO [(a, [b])] -dbCollect c ab = dbFold c group [] ab - where - group :: (Model a, Model b) => [(a, [b])] -> (a :. b) -> [(a, [b])] - group [] (a :. b) = [(a, [b])] - group ls@(l:_) (a :. b) | primaryKey a /= primaryKey (fst l) = (a, [b]):ls - group (l:ls) (_ :. b) = (fst l, b:(snd l)):ls - --- | Create a join of the 'selFields', 'selFrom', and 'selWhere' --- clauses of two 'DBSelect' queries. Other fields are simply taken --- from the second 'DBSelect', meaning fields such as 'selWith', --- 'selGroupBy', and 'selOrderBy' in the in the first 'DBSelect' are --- entirely ignored. -dbJoin :: forall a b. - (Model a, Model b) => - DBSelect a -- ^ First table - -> Query -- ^ Join keyword (@\"JOIN\"@, @\"LEFT JOIN\"@, etc.) - -> DBSelect b -- ^ Second table - -> Query -- ^ Predicate (if any) including @ON@ or @USING@ keyword - -> DBSelect (a :. b) -dbJoin left joinOp right onClause = addWhere_ (selWhere left) right { - selFields = Query $ S.concat [fromQuery $ selFields left, ", ", - fromQuery $ selFields right] - , selFrom = newfrom - } - where idab = modelIdentifiers :: ModelIdentifiers (a :. b) - newfrom | nullFrom $ selFrom right = selFrom left - | nullFrom $ selFrom left = selFrom right - | otherwise = FromJoin (selFrom left) joinOp (selFrom right) - onClause (modelQTable idab) - --- | A version of 'dbJoin' that uses 'modelDBSelect' for the joined --- tables. -dbJoinModels :: (Model a, Model b) => - Query -- ^ Join keyword - -> Query -- ^ @ON@ or @USING@ predicate - -> DBSelect (a :. b) -dbJoinModels kw on = dbJoin modelDBSelect kw modelDBSelect on - --- | Restrict the fields returned by a DBSelect to be those of a --- single 'Model' @a@. It only makes sense to do this if @a@ is part --- of @something_containing_a@, but no static check is performed that --- this is the case. If you @dbProject@ a type that doesn't make --- sense, you will get a runtime error from a failed database query. -dbProject :: forall a something_containing_a. - (Model a) => DBSelect something_containing_a -> DBSelect a -{-# INLINE dbProject #-} -dbProject dbs = r - where sela = modelDBSelect :: DBSelect a - r = dbs { selFields = selFields sela } - --- | Like 'dbProject', but renders the entire input 'DBSelect' as a --- subquery. Hence, you can no longer mention fields of models other --- than @a@ that might be involved in joins. The two advantages of --- this approach are 1) that you can once again join to tables that --- were part of the original query without worrying about row aliases, --- and 2) that all terms of the 'DBSelect' will be faithrully rendered --- into the subquery (whereas otherwise they could get dropped by join --- operations). Generally you will still want to use 'dbProject', but --- @dbProject'@ is available when needed. -dbProject' :: forall a something_containing_a. - (Model a) => DBSelect something_containing_a -> DBSelect a -dbProject' dbs = r - where sela = modelDBSelect :: DBSelect a - ida = modelIdentifiers :: ModelIdentifiers a - Just mq = modelQualifier ida - q = toQuery $ fromChar '(' <> - buildDBSelect dbs { selFields = selFields sela } <> - fromByteString ") AS " <> fromByteString mq - r = sela { selFrom = FromModel q $ modelQTable ida } - -mergeFromClauses :: S.ByteString -> FromClause -> FromClause -> FromClause -mergeFromClauses canon left right = - case go left of - (fc, 1) -> fc - (_, 0) -> error $ "mergeFromClauses could not find " ++ show canon - (_, _) -> error $ "mergeFromClauses found duplicate " ++ show canon - where go fc | fcCanonical fc == canon = (right, 1 :: Int) - go (FromJoin l op r on ffc) = - case (go l, go r) of - ((lfc, ln), (rfc, rn)) -> (FromJoin lfc op rfc on ffc, ln + rn) - go fc = (fc, 0) - --- | Nest two type-compatible @JOIN@ queries. As with 'dbJoin', --- fields of the first @JOIN@ (the @'DBSelect' (a :. b)@) other than --- 'selFields', 'selFrom', and 'selWhere' are entirely ignored. -dbNest :: forall a b c. (Model a, Model b) => - DBSelect (a :. b) -> DBSelect (b :. c) -> DBSelect (a :. b :. c) -dbNest left right = addWhere_ (selWhere left) right { - selFields = fields - , selFrom = mergeFromClauses nameb (selFrom left) (selFrom right) - } - where nameb = modelQTable (modelIdentifiers :: ModelIdentifiers b) - acols = modelQColumns (modelIdentifiers :: ModelIdentifiers a) - colcomma c r = fromByteString c <> fromByteString ", " <> r - fields = toQuery $ foldr colcomma (qBuilder $ selFields right) - acols - --- | Like 'dbNest', but projects away the middle type @b@. -dbChain :: (Model a, Model b, Model c) => - DBSelect (a :. b) -> DBSelect (b :. c) -> DBSelect (a :. c) -dbChain left right = dbProject $ dbNest left right diff --git a/Database/PostgreSQL/ORM/Model.hs b/Database/PostgreSQL/ORM/Model.hs deleted file mode 100644 --- a/Database/PostgreSQL/ORM/Model.hs +++ /dev/null @@ -1,1168 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE CPP #-} - --- | The main database ORM interface. This module contains --- functionality for moving a Haskell data structure in and out of a --- database table. --- --- The most important feature is the 'Model' class, which encodes a --- typed database interface (i.e., the ORM layer). This class has a --- default implementation for types that are members of the 'Generic' --- class (using GHC's @DeriveGeneric@ extension), provided the --- following conditions hold: --- --- 1. The data type must have a single constructor that is defined --- using record selector syntax. --- --- 2. The very first field of the data type must be a 'DBKey' to --- represent the primary key. Other orders will cause a --- compilation error. --- --- 3. Every field of the data structure must be an instance of --- 'FromField' and 'ToField'. --- --- 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: --- --- > data MyType = MyType { myKey :: !DBKey --- > , myName :: !S.ByteString --- > , myCamelCase :: !Int --- > , ... --- > } deriving (Show, Generic) --- > instance Model MyType --- --- The default 'modelInfo' method is called 'defaultModelInfo'. You --- may wish to use almost all of the defaults, but tweak a few things. --- This is easily accomplished by overriding a few fields of the --- default structure. For example, suppose your database columns use --- exactly the same name as your Haskell field names, but the name of --- your database table is not the same as the name of the Haskell data --- type. You can override the database table name (field 'modelTable') --- as follows: --- --- > instance Model MyType where --- > modelInfo = defaultModelInfo { modelTable = "my_type" } --- --- Finally, if you dislike the conventions followed by --- 'defaultModelInfo', you can simply implement an alternate pattern. --- An example of this is 'underscoreModelInfo', which strips a prefix --- off every field name and converts everything from camel-case to --- underscore notation: --- --- > instance Model MyType where --- > modelInfo = underscoreModelInfo "my" --- --- The above code will associate @MyType@ with a database table --- @my_type@ having column names @key@, @name@, @camel_case@, etc. --- --- You can implement other patterns like 'underscoreModelInfo' by --- calling 'defaultModelInfo' and modifying the results. --- Alternatively, you can directly call the lower-level functions from --- which 'defaultModelInfo' is built ('defaultModelTable', --- 'defaultModelColumns', 'defaultModelGetPrimaryKey'). -module Database.PostgreSQL.ORM.Model ( - -- * The Model class - Model(..), ModelInfo(..), ModelIdentifiers(..), ModelQueries(..) - , underscoreModelInfo - -- * Data types for holding primary keys - , DBKeyType, DBKey(..), isNullKey - , DBRef, DBRefUnique, GDBRef(..), mkDBRef - -- * Database operations on Models - , findAll, findRow, save, save_, trySave, destroy, destroyByRef - -- * Functions for accessing and using Models - , modelName, primaryKey, modelSelectFragment - , LookupRow(..), UpdateRow(..), InsertRow(..) - -- * Table aliases - , As(..), fromAs, toAs, RowAlias(..) - -- * Low-level functions providing manual access to defaults - , defaultModelInfo - , defaultModelTable, defaultModelColumns, defaultModelGetPrimaryKey - , defaultModelIdentifiers - , defaultModelWrite - , defaultModelQueries - , defaultModelLookupQuery, defaultModelUpdateQuery - , defaultModelInsertQuery, defaultModelDeleteQuery - -- * Helper functions and miscellaneous internals - , quoteIdent, NormalRef(..), UniqueRef(..) - , ModelCreateInfo(..), emptyModelCreateInfo - , defaultFromRow, defaultToRow - , printq - -- ** Helper classes - -- $HelperClasses - , GPrimaryKey0, GColumns, GDatatypeName - , GFromRow, GToRow - ) where - -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 qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Char -import Data.Data -import Data.Int -import qualified Data.HashMap.Strict as H -import Data.Maybe -import Data.Monoid -import Data.List hiding (find) -import Data.String -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.FromField -import Database.PostgreSQL.Simple.FromRow -import Database.PostgreSQL.Simple.ToField -import Database.PostgreSQL.Simple.ToRow -import Database.PostgreSQL.Simple.Types -import Database.PostgreSQL.ORM.Validations -import GHC.Generics - -import Data.RequireSelector -import Database.PostgreSQL.Escape (quoteIdent) - --- | A type large enough to hold database primary keys. Do not use --- this type directly in your data structures. Use 'DBKey' to hold a --- `Model`'s primary key and 'DBRef' to reference the primary key of --- another model. -type DBKeyType = Int64 - --- | The type of the Haskell data structure field containing a model's --- primary key. --- --- Every 'Model' must have exactly one @DBKey@, and the @DBKey@ must --- be the `Model`'s very first field in the Haskel data type --- definition. (The ordering is enforced by --- 'defaultModelGetPrimaryKey', which, through use of the --- @DeriveGeneric@ extension, fails to compile when the first field is --- not a @DBKey@.) --- --- Each 'Model' stored in the database should have a unique non-null --- primary key. However, the key is determined at the time the --- 'Model' is inserted into the database. While you are constructing --- a new 'Model' to insert, you will not have its key. Hence, you --- should use the value @NullKey@ to let the database chose the key. --- --- If you wish to store a `Model`'s primary key as a reference in --- another 'Model', do not copy the 'DBKey' structure. Use 'mkDBRef' --- to convert the `Model`'s primary key to a foreign key reference. -data DBKey = DBKey !DBKeyType | NullKey deriving (Data, Typeable, Generic) - -instance A.ToJSON DBKey where - toJSON NullKey = A.Null - toJSON (DBKey k) = A.toJSON k - -instance A.FromJSON DBKey where - parseJSON (A.Number a) = return $ DBKey (floor a) - parseJSON A.Null = return NullKey - parseJSON _ = error "Expected Number or Null" - -instance Eq DBKey where - (DBKey a) == (DBKey b) = a == b - _ == _ = error "compare NullKey" -instance Ord DBKey where - compare (DBKey a) (DBKey b) = compare a b - compare _ _ = error "compare NullKey" - -instance Show DBKey where - showsPrec n (DBKey k) = showsPrec n k - showsPrec _ NullKey = ("NullKey" ++) - -instance FromField DBKey where - fromField _ Nothing = pure NullKey - fromField f bs = DBKey <$> fromField f bs -instance ToField DBKey where - toField (DBKey k) = toField k - toField NullKey = toField Null - --- | Returns 'True' when a 'DBKey' is 'NullKey'. -isNullKey :: DBKey -> Bool -isNullKey NullKey = True -isNullKey _ = False - - --- | Many operations can take either a 'DBRef' or a 'DBRefUnique' --- (both of which consist internally of a 'DBKeyType'). Hence, these --- two types are just type aliases to a generalized reference type --- @GDBRef@, where @GDBRef@'s first type argument, @reftype@, is a --- phantom type denoting the flavor of reference ('NormalRef' or --- 'UniqueRef'). -newtype GDBRef reftype table = DBRef DBKeyType - deriving (Eq, Data, Typeable, Num, Integral, Real, Ord, Enum, Bounded, Generic) - -instance A.ToJSON (GDBRef t a) where - toJSON (DBRef k) = A.toJSON k - -instance A.FromJSON (GDBRef t a) where - parseJSON (A.Number n) = return $ DBRef (floor n) - parseJSON _ = error "Expected Number" - -instance (Model t) => Show (GDBRef rt t) where - showsPrec n (DBRef k) = showsPrec n k -instance (Model t) => Read (GDBRef rt t) where - readsPrec n str = map wrap $ readsPrec n str - where wrap (k, s) = (DBRef k, s) -instance FromField (GDBRef rt t) where - {-# INLINE fromField #-} - fromField f bs = DBRef <$> fromField f bs -instance ToField (GDBRef rt t) where - {-# INLINE toField #-} - toField (DBRef k) = toField k - --- | Phantom type for instantiating 'GDBRef' that represents a one-to-many --- relationship between tables. -data NormalRef = NormalRef deriving (Show, Data, Typeable) - --- | A @DBRef T@ represents a many-to-one relationship between tables. For --- example, if type @A@ contains a @DBRef B@, then each @B@ is associated --- with many @A@'s. By contrast, a @'DBRefUnique'@ represents a one-to-one --- relationship. --- --- @DBRef@ is a type alias of kind @* -> *@. The type @DBRef T@ --- references an instance of type @T@ by the primary key of its --- database row. The type argument @T@ should be an instance of --- 'Model'. -type DBRef = GDBRef NormalRef - --- | Phantom type for instantiating 'GDBRef' that represents a one-to-one --- relationship between tables. -data UniqueRef = UniqueRef deriving (Show, Data, Typeable) - --- | A @DBRefUnique T@ represents a one-to-one relationship between types. For --- example, if type @A@ contains a @DBRefUnique B@, then each @A@ is associated --- with one (or at most one) @B@, and each @B@ has one (or at most one) @A@ --- associated with it. --- --- By contrast, a @'DBRef'@ represents a many-to-one relationship. -type DBRefUnique = GDBRef UniqueRef --- Functionally, @DBRefUnique@ and @DBRef@ are treated the same by --- this module. However, other modules make a distinction. In --- particular, the 'modelCreateStatement' corresponding to a --- 'DBRefUnique' will include a @UNIQUE@ constraint. - --- | Create a reference to the primary key of a 'Model', suitable for --- storing in a 'DBRef' or 'DBRefUnique' field of a different 'Model'. -mkDBRef :: (Model a) => a -> GDBRef rt a -mkDBRef a - | (DBKey k) <- primaryKey a = DBRef k - | otherwise = error $ "mkDBRef " ++ S8.unpack (modelName a) ++ ": NullKey" - - --- | A @ModelInfo T@ contains the information necessary for mapping --- @T@ to a database table. Each @'Model'@ type has a single --- @ModelInfo@ associated with it, accessible through the 'modelInfo' --- method of the 'Model' class. Note the table and column names must --- all be unquoted in this data structure, as they will later be --- quoted using 'quoteIdent' by the 'modelIdentifiers' method. -data ModelInfo a = ModelInfo { - modelTable :: !S.ByteString - -- ^ The name of the database table corresponding to this model. - -- The default 'modelInfo' instance uses 'defaultModelTable', - -- which is the name of your data type with the first letter - -- downcased. - , modelColumns :: ![S.ByteString] - -- ^ The names of the database columns corresponding to fields of - -- this model. The column names should appear in the order in - -- which the fields are defined in the Haskell data type @a@ - -- (which should also be the order in which 'modelRead' parses - -- them to an @a@ and 'modelWrite' marshalls them). - -- - -- Note that all queries generated by the library specify explicit - -- column names. Hence the order of columns does not need to - -- match their order in the database table. They should instead - -- match the order of fields in the Haskell data structure. - -- - -- The default, given by 'defaultModelColumns', is to use the - -- Haskell field names for @a@. This default will fail to compile - -- if @a@ is not defined using record syntax. - , modelPrimaryColumn :: !Int - -- ^ The 0-based index of the primary key column in - -- 'modelColumns'. This should be 0 when your data structure's - -- first field is its 'DBKey' (highly recommended, and required by - -- 'defaultModelGetPrimaryKey'). If you customize this field, you - -- must also customize 'modelGetPrimaryKey'--no check is made that - -- the two are consistent. - , modelGetPrimaryKey :: !(a -> DBKey) - -- ^ Return the primary key of a particular model instance. If - -- you customize this field, you must also customize - -- 'modelPrimaryColumn'--no check is made that the two are - -- consistent. - } - -instance Show (ModelInfo a) where - show a = intercalate " " [ - "Model", show $ modelTable a, show $ modelColumns a - , show $ modelPrimaryColumn a , "?"] - - --- $HelperClasses --- --- These classes are used internally to manipulate the 'Rep' --- representations of 'Generic' data structures. You should not be --- defining instances of or using these classes directly. The names --- are exported so that you can include them in the context of the --- type signatures of your functions, should you wish to make use of --- the various @default@... funcitons in this file. - --- | This class returns the name of a datatype. -class GDatatypeName f where - gDatatypeName :: f p -> String -instance (Datatype c) => GDatatypeName (D1 c f) where - gDatatypeName a = datatypeName a --- | The default name of the database table corresponding to a Haskell --- type. The default is the same as the type name with the first --- letter converted to lower-case. (The rationale is that Haskell --- requires types to start with a capital letter, but all-lower-case --- table names are easier to use in queries because PostgreSQL --- generally does not require them to be quoted.) -defaultModelTable :: (Generic a, GDatatypeName (Rep a)) => a -> S.ByteString -defaultModelTable = fromString . caseFold. gDatatypeName . from - where caseFold (h:t) = toLower h:t - caseFold s = s - --- | This class extracts the field names of a Haskell data structure. Only --- defined for types with a single constructor that uses record syntax. -class GColumns f where - gColumns :: f p -> [S.ByteString] -instance GColumns U1 where - gColumns _ = [] -instance (Selector c) => GColumns (M1 S c f) where - gColumns s = [fromString $ selName s] -instance (GColumns a, GColumns b) => GColumns (a :*: b) where - gColumns ~(a :*: b) = gColumns a ++ gColumns b -instance (GColumns f) => GColumns (M1 C c f) where - gColumns ~(M1 fp) = gColumns fp -instance (GColumns f) => GColumns (M1 D c f) where - gColumns ~(M1 fp) = gColumns fp --- | Returns the Haskell field names in a data structure. -defaultModelColumns :: (Generic a, GColumns (Rep a)) => a -> [S.ByteString] -defaultModelColumns = gColumns . from - --- | This class extracts the first field in a data structure when the --- field is of type 'DBKey'. If you get a compilation error because --- of this class, then move the 'DBKey' first in your data structure. -class GPrimaryKey0 f where - gPrimaryKey0 :: f p -> DBKey -instance GPrimaryKey0 (S1 c (K1 i DBKey)) where - {-# INLINE gPrimaryKey0 #-} - gPrimaryKey0 (M1 (K1 k)) = k -instance (GPrimaryKey0 a) => GPrimaryKey0 (a :*: b) where - {-# INLINE gPrimaryKey0 #-} - gPrimaryKey0 (a :*: _) = gPrimaryKey0 a -instance (GPrimaryKey0 f) => GPrimaryKey0 (C1 c f) where - {-# INLINE gPrimaryKey0 #-} - gPrimaryKey0 (M1 fp) = gPrimaryKey0 fp -instance (GPrimaryKey0 f) => GPrimaryKey0 (D1 c f) where - {-# INLINE gPrimaryKey0 #-} - gPrimaryKey0 (M1 fp) = gPrimaryKey0 fp - --- | Extract the primary key of type 'DBKey' from a model when the --- 'DBKey' is the first element of the data structure. Fails to --- compile if the first field is not of type 'DBKey'. -defaultModelGetPrimaryKey :: (Generic a, GPrimaryKey0 (Rep a)) => a -> DBKey -{-# INLINE defaultModelGetPrimaryKey #-} -defaultModelGetPrimaryKey = gPrimaryKey0 . from - - -class GFromRow f where - gFromRow :: RowParser (f p) -instance GFromRow U1 where - {-# INLINE gFromRow #-} - gFromRow = return U1 -instance (FromField c) => GFromRow (K1 i c) where - {-# INLINE gFromRow #-} - gFromRow = K1 <$> field -instance (GFromRow a, GFromRow b) => GFromRow (a :*: b) where - {-# INLINE gFromRow #-} - gFromRow = (:*:) <$> gFromRow <*> gFromRow -instance (GFromRow f) => GFromRow (M1 i c f) where - {-# INLINE gFromRow #-} - gFromRow = M1 <$> gFromRow --- | This function provides a 'fromRow' function for 'Generic' types, --- suitable as a default of the 'FromRow' class. This module uses it --- as the default implementation of 'modelRead'. -defaultFromRow :: (Generic a, GFromRow (Rep a)) => RowParser a -{-# INLINE defaultFromRow #-} -defaultFromRow = to <$> gFromRow - - -class GToRow f where - gToRow :: f p -> [Action] -instance GToRow U1 where - gToRow _ = [] -instance (ToField c) => GToRow (K1 i c) where - gToRow (K1 c) = [toField c] -instance (GToRow a, GToRow b) => GToRow (a :*: b) where - gToRow (a :*: b) = gToRow a ++ gToRow b -instance (GToRow f) => GToRow (M1 i c f) where - gToRow (M1 fp) = gToRow fp --- | This function provides a 'toRow' function for 'Generic' types --- that marshalls each field of the data type in the order in which it --- appears in the type definition. This function is /not/ a suitable --- implementation of 'modelWrite' (since it marshals the primary key, --- which is not supposed to be written). However, it is required --- internally by 'defaultModelWrite', and exposed in the unlikely --- event it is of use to alternate generic 'modelWrite' functions. --- You probably don't want to call this function. -defaultToRow :: (Generic a, GToRow (Rep a)) => a -> [Action] -defaultToRow = gToRow . from - --- | Removes a single element from the list at the position specified. --- (Internal) -deleteAt :: Int -> [a] -> [a] -deleteAt 0 (_:t) = t -deleteAt n (h:t) = h:deleteAt (n-1) t -deleteAt _ _ = [] - --- | Returns a series of 'Action's serializing each field of a data --- structure (in the order of the Haskell datatype definition), --- /except/ the primary key, since the primary key should never be --- written to a database. Every field must be an instance of --- 'ToField'. -defaultModelWrite :: forall a. (Model a, Generic a, GToRow (Rep a)) - => a -> [Action] -{-# INLINE defaultModelWrite #-} -defaultModelWrite a = deleteAt pki $ defaultToRow a - where pki = modelPrimaryColumn (modelInfo :: ModelInfo a) - --- | The default definition of 'modelInfo'. See the documentation at --- 'Model' for more information. Sets 'modelTable' to the name of the --- type with the first character converted to lower-case. Sets --- 'modelColumns' to the names of the Haskell field selectors. Sets --- 'modelPrimaryColumn' to @0@ and extracts the first field of the --- structure for 'modelGetPrimaryKey'. Will fail to compile unless --- the data structure is defined with record syntax and that its first --- field is of type 'DBKey'. --- --- Note that defaults for the individual fields are available in --- separate functions (e.g., 'defaultModelTable') with fewer class --- requirements in the context, in case you want to make piecemeal use --- of defaults. The default for 'modelPrimaryColumn' is 0. If you --- overwrite that, you will need to overwrite 'modelGetPrimaryKey' as --- well (and likely vice versa). -defaultModelInfo :: forall a. - (Generic a, GDatatypeName (Rep a), GColumns (Rep a) - , GPrimaryKey0 (Rep a)) => ModelInfo a -defaultModelInfo = m - where m = ModelInfo { modelTable = defaultModelTable a - , modelColumns = defaultModelColumns a - , modelPrimaryColumn = 0 - , modelGetPrimaryKey = defaultModelGetPrimaryKey - } - a = undefined :: a - --- | An alternate 'Model' pattern in which Haskell type and field --- names are converted from camel-case to underscore notation. The --- first argument is a prefix to be removed from field names (since --- Haskell requires field names to be unique across data types, while --- SQL allows the same column names to be used in different tables). --- --- For example: --- --- > data Bar = Bar { --- > barId :: !DBKey --- > , barNameOfBar :: !String --- > , barParent :: !(Maybe (DBRef Bar)) --- > } deriving (Show, Generic) --- > --- > instance Model Bar where modelInfo = underscoreModelInfo "bar" --- --- would associate type @Bar@ with a database table called @bar@ with --- fields @id@, @name_of_bar@, and @parent@. -underscoreModelInfo :: (Generic a, GToRow (Rep a), GFromRow (Rep a) - , GPrimaryKey0 (Rep a), GColumns (Rep a) - , GDatatypeName (Rep a)) => - S.ByteString -> ModelInfo a -underscoreModelInfo prefix = def { - modelTable = toUnderscore True $ modelTable def - , modelColumns = map fixCol $ modelColumns def - } - where def = defaultModelInfo - plen = S.length prefix - fixCol c = toUnderscore False $ stripped - where stripped | prefix `S.isPrefixOf` c = S.drop plen c - | otherwise = c - --- | Convert a name from camel-case to underscore notation. --- I.e., names of the form "MSizeForm" are changed to "MSize_From". --- @skipFirst@ determines if the first character should be ignored --- in the conversion. -toUnderscore :: Bool -> S.ByteString -> S.ByteString -toUnderscore skipFirst | skipFirst = S8.pack . skip . S8.unpack - | otherwise = S8.pack . go True . S8.unpack - where skip "" = "" - skip (h:t) = toLower h : go True t - go _ "" = "" - go _ (h:t) | not (isUpper h) = h : go False t - go True (h:t) = toLower h : go True t - go False (h:t) = '_' : toLower h : go True t - - --- | SQL table and column identifiers that should be copied verbatim --- into queries. For normal models, these will simply be quoted --- versions of the fields in the corresponding 'ModelInfo'. However, --- for special cases, the fields of this structure can contain --- unquoted SQL including @JOIN@ keywords. In the case of joins, --- different elements of 'modelQColumns' may be qualified by different --- table names. --- --- Note that 'modelQColumns' and 'modelQPrimaryColumn' both contain --- table-qualified names (e.g., @\"\\\"my_type\\\".\\\"key\\\"\"@), --- while 'modelQWriteColumns' contains only the quoted column names. -data ModelIdentifiers a = ModelIdentifiers { - modelQTable :: !S.ByteString - -- ^ Literal SQL for the name of the table. - , modelQColumns :: ![S.ByteString] - -- ^ Literal SQL for each, table-qualified column. - , modelQPrimaryColumn :: S.ByteString - -- ^ Literal SQL for the model's table-qualified primary key - -- column. - , modelQWriteColumns :: [S.ByteString] - -- ^ Literal SQL for all the columns except the primary key. - -- These are the columns that should be included in an @INSERT@ or - -- @UPDATE@. Note that unlike the other fields, these column - -- names should /not/ be table-qualified. - , modelQualifier :: !(Maybe S.ByteString) - -- ^ When all columns in 'modelQColumns' are qualified by the same - -- table name, this field contains 'Just' the table name. - -- For the ':.' type (in which different columns have different - -- table qualifications), this field is 'Nothing'. - -- - -- For normal models, this field will be identical to - -- 'modelQTable'. However, for 'As' models, 'modelQTable' will - -- contain unquoted SQL such as @\"\\\"MyType\\\" AS - -- \\\"my_alias\\\"\"@, in which case @modelQualifier@ will - -- contain @'Just' \"\\\"my_alias\\\"\"@. - , modelOrigTable :: !(Maybe S.ByteString) - -- ^ The original, unquoted name of the table representing the - -- model in the database. Ordinarily, this should be the same as - -- 'modelTable' in 'ModelInfo', but in the case of 'As' aliases, - -- the 'modelTable' is an alias, and 'modelOrigTable' is the - -- original table. 'Nothing' for joins. - } deriving (Show) - --- | The default simply quotes the 'modelInfo' and 'modelColumns' --- fields of 'ModelInfo' using 'quoteIdent'. -defaultModelIdentifiers :: ModelInfo a -> ModelIdentifiers a -defaultModelIdentifiers mi = ModelIdentifiers { - modelQTable = qtable - , modelQColumns = qcols - , modelQPrimaryColumn = qcols !! pki - , modelQWriteColumns = deleteAt pki $ map quoteIdent $ modelColumns mi - , modelQualifier = Just qtable - , modelOrigTable = Just $ modelTable mi - } - where qtable = quoteIdent (modelTable mi) - qcol c = S.concat [qtable, ".", quoteIdent c] - qcols = map qcol $ modelColumns mi - pki = modelPrimaryColumn mi - --- | Standard CRUD (create\/read\/update\/delete) queries on a model. -data ModelQueries a = ModelQueries { - modelLookupQuery :: !Query - -- ^ A query template for looking up a model by its primary key. - -- Expects a single query parameter, namely the 'DBKey' or 'DBRef' - -- being looked up. - , modelUpdateQuery :: !Query - -- ^ A query template for updating an existing 'Model' in the - -- database. Expects as query parameters a value for every column - -- of the model /except/ the primary key, followed by the primary - -- key. (The primary key is not written to the database, just - -- used to select the row to change.) - , modelInsertQuery :: !Query - -- ^ A query template for inserting a new 'Model' in the database. - -- The query parameters are values for all columns /except/ the - -- primary key. The query returns the full row as stored in the - -- database (including the values of fields, such as the primary - -- key, that have been chosen by the database server). - , modelDeleteQuery :: !Query - -- ^ A query template for deleting a 'Model' from the database. - -- Should have a single query parameter, namely the 'DBKey' of the - -- row to delete. - } deriving (Show) - --- | Default SQL lookup query for a model. -defaultModelLookupQuery :: ModelIdentifiers a -> Query -defaultModelLookupQuery mi = Query $ S.concat [ - modelSelectFragment mi, " WHERE ", modelQPrimaryColumn mi, " = ?" - ] - --- | Default SQL update query for a model. -defaultModelUpdateQuery :: ModelIdentifiers a -> Query -defaultModelUpdateQuery mi = Query $ S.concat [ - "UPDATE ", modelQTable mi, " SET " - , S.intercalate ", " $ map (<> " = ?") $ modelQWriteColumns mi - , " WHERE ", modelQPrimaryColumn mi, " = ?" - , " RETURNING ", S.intercalate ", " (modelQColumns mi) - ] - --- | Default SQL insert query for a model. -defaultModelInsertQuery :: ModelIdentifiers a -> Query -defaultModelInsertQuery mi - | null (modelQWriteColumns mi) = Query $ S.concat [ - "INSERT INTO ", modelQTable mi, " DEFAULT VALUES RETURNING " - , S.intercalate ", " $ modelQColumns mi ] - | otherwise = Query $ S.concat $ [ - "INSERT INTO ", modelQTable mi - , " (", S.intercalate ", " $ modelQWriteColumns mi - , ") VALUES (", S.intercalate ", " $ map (const "?") $ modelQWriteColumns mi - , ") RETURNING ", S.intercalate ", " $ modelQColumns mi - ] - --- | Default SQL delete query for a model. -defaultModelDeleteQuery :: ModelIdentifiers a -> Query -defaultModelDeleteQuery mi = Query $ S.concat [ - "DELETE FROM ", modelQTable mi - , " WHERE ", modelQPrimaryColumn mi, " = ?" - ] - --- | The default value of 'modelQueries'. -defaultModelQueries :: ModelIdentifiers a -> ModelQueries a -defaultModelQueries mi = ModelQueries { - modelLookupQuery = defaultModelLookupQuery mi - , modelUpdateQuery = defaultModelUpdateQuery mi - , modelInsertQuery = defaultModelInsertQuery mi - , modelDeleteQuery = defaultModelDeleteQuery mi - } - --- | Extra information for "Database.PostgreSQL.ORM.CreateTable". You --- probably don't need to use this. -data ModelCreateInfo a = ModelCreateInfo { - modelCreateColumnTypeExceptions :: ![(S.ByteString, S.ByteString)] - -- ^ A list of (column-name, type) pairs for which you want to - -- override the default. - , modelCreateExtraConstraints :: !S.ByteString - -- ^ Extra constraints to stick at the end of the @CREATE TABLE@ - -- statement. - } deriving (Show) - --- | A 'ModelCreateInfo' that doesn't imply any extra constraints or --- exceptions. -emptyModelCreateInfo :: ModelCreateInfo a -emptyModelCreateInfo = ModelCreateInfo { - modelCreateColumnTypeExceptions = [] - , modelCreateExtraConstraints = S.empty - } - --- | The class of data types that represent a database table. This --- class conveys information necessary to move a Haskell data --- structure in and out of a database table. The most important field --- is 'modelInfo', which describes the database table and column --- names. 'modelInfo' has a reasonable default implementation for --- types that are members of the 'Generic' class (using GHC's --- @DeriveGeneric@ extension), provided the following conditions hold: --- --- 1. The data type must have a single constructor that is defined --- using record selector syntax. --- --- 2. The very first field of the data type must be a 'DBKey' to --- represent the primary key. Other orders will cause a --- compilation error. --- --- 3. Every field of the data structure must be an instance of --- 'FromField' and 'ToField'. --- --- 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: --- --- > data MyType = MyType { myKey :: !DBKey --- > , myName :: !S.ByteString --- > , myCamelCase :: !Int --- > , ... --- > } deriving (Show, Generic) --- > instance Model MyType --- --- The default 'modelInfo' method is called 'defaultModelInfo'. You --- may wish to use almost all of the defaults, but tweak a few things. --- This is easily accomplished by overriding a few fields of the --- default structure. For example, suppose your database columns use --- exactly the same name as your Haskell field names, but the name of --- your database table is not the same as the name of the Haskell data --- type. You can override the database table name (field --- 'modelTable') as follows: --- --- > instance Model MyType where --- > modelInfo = defaultModelInfo { modelTable = "my_type" } --- --- Finally, if you dislike the conventions followed by --- 'defaultModelInfo', you can simply implement an alternate pattern. --- An example of this is 'underscoreModelInfo', which strips a prefix --- off every field name and converts everything from camel-case to --- underscore notation: --- --- > instance Model MyType where --- > modelInfo = underscoreModelInfo "my" --- --- The above code will associate @MyType@ with a database table --- @my_type@ having column names @key@, @name@, @camel_case@, etc. --- --- You can implement other patterns like 'underscoreModelInfo' by --- calling 'defaultModelInfo' and modifying the results. --- Alternatively, you can directly call the lower-level functions from --- which 'defaultModelInfo' is built ('defaultModelTable', --- 'defaultModelColumns', 'defaultModelGetPrimaryKey'). -class Model a where - -- | @modelInfo@ provides information about how the Haskell data - -- type is stored in the database, in the form of a 'ModelInfo' data - -- structure. Among other things, this structure specifies the name - -- of the database table, the names of the database columns - -- corresponding to the Haskell data structure fields, and the - -- position of the primary key in both the database columns and the - -- Haskell data structure. - modelInfo :: ModelInfo a - default modelInfo :: (Generic a, GDatatypeName (Rep a), GColumns (Rep a) - , GPrimaryKey0 (Rep a)) => ModelInfo a - {-# INLINE modelInfo #-} - modelInfo = defaultModelInfo - - -- | 'modelIdentifiers' contains the table and column names verbatim - -- as they should be inserted into SQL queries. For normal models, - -- these are simply double-quoted (with 'quoteIdent') versions of - -- the names in 'modelInfo', with the column names qualified by the - -- double-quoted table name. However, for special cases such as - -- join relations (with ':.') or row aliases (with 'As'), - -- 'modelIdentifiers' can modify the table name with unquoted SQL - -- identifiers (such as @JOIN@ and @AS@) and change the qualified - -- column names appropriately. - modelIdentifiers :: ModelIdentifiers a - {-# INLINE modelIdentifiers #-} - modelIdentifiers = defaultModelIdentifiers modelInfo - - -- | @modelRead@ converts from a database 'query' result to the - -- Haskell data type of the @Model@, namely @a@. Note that if type - -- @a@ is an instance of 'FromRow', a fine definition of @modelRead@ - -- is @modelRead = fromRow@. The default is to construct a row - -- parser using the 'Generic' class. However, it is crucial that - -- the columns be parsed in the same order they are listed in the - -- 'modelColumns' field of @a@'s 'ModelInfo' structure, and this - -- should generally be the same order they are defined in the - -- Haskell data structure. Hence @modelRead@ should generally look - -- like: - -- - -- @ - -- -- Call 'field' as many times as there are fields in your type - -- modelRead = Constructor \<$> 'field' \<*> 'field' \<*> 'field' - -- @ - modelRead :: RowParser a - default modelRead :: (Generic a, GFromRow (Rep a)) => RowParser a - {-# INLINE modelRead #-} - modelRead = defaultFromRow - - -- | Marshal all fields of @a@ /except/ the primary key. As with - -- 'modelRead', the fields must be marshalled in the same order the - -- corresponding columns are listed in 'modelColumns', only with the - -- primary key (generally column 0) deleted. - -- - -- Do /not/ define this as 'toRow', even if @a@ is an instance of - -- 'ToRow', because 'toRow' would include the primary key. - -- Similarly, do /not/ define this as 'defaultToRow'. On the other - -- hand, it is reasonable for @modelWrite@ to return an error for - -- degenerate models (such as joins) that should never be 'save'd. - modelWrite :: a -> [Action] - default modelWrite :: (Generic a, GToRow (Rep a)) => a -> [Action] - {-# INLINE modelWrite #-} - modelWrite = defaultModelWrite - - -- | @modelQueries@ provides pre-formatted 'Query' templates for - -- 'findRow', 'save', and 'destroy'. The default 'modelQueries' - -- value is generated from 'modelIdentifiers' and should not be - -- modified. However, for degenerate tables (such as joins created - -- with ':.'), it is reasonable to make 'modelQueries' always throw - -- an exception, thereby disallowing ordinary queries and requiring - -- use of more general query functions. - -- - -- This method should either throw an exception or use the default - -- implementation. - modelQueries :: ModelQueries a - {-# INLINE modelQueries #-} - modelQueries = defaultModelQueries modelIdentifiers - - -- | Extra constraints, if any, to place in a @CREATE TABLE@ - -- statement. Only used by "Database.PostgreSQL.ORM.CreateTable". - modelCreateInfo :: ModelCreateInfo a - modelCreateInfo = emptyModelCreateInfo - - -- | Perform a validation of the model, returning any errors if - -- it is invalid. - modelValid :: a -> ValidationError - modelValid = const mempty - --- | Degenerate instances of 'Model' for types in the 'ToRow' class --- are to enable extra 'ToRow' types to be included with ':.' in the --- result of 'dbSelect' queries. -degen_err :: a -degen_err = error "Attempt to use degenerate ToRow instance as Model" -#define DEGENERATE(ctx,t) \ -instance ctx => Model t where { \ - modelInfo = degen_err; \ - modelIdentifiers = degen_err; \ - modelRead = fromRow; \ - modelWrite _ = degen_err; \ - modelCreateInfo = degen_err; } - -DEGENERATE(FromField t, (Only t)) -DEGENERATE(FromField t, [t]) -DEGENERATE((FromField a, FromField b), (a, b)) -DEGENERATE((FromField a, FromField b, FromField c), (a, b, c)) -DEGENERATE((FromField a, FromField b, FromField c, FromField d), (a, b, c, d)) -DEGENERATE((FromField a, FromField b, FromField c, FromField d, FromField e), \ - (a, b, c, d, e)) - -#undef DEGEN_ERR -#undef DEGENERATE - --- | A degenerate model that lifts any model to a Maybe version. Returns --- 'Nothing' on a parse failure. Useful, for example, for performing outer --- joins: --- @ --- dbJoin modelDBSelect "LEFT OUTER JOIN" --- (addWhere 'foo = 123' $ modelDBSelect) --- "USING a.id = b.a_id" :: (A :. Maybe B) --- @ --- -instance forall a. Model a => Model (Maybe a) where - modelInfo = mi_a { modelGetPrimaryKey = getPrimaryKey } - where mi_a = modelInfo :: ModelInfo a - getPrimaryKey Nothing = NullKey - getPrimaryKey (Just a) = modelGetPrimaryKey mi_a a - - modelIdentifiers = mi_a { modelQTable = modelQTable mi_a } - where mi_a = modelIdentifiers :: ModelIdentifiers a - - modelQueries = mi_a { modelLookupQuery = modelLookupQuery mi_a } - where mi_a = modelQueries :: ModelQueries a - - modelCreateInfo = error - "Attempt to use degenerate Maybe (Model a) instance for ModelCreateInfo" - - modelValid = maybe mempty modelValid - - modelWrite = maybe [] modelWrite - - modelRead = - Just `fmap` (modelRead :: RowParser a) - <|> do - let n = length $ modelColumns (modelInfo :: ModelInfo a) - replicateM_ n (field :: RowParser AnyField) - return Nothing - --- | AnyField parses (simply by consuming) any SQL column. -data AnyField = AnyField - -instance FromField AnyField where - fromField _ _ = pure AnyField - -joinModelIdentifiers :: forall a b. (Model a, Model b) - => ModelIdentifiers (a :. b) -joinModelIdentifiers = r - where r = ModelIdentifiers { - modelQTable = qtable - , modelQColumns = modelQColumns mia ++ modelQColumns mib - , modelQWriteColumns = error "attempt to write join relation" - , modelQPrimaryColumn = - error "attempt to use primary key of join relation" - , modelQualifier = Nothing - , modelOrigTable = Nothing - } - qtable | S.null $ modelQTable mib = modelQTable mia - | S.null $ modelQTable mia = modelQTable mib - | otherwise = S.concat [modelQTable mia, " CROSS JOIN " - , modelQTable mib] - mia = modelIdentifiers :: ModelIdentifiers a - mib = modelIdentifiers :: ModelIdentifiers b - --- | A degenerate instance of model representing a database join. The --- ':.' instance does not allow normal model operations such as --- 'findRow', 'save', and 'destroy'. Attempts to use such functions --- will result in an exception. -instance (Model a, Model b) => Model (a :. b) where - modelInfo = error "attempt to access ModelInfo of join type :." - modelIdentifiers = joinModelIdentifiers - modelRead = (:.) <$> modelRead <*> modelRead - modelWrite _ = error "attempt to write join type :. as a normal Model" - modelQueries = error "attempt to perform standard query on join type :." - - -class GUnitType f where - gUnitTypeName :: f p -> String -instance GUnitType (C1 c U1) where - gUnitTypeName _ = error "gUnitTypeName" -instance GUnitType V1 where - gUnitTypeName _ = error "gUnitTypeName" -instance (Datatype c, GUnitType f) => GUnitType (D1 c f) where - gUnitTypeName = datatypeName - --- | The class of types that can be used as tags in as 'As' alias. --- Such types should be unit types--in other words, have exactly one --- constructor where the constructor is nullary (take no arguments). --- The reason for this class is that the 'Model' instance for 'As' --- requires a way to extract the name of the row alias without having --- a concrete instance of the type. This is provided by the --- 'rowAliasName' method (which must be non-strict). -class RowAlias a where - rowAliasName :: g a row -> S.ByteString - -- ^ Return the SQL identifier for the row alias. This method must - -- be non-strict in its argument. Hence, it should discard the - -- argument and return the name of the alias. For example: - -- - -- > {-# LANGUAGE OverloadedStrings #-} - -- > - -- > data My_alias = My_alias - -- > instance RowAlias My_alias where rowAliasName _ = "my_alias" - -- - -- Keep in mind that PostgreSQL folds unquoted identifiers to - -- lower-case. However, this library quotes row aliases in @SELECT@ - -- statements, thereby preserving case. Hence, if you want to call - -- construct a @WHERE@ clause without double-quoting row aliases in - -- your 'Query', you should avoid capital letters in alias names. - -- - -- A default implementation of @rowAliasName@ exists for unit types - -- (as well as empty data declarations) in the 'Generic' class. The - -- default converts the first character of the type name to - -- lower-case, following the logic of 'defaultModelTable'. - default rowAliasName :: (Generic a, GUnitType (Rep a)) => - g a row -> S.ByteString - rowAliasName _ = fromString $ caseFold $ gUnitTypeName . from $ a - where caseFold (h:t) = toLower h:t -- fold first character only - caseFold [] = [] - a = undefined :: a - --- | The newtype @As@ can be wrapped around an existing type to give --- it a table name alias in a query. This is necessary when a model --- is being joined with itself, to distinguish the two joined --- instances of the same table. --- --- For example: --- --- @{-\# LANGUAGE OverloadedStrings #-} --- ---data X = X ---instance 'RowAlias' X where rowAliasName = const \"x\" --- --- \ ... --- r <- 'dbSelect' c $ addWhere_ \"bar.bar_key = x.bar_parent\" modelDBSelect --- :: IO [Bar :. As X Bar] --- @ -newtype As alias row = As { unAs :: row } -instance (RowAlias alias, Show row) => Show (As alias row) where - showsPrec d as@(As row) = showParen (d > 10) $ \rest -> - "As " ++ S8.unpack (rowAliasName as) ++ - " (" ++ showsPrec 11 row (")" ++ rest) - - --- | @fromAs@ extracts the @row@ from an @'As' alias row@, but --- constrains the type of @alias@ to be the same as its first argument --- (which is non-strict). This can save you from explicitly --- specifying types. For example: --- --- > data X = X deriving (Generic) --- > instance RowAlias X where rowAliasName = const "x" --- > --- > ... --- > r <- map (\(b1 :. b2) -> (b1, fromAs X b2)) <$> --- > dbSelect c $ addWhere \"bar.bar_key = x.bar_parent\" modelDBSelect -fromAs :: alias -> As alias row -> row -{-# INLINE fromAs #-} -fromAs _ (As row) = row - --- | A type-restricted wrapper around the 'As' constructor, under the --- same rationale as 'fromAs'. Not strict in its first argument. -toAs :: alias -> row -> As alias row -{-# INLINE toAs #-} -toAs _ = As - -aliasModelInfo :: forall a alias. - (Model a, RowAlias alias) => - ModelInfo a -> ModelInfo (As alias a) -aliasModelInfo mi = r - where alias = rowAliasName (undefined :: As alias a) - r = mi { modelTable = alias - , modelGetPrimaryKey = modelGetPrimaryKey mi . unAs - } - -aliasModelIdentifiers :: forall a alias. (Model a, RowAlias alias) - => ModelInfo a -> ModelIdentifiers (As alias a) -aliasModelIdentifiers mi - | not ok = error $ "aliasModelIdentifiers: degenerate model " ++ - show (modelQTable ida ) - | otherwise = r - where r = ModelIdentifiers { - modelQTable = S.concat [quoteIdent orig, " AS ", alias] - , modelQColumns = qcols - , modelQPrimaryColumn = qcols !! pki - , modelQWriteColumns = deleteAt pki qcols - , modelQualifier = Just alias - , modelOrigTable = Just orig - } - ida = modelIdentifiers :: ModelIdentifiers a - ok = Just (modelQTable ida) == modelQualifier ida - && isJust (modelOrigTable ida) - Just orig = modelOrigTable ida - alias = quoteIdent $ rowAliasName (undefined :: As alias a) - qcol c = S.concat [alias, ".", quoteIdent c] - qcols = map qcol $ modelColumns mi - pki = modelPrimaryColumn mi - --- | A degenerate instance of 'Model' that re-names the row with a SQL --- @AS@ keyword. This is primarily useful when joining a model with --- itself. Hence, standard operations ('findRow', 'save', 'destroy') --- are not allowed on 'As' models. -instance (Model a, RowAlias as) => Model (As as a) where - {-# INLINE modelInfo #-} - modelInfo = aliasModelInfo modelInfo - {-# INLINE modelRead #-} - modelRead = As <$> modelRead - modelWrite = error "attempt to write \"As\" alias as normal Model" - {-# INLINE modelIdentifiers #-} - modelIdentifiers = aliasModelIdentifiers modelInfo - modelQueries = error "attempt to perform standard query on AS table alias" - - --- | Lookup the 'modelTable' of a 'Model' (@modelName _ = 'modelTable' --- ('modelInfo' :: 'ModelInfo' a)@). -modelName :: forall a. (Model a) => a -> S.ByteString -{-# INLINE modelName #-} -modelName _ = modelTable (modelInfo :: ModelInfo a) - --- | Lookup the primary key of a 'Model'. -primaryKey :: (Model a) => a -> DBKey -{-# INLINE primaryKey #-} -primaryKey a = modelGetPrimaryKey modelInfo a - --- | Generate a SQL @SELECT@ statement with no @WHERE@ predicate. For --- example, 'defaultModelLookupQuery' consists of --- @modelSelectFragment@ followed by \"@WHERE@ /primary-key/ = ?\". -modelSelectFragment :: ModelIdentifiers a -> S.ByteString -modelSelectFragment mi = S.concat [ - "SELECT ", S.intercalate ", " $ modelQColumns mi, " FROM ", modelQTable mi ] - --- | A newtype wrapper in the 'FromRow' class, permitting every model --- to be used as the result of a database query. -newtype LookupRow a = LookupRow { lookupRow :: a } deriving (Show) -instance (Model a) => FromRow (LookupRow a) where - fromRow = LookupRow <$> modelRead - --- | A newtype wrapper in the 'ToRow' class, which marshalls every --- field except the primary key. For use with 'modelInsertQuery'. -newtype InsertRow a = InsertRow a deriving (Show) -instance (Model a) => ToRow (InsertRow a) where - toRow (InsertRow a) = modelWrite a - --- | A newtype wrapper in the 'ToRow' class, which marshalls every --- field except the primary key, followed by the primary key. For use --- with 'modelUpdateQuery'. -newtype UpdateRow a = UpdateRow a deriving (Show) -instance (Model a) => ToRow (UpdateRow a) where - toRow (UpdateRow a) = toRow $ InsertRow a :. Only (primaryKey a) - --- | Dump an entire model. Useful for development and debugging only, --- as every row will be read into memory before the function returns. --- --- Note that unlike the other primary model operations, it is OK to --- call 'findAll' even on degenerate models such as 'As' and ':.'. -findAll :: forall r. (Model r) => Connection -> IO [r] -findAll c = action - where mi = modelIdentifiers :: ModelIdentifiers r - q = Query $ modelSelectFragment mi - action = map lookupRow <$> query_ c q - --- | Follow a 'DBRef' or 'DBRefUnique' and fetch the target row from --- the database into a 'Model' type @r@. -findRow :: forall r rt. (Model r) => Connection -> GDBRef rt r -> IO (Maybe r) -findRow c k = action - where qs = modelQueries :: ModelQueries r - action = do rs <- query c (modelLookupQuery qs) (Only k) - case rs of [r] -> return $ Just $ lookupRow $ r - _ -> return Nothing - --- | Like 'trySave' but instead of returning an 'Either', throws a --- 'ValidationError' if the 'Model' is invalid. -save :: (Model r) - => Connection -> r -> IO r -save c r = do - eResp <- trySave c r - case eResp of - Right resp -> return resp - Left errs -> throwIO errs - --- | 'save' but returning '()' instead of the saved model. -save_ :: (Model r) - => Connection -> r -> IO () -save_ c r = void $ save c r - --- | Write a 'Model' to the database. If the primary key is --- 'NullKey', the item is written with an @INSERT@ query, read back --- from the database, and returned with its primary key filled in. If --- the primary key is not 'NullKey', then the 'Model' is written with --- an @UPDATE@ query and returned as-is. --- --- If the 'Model' is invalid (i.e. the return value of 'modelValid' is --- non-empty), a list of 'InvalidError' is returned instead. -trySave :: forall r. Model r - => Connection -> r -> IO (Either ValidationError r) -trySave c r | not . H.null $ validationErrors errors = return $ Left errors - | NullKey <- primaryKey r = do - rs <- query c (modelInsertQuery qs) (InsertRow r) - case rs of [r'] -> return $ Right $ lookupRow r' - _ -> fail "save: database did not return row" - | otherwise = do - rows <- query c (modelUpdateQuery qs) (UpdateRow r) - case rows of [r'] -> return $ Right $ lookupRow r' - _ -> fail $ "save: database updated " - ++ show (length rows) - ++ " records" - where qs = modelQueries :: ModelQueries r - errors = modelValid r - --- | Remove the row corresponding to a particular data structure from --- the database. This function only looks at the primary key in the --- data structure. It is an error to call this function if the --- primary key is not set. -destroy :: forall a. (Model a) - => Connection -> a -> IO (Either ValidationError Bool) -destroy c a = - case primaryKey a of - NullKey -> fail "destroy: NullKey" - DBKey k -> destroyByRef_ "destroy" c (DBRef k :: DBRef a) - --- | Remove a row from the database without fetching it first. -destroyByRef :: forall a rt. (Model a) - => Connection -> GDBRef rt a -> IO (Either ValidationError Bool) -destroyByRef = destroyByRef_ "destroyByRef" - -destroyByRef_ :: forall a rt. (Model a) - => T.Text -> Connection -> GDBRef rt a -> IO (Either ValidationError Bool) -destroyByRef_ msg c a = action - where mq = modelQueries :: ModelQueries a - mi = modelIdentifiers :: ModelIdentifiers a - pkCol = modelQPrimaryColumn mi - action = do - n <- execute c (modelDeleteQuery mq) (Only a) - return $ case n of - 0 -> Right False - 1 -> Right True - _ -> Left $ validationError (T.decodeUtf8 pkCol) $ - msg <> ": DELETE modified " <> T.pack (show n) <> - " rows. This may indicate that your primary key" <> - " accessor field is not actually a primary key." - --- | Print to stdout the query statement. -printq :: Query -> IO () -printq (Query bs) = S8.putStrLn bs - diff --git a/Database/PostgreSQL/ORM/SqlType.hs b/Database/PostgreSQL/ORM/SqlType.hs deleted file mode 100644 --- a/Database/PostgreSQL/ORM/SqlType.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Database.PostgreSQL.ORM.SqlType (SqlType(..), getTypeOid) where - -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L -import Data.Int -import Data.Monoid -import qualified Data.Text as ST -import qualified Data.Text.Lazy as LT -import Data.Time -import Data.Typeable -import qualified Data.Vector as V -import Database.PostgreSQL.Simple -import Database.PostgreSQL.Simple.FromField -import Database.PostgreSQL.Simple.Time -import Database.PostgreSQL.Simple.ToField -import Database.PostgreSQL.Simple.TypeInfo.Static -import Database.PostgreSQL.Simple.Types - -import Database.PostgreSQL.ORM.Model - -newtype ExtractTypeOid = ExtractTypeOid Oid -instance FromField ExtractTypeOid where - fromField f _ = return $ ExtractTypeOid $ typeOid f - --- | Retreive the 'Oid' corresponding to a type. You can subsequently --- use the 'Oid' to call 'getTypeInfo' for more information on the --- type. -getTypeOid :: Connection -> S.ByteString -> IO Oid -getTypeOid c tname = do - [Only (ExtractTypeOid ti)] <- query_ c $ Query $ "SELECT NULL :: " <> tname - return ti - --- | The class of Haskell types that can be converted to and from a --- particular SQL type. For most instances, you only need to define --- 'sqlBaseType'. -class (ToField a, FromField a) => SqlType a where - sqlBaseType :: a -> S.ByteString - -- ^ The name of the SQL type corresponding to Haskell type @a@, - -- when a value of @a@ can be null. This is the SQL type to and - -- from which a @'Maybe' a@ will be converted (where 'Nothing' - -- corresponds to the SQL value null). - sqlType :: a -> S.ByteString - -- ^ The name of the SQL type corresponding to Haskell type @a@, - -- when @a@ is not wrapped in 'Maybe' and hence cannot be null. If - -- @sqlType@ is unspecified, the default is to append \"@NOT NULL@\" - -- to 'sqlBaseType'. - {-# INLINE sqlType #-} - sqlType _ = (sqlBaseType (undefined :: a)) <> " NOT NULL" - -#define TYPE(hs, sql) \ - instance SqlType (hs) where sqlBaseType _ = typname (sql) -TYPE(Bool, bool) -TYPE(Double, float8) -TYPE(Float, float4) -TYPE(Int16, int2) -TYPE(Int32, int4) -TYPE(Int64, int8) -TYPE(S.ByteString, text) -TYPE(L.ByteString, text) -TYPE(ST.Text, text) -TYPE(LT.Text, text) -TYPE(Oid,oid) -TYPE(LocalTime, timestamp) -TYPE(ZonedTime, timestamptz) -TYPE(TimeOfDay, time) -TYPE(UTCTime, timestamptz) -TYPE(Day, date) -TYPE(Date, date) -TYPE(ZonedTimestamp, timestamptz) -TYPE(UTCTimestamp, timestamptz) -TYPE(LocalTimestamp, timestamp) -TYPE(String, text) -TYPE(Binary S.ByteString, bytea) -TYPE(Binary L.ByteString, bytea) - -#undef TYPE - -instance SqlType DBKey where - sqlType _ = "bigserial UNIQUE NOT NULL PRIMARY KEY" - sqlBaseType _ = error "DBKey should not be wrapped in type" - -instance (SqlType a) => SqlType (Maybe a) where - sqlType _ = sqlBaseType (undefined :: a) - sqlBaseType _ = error "Table field Maybe should not be wrapped in other type" - -instance (Typeable a, SqlType a) => SqlType (V.Vector a) where - sqlBaseType _ = sqlBaseType (undefined :: a) <> "[]" - -instance (Model a) => SqlType (DBRef a) where - sqlBaseType (DBRef k) = sqlBaseType k <> ref - where t = modelInfo :: ModelInfo a - Just orig = modelOrigTable (modelIdentifiers :: ModelIdentifiers a) - ref = S.concat [ - " REFERENCES ", quoteIdent orig, "(" - , quoteIdent (modelColumns t !! modelPrimaryColumn t), ")" ] - -instance (Model a) => SqlType (DBRefUnique a) where - sqlBaseType (DBRef k) = sqlBaseType k <> ref - where t = modelInfo :: ModelInfo a - Just orig = modelOrigTable (modelIdentifiers :: ModelIdentifiers a) - ref = S.concat [ - " UNIQUE REFERENCES ", quoteIdent orig , "(" - , quoteIdent (modelColumns t !! modelPrimaryColumn t), ")" ] diff --git a/Database/PostgreSQL/ORM/Validations.hs b/Database/PostgreSQL/ORM/Validations.hs deleted file mode 100644 --- a/Database/PostgreSQL/ORM/Validations.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE CPP, FlexibleContexts, DeriveDataTypeable, OverloadedStrings #-} -module Database.PostgreSQL.ORM.Validations where - -import Control.Exception -import Data.Aeson -import qualified Data.HashMap.Strict as H -#if __GLASGOW_HASKELL__ < 710 -import Data.Monoid -#endif -import qualified Data.Text as T -import Data.Typeable - -newtype ValidationError = ValidationError - { validationErrors :: H.HashMap T.Text [T.Text] } deriving (Show, Typeable) - -instance Exception ValidationError - -instance Monoid ValidationError where - mempty = ValidationError mempty - mappend ein zwei = ValidationError $! - H.unionWith mappend (validationErrors ein) (validationErrors zwei) - -instance ToJSON ValidationError where - toJSON = toJSON . validationErrors - -instance FromJSON ValidationError where - parseJSON val = ValidationError `fmap` parseJSON val - -type ValidationFunc a = a -> ValidationError - -validationError :: T.Text -> T.Text -> ValidationError -validationError columnName description = - ValidationError $ H.singleton columnName [description] - -validate :: (a -> Bool) - -> T.Text -- ^ Column name - -> T.Text -- ^ Error description - -> ValidationFunc a -validate validator columnName desc = \a -> - if validator a - then mempty - else validationError columnName desc - -validateNotEmpty :: (a -> T.Text) - -> T.Text - -> T.Text - -> ValidationFunc a -validateNotEmpty accessor = validate (not . T.null . accessor) - diff --git a/pg_migrate.hs b/pg_migrate.hs --- a/pg_migrate.hs +++ b/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,9 +19,12 @@ "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]" @@ -29,4 +32,3 @@ if ec == ExitSuccess then return () else exitWith ec - diff --git a/postgresql-orm.cabal b/postgresql-orm.cabal --- a/postgresql-orm.cabal +++ b/postgresql-orm.cabal @@ -1,5 +1,5 @@ name: postgresql-orm -version: 0.5.0 +version: 0.5.1 cabal-version: >= 1.14 build-type: Simple license: GPL @@ -8,7 +8,7 @@ maintainer: amit@amitlevy.com 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. @@ -16,21 +16,14 @@ executable pg_migrate default-language: Haskell2010 Main-is: pg_migrate.hs + hs-source-dirs: . ghc-options: -Wall build-depends: base < 6 - , blaze-builder >= 0.4 - , bytestring - , bytestring-builder - , directory + , postgresql-orm , filepath - , ghc-prim - , mtl - , old-locale - , postgresql-simple >= 0.4.1.0 - , process - , time library + hs-source-dirs: src default-language: Haskell2010 build-depends: base < 6 , aeson @@ -40,10 +33,12 @@ , directory , filepath , ghc-prim + , haskell-src-exts , mtl , old-locale , postgresql-simple , process + , temporary , text , time , transformers @@ -79,4 +74,3 @@ source-repository head type: git location: https://github.com/alevy/postgresql-orm.git - diff --git a/src/Data/GetField.hs b/src/Data/GetField.hs new file mode 100644 --- /dev/null +++ b/src/Data/GetField.hs @@ -0,0 +1,247 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +#if __GLASGOW_HASKELL__ < 710 +{-# LANGUAGE OverlappingInstances #-} +#endif +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Functions to extract a field of a particular type from a +-- 'Generic' data structure, when the data structure contains exactly +-- one field of the given type. Only works for types with exactly one +-- constructor (not variant types). +-- +-- An example of usage: +-- +-- > data MyType = MyType { myString :: String -- position 0 +-- > , myInt :: Int -- position 1 +-- > , myBool :: Bool -- position 2 +-- > , myMaybeChar :: Maybe Char -- position 3 +-- > , myMaybeString :: Maybe String -- position 4 +-- > } deriving (Show, Generic) +-- > +-- > myType :: MyType +-- > myType = MyType "my type" 21 True Nothing (Just "maybe string") +-- +-- >>> getFieldVal ExtractId myType :: String +-- "my type" +-- >>> getFieldVal ExtractId myType :: Int +-- 21 +-- >>> getFieldVal ExtractMaybe myType :: Maybe Char +-- Nothing +-- >>> getFieldVal ExtractMaybe myType :: Maybe Int +-- Just 21 +-- >>> getFieldVal ExtractMaybe myType :: Maybe String -- ambiguous +-- :5:1: Couldn't match type `THasMany' with `THasOne' +-- >>> getFieldPos' ExtractId (undefined :: MyType) (undefined :: Bool) +-- 2 +-- >>> getFieldPos' ExtractMaybe (undefined :: MyType) (undefined :: Maybe Bool) +-- 2 +-- >>> getFieldPos' ExtractMaybe myType () -- No field has type () +-- :8:1: Couldn't match type `THasNone' with `THasOne' +module Data.GetField ( + GetField(..), ExtractId(..), ExtractMaybe(..), getFieldPos' + -- * Internals + , THasOne(..), THasNone(..), THasMany(..), Extractor(..), GGetField(..) + ) where + +import GHC.Generics + +-- | Dirty trick to construct "less specific" overlapping instances by +-- making a class argument a simple type variable, but constraining +-- that variable to be a particular type. E.g., neither of the +-- following two instances is more specific than the other, because +-- @NO@ is not more general than @YES@: +-- +-- > class MyClass a b c | a b -> c where myClass :: a -> b -> c () +-- > instance MyClass a a YES where myClass _ _ = YES () +-- > instance MyClass a b NO where myClass _ _ = NO () +-- +-- Hence, attempting to use the first instance will generate a +-- compilation error rather than inferring the type of c as YES. On +-- the other hand, of the following two instances, the first is more +-- specific than the second: +-- +-- > instance MyClass a a YES where +-- > myClass _ _ = YES () +-- > instance (TypeGCast NO c) => MyClass a b c where +-- > myClass _ _ = typeGCast $ NO () +-- +-- That's because @c@ is more general than @YES@. The key to this +-- working is that an instance context--i.e., @(TypeGCast NO c)@--is +-- never consulted during instance selection, only to validate an +-- already-selected most-specific instance. +-- +-- Note that @YES@ and @NO@ in these examples have kind @* -> *@. +-- Hence the @G@ in @TypeGCast@. The same trick is equally applicable +-- to types of kind @*@, we just don't happen to need that in this +-- module. +class TypeGCast f g | f -> g where + typeGCast :: f p -> g p +instance TypeGCast f f where + typeGCast = id + +-- | Exactly one matching field has been found. +newtype THasOne a = THasOne { fromTHasOne :: a } deriving (Show) +-- | Zero matching fields have been found. +data THasNone a = THasNone deriving (Show) +-- | More than one matching field has been found. +newtype THasMany a = THasMany { fromTHasMany :: [a] } deriving (Show) + +class GCombine a b c | a b -> c where + gCombine :: a p -> b p -> c p +instance GCombine THasOne THasNone THasOne where + {-# INLINE gCombine #-} + gCombine j _ = j +instance GCombine THasNone THasOne THasOne where + {-# INLINE gCombine #-} + gCombine _ j = j +instance GCombine THasNone THasNone THasNone where + -- Should never be evaluated, so no need to inline it + gCombine _ _ = THasNone +instance GCombine THasOne THasOne THasMany where + {-# INLINE gCombine #-} + gCombine (THasOne a) (THasOne b) = THasMany [a,b] +instance GCombine THasMany THasMany THasMany where + {-# INLINE gCombine #-} + gCombine (THasMany as) (THasMany bs) = THasMany (as ++ bs) +instance GCombine THasNone THasMany THasMany where + {-# INLINE gCombine #-} + gCombine _ hm = hm +instance GCombine THasMany THasNone THasMany where + {-# INLINE gCombine #-} + gCombine hm _ = hm +instance GCombine THasOne THasMany THasMany where + {-# INLINE gCombine #-} + gCombine (THasOne a) (THasMany as) = THasMany (a:as) +instance GCombine THasMany THasOne THasMany where + {-# INLINE gCombine #-} + gCombine (THasMany as) (THasOne a) = THasMany (as++[a]) + +class GCount f where gCount :: f p -> (Int, [Int]) +instance GCount THasOne where gCount _ = (1, [0]) +instance GCount THasMany where gCount _ = (1, [0]) +instance GCount THasNone where gCount _ = (1, []) + +-- | Class of types used as tag arguments to 'gGetFieldVal' and +-- 'gGetFieldPos'. @f@ should be a new unit type of kind @* -> *@, +-- used to designate the type of extraction you want. Then instances +-- should be defined to transform each type @a@ you want to extract to +-- some type @r@, with @g@ set to 'THasOne'. +-- +-- For example, 'ExtractMaybe' is a type to convert types @a@ and +-- @Maybe a@ both to type @Maybe a@ (i.e., type argument @r@ is @Maybe +-- a@). +-- +-- > data ExtractMaybe a = ExtractMaybe +-- > instance Extractor ExtractMaybe a (Maybe a) THasOne where +-- > extract _ = THasOne . Just +-- > instance Extractor ExtractMaybe (Maybe a) (Maybe a) THasOne where +-- > extract _ = THasOne +-- +-- Note that there is already a default general instance returning +-- 'THasNone'. Hence, you do not need to define one. Otherwise, you +-- would have to define an overlapping instance such as: +-- +-- > instance Extractor ExtractMaybe a b THasZero where -- Incorrect +-- > extract _ = THasNone +-- +-- (Except the above wouldn't quite work anyway given the rules for +-- overlapping instances.) So just assume that any instance you don't +-- explicitly define for your 'Extractor' will automatically fall back +-- to 'THasNone'. +class Extractor f a r g | f a r -> g where + extract :: f r -> a -> g r + extractCount :: f r -> a -> (Int, [Int]) + default extractCount :: (GCount g) => f r -> a -> (Int, [Int]) + extractCount fr a = gCount (extract fr a) +instance + {-# OVERLAPPABLE #-} + (TypeGCast THasNone g) => Extractor f a r g where + extract _ _ = typeGCast THasNone + extractCount _ _ = gCount THasNone + +-- | Generlized extraction of a field from a 'Generic' data structure. +-- Argument @rep@ should generally be the type @'Rep' t@ for some data +-- type @t@ whose fields you want to extract. @r@ is the result type +-- you want back from the extraction. @f@ should be defined such that +-- there is an instance of @'Extractor' f a r THasOne@ for each type +-- @a@ you want to convert to @r@ and extract. +class GGetField f rep r g | f rep r -> g where + gGetFieldVal :: f r -> rep p -> g r + -- ^ Returns zero, one, or multiple values of type @f@ wrapped in + -- 'THasOne', 'THasNone', or 'THasMany' respectively. + gGetFieldPos :: f r -> rep p -> (Int, [Int]) + -- ^ Returns @(total, positions)@ where @total@ is the total number + -- of fields (matching or not) in the structure and @positions@ is a + -- list of zero-based field numbers of the fields matching target + -- type @f r@. +instance (Extractor f c r g) => GGetField f (K1 i c) r g where + {-# INLINE gGetFieldVal #-} + gGetFieldVal f (K1 c) = extract f c + gGetFieldPos f (K1 c) = extractCount f c +instance (GGetField f a1 r g1, GGetField f a2 r g2, GCombine g1 g2 g) => + GGetField f (a1 :*: a2) r g where + {-# INLINE gGetFieldVal #-} + gGetFieldVal f (a1 :*: a2) = + gCombine (gGetFieldVal f a1) (gGetFieldVal f a2) + gGetFieldPos f ~(a1 :*: a2) = (n1 + n2, p1 ++ map (n1 +) p2) + where (n1, p1) = gGetFieldPos f a1 + (n2, p2) = gGetFieldPos f a2 +instance (GGetField f a r g) => GGetField f (M1 i c a) r g where + {-# INLINE gGetFieldVal #-} + gGetFieldVal f (M1 a) = gGetFieldVal f a + gGetFieldPos f ~(M1 a) = gGetFieldPos f a + + +class (Generic a, GGetField f (Rep a) r THasOne) => GetField f a r where + -- | Extract the single field matching 'Extractor' @f r@ from a + -- 'Generic' data structure @a@ with exactly one constructor. + getFieldVal :: f r -> a -> r + -- | Extract the 0-based position of the single field matching + -- 'Extractor' @f r@ within 'Generic' data structure @a@. + -- Non-strict in both arguments. + getFieldPos :: f r -> a -> Int +instance (Generic a, GGetField f (Rep a) r THasOne) => GetField f a r where + {-# INLINE getFieldVal #-} + getFieldVal f a = fromTHasOne $ gGetFieldVal f (from a) + getFieldPos f a = head $ snd $ gGetFieldPos f (from a) + +-- | A variant of 'getFieldPos' in which the type of the field is +-- supplied as a non-strict argument. This may be easier than +-- typecasting the extractor argument. For example, to extract the +-- 'Int' from a structure with a single 'Int' field: +-- +-- @ +-- getFieldPos' 'ExtractId' myStruct ('undefined' :: 'Int') +-- @ +getFieldPos' :: (Generic a, GGetField f (Rep a) r THasOne) => + (f ()) -> a -> r -> Int +getFieldPos' f a r = getFieldPos (fixType f r) a + where fixType :: f () -> r -> f r + fixType _ _ = undefined + +-- | An extractor that matches an exact field type. +data ExtractId r = ExtractId deriving (Show) +instance Extractor ExtractId a a THasOne where + {-# INLINE extract #-} + extract _ = THasOne + +-- | An extractor that matches either type @r@ or type @Maybe r@, and, +-- in the former case, wraps @Just@ around the value so as always to +-- return type @Maybe r@. +data ExtractMaybe r = ExtractMaybe +instance Extractor ExtractMaybe a (Maybe a) THasOne where + {-# INLINE extract #-} + extract _ = THasOne . Just +instance Extractor ExtractMaybe (Maybe a) (Maybe a) THasOne where + {-# INLINE extract #-} + extract _ = THasOne + diff --git a/src/Data/RequireSelector.hs b/src/Data/RequireSelector.hs new file mode 100644 --- /dev/null +++ b/src/Data/RequireSelector.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances, CPP #-} + +module Data.RequireSelector (RequireSelector) where + +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 800) +import GHC.Generics + +-- | There are intentionally no members of this class, so that placing +-- it in a context will always cause an error. +class IntentionallyCauseError a +#endif + +-- | The point of this class is to ensure that you are using data +-- types defined with record selectors (i.e., @data Foo = Foo { unFoo +-- :: Int }@ as opposed to @data Foo = Foo Int@). +-- +-- Unfortunately, "GHC.Generics" makes the 'NoSelector' type a member +-- of the 'Selector' class. Hence, if you want to ensure a type @a@ +-- is /not/ 'NoSelector', use the context @(RequireSelector a) =>@. +-- +-- If you see a compilation error involving @RequireSelector@ or +-- @IntentionallyCauseError@, it means you failed to define one of +-- your datatypes using record selector syntax. +class RequireSelector a +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 800) +instance (IntentionallyCauseError NoSelector) => RequireSelector NoSelector +#endif +instance RequireSelector a diff --git a/src/Database/PostgreSQL/Describe.hs b/src/Database/PostgreSQL/Describe.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Describe.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Utility function for describing a table in the database. +module Database.PostgreSQL.Describe ( + ColumnInfo(..), describeTable + ) where + +import Control.Monad +import qualified Data.ByteString as S +import Data.Int +import qualified Data.Vector as V +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PG +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.TypeInfo +import Database.PostgreSQL.Simple.Types + +data ColumnInfo = ColumnInfo { + colNum :: !Int16 + -- ^ Internal column number used by PostgreSQL. Generally these + -- will be consecutive starting from 1, but this may not be the + -- case if you have altered a table to delete columns. + , colName :: S.ByteString + -- ^ Name of the column + , colType :: !TypeInfo + -- ^ Type of the column + , colNotNull :: !Bool + -- ^ If 'True', the database cannot contain null. (This + -- constraint should always be accurate.) + , colPrimary :: !Bool + -- ^ 'True' if this column (and only this column) constitutes the + -- primary key of the table. Always 'False' if the primary key + -- comprises multiple columns (even if this is one of those + -- columns). + , colUnique :: !Bool + -- ^ 'True' if there is a uniqueness constraint on this column. + -- Not 'True' if this column is part of a uniqueness constraint + -- involving multiple columns. (Such multi-column uniqueness + -- constraints are not reported by this interface.) + , colReferences :: !(Maybe S.ByteString) + -- ^ If this there is a foreign key constraint on this column (and + -- the constraint does not span multiple columns), report the + -- table referenced by this column. + } deriving (Show) + +defColInfo :: ColumnInfo +defColInfo = ColumnInfo { + colNum = 0 + , colName = S.empty + , colType = PG.void + , colNotNull = False + , colPrimary = False + , colUnique = False + , colReferences = Nothing + } + +-- | Returns a list of 'ColumnInfo' structures for a particular table. +-- Not all information about a table is returned. In particular, +-- constraints that span columns are ignored. +describeTable :: Connection -> S.ByteString -> IO [ColumnInfo] +describeTable cn t = do + [(Only tbloid)] <- query cn "select oid from pg_class where relname = ?" + (Only t) + cs0 <- query cn "select attnum, attname, atttypid, attnotnull\ + \ from pg_attribute\ + \ where attrelid = ? and attisdropped = 'f' and attnum > 0\ + \ order by attnum" + (Only (tbloid :: Oid)) + cs1 <- forM cs0 $ \ (num, name, typ, notnull) -> do + ti <- getTypeInfo cn typ + return defColInfo { + colNum = num, colName = name, colType = ti, colNotNull = notnull + } + constraints <- query cn "select contype, conkey, relname\ + \ from pg_constraint left join pg_class\ + \ on confrelid = pg_class.oid\ + \ where conrelid = ?" + (Only tbloid) + let _ = constraints :: [(String, V.Vector Int16, Maybe S.ByteString)] + return $ map (\c -> foldl appConstr c constraints) cs1 + where appConstr ci (ct, ck, mn) + | V.length ck == 1, colNum ci == ck V.! 0 = appConstr1 ci ct mn + | otherwise = ci + appConstr1 ci "p" _ = ci { colPrimary = True } + appConstr1 ci "u" _ = ci { colUnique = True } + appConstr1 ci "f" n@(Just _) = ci { colReferences = n } + appConstr1 ci _ _ = ci diff --git a/src/Database/PostgreSQL/Devel.hs b/src/Database/PostgreSQL/Devel.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Devel.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Functions for initializing self-contained local postgreSQL +-- database clusters (useful in development more than production). +module Database.PostgreSQL.Devel ( + createLocalDB, configLocalDB, startLocalDB + , initLocalDB, stopLocalDB, setLocalDB + , withTempDB + , resetConnection + ) where + +import Control.Exception +import Control.Monad +#if __GLASGOW_HASKELL__ < 710 +import Data.Functor +#endif +import Data.List +import Database.PostgreSQL.Simple +import System.Directory +import System.Exit +import System.FilePath +import System.IO +import System.IO.Error +import System.Posix.Env +import System.Posix.Temp +import System.Process + +isNonEmptyDir :: FilePath -> IO Bool +isNonEmptyDir dir = + catchJust (\e -> if isDoesNotExistError e then Just () else Nothing) + ((> 2) . length <$> getDirectoryContents dir) + (const $ return False) + +addDirectives :: [(String, String)] -> [String] -> [String] +addDirectives directives [] = map snd directives +addDirectives directives (cl:cls) + | Just l <- lookup directive directives = + (if comment then [l, cl] else [l]) ++ + addDirectives (directives \\ [(directive,l)]) cls + | otherwise = cl : addDirectives directives cls + where (comment, directive) + | '#':clr <- cl, [(d,_)] <- lex clr = (True, d) + | [(d,_)] <- lex cl = (False, d) + | otherwise = (False, "") + +-- | Set configuration parameters on a database by editing the +-- @postgresql.conf@ file. Takes the database directory and a list of +-- @(@/parameter/@,@ /full-line/@)@ pairs. For example, when creating +-- a throw-away database cluster you later intend to discard, you +-- might say: +-- +-- > configLocalDB dbpath [("fsync", "fsync = off")] +-- +-- Note that the second element of each pair is the complete +-- configuration line. It is not correct to say: +-- +-- > configLocalDB dbpath [("fsync", "off")] -- INCORRECT +-- +configLocalDB :: FilePath -> [(String, String)] -> IO () +configLocalDB dir directives = do + let confpath = dir "postgresql.conf" + oldconf <- lines <$> readFile confpath + 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_directories" + , "unix_socket_directories = '" ++ singleQuote dir ++ "'") + , ("logging_collector", "logging_collector = yes") + , ("listen_addresses", "listen_addresses = ''")] + +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@: +-- +-- * @listen_address@ is set to empty (i.e., @\'\'@), so that no TCP +-- socket is bound, avoiding conflicts with any other running instaces +-- of PostgreSQL. +-- +-- * @logging_collector@ is set to @yes@, so that all message logs are +-- kept in the @pg_log@ subdirectory of the directory you specified. +-- +-- Note this function does /not/ start a postgres server after +-- creating the directory. You will seperately need to start the +-- server using 'startLocalDB' or 'initLocalDB'. (And note that +-- 'initLocalDB' already calls @createLocalDB@ if the directory does +-- not exist or is empty. Hence the primary use of this function is +-- if you want to call 'configLocalDB' between 'createLocalDB' and +-- 'startLocalDB'.) +createLocalDB :: FilePath -> IO () +createLocalDB dir = do + (exit, _, err) <- readProcessWithExitCode "pg_ctl" + ["-D", dir, "-o", "--no-locale", "init"] "" + when (exit /= ExitSuccess) $ fail err + dir' <- canonicalizePath dir + writeFile (dir "README_BEFORE_DELETING") $ + "## IMPORTANT: Run the following command before deleting this " ++ + "directory ##\n\n" ++ + "pg_ctl -D " ++ showCommandForUser dir' [] ++ " stop -m immediate\n\n" + 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 = + bracket (openFile "/dev/null" ReadWriteMode) hClose $ \devnull -> do + let cp = (proc prog args) { std_in = UseHandle devnull + , std_out = UseHandle devnull } + (_,_,_,pid) <- createProcess cp + waitForProcess pid + +-- | Start a local database if the server is not already running. +-- Otherwise, does nothing, but returns a 'ConnectInfo' in either +-- case. The database server will continue running after the current +-- process exits (but see 'stopLocalDB'). +startLocalDB :: FilePath -> IO ConnectInfo +startLocalDB dir0 = do + dir <- canonicalizePath dir0 + (e0, _, _) <- readProcessWithExitCode "pg_ctl" ["status", "-D", dir] "" + when (e0 /= ExitSuccess) $ do + e1 <- systemNoStdout "pg_ctl" [ "start", "-w", "-D", dir ] + when (e1 /= ExitSuccess) $ fail "could not start postgres" + return defaultConnectInfo { connectHost = dir + , connectUser = "" + , connectDatabase = "postgres" + } + +-- | A combination of 'createLocalDB' and 'startLocalDB'. +-- +-- The parameter is a PostgreSQL data directory. If the directory is +-- empty or does not exist, this function creates a new database +-- cluster (via 'createLocalDB'). Then, if a database server is not +-- already running for the directory, starts a server. No matter +-- what, returns a 'ConnectInfo' that will connect to the server +-- running on this local database. +-- +-- Note that if @initLocalDB@ starts a postgres server, the server +-- process will continue running after the process that called +-- @initLocalDB@ exits. This is normally fine. Since multiple client +-- processes may access the same PostgreSQL database, it makes sense +-- for the first client to start the database and no one to stop it. +-- See 'stopLocalDB' if you wish to stop the server process (which you +-- should always do before deleting a test cluster). See also +-- 'withTempDB' to create a temporary cluster for the purposes of +-- running a test suite. +initLocalDB :: FilePath -> IO ConnectInfo +initLocalDB dir = do + exists <- isNonEmptyDir dir + unless exists $ createLocalDB dir + startLocalDB dir + +-- | Stop the server for a local database cluster entirely +-- self-contained within one directory. You must call this before +-- deleting the directory, or else stray postgres processes will +-- linger forever. If the argument is the empty string, looks for the +-- database directory in the @PGDATA@ environment variable. +stopLocalDB :: FilePath -> IO () +stopLocalDB dir0 = do + dir <- if not (null dir0) then return dir0 else do + mpgd <- getEnv "PGDATA" + case mpgd of Just pgd -> return pgd + _ -> fail "stopLocalDB: must specify database" + e <- systemNoStdout "pg_ctl" ["stop", "-D", dir, "-m", "fast"] + when (e /= ExitSuccess) $ fail "could not stop postgres" + +-- | Set environment variables to make a local database cluster the +-- default. Also returns shell commands you can eval or cut-and-paste +-- into your shell to make @pg_ctl@ and @psql@ access a local database +-- cluster. +setLocalDB :: FilePath -> IO String +setLocalDB dir0 = do + dir1 <- canonicalizePath dir0 + setEnv "PGHOST" dir1 True + setEnv "PGDATA" dir1 True + setEnv "PGDATABASE" "postgres" True + let dir = showCommandForUser dir1 [] + msh <- getEnv "SHELL" + return $ case msh of Just sh | isSuffixOf "csh" sh -> + "setenv PGDATA " ++ dir ++ "; setenv PGHOST " ++ dir + _ -> "export PGDATA=" ++ dir ++ " PGHOST=" ++ dir + +-- | Run a function with a completely fresh database cluster that gets +-- deleted on return. Since the entire database is blown away when +-- the function returns, @withTempDB@ is obviously only useful for +-- test suites. +withTempDB :: (ConnectInfo -> IO a) -> IO a +withTempDB f = bracket createdir removeDirectoryRecursive $ \d -> + flip finally (stopLocalDB d) $ do + createLocalDB d + configLocalDB d [("fsync", "fsync = off") + , ("synchronous_commit", "synchronous_commit = off") + , ("full_page_writes", "full_page_writes = off")] + initLocalDB d >>= f + where createdir = do + tmp <- getTemporaryDirectory + mkdtemp $ tmp "db." + +-- | Reset a connection to its default state before re-cycling it for +-- another thread or request. +resetConnection :: Connection -> IO () +resetConnection c = (void $ execute_ c "DISCARD ALL") `catch` \SqlError{} -> + void $ execute_ c "ROLLBACK" >> execute_ c "DISCARD ALL" diff --git a/src/Database/PostgreSQL/Escape.hs b/src/Database/PostgreSQL/Escape.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Escape.hs @@ -0,0 +1,269 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE CPP #-} + +#include "MachDeps.h" + +-- | This module deals with escaping and sanitizing SQL templates. +module Database.PostgreSQL.Escape ( + fmtSql, quoteIdent + , buildSql, buildSqlFromActions + , buildAction, buildLiteral, buildByteA, buildIdent + ) where + +import Blaze.ByteString.Builder.Internal.Write +import Data.ByteString.Builder +import Data.ByteString.Builder.Internal +import Data.ByteString.Lazy (toStrict) +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Unsafe as S +import Data.Monoid +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.ToRow +import Database.PostgreSQL.Simple.Types +import Foreign.Marshal.Alloc (mallocBytes) +import Foreign.Storable (pokeByteOff) +import GHC.Prim (Addr#, and#, geAddr#, geWord#, Int#, int2Word# + , minusAddr#, ord# , plusAddr#, readWord8OffAddr# + , State# , uncheckedShiftRL#, word2Int#, writeWord8OffAddr# + , Word#) +import GHC.Ptr (Ptr(Ptr)) +import GHC.Types (Char(C#), Int(I#), IO(IO)) +import GHC.Word (Word8(W8#)) +import System.IO.Unsafe (unsafeDupablePerformIO) + +{-# INLINE cmpres #-} +-- | Newer versions of GHC return an Int# instead of a Bool for +-- primitive comparison functions. The @cmpres@ function converts the +-- result of such a comparison to a @Bool@. +#if __GLASGOW_HASKELL__ >= 707 +cmpres :: Int# -> Bool +cmpres 0# = False +cmpres _ = True +#else /* __GLASGOW_HASKELL__ < 707 */ +cmpres :: Bool -> Bool +cmpres b = b +#define cmpres(b) b +#endif /* __GLASGOW_HASKELL__ < 707 */ + +c2b :: Char -> Word8 +c2b (C# i) = W8# (int2Word# (ord# i)) + +c2b# :: Char -> Word# +c2b# (C# i) = int2Word# (ord# i) + +inlinePerformIO :: IO a -> a +#if MIN_VERSION_bytestring(0,10,6) +inlinePerformIO = S.accursedUnutterablePerformIO +#else +inlinePerformIO = S.inlinePerformIO +#endif + +fastFindIndex :: (Word# -> Bool) -> S.ByteString -> Maybe Int +{-# INLINE fastFindIndex #-} +fastFindIndex test bs = + inlinePerformIO $ S.unsafeUseAsCStringLen bs $ \(Ptr bsp0, I# bsl0) -> do + let bse = bsp0 `plusAddr#` bsl0 + check bsp = IO $ \rw -> case readWord8OffAddr# bsp 0# rw of + (# rw1, w #) -> (# rw1, test w #) + go bsp | cmpres(bsp `geAddr#` bse) = return Nothing + | otherwise = do + match <- check bsp + if match + then return $ Just $ I# (bsp `minusAddr#` bsp0) + else go (bsp `plusAddr#` 1#) + go bsp0 + +fastBreak :: (Word# -> Bool) -> S.ByteString -> (S.ByteString, S.ByteString) +{-# INLINE fastBreak #-} +fastBreak test bs + | Just n <- fastFindIndex test bs = (S.unsafeTake n bs, S.unsafeDrop n bs) + | otherwise = (bs, S.empty) + +quoter :: S.ByteString -> S.ByteString -> (Word# -> Bool) + -> (Word8 -> Builder) -> S.ByteString -> Builder +{-# INLINE quoter #-} +quoter start end escPred escFn bs0 = + mconcat [byteStringCopy start, escaped bs0, byteStringCopy end] + where escaped bs = case fastBreak escPred bs of + (h, t) | S.null t -> byteString h + | otherwise -> byteString h <> + escFn (S.unsafeHead t) <> + escaped (S.unsafeTail t) + +-- | Quote an identifier using unicode quoting syntax. This is +-- necessary for identifiers containing a question mark, as otherwise +-- "PostgreSQL.Simple"'s naive formatting code will attempt to match +-- the question mark to a paremeter. +uBuildIdent :: S.ByteString -> Builder +uBuildIdent ident = quoter " U&\"" "\"" isSpecial esc ident + where isSpecial 34## = True -- '"' + isSpecial 63## = True -- '?' + isSpecial 92## = True -- '\\' + isSpecial _ = False + esc c = byteStringCopy $ case () of + _ | c == c2b '"' -> "\"\"" + | c == c2b '?' -> "\\003f" + | c == c2b '\\' -> "\\\\" + | otherwise -> error "uquoteIdent" + +-- | Build a quoted identifier. Generally you will want to use +-- 'quoteIdent', and for repeated use it will be faster to use +-- @'byteString' . 'quoteIdent'@, but this internal function is +-- exposed in case it is useful. +buildIdent :: S.ByteString -> Builder +buildIdent ident + | Just _ <- fastFindIndex isQuestionmark ident = uBuildIdent ident + | otherwise = quoter "\"" "\"" isDQuote (const $ byteStringCopy "\"\"") ident + where isQuestionmark 63## = True + isQuestionmark 0## = error "quoteIdent: illegal NUL character" + isQuestionmark _ = False + isDQuote 34## = True + isDQuote _ = False + +-- | Quote an identifier such as a table or column name using +-- double-quote characters. Note this has nothing to do with quoting +-- /values/, which must be quoted using single quotes. (Anyway, all +-- values should be quoted by 'query' or 'fmtSql'.) This function +-- uses a unicode escape sequence to escape \'?\' characters, which +-- would otherwise be expanded by 'query', 'formatQuery', or 'fmtSql'. +-- +-- >>> S8.putStrLn $ quoteIdent "hello \"world\"!" +-- "hello ""world""!" +-- >>> S8.putStrLn $ quoteIdent "hello \"world\"?" +-- U&"hello ""world""\003f" +-- +-- Note that this quoting function is correct only if +-- @client_encoding@ is @SQL_ASCII@, @client_coding@ is @UTF8@, or the +-- identifier contains no multi-byte characters. For other coding +-- schemes, this function may erroneously duplicate bytes that look +-- like quote characters but are actually part of a multi-byte +-- character code. In such cases, maliciously crafted identifiers +-- will, even after quoting, allow injection of arbitrary SQL commands +-- to the server. +-- +-- The upshot is that it is unwise to use this function on identifiers +-- provided by untrustworthy sources. Note this is true anyway, +-- regardless of @client_encoding@ setting, because certain \"system +-- column\" names (e.g., @oid@, @tableoid@, @xmin@, @cmin@, @xmax@, +-- @cmax@, @ctid@) are likely to produce unexpected results even when +-- properly quoted. +-- +-- See 'Id' for a convenient way to include quoted identifiers in +-- parameter lists. +quoteIdent :: S.ByteString -> S.ByteString +quoteIdent = toStrict . toLazyByteString . buildIdent + +hexNibblesPtr :: Ptr Word8 +{-# NOINLINE hexNibblesPtr #-} +hexNibblesPtr = unsafeDupablePerformIO $ do + ptr <- mallocBytes 16 + sequence_ $ zipWith (\o v -> pokeByteOff ptr o $ c2b v) + [0..] (['0'..'9'] ++ ['a'..'f']) + return ptr + +-- | Bad things will happen if the argument is greater than 0xff. +uncheckedWriteNibbles# :: Addr# -> Word# -> State# d -> State# d +{-# INLINE uncheckedWriteNibbles# #-} +uncheckedWriteNibbles# p w rw0 = + case (# word2Int# (w `uncheckedShiftRL#` 4# ) + , word2Int# (w `and#` 0xf## ) #) of { (# h, l #) -> + case readWord8OffAddr# nibbles h rw0 of { (# rw1, hascii #) -> + case writeWord8OffAddr# p 0# hascii rw1 of { rw2 -> + case readWord8OffAddr# nibbles l rw2 of { (# rw3, lascii #) -> + writeWord8OffAddr# p 1# lascii rw3 }}}} + where !(Ptr nibbles) = hexNibblesPtr + +hexCharEscBuilder :: Word8 -> Builder +{-# INLINE hexCharEscBuilder #-} +hexCharEscBuilder (W8# w) = fromWrite $ exactWrite 4 $ \(Ptr p) -> IO $ \rw0 -> + (# uncheckedWriteNibbles# (p `plusAddr#` 2#) w + (writeWord8OffAddr# p 1# (c2b# 'x') + (writeWord8OffAddr# p 0# (c2b# '\\') rw0)) + , () #) + +buildLiteral :: S.ByteString -> Builder +buildLiteral = quoter " E'" "'" isSpecial esc + where isSpecial 39## = True -- '\'' + isSpecial 63## = True -- '?' + isSpecial 92## = True -- '\\' + isSpecial b = cmpres(b `geWord#` 128##) + esc b | b == c2b '\'' = byteStringCopy "''" + | b == c2b '\\' = byteStringCopy "\\\\" + | otherwise = hexCharEscBuilder b + + +copyByteToNibbles :: Addr# -> Addr# -> IO () +{-# INLINE copyByteToNibbles #-} +copyByteToNibbles src dst = IO $ \rw0 -> + case readWord8OffAddr# src 0# rw0 of + (# rw1, w #) -> (# uncheckedWriteNibbles# dst w rw1, () #) + +buildByteA :: S.ByteString -> Builder +buildByteA bs = equote $ + builder $ \cont (BufferRange (Ptr bb0) (Ptr be0)) -> + S.unsafeUseAsCStringLen bs $ \(Ptr inptr0, I# inlen0) -> do + let ine = plusAddr# inptr0 inlen0 + fill oute inp outp + | cmpres(inp `geAddr#` ine) = cont (BufferRange (Ptr outp) (Ptr oute)) + | cmpres(plusAddr# outp 2# `geAddr#` oute) = return $ + bufferFull (2 * (I# (ine `minusAddr#` inp)) + 1) (Ptr outp) $ + \(BufferRange (Ptr bb) (Ptr be)) -> fill be inp bb + | otherwise = do copyByteToNibbles inp outp + fill oute (inp `plusAddr#` 1#) (outp `plusAddr#` 2#) + fill be0 inptr0 bb0 + where equote b = mconcat [byteString " E'\\\\x", b, char8 '\''] + + + +buildAction :: Action -> Builder +buildAction (Plain b) = b +buildAction (Escape bs) = buildLiteral bs +buildAction (EscapeByteA bs) = buildByteA bs +buildAction (EscapeIdentifier bs) = buildIdent bs +buildAction (Many bs) = mconcat $ map buildAction bs + +-- | A lower-level function used by 'buildSql' and 'fmtSql'. You +-- probably don't need to call it directly. +buildSqlFromActions :: Query -> [Action] -> Builder +buildSqlFromActions (Query template) actions = + intercatlate (split template) (map buildAction $ actions) + where intercatlate (t:ts) (p:ps) = t <> p <> intercatlate ts ps + intercatlate [t] [] = t + intercatlate _ _ = + error $ "buildSql: wrong number of parameters for " ++ show template + split s = case S.break (== c2b '?') s of + (h,t) | S.null t -> [byteString h] + | otherwise -> byteString h : split (S.unsafeTail t) + +-- | A builder version of 'fmtSql', possibly useful if you are about +-- to concatenate various individually formatted query fragments and +-- want to save the work of concatenating each individually. +buildSql :: (ToRow p) => Query -> p -> Builder +{-# INLINE buildSql #-} +buildSql q p = buildSqlFromActions q (toRow p) + +-- | Take a SQL template containing \'?\' characters and a list of +-- paremeters whose length must match the number of \'?\' characters, +-- and format the result as an escaped 'S.ByteString' that can be used +-- as a query. +-- +-- Like 'formatQuery', this function is naive about the placement of +-- \'?\' characters and will expand all of them, even ones within +-- quotes. To avoid this, you must use 'quoteIdent' on identifiers +-- containing question marks. +-- +-- Also like 'formatQuery', \'?\' characters touching other \'?\' +-- characters or quoted strings may do the wrong thing, and end up +-- doubling a quote, so avoid substrings such as @\"??\"@ or +-- @\"?'string'\"@, as these could get expanded to, e.g., +-- @\"\'param''string'\"@, which is a single string containing an +-- apostrophe, when you probably wanted two strings. +fmtSql :: (ToRow p) => Query -> p -> Query +{-# INLINE fmtSql #-} +fmtSql q p = Query $ toStrict . toLazyByteString $ buildSql q p diff --git a/src/Database/PostgreSQL/Migrate.hs b/src/Database/PostgreSQL/Migrate.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrate.hs @@ -0,0 +1,254 @@ +{-# LANGUAGE CPP, OverloadedStrings #-} + +-- | Functions for creating and running database migrations. You should +-- probably be using the `pg_migrate` executable to run migrations, however +-- these functions are exposed for developers that want to integrate migrations +-- more tightly into their applications or utilities. + +module Database.PostgreSQL.Migrate + ( initializeDb + , runMigrationsForDir + , runRollbackForDir + , compileMigrationsForDir + , dumpDb + , newMigration + , defaultMigrationsDir + , getDirectoryMigrations + , 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 +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 + +import Paths_postgresql_orm + +-- | The default relative path containing migrations: @\"db\/migrations\"@ +defaultMigrationsDir :: FilePath +defaultMigrationsDir = "db" "migrations" + +-- | Dumps the database schema to the given file handle. +-- +-- This is a wrapper around the utility /pg_dump/ that comes with postgresql. +-- Therefore, /pg_dump/ must be installed on the system. +dumpDb :: Handle -> IO ExitCode +dumpDb outputFile = do + 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 + else do + raw <- S8.hGetContents out + let clean = S8.concat $ intersperse "\n" $ + filter ((/= "--") . (S8.take 2)) $ + S8.lines raw + S8.hPut outputFile clean + return exitCode + +-- | Initializes the database by creating a \"schema-migrations\" table. +-- This table must exist before running any migrations. +initializeDb :: IO () +initializeDb = do + conn <- connectEnv + 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 +-- 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. +runMigrationsForDir :: Handle -- ^ Log output (probably stdout) + -> FilePath -- ^ Path to directory containing migrations + -> IO ExitCode +runMigrationsForDir logOut dir = 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 + migrations <- getDirectoryMigrations dir >>= + return . (dropWhile (isVersion (<= latestVersion))) + go migrations + where go [] = withFile (dir ".." "schema.sql") WriteMode dumpDb + go (mig@(MigrationDetails _ _ name):fs) = do + hPutStrLn logOut $ "=== Running Migration " ++ name + exitCode <- runMigration mig + if exitCode == ExitSuccess then do + hPutStrLn logOut "=== Success" + go fs + else do + hPutStrLn logOut "=== Migration Failed!" + return exitCode + +-- | Run a migration. The returned exit code denotes the success or failure of +-- the migration. +runMigration :: MigrationDetails -> IO ExitCode +runMigration (MigrationDetails file vers _) = do + rawSystem "runghc" + [file, "up", vers, "--with-db-commit"] + +runRollbackForDir :: FilePath -> IO ExitCode +runRollbackForDir dir = do + conn <- connectEnv + res <- query_ conn + "select version from schema_migrations order by version desc limit 1" + case res of + [] -> do + putStrLn "=== DB Fully Rolled Back!" + return ExitSuccess + (Only latest):_ -> do + (Just (mig@(MigrationDetails _ _ name))) <- + getDirectoryMigrations dir >>= + return . (find (isVersion (== latest))) + putStrLn $ "=== Running Rollback " ++ name + exitCode <- runRollback mig + if exitCode == ExitSuccess then do + putStrLn "=== Success" + withFile (dir ".." "schema.sql") WriteMode dumpDb + else do + putStrLn "=== Migration Failed!" + return exitCode + +-- | Run a migration. The returned exit code denotes the success or failure of +-- the migration. +runRollback :: MigrationDetails -> IO ExitCode +runRollback (MigrationDetails file vers _) = do + rawSystem "runghc" + [file, "down", vers, "--with-db-commit"] + +data MigrationDetails = MigrationDetails { migrationPath :: FilePath + , migrationVersion :: String + , migrationName :: String } + deriving (Show) + +getDirectoryMigrations :: FilePath -> IO [MigrationDetails] +getDirectoryMigrations dir = do + files0 <- getDirectoryContents dir + let files = filter (('.' /=) . head) $ sort files0 + return $ map (splitFileVersionName dir) files + +splitFileVersionName :: FilePath -> FilePath -> MigrationDetails +splitFileVersionName dir file = + let fileName = takeBaseName file + parts = foldr (\chr (hd:result) -> + if chr == '_' then + "":hd:result + else ((chr:hd):result)) + [""] fileName + vers = head parts + name = concat $ intersperse "_" $ tail parts + 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) + + +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 (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)" diff --git a/src/Database/PostgreSQL/Migrations.hs b/src/Database/PostgreSQL/Migrations.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Migrations.hs @@ -0,0 +1,564 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Functions to help with building database migrations. + +Most users will want to create a database migration using @defaultMain@ as +follows, + +> +> import Database.PostgreSQL.Migrations +> +> main = defaultMain up down +> +> up = migrate $ do +> create_table "posts" +> [ column "title" "VARCHAR(255) NOT NULL" +> , column "author_id" "integer references authors(id)"] +> +> down = migrate $ drop_table "posts" +> +-} +module Database.PostgreSQL.Migrations ( + -- * Utilities + defaultMain + , connectEnv + , runSqlFile + -- * DSL + , Migration, migrate + , column + -- ** Adding + , create_table + , add_column + , create_index + , create_unique_index + -- ** Removing + , drop_table + , drop_column + , drop_index + -- ** Modifying + , rename_table + , rename_column + , change_column + , rename_index + , rename_sequence + , rename_constraint + -- ** Statements + , create_table_stmt, add_column_stmt, create_index_stmt + , drop_table_stmt, drop_column_stmt, drop_index_stmt + , rename_table_stmt, rename_column_stmt, change_column_stmt + , rename_index_stmt, rename_sequence_stmt, rename_constraint_stmt + ) where + +import Control.Monad +import Control.Monad.Reader +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Data.Int +import Data.Maybe +import Database.PostgreSQL.Simple hiding (connect) +import Database.PostgreSQL.Simple.Internal (exec) +import Database.PostgreSQL.Simple.Types +import System.Environment +import System.Exit + +import Database.PostgreSQL.Escape + +-- | Creates a PostgreSQL 'Connection' using the /DATABASE_URL/ environment +-- variable, if it exists. If it does, it should match the format: +-- +-- @ +-- postgresql:\/\/[[USERNAME\@PASSWORD]HOSTNAME[:PORT]]/[DBNAME] +-- @ +-- +-- If it is not present, the environment variables /PG_DBNAME/ /PG_HOST/ etc, +-- are used. +connectEnv :: IO Connection +connectEnv = do + psqlStr <- getEnvironment >>= + return . (fromMaybe "") . (lookup "DATABASE_URL") + connectPostgreSQL $ S8.pack psqlStr + +-- +-- Migration Monad +-- + +type Migration = ReaderT Connection IO + +migrate :: Migration a -> Connection -> IO () +migrate = (void .) . runReaderT + +executeQuery_ :: Query -> Migration Int64 +executeQuery_ q = ask >>= \conn -> liftIO $ execute_ conn q + +-- | Runs the SQL file at the given path, relative to the current working +-- directory. +runSqlFile :: FilePath -> Migration () +runSqlFile sqlFile = void $ do + conn <- ask + liftIO $ do + rawSql <- S.readFile sqlFile + exec conn rawSql + +-- | Returns a column defition by quoting the given name +column :: S8.ByteString -- ^ name + -> S8.ByteString -- ^ type, definition, constraints + -> S8.ByteString +column name def = S8.concat [quoteIdent name, " ", def] + +-- | Creates a table. See 'column' for constructing the column list. +create_table :: S8.ByteString + -- ^ Table name + -> [S8.ByteString] + -- ^ Column definitions + -> Migration Int64 +create_table = (executeQuery_ .) . create_table_stmt + +-- | Returns a 'Query' that creates a table, for example: +-- +-- @ +-- create_table_stmt \"posts\" +-- [ column \"title\" \"VARCHAR(255) NOT NULL\" +-- , column \"body\" \"text\"] +-- @ +create_table_stmt :: S8.ByteString + -- ^ Table name + -> [S8.ByteString] + -- ^ Column definitions + -> Query +create_table_stmt tableName colDefs = Query $ S8.concat $ + [ "create table " + , quoteIdent tableName + , " ("] ++ (S8.intercalate ", " colDefs):([");"]) + +-- | Drops a table +drop_table :: S8.ByteString -> Migration Int64 +drop_table = executeQuery_ . drop_table_stmt + +-- | Returns a 'Query' that drops a table +drop_table_stmt :: S8.ByteString -> Query +drop_table_stmt tableName = Query $ S8.concat + [ "drop table ", quoteIdent tableName, ";"] + +-- | Adds a column to the given table. For example, +-- +-- @ +-- add_column \"posts\" \"title\" \"VARCHAR(255)\" +-- @ +-- +-- adds a varchar column called \"title\" to the table \"posts\". +-- +add_column :: S8.ByteString + -- ^ Table name + -> S8.ByteString + -- ^ Column name + -> S8.ByteString + -- ^ Column definition + -> Migration Int64 +add_column = ((executeQuery_ .) .) . add_column_stmt + +-- | Returns a 'Query' that adds a column to the given table. For example, +-- +-- @ +-- add_column_stmt \"posts\" \"title\" \"VARCHAR(255)\" +-- @ +-- +-- Returns the query +-- +-- @ +-- ALTER TABLE \"posts\" add \"title\" VARCHAR(255); +-- @ +add_column_stmt :: S8.ByteString + -- ^ Table name + -> S8.ByteString + -- ^ Column name + -> S8.ByteString + -- ^ Column definition + -> Query +add_column_stmt tableName colName colDef = Query $ S8.concat + [ "alter table ", quoteIdent tableName, " add ", column colName colDef, ";"] + +-- | Drops a column from the given table. For example, +-- +-- @ +-- drop_column \"posts\" \"title\" +-- @ +-- +-- drops the column \"title\" from the \"posts\" table. +drop_column :: S8.ByteString + -- ^ Table name + -> S8.ByteString + -- ^ Column name + -> Migration Int64 +drop_column = (executeQuery_ .) . drop_column_stmt + +-- | Returns a 'Query' that drops a column from the given table. For example, +-- +-- @ +-- drop_column_stmt \"posts\" \"title\" +-- @ +-- +-- Returns the query +-- +-- @ +-- ALTER TABLE \"posts\" add \"title\"; +-- @ +drop_column_stmt :: S8.ByteString + -- ^ Table name + -> S8.ByteString + -- ^ Column name + -> Query +drop_column_stmt tableName colName = Query $ S8.concat + ["alter table ", quoteIdent tableName, " drop ", quoteIdent colName, ";"] + +-- | Renames the given table. For example, +-- +-- @ +-- rename_table \"posts\" \"blog_posts\" +-- @ +-- +-- renames the \"posts\" table to be called \"blog_posts\". +rename_table :: S8.ByteString + -- ^ Table name + -> S8.ByteString + -- ^ New table name + -> Migration Int64 +rename_table = (executeQuery_ .) . rename_table_stmt + +-- | Returns a 'Query' that renames the given table. For example, +-- +-- @ +-- rename_table_stmt \"posts\" \"blog_posts\" +-- @ +-- +-- Returns the query +-- +-- @ +-- ALTER TABLE \"posts\" RENAME TO \"blog_posts\"; +-- @ +rename_table_stmt :: S8.ByteString + -- ^ Table name + -> S8.ByteString + -- ^ New table name + -> Query +rename_table_stmt tableName newTableName = Query $ S8.concat + [ "alter table ", quoteIdent tableName, " rename to" + , quoteIdent newTableName, ";"] + +-- | Renames the given index. For example, +-- +-- @ +-- rename_index \"posts_pkey\" \"blog_posts_pkey\" +-- @ +-- +-- renames the \"posts_pkey\" index to be called \"blog_posts_pkey\". +rename_index :: S8.ByteString + -- ^ Index name + -> S8.ByteString + -- ^ New index name + -> Migration Int64 +rename_index = (executeQuery_ .) . rename_index_stmt + +-- | Returns a 'Query' that renames the given table. For example, +-- +-- @ +-- rename_index_stmt \"posts_pkey\" \"blog_posts_pkey\" +-- @ +-- +-- Returns the query +-- +-- @ +-- ALTER INDEX \"posts\" RENAME TO \"blog_posts_pkey\"; +-- @ +rename_index_stmt :: S8.ByteString + -- ^ Index name + -> S8.ByteString + -- ^ New index name + -> Query +rename_index_stmt indexName newIndexName = Query $ S8.concat + [ "alter index ", quoteIdent indexName, " rename to" + , quoteIdent newIndexName, ";"] + +-- | Renames the given sequence. For example, +-- +-- @ +-- rename_sequence \"posts_id_seq\" \"blog_posts_id_seq\" +-- @ +-- +-- renames the \"posts_id_seq\" sequence to be called \"blog_posts_id_seq\". +rename_sequence :: S8.ByteString + -- ^ Sequence name + -> S8.ByteString + -- ^ New sequence name + -> Migration Int64 +rename_sequence = (executeQuery_ .) . rename_sequence_stmt + +-- | Returns a 'Query' that renames the given sequence. For example, +-- +-- @ +-- rename_sequence_stmt \"posts_id_seq\" \"blog_posts_id_seq\" +-- @ +-- +-- Returns the query +-- +-- @ +-- ALTER SEQUENCE \"posts_id_seq\" RENAME TO \"blog_posts__id_seq\"; +-- @ +rename_sequence_stmt :: S8.ByteString + -- ^ Sequence name + -> S8.ByteString + -- ^ New sequence name + -> Query +rename_sequence_stmt seqName newSeqName = Query $ S8.concat + [ "alter sequence ", quoteIdent seqName, " rename to" + , quoteIdent newSeqName, ";"] + +-- | Renames the given constraint. For example, +-- +-- @ +-- rename_constraint \"posts\" \"posts_author_id_fkey\" +-- \"blog_posts_author_id_fkey\" +-- @ +-- +-- renames the \"posts_author_id_fkey\" sequence to be called +-- \"blog_posts_author_id_fkey\". +rename_constraint :: S8.ByteString + -- ^ Table name + -> S8.ByteString + -- ^ Constraint name + -> S8.ByteString + -- ^ New constraint name + -> Migration Int64 +rename_constraint = ((executeQuery_ .) .) . rename_constraint_stmt + +-- | Returns a 'Query' that renames the given constraint. For example, +-- +-- @ +-- rename_constraint_stmt \"posts\" \"posts_author_id_fkey\" +-- \"blog_posts_author_id_fkey\" +-- @ +-- +-- Returns the query +-- +-- @ +-- ALTER TABLE \"posts\" RENAME CONSTRAINT \"posts_author_id_fkey\" +-- RENAME TO \"blog_posts_author_id_fkey\"; +-- @ +rename_constraint_stmt :: S8.ByteString + -- ^ Table name + -> S8.ByteString + -- ^ Constraint name + -> S8.ByteString + -- ^ New constraint name + -> Query +rename_constraint_stmt tbl conName newConName = Query $ S8.concat + [ "alter table ", quoteIdent tbl, " rename constraint" + , quoteIdent conName, "to", quoteIdent newConName, ";"] + +-- | Renames a column in the given table. For example, +-- +-- @ +-- rename_column \"posts\" \"title\" \"name\" +-- @ +-- +-- renames the column \"title\" in the \"posts\" table to \"name\". +rename_column :: S8.ByteString + -- ^ Table name + -> S8.ByteString + -- ^ Old column name + -> S8.ByteString + -- ^ New column name + -> Migration Int64 +rename_column = ((executeQuery_ .) .) . rename_column_stmt + +-- | Returns a 'Query' that renames a column in the given table. For example, +-- +-- @ +-- rename_column_stmt \"posts\" \"title\" \"name\" +-- @ +-- +-- Returns the query +-- +-- @ +-- ALTER TABLE \"posts\" RENAME \"title\" TO \"name\"; +-- @ +rename_column_stmt :: S8.ByteString + -- ^ Table name + -> S8.ByteString + -- ^ Old column name + -> S8.ByteString + -- ^ New column name + -> Query +rename_column_stmt tableName colName colNameNew = Query $ S8.concat + [ "alter table ", quoteIdent tableName, " rename " + , quoteIdent colName, " to ", quoteIdent colNameNew, ";"] + +-- | Alters a column in the given table. For example, +-- +-- @ +-- change_column \"posts\" \"title\" \"DROP DEFAULT\" +-- @ +-- +-- drops the default constraint for the \"title\" column in the \"posts\" +-- table. +change_column :: S8.ByteString + -- ^ Table name + -> S8.ByteString + -- ^ Column name + -> S8.ByteString + -- ^ Action + -> Migration Int64 +change_column = ((executeQuery_ .) .) . change_column_stmt + +-- | Returns a 'Query' that alters a column in the given table. For example, +-- +-- @ +-- change_column_stmt \"posts\" \"title\" \"DROP DEFAULT\" +-- @ +-- +-- Returns the query +-- +-- @ +-- ALTER TABLE \"posts\" ALTER \"title\" DROP DEFAULT; +-- @ +change_column_stmt :: S8.ByteString + -- ^ Table name + -> S8.ByteString + -- ^ Column name + -> S8.ByteString + -- ^ Action + -> Query +change_column_stmt tableName colName action = Query $ S8.concat + [ "alter table ", quoteIdent tableName, " alter " + , quoteIdent colName, " ", action, ";"] + +data CmdArgs = CmdArgs { cmd :: String + , cmdVersion :: String + , cmdCommit :: Bool } + +-- | Creates an index for efficient lookup. +create_index :: S8.ByteString + -- ^ Index name + -> S8.ByteString + -- ^ Table name + -> [S8.ByteString] + -- ^ Column names + -> Migration Int64 +create_index = ((executeQuery_ .) .) . (create_index_stmt False) + +-- | Creates a unique index for efficient lookup. +create_unique_index :: S8.ByteString + -- ^ Index name + -> S8.ByteString + -- ^ Table name + -> [S8.ByteString] + -- ^ Column names + -> Migration Int64 +create_unique_index = ((executeQuery_ .) .) . (create_index_stmt True) + +-- | Returns a 'Query' that creates an index for the given columns on the given +-- table. For example, +-- +-- @ +-- create_index_stmt \"post_owner_index\" \"posts\" \"owner\" +-- @ +-- +-- Returns the query +-- +-- @ +-- CREATE INDEX \"post_owner_index\" ON \"posts\" (\"owner\") +-- @ +create_index_stmt :: Bool + -- ^ Unique index? + -> S8.ByteString + -- ^ Index name + -> S8.ByteString + -- ^ Table name + -> [S8.ByteString] + -- ^ Column names + -> Query +create_index_stmt unq indexName tableName colNames = Query $ S8.concat + [ "create", unique, " index ", quoteIdent indexName, " on " + , quoteIdent tableName, " (", cols, ")", ";" ] + where cols = S8.intercalate ", " $ map quoteIdent colNames + unique = if unq then " unique" else "" + +-- | Drops an index. +drop_index :: S8.ByteString + -- ^ Index name + -> Migration Int64 +drop_index = executeQuery_ . drop_index_stmt + +-- | Returns a 'Query' that drops an index. +-- +-- @ +-- drop_index_stmt \"post_owner_index\" +-- @ +-- +-- Returns the query +-- +-- @ +-- DROP INDEX \"post_owner_index\" +-- @ +drop_index_stmt :: S8.ByteString + -- ^ Index name + -> Query +drop_index_stmt indexName = Query $ S8.concat + [ "drop index ", quoteIdent indexName, ";" ] + +parseCmdArgs :: [String] -> Maybe CmdArgs +parseCmdArgs args = do + mycmd <- listToMaybe args + let args0 = tail args + myversion <- listToMaybe args0 + return $ go (CmdArgs mycmd myversion False) $ tail args0 + where go res [] = res + go res (arg:as) = + let newRes = case arg of + "--with-db-commit" -> res { cmdCommit = True } + _ -> res + in go newRes as + +defaultMain :: (Connection -> IO ()) -- ^ Migration function + -> (Connection -> IO ()) -- ^ Rollback function + -> IO () +defaultMain up down = do + (Just cmdArgs) <- getArgs >>= return . parseCmdArgs + case cmd cmdArgs of + "up" -> do + conn <- connectEnv + res <- query_ conn + "select version from schema_migrations order by version desc limit 1" + let currentVersion = case res of + [] -> "" + (Only v):_ -> v + let version = cmdVersion cmdArgs + if currentVersion < version then do + begin conn + up conn + void $ execute conn "insert into schema_migrations values(?)" + (Only version) + if cmdCommit cmdArgs then + commit conn + else rollback conn + else exitWith $ ExitFailure 1 + "down" -> do + conn <- connectEnv + res <- query_ conn + "select version from schema_migrations order by version desc limit 1" + let currentVersion = case res of + [] -> "" + (Only v):_ -> v + let version = cmdVersion cmdArgs + if currentVersion == version then do + begin conn + down conn + void $ execute conn "delete from schema_migrations where version = ?" + (Only version) + if cmdCommit cmdArgs then + commit conn + else rollback conn + else + exitWith $ ExitFailure 1 + _ -> exitWith $ ExitFailure 1 + diff --git a/src/Database/PostgreSQL/ORM.hs b/src/Database/PostgreSQL/ORM.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/ORM.hs @@ -0,0 +1,29 @@ + +module Database.PostgreSQL.ORM ( + -- * The Model class and related types + Model(modelInfo, modelValid), ModelInfo(..) + , defaultModelInfo, underscoreModelInfo + , DBKey(..), DBRef, DBRefUnique, mkDBRef, primaryKey + , (:.), As(..), RowAlias(..), fromAs + -- ** Single-row operations + , findRow, findAll, save, trySave, destroy, destroyByRef + -- * Abstracted select queries + , DBSelect(..), modelDBSelect, dbSelectParams, dbSelect + , addWhere_, addWhere, setOrderBy, setLimit, setOffset + -- * Associations between models + , Association, assocSelect, assocProject, assocWhere, findAssoc + -- ** Parent-child associations + , GDBRefInfo(..), DBRefInfo, defaultDBRefInfo, dbrefAssocs, has, belongsTo + -- ** Join table associations + , JoinTable(..), defaultJoinTable, jtAssocs, jtAdd, jtRemove, jtRemoveByRef + -- ** Chaining associations + , nestAssoc, chainAssoc + -- ** Validations + , ValidationError(..), validate, validateNotEmpty, validationError + ) where + +import Database.PostgreSQL.ORM.Model +import Database.PostgreSQL.ORM.DBSelect +import Database.PostgreSQL.ORM.Association +import Database.PostgreSQL.ORM.Validations +import Database.PostgreSQL.Simple ((:.)) diff --git a/src/Database/PostgreSQL/ORM/Association.hs b/src/Database/PostgreSQL/ORM/Association.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/ORM/Association.hs @@ -0,0 +1,543 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Database.PostgreSQL.ORM.Association ( + Association(..), assocProject, assocWhere, findAssoc + -- * Associations based on parent-child relationships + , GDBRefInfo(..), DBRefInfo, defaultDBRefInfo, dbrefAssocs, has, belongsTo + -- * Join table Associations + , JoinTable(..), defaultJoinTable, jtAssocs, joinTable + -- ** Operations on join tables + , jtAdd, jtRemove, jtRemoveByRef + -- ** Semi-internal join table functions + , jtAddStatement, jtRemoveStatement, jtParam + , jtFlip, jtAssoc + -- * Nested and chained associations + , nestAssoc, chainAssoc + ) where + +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative +#endif +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Data.List +import Data.Monoid +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.Types + +import Data.GetField +import Database.PostgreSQL.Escape +import Database.PostgreSQL.ORM.DBSelect +import Database.PostgreSQL.ORM.Model + + +-- | A data structure representing a relationship between a model @a@ +-- and a model @b@. At a high level, an @Association a b@ tells you +-- how to find rows of type @b@ given rows of type @a@. More +-- concretely, this boils down to being able to make two types of +-- query. +-- +-- * You want to look up a bunch of @(a ':.' b)@s, filtering using +-- predicates on both @a@ and @b@ (e.g., get a list of recent posts +-- and their authors). For this purpose, you can use 'assocSelect', +-- which allows you to 'addWhere' predicates mentioning columns in +-- both @a@ and @b@. +-- +-- * You already have an instance of type @a@, and want to find all +-- the @b@s associated with it. For that you use either 'assocWhere' +-- or 'findAssoc' (which internally access fields 'assocSelectOnlyB', +-- 'assocWhereQuery', and 'assocWhereParam'). This type of query is +-- strictly less general than the first one, but can be formulated in +-- a more efficient way by extracting values directly from a concrete +-- instance of @a@ without needing to touch table @a@ in the +-- database. +-- +-- Note that an @Association@ is asymmetric. It tells you how to get +-- @b@s from @a@s, but not vice versa. In practice, there will almost +-- always be an association in the other direction, too. Functions +-- such as 'dbrefAssocs' and 'jtAssocs' therefore create an +-- @Association@ and its inverse simultaneously, returning them as a +-- pair. +data Association a b = Association { + assocSelect :: !(DBSelect (a :. b)) + -- ^ General select returning all instances of @a@ and @b@ that + -- match according to the association. + , assocSelectOnlyB :: !(DBSelect b) + -- ^ The right-hand side of the 'assocSelect' query. This query + -- makes no mention of type @a@ (but can be combined with the next + -- two fields to form an optimized query). You probably never + -- want to use this directly, and should instead use either + -- 'findAssoc' or 'assocWhere'. Also note this is not useful for + -- selecting all the @b@s in the relation; for that you should use + -- 'assocProject'. + , assocWhereQuery :: !Query + -- ^ A @WHERE@ clause to find all the 'b's associated with a + -- particular @a@. This can often be done more efficiently than + -- through 'assocSelect'. The clause contains @\'?\'@ characters + -- which should be filled in by 'assocWhereParam'. + , assocWhereParam :: !(a -> [Action]) + -- ^ The query parameters for the query returned by + -- 'assocWhereQuery'. + } + +instance Show (Association a b) where + show assoc = + "Association { assocSelect = " ++ show (assocSelect assoc) ++ + ", assocSelectOnlyB = " ++ show (assocSelectOnlyB assoc) ++ + ", assocWhereQuery = " ++ S8.unpack (fromQuery $ assocWhereQuery assoc) ++ + " }" + +-- | A projection of 'assocSelect', extracting only the fields of +-- model @b@. Note that this query touches table @a@ even if it does +-- not return results from @a@. Hence, you can use 'addWhere' to add +-- predicates on both @a@ and @b@. (Note the contrast to +-- 'assocSelectOnlyB', which does not touch table @a@ at all, and +-- hence in the case of an @INNER JOIN@ might return rows of @b@ that +-- should not be part of the association. 'assocSelectOnlyB' is +-- intended for use only in conjunction with 'assocWhereQuery'.) +assocProject :: (Model b) => Association a b -> DBSelect b +assocProject = dbProject . assocSelect + +-- | Returns a 'DBSelect' for all @b@s associated with a particular +-- @a@. +assocWhere :: (Model b) => Association a b -> a -> DBSelect b +assocWhere ab a = addWhere (assocWhereQuery ab) (assocWhereParam ab a) + (assocSelectOnlyB ab) + +-- | Follow an association to return all of the @b@s associated +-- with a particular @a@. The behavior is similar to: +-- +-- > findAssoc' ab c a = dbSelect c $ assocWhere ab a +-- +-- But if the first argument is a static association, this function +-- may be marginally faster because it pre-renders most of the query. +findAssoc :: (Model b) => Association a b -> Connection -> a -> IO [b] +{-# INLINE findAssoc #-} +findAssoc assoc = \c a -> + map lookupRow <$> query c q (assocWhereParam assoc a) + where {-# NOINLINE q #-} + q = renderDBSelect $ + addWhere_ (assocWhereQuery assoc) $ assocSelectOnlyB assoc + +-- | Combine two associations into one. +nestAssoc :: (Model a, Model b) => + Association a b -> Association b c -> Association a (b :. c) +nestAssoc ab bc = ab { assocSelect = dbNest (assocSelect ab) (assocSelect bc) + , assocSelectOnlyB = assocSelect bc } + +-- | Combine two associations into one, and project away the middle +-- type. (The middle type can still be mentioned in @WHERE@ clauses.) +-- +-- An example: +-- +-- > data Author = Author { +-- > authorId :: DBKey +-- > } deriving (Show, Generic) +-- > instance Model Author where modelInfo = underscoreModelInfo "author" +-- > +-- > data Post = Post { +-- > postId :: DBKey +-- > , postAuthorId :: DBRef Author +-- > } deriving (Show, Generic) +-- > instance Model Post where modelInfo = underscoreModelInfo "post" +-- > +-- > data Comment = Comment { +-- > commentId :: DBKey +-- > , commentPostId :: DBRef Post +-- > } deriving (Show, Generic) +-- > instance Model Comment where modelInfo = underscoreModelInfo "comment" +-- > +-- > author_posts :: Association Author Post +-- > post_author :: Association Post Author +-- > (post_author, author_posts) = dbrefAssocs defaultDBRefInfo +-- > +-- > -- Could equally well use dbrefAssocs as above +-- > post_comments :: Association Post Comment +-- > post_comments = has +-- > +-- > comment_post :: Association Comment Post +-- > comment_post = belongsTo +-- > +-- > comment_author :: Association Comment Author +-- > comment_author = chainAssoc comment_post post_author +-- > +-- > author_comments :: Association Author Comment +-- > author_comments = chainAssoc author_posts post_comments +chainAssoc :: (Model a, Model b, Model c) => + Association a b -> Association b c -> Association a c +chainAssoc ab bc = ab { assocSelect = dbChain (assocSelect ab) (assocSelect bc) + , assocSelectOnlyB = dbProject $ assocSelect bc } + + +-- | A common type of association is when one model contains a 'DBRef' +-- or 'DBRefUnique' pointing to another model. In this case, the +-- model containing the 'DBRef' is known as the /child/, and the +-- referenced model is known as the /parent/. +-- +-- Two pieces of information are required to describe a parent-child +-- relationship: First, the field selector that extracts the Haskell +-- 'DBRef' from the haskell type @child@, and second the name of the +-- database column that stores this 'DBRef' field. +-- +-- For example, consider the following: +-- +-- > data Author = Author { +-- > authorId :: DBKey +-- > } deriving (Show, Generic) +-- > instance Model Author +-- > +-- > data Post = Post { +-- > postId :: DBKey +-- > , postAuthorId :: DBRef Author +-- > } deriving (Show, Generic) +-- > instance Model Post +-- > +-- > post_author_refinfo :: DBRefInfo Post Author +-- > post_author_refinfo = DBRefInfo { +-- > dbrefSelector = postAuthorId +-- > , dbrefQColumn = "\"post\".\"postAuthorId\"" +-- > } +-- +-- Note that the parent-child relationship described by a @GDBRefInfo@ +-- is asymmetric, but bidirectional. When a @'DBRefInfo' child +-- parent@ exists, the schema should generally /not/ permit the +-- existence of a valid @'DBRefInfo' parent child@ structure. +-- However, the 'dbrefAssocs' function generates 'Association's in +-- both directions from a single 'DBRefInfo'. +-- +-- Constructing such parent-child 'Association's requires knowing how +-- to extract primary keys from the @parent@ type as well as the name +-- of the column storing primary keys in @parent@. Fortunately, this +-- information is already available from the 'Model' class, and thus +-- does not need to be in the @GDBRefInfo@. (Most functions on +-- @GDBRefInfo@s require @parent@ and @child@ to be instances of +-- 'Model'.) +-- +-- When your 'Model's are instances of 'Generic' (which will usually +-- be the case), a 'DBRefInfo' structure can be computed automatically +-- by 'defaultDBRefInfo'. This is the recommended way to produce a +-- @GDBRefInfo@. (Alternatively, see 'has' and 'belongsTo' to make +-- use of an entirely implicit @DBRefInfo@.) +data GDBRefInfo reftype child parent = DBRefInfo { + dbrefSelector :: !(child -> GDBRef reftype parent) + -- ^ Field selector returning a reference. + , dbrefQColumn :: !S.ByteString + -- ^ Literal SQL for the database column storing the reference. + -- This should be double-quoted and table-qualified, in case the + -- column name is a reserved keyword, contains capital letters, or + -- conflicts with the name of a column in the joined table. An + -- example would be: + -- + -- > dbrefQColumn = "\"table_name\".\"column_name\"" + } + +instance Show (GDBRefInfo rt c p) where + show ri = "DBRefInfo ? " ++ show (dbrefQColumn ri) + +-- | @DBRefInfo@ is a type alias for the common case that the +-- reference in a 'GDBRefInfo' is a 'DBRef' (as opposed to a +-- 'DBRefUnique'). The functions in this library do not care what +-- type of reference is used. The type is generalized to 'GDBRefInfo' +-- just to make it easier to assign a selector to 'dbrefSelector' when +-- the selector returns a 'DBRefUnique'. Note, however, that +-- 'defaultDBRefInfo' returns a 'DBRefInfo' regardless of the flavor +-- of reference actually encountered. +type DBRefInfo = GDBRefInfo NormalRef + +data ExtractRef a = ExtractRef deriving (Show) +instance Extractor ExtractRef (GDBRef rt a) (DBRef a) THasOne where + extract _ (DBRef k) = THasOne $ DBRef k +instance Extractor ExtractRef (GDBRef rt a) (DBRef (As alias a)) THasOne where + extract _ (DBRef k) = THasOne $ DBRef k +instance Extractor ExtractRef (Maybe (GDBRef rt a)) (DBRef a) THasOne where + extract _ (Just (DBRef k)) = THasOne $ DBRef k + extract _ _ = error "Maybe DBRef is Nothing" +instance Extractor ExtractRef (Maybe (GDBRef rt a)) (DBRef (As alias a)) + THasOne where + extract _ (Just (DBRef k)) = THasOne $ DBRef k + extract _ _ = error "Maybe DBRef is Nothing" + +-- | Creates a 'DBRefInfo' from a model @child@ that references +-- @parent@. For this to work, the @child@ type must be an instance +-- of 'Generic' and must contain exactly one field of the any of the +-- following types: +-- +-- 1. @'GDBRef' rt parent@, which matches both @'DBRef' parent@ and +-- @'DBRefUnique' parent@. +-- +-- 2. @Maybe ('GDBRef' rt parent)@, for cases where the reference +-- might be @NULL@. Note, however, that an exception will be thrown +-- if you call 'findAssoc' on a child whose reference is 'Nothing'. +-- +-- A special case arises when a Model contains a 'DBRef' to itself. +-- If you just wish to find parents and children given an existing +-- structure (i.e., 'findAssoc'), it is okay to declare an +-- @'Association' MyType MyType@. However, in this case attempts to +-- use 'assocSelect' will then fail. To work around this problem, the +-- parent must use a row alias. +-- +-- Note that currently /aliasing the child will not work/, since the +-- 'As' data structure will not contain a 'DBRef' field, only the +-- contents of the 'As' data structure. An example of doing this +-- correctly (using 'has' and 'belongsTo', both of which wrap +-- @defaultDBRefInfo@): +-- +-- > data Bar = Bar { +-- > barId :: !DBKey +-- > , barName :: !String +-- > , barParent :: !(Maybe (DBRef Bar)) +-- > } deriving (Show, Generic) +-- > instance Model Bar where modelInfo = underscoreModelInfo "bar" +-- > +-- > data ParentBar = ParentBar +-- > instance RowAlias ParentBar where rowAliasName _ = "parent_bar" +-- > +-- > toParent :: Association Bar (As ParentBar Bar) +-- > toParent = belongsTo +-- > +-- > toChild :: Association (As ParentBar Bar) Bar +-- > toChild = has +defaultDBRefInfo :: forall child parent. + (Model child, Model parent + , GetField ExtractRef child (DBRef parent)) => + DBRefInfo child parent +defaultDBRefInfo = ri + where extractor = (const ExtractRef :: g p -> ExtractRef (DBRef p)) ri + child = undefined :: child + childids = modelIdentifiers :: ModelIdentifiers child + ri = DBRefInfo { + dbrefSelector = getFieldVal extractor + , dbrefQColumn = modelQColumns childids !! getFieldPos extractor child + } + +-- | Generate both the child-parent and parent-child 'Association's +-- implied by a 'GDBRefInfo'. +dbrefAssocs :: forall child parent rt. + (Model child, Model parent) => + GDBRefInfo rt child parent + -> (Association child parent, Association parent child) +dbrefAssocs ri = (c_p, p_c) + where idp = modelIdentifiers :: ModelIdentifiers parent + on = Query $ "ON " <> modelQPrimaryColumn idp + <> " = " <> dbrefQColumn ri + c_p = Association { + assocSelect = dbJoinModels "JOIN" on + , assocSelectOnlyB = modelDBSelect + , assocWhereQuery = Query $ modelQPrimaryColumn idp <> " = ?" + , assocWhereParam = \child -> [toField $ dbrefSelector ri child] + } + p_c = Association { + assocSelect = dbJoinModels "JOIN" on + , assocSelectOnlyB = modelDBSelect + , assocWhereQuery = Query $ dbrefQColumn ri <> " = ?" + , assocWhereParam = \parent -> [toField $ primaryKey parent] + } + + +-- | Short for +-- +-- > snd $ dbrefAssocs defaultDBRefInfo +-- +-- Note the inverse 'Association' is given by 'belongsTo'. For +-- example, given the @Author@ and @Post@ models described in the +-- documentation for 'GDBRefInfo', in which each @Post@ references an +-- @Author@, you might say: +-- +-- > author_post :: Association Author Post +-- > author_post = has +-- > +-- > post_author :: Association Post Author +-- > post_author = belongsTo +has :: (Model child, Model parent, GetField ExtractRef child (DBRef parent)) => + Association parent child +has = snd $ dbrefAssocs defaultDBRefInfo + +-- | The inverse of 'has'. Short for +-- +-- > fst $ dbrefAssocs defaultDBRefInfo +-- +-- See an example at 'has'. +belongsTo :: (Model child, Model parent + , GetField ExtractRef child (DBRef parent)) => + Association child parent +belongsTo = fst $ dbrefAssocs defaultDBRefInfo + +-- | A data structure representing a dedicated join table in the +-- database. A join table differs from a model in that rows do not +-- have primary keys. Hence, model operations do not apply. +-- Nonetheless a join table conveys information about a relationship +-- between models. +-- +-- Note that all names in a @JoinTable@ should be unquoted. +data JoinTable a b = JoinTable { + jtTable :: !S.ByteString + -- ^ Name of the join table in the database. (Not quoted.) + , jtColumnA :: !S.ByteString + -- ^ Name of the column in table 'jtTable' that contains a 'DBRef' + -- to model @a@. (Not quoted or table-qualified.) + , jtColumnB :: !S.ByteString + -- ^ Like 'jtColumnA' for model @b@. + } deriving (Show) + +-- | The default join table has the following fields: +-- +-- * 'jtName' is the name of the two models (in alphabetical order), +-- separated by an @\'_\'@ character. +-- +-- * 'jtColumnA' is the name of model @a@, an @\'_\'@ character, and +-- the name of the primary key column in table @a@. +-- +-- * 'jtColumnB' is the name of model @b@, an @\'_\'@ character, and +-- the name of the primary key column in table @b@. +-- +-- Note that 'defaultJoinTable' cannot create a default join table for +-- joining a model to itself, as following these rules the two columns +-- would have the same name. If you wish to join a table to itself, +-- you have two options: First, you can define the join table and +-- assign the column names manually. This will permit you to call +-- 'findAssoc', but you still will not be able to use 'assocSelect' +-- for more complex queries, since SQL does not permit joins between +-- two tables with the same name. The second option is to give one of +-- the sides of the join table a row alias with 'As'. For example: +-- +-- > data ParentBar = ParentBar +-- > instance RowAlias ParentBar where rowAliasName _ = "parent_bar" +-- > +-- > selfJoinTable :: JoinTable Bar (As ParentBar Bar) +-- > selfJoinTable = defaultJoinTable +-- > +-- > selfJoin :: Association Bar (As ParentBar Bar) +-- > otherSelfJoin :: Association (As ParentBar Bar) Bar +-- > (selfJoin, otherSelfJoin) = jtAssocs selfJoinTable +defaultJoinTable :: forall a b. (Model a, Model b) => JoinTable a b +defaultJoinTable + | colA == colB = error "defaultJoinTable has default for self joins" + | otherwise = jti + where a = modelInfo :: ModelInfo a + b = modelInfo :: ModelInfo b + colA = S.intercalate "_" + [modelTable a, modelColumns a !! modelPrimaryColumn a] + colB = S.intercalate "_" + [modelTable b, modelColumns b !! modelPrimaryColumn b] + jti = JoinTable { + jtTable = S.intercalate "_" $ sort [modelTable a, modelTable b] + , jtColumnA = colA + , jtColumnB = colB + } + +jtQTable :: JoinTable a b -> S.ByteString +jtQTable = quoteIdent . jtTable + +jtQColumnA :: JoinTable a b -> S.ByteString +jtQColumnA jt = S.concat [ jtQTable jt, ".", quoteIdent $ jtColumnA jt] + +jtQColumnB :: JoinTable a b -> S.ByteString +jtQColumnB jt = S.concat [ jtQTable jt, ".", quoteIdent $ jtColumnB jt] + +-- | Flip a join table. This doesn't change the name of the table +-- (since the same join table is used in both directions, and the +-- default join table name glues together the two model names in +-- alphabetical order anyway). +jtFlip :: JoinTable a b -> JoinTable b a +jtFlip jt = jt { jtColumnA = jtColumnB jt , jtColumnB = jtColumnA jt } + +-- | A SQL statement suitable for adding a pair to a join table. Note +-- that the statement takes two parameters (i.e., contains two @\'?\'@ +-- characters) corresponding to the primary keys of the two models +-- being associated. These parameters can be supplied by 'jtParam'. +jtAddStatement :: JoinTable a b -> Query +jtAddStatement jt = Query $ S.concat [ + "INSERT INTO ", jtQTable jt, " (" + , quoteIdent $ jtColumnA jt, ", ", quoteIdent $ jtColumnB jt + , ") VALUES (?, ?) EXCEPT SELECT " + , jtQColumnA jt, ", ", jtQColumnB jt, " FROM ", quoteIdent $ jtTable jt + ] + +-- | Add an association between two models to a join table. Returns +-- 'True' if the association was not already there. +jtAdd :: (Model a, Model b) => JoinTable a b -> Connection -> a -> b -> IO Bool +{-# INLINE jtAdd #-} +jtAdd jt = \c a b -> (/= 0) <$> execute c q (jtParam jt a b) + where {-# NOINLINE q #-} + q = jtAddStatement jt + +-- | A SQL statement for removing a pair from a join table. Like +-- 'jtAddStatement', the query is parameterized by two primary keys. +jtRemoveStatement :: JoinTable a b -> Query +jtRemoveStatement jt = Query $ S.concat [ + "DELETE FROM ", quoteIdent $ jtTable jt, " WHERE " + , jtQColumnA jt, " = ? AND ", jtQColumnB jt, " = ?" + ] + +-- | Remove an association from a join table. Returns 'True' if the +-- association was previously there. +jtRemove :: (Model a, Model b) => + JoinTable a b -> Connection -> a -> b -> IO Bool +{-# INLINE jtRemove #-} +jtRemove jt = \c a b -> (/= 0) <$> execute c q (jtParam jt a b) + where {-# NOINLINE q #-} + q = jtRemoveStatement jt + +-- | Remove an assocation from a join table when you don't have the +-- target instances of the two models handy, but do have references. +jtRemoveByRef :: (Model a, Model b) => JoinTable a b + -> Connection -> GDBRef rt a -> GDBRef rt b -> IO Bool +{-# INLINE jtRemoveByRef #-} +jtRemoveByRef jt = \c a b -> (/= 0) <$> execute c q (a, b) + where {-# NOINLINE q #-} + q = jtRemoveStatement jt + +-- | Generate parameters for 'jtAddStatement' and 'jtRemoveStatement'. +-- The returned list is suitable for use as a 'ToRow' instance. For +-- example: +-- +-- > execute conn (jtAddStatement my_join_table) (jtParam a b) +jtParam :: (Model a, Model b) => JoinTable a b -> a -> b -> [Action] +jtParam _ a b = [toField $ primaryKey a, toField $ primaryKey b] + +-- | Generate a one-way association from a 'JoinTable'. Use +-- 'jtAssocs' instead. +jtAssoc :: forall a b. (Model a, Model b) => JoinTable a b -> Association a b +jtAssoc jt = Association { + assocSelect = dbJoin modelDBSelect "JOIN" onlyB $ Query $ S.concat [ + "ON ", priA, " = ", jtQColumnA jt] + , assocSelectOnlyB = onlyB + , assocWhereQuery = Query $ jtQColumnA jt <> " = ?" + , assocWhereParam = \a -> [toField $ primaryKey a] + } + where priA = modelQPrimaryColumn (modelIdentifiers :: ModelIdentifiers a) + priB = modelQPrimaryColumn (modelIdentifiers :: ModelIdentifiers b) + selB = modelDBSelect :: DBSelect b + fromB = FromJoin + (FromModel (Query $ jtQTable jt) (jtQTable jt)) + "JOIN" (selFrom selB) + (Query $ S.concat ["ON ", jtQColumnB jt, " = ", priB]) + (jtQTable jt <> "->B") + onlyB = selB { selFrom = fromB } + +-- | Generate the two associations implied by a 'JoinTable'. +jtAssocs :: (Model a, Model b) => + JoinTable a b -> (Association a b, Association b a) +jtAssocs jt = (jtAssoc jt, jtAssoc $ jtFlip jt) + +-- | Generate a one-way association based on the default join table +-- naming scheme described at 'defaultJoinTable'. Defined as: +-- +-- > joinTable = jtAssoc defaultJoinTable +-- +-- For example: +-- +-- > aToB :: Association A B +-- > aToB = joinTable +-- > +-- > bToA :: Association B A +-- > bToA = joinTable +joinTable :: (Model a, Model b) => Association a b +joinTable = jtAssoc defaultJoinTable diff --git a/src/Database/PostgreSQL/ORM/CreateTable.hs b/src/Database/PostgreSQL/ORM/CreateTable.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/ORM/CreateTable.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Functions for creating a table from a model. These are mostly +-- useful in development, for very rigid applications, or to compare +-- what would be created against what is actually in the database. In +-- practice, production settings should create and update tables using +-- migrations. +-- +-- Note that often it is more interesting to see what would be created +-- than to create an actual table. For that reason, functions +-- creating the statements are exposed. +module Database.PostgreSQL.ORM.CreateTable ( + modelCreateStatement, modelCreate, GDefTypes(..) + , jtCreateStatement, jtCreate + ) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Data.Int +import Data.List +import Data.Monoid +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.Types +import GHC.Generics + +import Database.PostgreSQL.ORM.Model +import Database.PostgreSQL.ORM.Association +import Database.PostgreSQL.ORM.SqlType + +-- | This is a helper class used to extract the row types. You don't +-- need to use this class. If you are creating custom types, just +-- declare an instance of 'SqlType'. +class GDefTypes f where + gDefTypes :: f p -> [S.ByteString] +instance (SqlType c) => GDefTypes (K1 i c) where + gDefTypes ~(K1 c) = [sqlType c] +instance (GDefTypes a, GDefTypes b) => GDefTypes (a :*: b) where + gDefTypes ~(a :*: b) = gDefTypes a ++ gDefTypes b +instance (GDefTypes f) => GDefTypes (M1 i c f) where + gDefTypes ~(M1 fp) = gDefTypes fp + +customModelCreateStatement :: forall a. + (Model a, Generic a, GDefTypes (Rep a)) => + [(S.ByteString, S.ByteString)] + -- ^ A list of @(@/field/@,@/type/@)@ pairs to overwrite the default + -- SQL types of fields. + -> [S.ByteString] + -- ^ A list of extra table constraints. + -> a + -- ^ A non-strict argument to specify which model's table you want + -- to create. @(undefined :: YourModel)@ should be fine. + -> Query +customModelCreateStatement except constraints a + | not (null extraneous) = + error $ "customCreateTableStatement: no such columns: " ++ show extraneous + | otherwise = Query $ S.concat [ + "CREATE TABLE ", quoteIdent $ modelTable info, " (" + , S.intercalate ", " (go types names) + , S.concat $ concatMap (\c -> [", ", c]) constraints, ")" + ] + where extraneous = fst (unzip except) \\ names + types = gDefTypes $ from a + info = modelInfo :: ModelInfo a + names = modelColumns info + go (t:ts) (n:ns) + | Just t' <- lookup n except = quoteIdent n <> " " <> t' : go ts ns + | otherwise = quoteIdent n <> " " <> t : go ts ns + go [] [] = [] + go _ _ = error $ "createTable: " ++ S8.unpack (modelTable info) ++ + " has incorrect number of columns" + +-- | Statement for creating the table corresponding to a model. Not +-- strict in its argument. +modelCreateStatement :: forall a. (Model a, Generic a, GDefTypes (Rep a)) + => a -> Query +modelCreateStatement a = customModelCreateStatement except constraints a + where ModelCreateInfo except constraint = modelCreateInfo :: ModelCreateInfo a + constraints = if S.null constraint then [] else [constraint] + +-- | Create a the database table for a model. +modelCreate :: (Model a, Generic a, GDefTypes (Rep a)) => + Connection -> a -> IO Int64 +modelCreate c a = execute_ c (modelCreateStatement a) + +-- | Create the database table corresponding to a 'JoinTable'. +jtCreateStatement :: (Model a, Model b) => JoinTable a b -> Query +jtCreateStatement jt = Query $ S.concat [ + "CREATE TABLE ", quoteIdent $ jtTable jt, " (" + , S.intercalate ", " $ sort [typa, typb] + , ", UNIQUE (", S.intercalate ", " $ sort [ida, idb], "))" + ] + where ida = quoteIdent $ jtColumnA jt + idb = quoteIdent $ jtColumnB jt + refa = (undefined :: JoinTable a b -> DBRef a) jt + refb = (undefined :: JoinTable a b -> DBRef b) jt + typa = ida <> " " <> sqlBaseType refa <> " ON DELETE CASCADE NOT NULL" + typb = idb <> " " <> sqlBaseType refb <> " ON DELETE CASCADE NOT NULL" + +-- | Create a join table in the database. +jtCreate :: (Model a, Model b) => Connection -> JoinTable a b -> IO Int64 +jtCreate c jt = execute_ c (jtCreateStatement jt) diff --git a/src/Database/PostgreSQL/ORM/DBSelect.hs b/src/Database/PostgreSQL/ORM/DBSelect.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/ORM/DBSelect.hs @@ -0,0 +1,473 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# 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_ + , dbCollect + , renderDBSelect, buildDBSelect + -- * Creating DBSelects + , emptyDBSelect, expressionDBSelect + , modelDBSelect + , dbJoin, dbJoinModels + , dbProject, dbProject' + , dbNest, dbChain + -- * Altering DBSelects + , 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 +import qualified Data.ByteString.Char8 as S8 +#if __GLASGOW_HASKELL__ < 710 +import Data.Functor +#endif +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 + +import Database.PostgreSQL.Escape +import Database.PostgreSQL.ORM.Model + +-- | As it's name would suggest, a @FromClause@ is the part of a query +-- between the @FROM@ keyword and the @WHERE@ keyword. It can consist +-- of simple table names, @JOIN@ operations, and parenthesized +-- subqueries. +-- +-- From clauses are represented in a more structured way than the +-- other fields so as to allow the possibility of collapsing join +-- relations. For instance, given a @'DBSelect' (A :. B)@ and a +-- @'DBSelect' (B :. C)@, it is desirable to be able to generate a +-- @'DBSelect' (A :. B :. C)@ in which each pair of terms involving +-- @B@ in the three-way relation is constrained according to the +-- original two queries. This functionality is provided by 'dbNest' +-- and 'dbChain', but it requires the ability to locate and replace +-- the instance of type @B@ in one 'DBSelect' with the @FromClause@ of +-- the other 'DBSelect'. +-- +-- The 'fcCanonical' field is a canonical name of each type, which by +-- convention is the quoted and fully-qualified table name. Comparing +-- 'fcCanonical' is somewhat of a hack, and happens entirely at +-- runtime. It would be nicer to do this at compile time, but doing +-- so would require language extensions such as @GADTs@ of +-- @FunctionalDependencies@. +data FromClause = FromModel { + fcVerbatim :: !Query -- ^ Verbatim SQL for a table, table @AS@ + -- alias, or parenthesized subquery. + , fcCanonical :: !S.ByteString + -- ^ Canonical name of the table or join relation represented by + -- this term. For @JOIN@ terms, this is always the @CROSS JOIN@ + -- of the canonical names of 'fcLeft' and 'fcRight'. This means + -- one can locate a join given only it's type (e.g., the canonical + -- name for @A :. B@ is always @\"a CROSS JOIN b\"@), but it does + -- mean you have to be careful not accidentally to merge two + -- different joins on the same types. For this reason it may be + -- safest always to have type @b@ be a single table in 'dbNest' + -- and 'dbChain'. + } + | FromJoin { + fcLeft :: !FromClause + , fcJoinOp :: !Query -- ^ Usually @\"JOIN\"@ + , fcRight :: !FromClause + , fcOnClause :: !Query -- ^ @ON@ or @USING@ clause (or empty) + , fcCanonical :: !S.ByteString + } + deriving Show + +nullFrom :: FromClause -> Bool +nullFrom (FromModel q _) | qNull q = True +nullFrom _ = False + +-- | A deconstructed SQL select statement that allows easier +-- manipulation of individual terms. Several functions are provided +-- to combine the 'selFields', 'selFrom', and 'selWhere' clauses of +-- muliple @DBSelect@ structures. Other clauses may be discarded when +-- combining queries with join operations. Hence it is advisable to +-- set the other clauses at the end (or, if you set these fields, to +-- collapse your 'DBSelect' structure into a subquery using +-- `dbProject'`). +data DBSelect a = DBSelect { + selWith :: !Query + , selSelectKeyword :: !Query + -- ^ By default @\"SELECT\"@, but might usefully be set to + -- something else such as @\"SELECT DISTINCT\"@ in some + -- situations. + , selFields :: Query + , selFrom :: !FromClause + , selWhereKeyword :: !Query + -- ^ Empty by default, but set to @\"WHERE\"@ if any @WHERE@ + -- clauses are added to the 'selWhere' field. + , selWhere :: !Query + , selGroupBy :: !Query + , selHaving :: !Query + -- below here, should appear outside any union + , selOrderBy :: !Query + , selLimit :: !Query + , selOffset :: !Query + } deriving (Generic) + +instance Show (DBSelect a) where + show = S8.unpack . fromQuery . renderDBSelect + +space :: Builder +space = fromChar ' ' + +qNull :: Query -> Bool +qNull = S.null . fromQuery + +qBuilder :: Query -> Builder +qBuilder = fromByteString . fromQuery + +toQuery :: Builder -> Query +toQuery = Query . toByteString + +buildFromClause :: FromClause -> Builder +buildFromClause (FromModel q _) | qNull q = mempty +buildFromClause cl0 = fromByteString " FROM " <> go cl0 + where go (FromModel q _) = qBuilder q + go (FromJoin left joinkw right onClause _) = mconcat [ + fromChar '(', go left, space, qBuilder joinkw, space, go right + , if qNull onClause then mempty else space <> qBuilder onClause + , fromChar ')' ] + +class GDBS f where + gdbsDefault :: f p + gdbsQuery :: f p -> Builder +instance GDBS (K1 i Query) where + gdbsDefault = K1 (Query S.empty) + gdbsQuery (K1 q) | qNull q = mempty + | otherwise = space <> qBuilder q +instance GDBS (K1 i FromClause) where + gdbsDefault = K1 (FromModel "" "") + gdbsQuery (K1 fc) = buildFromClause fc +instance (GDBS a, GDBS b) => GDBS (a :*: b) where + gdbsDefault = gdbsDefault :*: gdbsDefault + gdbsQuery (a :*: b) = gdbsQuery a <> gdbsQuery b +instance (GDBS f) => GDBS (M1 i c f) where + gdbsDefault = M1 gdbsDefault + gdbsQuery = gdbsQuery . unM1 + +-- | A 'DBSelect' structure with keyword @\"SELECT\"@ and everything +-- else empty. +emptyDBSelect :: DBSelect a +emptyDBSelect = (to gdbsDefault) { selSelectKeyword = fromString "SELECT" } + +-- | A 'DBSelect' for one or more comma-separated expressions, rather +-- than for a table. For example, to issue the query @\"SELECT +-- lastval()\"@: +-- +-- > lastval :: DBSelect (Only DBKeyType) +-- > lastval = expressionDBSelect "lastval ()" +-- > +-- > ... +-- > [just_inserted_id] <- dbSelect conn lastval +-- +-- On the other hand, for such a simple expression, you might as well +-- call 'query_' directly. +expressionDBSelect :: (Model r) => Query -> DBSelect r +expressionDBSelect q = emptyDBSelect { selFields = q } + +-- | Create a 'Builder' for a rendered version of a 'DBSelect'. This +-- can save one string copy if you want to embed one query inside +-- another as a subquery, as done by `dbProject'`, and thus need to +-- parenthesize it. However, the function is probably not a useful +-- for end users. +buildDBSelect :: DBSelect a -> Builder +buildDBSelect dbs = gdbsQuery $ from dbs + +-- | Turn a 'DBSelect' into a 'Query' suitable for the 'query' or +-- 'query_' functions. +renderDBSelect :: DBSelect a -> Query +renderDBSelect = Query . S.tail . toByteString . buildDBSelect +-- S.tail is because the rendering inserts an extra space at the beginning + +catQueries :: Query -> Query -> Query -> Query +catQueries left delim right + | qNull left = right + | qNull right = left + | otherwise = Query $ S.concat $ map fromQuery [left, delim, right] + +-- | Add a where clause verbatim to a 'DBSelect'. The clause must +-- /not/ contain the @WHERE@ keyword (which is added automatically by +-- @addWhere_@ if needed). If the @DBSelect@ has existing @WHERE@ +-- clauses, the new clause is appended with @AND@. If the query +-- contains any @\'?\'@ characters, they will be rendered into the +-- query and matching parameters will later have to be filled in via a +-- call to 'dbSelectParams'. +addWhere_ :: Query -> DBSelect a -> DBSelect a +addWhere_ q dbs + | qNull q = dbs + | otherwise = dbs { selWhereKeyword = "WHERE" + , selWhere = catQueries (selWhere dbs) " AND " q } + +-- | Add a where clause, and pre-render parameters directly into the +-- clause. The argument @p@ must have exactly as many fields as there +-- are @\'?\'@ characters in the 'Query'. Example: +-- +-- > bars <- dbSelect c $ addWhere "bar_id = ?" (Only target_id) $ +-- > (modelDBSelect :: DBSelect Bar) +addWhere :: (ToRow p) => Query -> p -> DBSelect a -> DBSelect a +addWhere q p dbs + | qNull q = dbs + | otherwise = dbs { + selWhereKeyword = "WHERE" + , selWhere = if qNull $ selWhere dbs + then toQuery clause + else toQuery $ qBuilder (selWhere dbs) <> + fromByteString " AND " <> clause + } + where clause = mconcat [fromChar '(', buildSql q p, fromChar ')'] + +-- | Set the @ORDER BY@ clause of a 'DBSelect'. Example: +-- +-- > dbSelect c $ setOrderBy "\"employeeName\" DESC NULLS FIRST" $ +-- > modelDBSelect +setOrderBy :: Query -> DBSelect a -> DBSelect a +setOrderBy (Query ob) dbs = dbs { selOrderBy = Query $ "ORDER BY " <> ob } + +-- | Set the @LIMIT@ clause of a 'DBSelect'. +setLimit :: Int -> DBSelect a -> DBSelect a +setLimit i dbs = dbs { selLimit = fmtSql "LIMIT ?" (Only i) } + +-- | Set the @OFFSET@ clause of a 'DBSelect'. +setOffset :: Int -> DBSelect a -> DBSelect a +setOffset i dbs = dbs { selOffset = fmtSql "OFFSET ?" (Only i) } + +-- | Add one or more comma-separated expressions to 'selFields' that +-- produce column values without any corresponding relation in the +-- @FROM@ clause. Type @r@ is the type into which the expression is +-- to be parsed. Generally this will be an instance of 'FromRow' that +-- is a degenerate model (e.g., 'Only', or a tuple). +-- +-- For example, to rank results by the field @value@ and compute the +-- fraction of overall value they contribute: +-- +-- > r <- dbSelect c $ addExpression +-- > "rank() OVER (ORDER BY value), value::float4/SUM(value) OVER ()" +-- > modelDBSelect +-- > :: IO [Bar :. (Int, Double)] +addExpression :: (Model r) => Query -> DBSelect a -> DBSelect (a :. r) +addExpression q dbs = dbs { + selFields = if qNull $ selFields dbs then q + else Query $ S.concat $ map fromQuery [selFields dbs, ", ", q] + } + +-- | A 'DBSelect' that returns all rows of a model. +modelDBSelect :: forall a. (Model a) => DBSelect a +modelDBSelect = r + where mi = modelIdentifiers :: ModelIdentifiers a + r = emptyDBSelect { + selFields = Query $ S.intercalate ", " $ modelQColumns mi + , selFrom = FromModel (Query $ modelQTable mi) (modelQTable mi) + } + +-- | Run a 'DBSelect' query on parameters. The number of @\'?\'@ +-- characters embedeed in various fields of the 'DBSelect' must +-- exactly match the number of fields in parameter type @p@. Note the +-- order of arguments is such that the 'DBSelect' can be pre-rendered +-- and the parameters supplied later. Hence, you should use this +-- version when the 'DBSelect' is static. For dynamically modified +-- 'DBSelect' structures, you may prefer 'dbSelect'. +dbSelectParams :: (Model a, ToRow p) => DBSelect a -> Connection -> p -> IO [a] +{-# INLINE dbSelectParams #-} +dbSelectParams dbs = \c p -> map lookupRow <$> query c q p + where -- {-# NOINLINE q #-} (crashes under GHC 7.8) + q = renderDBSelect dbs + +-- | Run a 'DBSelect' query and return the resulting models. +dbSelect :: (Model a) => Connection -> DBSelect a -> IO [a] +{-# INLINE dbSelect #-} +dbSelect c dbs = map lookupRow <$> query_ c q + where -- {-# NOINLINE q #-} (crashes under GHC 7.8) + 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 + +-- | Group the returned tuples by unique a's. Expects the query to return a's +-- in sequence -- all rows with the same value for a must be grouped together, +-- for example, by sorting the result on a's primary key column. +dbCollect :: (Model a, Model b) + => Connection -> DBSelect (a :. b) -> IO [(a, [b])] +dbCollect c ab = dbFold c group [] ab + where + group :: (Model a, Model b) => [(a, [b])] -> (a :. b) -> [(a, [b])] + group [] (a :. b) = [(a, [b])] + group ls@(l:_) (a :. b) | primaryKey a /= primaryKey (fst l) = (a, [b]):ls + group (l:ls) (_ :. b) = (fst l, b:(snd l)):ls + +-- | Create a join of the 'selFields', 'selFrom', and 'selWhere' +-- clauses of two 'DBSelect' queries. Other fields are simply taken +-- from the second 'DBSelect', meaning fields such as 'selWith', +-- 'selGroupBy', and 'selOrderBy' in the in the first 'DBSelect' are +-- entirely ignored. +dbJoin :: forall a b. + (Model a, Model b) => + DBSelect a -- ^ First table + -> Query -- ^ Join keyword (@\"JOIN\"@, @\"LEFT JOIN\"@, etc.) + -> DBSelect b -- ^ Second table + -> Query -- ^ Predicate (if any) including @ON@ or @USING@ keyword + -> DBSelect (a :. b) +dbJoin left joinOp right onClause = addWhere_ (selWhere left) right { + selFields = Query $ S.concat [fromQuery $ selFields left, ", ", + fromQuery $ selFields right] + , selFrom = newfrom + } + where idab = modelIdentifiers :: ModelIdentifiers (a :. b) + newfrom | nullFrom $ selFrom right = selFrom left + | nullFrom $ selFrom left = selFrom right + | otherwise = FromJoin (selFrom left) joinOp (selFrom right) + onClause (modelQTable idab) + +-- | A version of 'dbJoin' that uses 'modelDBSelect' for the joined +-- tables. +dbJoinModels :: (Model a, Model b) => + Query -- ^ Join keyword + -> Query -- ^ @ON@ or @USING@ predicate + -> DBSelect (a :. b) +dbJoinModels kw on = dbJoin modelDBSelect kw modelDBSelect on + +-- | Restrict the fields returned by a DBSelect to be those of a +-- single 'Model' @a@. It only makes sense to do this if @a@ is part +-- of @something_containing_a@, but no static check is performed that +-- this is the case. If you @dbProject@ a type that doesn't make +-- sense, you will get a runtime error from a failed database query. +dbProject :: forall a something_containing_a. + (Model a) => DBSelect something_containing_a -> DBSelect a +{-# INLINE dbProject #-} +dbProject dbs = r + where sela = modelDBSelect :: DBSelect a + r = dbs { selFields = selFields sela } + +-- | Like 'dbProject', but renders the entire input 'DBSelect' as a +-- subquery. Hence, you can no longer mention fields of models other +-- than @a@ that might be involved in joins. The two advantages of +-- this approach are 1) that you can once again join to tables that +-- were part of the original query without worrying about row aliases, +-- and 2) that all terms of the 'DBSelect' will be faithrully rendered +-- into the subquery (whereas otherwise they could get dropped by join +-- operations). Generally you will still want to use 'dbProject', but +-- @dbProject'@ is available when needed. +dbProject' :: forall a something_containing_a. + (Model a) => DBSelect something_containing_a -> DBSelect a +dbProject' dbs = r + where sela = modelDBSelect :: DBSelect a + ida = modelIdentifiers :: ModelIdentifiers a + Just mq = modelQualifier ida + q = toQuery $ fromChar '(' <> + buildDBSelect dbs { selFields = selFields sela } <> + fromByteString ") AS " <> fromByteString mq + r = sela { selFrom = FromModel q $ modelQTable ida } + +mergeFromClauses :: S.ByteString -> FromClause -> FromClause -> FromClause +mergeFromClauses canon left right = + case go left of + (fc, 1) -> fc + (_, 0) -> error $ "mergeFromClauses could not find " ++ show canon + (_, _) -> error $ "mergeFromClauses found duplicate " ++ show canon + where go fc | fcCanonical fc == canon = (right, 1 :: Int) + go (FromJoin l op r on ffc) = + case (go l, go r) of + ((lfc, ln), (rfc, rn)) -> (FromJoin lfc op rfc on ffc, ln + rn) + go fc = (fc, 0) + +-- | Nest two type-compatible @JOIN@ queries. As with 'dbJoin', +-- fields of the first @JOIN@ (the @'DBSelect' (a :. b)@) other than +-- 'selFields', 'selFrom', and 'selWhere' are entirely ignored. +dbNest :: forall a b c. (Model a, Model b) => + DBSelect (a :. b) -> DBSelect (b :. c) -> DBSelect (a :. b :. c) +dbNest left right = addWhere_ (selWhere left) right { + selFields = fields + , selFrom = mergeFromClauses nameb (selFrom left) (selFrom right) + } + where nameb = modelQTable (modelIdentifiers :: ModelIdentifiers b) + acols = modelQColumns (modelIdentifiers :: ModelIdentifiers a) + colcomma c r = fromByteString c <> fromByteString ", " <> r + fields = toQuery $ foldr colcomma (qBuilder $ selFields right) + acols + +-- | Like 'dbNest', but projects away the middle type @b@. +dbChain :: (Model a, Model b, Model c) => + DBSelect (a :. b) -> DBSelect (b :. c) -> DBSelect (a :. c) +dbChain left right = dbProject $ dbNest left right diff --git a/src/Database/PostgreSQL/ORM/Model.hs b/src/Database/PostgreSQL/ORM/Model.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/ORM/Model.hs @@ -0,0 +1,1166 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} + +-- | The main database ORM interface. This module contains +-- functionality for moving a Haskell data structure in and out of a +-- database table. +-- +-- The most important feature is the 'Model' class, which encodes a +-- typed database interface (i.e., the ORM layer). This class has a +-- default implementation for types that are members of the 'Generic' +-- class (using GHC's @DeriveGeneric@ extension), provided the +-- following conditions hold: +-- +-- 1. The data type must have a single constructor that is defined +-- using record selector syntax. +-- +-- 2. The very first field of the data type must be a 'DBKey' to +-- represent the primary key. Other orders will cause a +-- compilation error. +-- +-- 3. Every field of the data structure must be an instance of +-- 'FromField' and 'ToField'. +-- +-- 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: +-- +-- > data MyType = MyType { myKey :: !DBKey +-- > , myName :: !S.ByteString +-- > , myCamelCase :: !Int +-- > , ... +-- > } deriving (Show, Generic) +-- > instance Model MyType +-- +-- The default 'modelInfo' method is called 'defaultModelInfo'. You +-- may wish to use almost all of the defaults, but tweak a few things. +-- This is easily accomplished by overriding a few fields of the +-- default structure. For example, suppose your database columns use +-- exactly the same name as your Haskell field names, but the name of +-- your database table is not the same as the name of the Haskell data +-- type. You can override the database table name (field 'modelTable') +-- as follows: +-- +-- > instance Model MyType where +-- > modelInfo = defaultModelInfo { modelTable = "my_type" } +-- +-- Finally, if you dislike the conventions followed by +-- 'defaultModelInfo', you can simply implement an alternate pattern. +-- An example of this is 'underscoreModelInfo', which strips a prefix +-- off every field name and converts everything from camel-case to +-- underscore notation: +-- +-- > instance Model MyType where +-- > modelInfo = underscoreModelInfo "my" +-- +-- The above code will associate @MyType@ with a database table +-- @my_type@ having column names @key@, @name@, @camel_case@, etc. +-- +-- You can implement other patterns like 'underscoreModelInfo' by +-- calling 'defaultModelInfo' and modifying the results. +-- Alternatively, you can directly call the lower-level functions from +-- which 'defaultModelInfo' is built ('defaultModelTable', +-- 'defaultModelColumns', 'defaultModelGetPrimaryKey'). +module Database.PostgreSQL.ORM.Model ( + -- * The Model class + Model(..), ModelInfo(..), ModelIdentifiers(..), ModelQueries(..) + , underscoreModelInfo + -- * Data types for holding primary keys + , DBKeyType, DBKey(..), isNullKey + , DBRef, DBRefUnique, GDBRef(..), mkDBRef + -- * Database operations on Models + , findAll, findRow, save, save_, trySave, destroy, destroyByRef + -- * Functions for accessing and using Models + , modelName, primaryKey, modelSelectFragment + , LookupRow(..), UpdateRow(..), InsertRow(..) + -- * Table aliases + , As(..), fromAs, toAs, RowAlias(..) + -- * Low-level functions providing manual access to defaults + , defaultModelInfo + , defaultModelTable, defaultModelColumns, defaultModelGetPrimaryKey + , defaultModelIdentifiers + , defaultModelWrite + , defaultModelQueries + , defaultModelLookupQuery, defaultModelUpdateQuery + , defaultModelInsertQuery, defaultModelDeleteQuery + -- * Helper functions and miscellaneous internals + , quoteIdent, NormalRef(..), UniqueRef(..) + , ModelCreateInfo(..), emptyModelCreateInfo + , defaultFromRow, defaultToRow + , printq + -- ** Helper classes + -- $HelperClasses + , GPrimaryKey0, GColumns, GDatatypeName + , GFromRow, GToRow + ) where + +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 qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Char +import Data.Data +import Data.Int +import qualified Data.HashMap.Strict as H +import Data.Maybe +import Data.Monoid +import Data.List hiding (find) +import Data.String +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.FromRow +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.ToRow +import Database.PostgreSQL.Simple.Types +import Database.PostgreSQL.ORM.Validations +import GHC.Generics + +import Database.PostgreSQL.Escape (quoteIdent) + +-- | A type large enough to hold database primary keys. Do not use +-- this type directly in your data structures. Use 'DBKey' to hold a +-- `Model`'s primary key and 'DBRef' to reference the primary key of +-- another model. +type DBKeyType = Int64 + +-- | The type of the Haskell data structure field containing a model's +-- primary key. +-- +-- Every 'Model' must have exactly one @DBKey@, and the @DBKey@ must +-- be the `Model`'s very first field in the Haskel data type +-- definition. (The ordering is enforced by +-- 'defaultModelGetPrimaryKey', which, through use of the +-- @DeriveGeneric@ extension, fails to compile when the first field is +-- not a @DBKey@.) +-- +-- Each 'Model' stored in the database should have a unique non-null +-- primary key. However, the key is determined at the time the +-- 'Model' is inserted into the database. While you are constructing +-- a new 'Model' to insert, you will not have its key. Hence, you +-- should use the value @NullKey@ to let the database chose the key. +-- +-- If you wish to store a `Model`'s primary key as a reference in +-- another 'Model', do not copy the 'DBKey' structure. Use 'mkDBRef' +-- to convert the `Model`'s primary key to a foreign key reference. +data DBKey = DBKey !DBKeyType | NullKey deriving (Data, Typeable, Generic) + +instance A.ToJSON DBKey where + toJSON NullKey = A.Null + toJSON (DBKey k) = A.toJSON k + +instance A.FromJSON DBKey where + parseJSON (A.Number a) = return $ DBKey (floor a) + parseJSON A.Null = return NullKey + parseJSON _ = error "Expected Number or Null" + +instance Eq DBKey where + (DBKey a) == (DBKey b) = a == b + _ == _ = error "compare NullKey" +instance Ord DBKey where + compare (DBKey a) (DBKey b) = compare a b + compare _ _ = error "compare NullKey" + +instance Show DBKey where + showsPrec n (DBKey k) = showsPrec n k + showsPrec _ NullKey = ("NullKey" ++) + +instance FromField DBKey where + fromField _ Nothing = pure NullKey + fromField f bs = DBKey <$> fromField f bs +instance ToField DBKey where + toField (DBKey k) = toField k + toField NullKey = toField Null + +-- | Returns 'True' when a 'DBKey' is 'NullKey'. +isNullKey :: DBKey -> Bool +isNullKey NullKey = True +isNullKey _ = False + + +-- | Many operations can take either a 'DBRef' or a 'DBRefUnique' +-- (both of which consist internally of a 'DBKeyType'). Hence, these +-- two types are just type aliases to a generalized reference type +-- @GDBRef@, where @GDBRef@'s first type argument, @reftype@, is a +-- phantom type denoting the flavor of reference ('NormalRef' or +-- 'UniqueRef'). +newtype GDBRef reftype table = DBRef DBKeyType + deriving (Eq, Data, Typeable, Num, Integral, Real, Ord, Enum, Bounded, Generic) + +instance A.ToJSON (GDBRef t a) where + toJSON (DBRef k) = A.toJSON k + +instance A.FromJSON (GDBRef t a) where + parseJSON (A.Number n) = return $ DBRef (floor n) + parseJSON _ = error "Expected Number" + +instance (Model t) => Show (GDBRef rt t) where + showsPrec n (DBRef k) = showsPrec n k +instance (Model t) => Read (GDBRef rt t) where + readsPrec n str = map wrap $ readsPrec n str + where wrap (k, s) = (DBRef k, s) +instance FromField (GDBRef rt t) where + {-# INLINE fromField #-} + fromField f bs = DBRef <$> fromField f bs +instance ToField (GDBRef rt t) where + {-# INLINE toField #-} + toField (DBRef k) = toField k + +-- | Phantom type for instantiating 'GDBRef' that represents a one-to-many +-- relationship between tables. +data NormalRef = NormalRef deriving (Show, Data, Typeable) + +-- | A @DBRef T@ represents a many-to-one relationship between tables. For +-- example, if type @A@ contains a @DBRef B@, then each @B@ is associated +-- with many @A@'s. By contrast, a @'DBRefUnique'@ represents a one-to-one +-- relationship. +-- +-- @DBRef@ is a type alias of kind @* -> *@. The type @DBRef T@ +-- references an instance of type @T@ by the primary key of its +-- database row. The type argument @T@ should be an instance of +-- 'Model'. +type DBRef = GDBRef NormalRef + +-- | Phantom type for instantiating 'GDBRef' that represents a one-to-one +-- relationship between tables. +data UniqueRef = UniqueRef deriving (Show, Data, Typeable) + +-- | A @DBRefUnique T@ represents a one-to-one relationship between types. For +-- example, if type @A@ contains a @DBRefUnique B@, then each @A@ is associated +-- with one (or at most one) @B@, and each @B@ has one (or at most one) @A@ +-- associated with it. +-- +-- By contrast, a @'DBRef'@ represents a many-to-one relationship. +type DBRefUnique = GDBRef UniqueRef +-- Functionally, @DBRefUnique@ and @DBRef@ are treated the same by +-- this module. However, other modules make a distinction. In +-- particular, the 'modelCreateStatement' corresponding to a +-- 'DBRefUnique' will include a @UNIQUE@ constraint. + +-- | Create a reference to the primary key of a 'Model', suitable for +-- storing in a 'DBRef' or 'DBRefUnique' field of a different 'Model'. +mkDBRef :: (Model a) => a -> GDBRef rt a +mkDBRef a + | (DBKey k) <- primaryKey a = DBRef k + | otherwise = error $ "mkDBRef " ++ S8.unpack (modelName a) ++ ": NullKey" + + +-- | A @ModelInfo T@ contains the information necessary for mapping +-- @T@ to a database table. Each @'Model'@ type has a single +-- @ModelInfo@ associated with it, accessible through the 'modelInfo' +-- method of the 'Model' class. Note the table and column names must +-- all be unquoted in this data structure, as they will later be +-- quoted using 'quoteIdent' by the 'modelIdentifiers' method. +data ModelInfo a = ModelInfo { + modelTable :: !S.ByteString + -- ^ The name of the database table corresponding to this model. + -- The default 'modelInfo' instance uses 'defaultModelTable', + -- which is the name of your data type with the first letter + -- downcased. + , modelColumns :: ![S.ByteString] + -- ^ The names of the database columns corresponding to fields of + -- this model. The column names should appear in the order in + -- which the fields are defined in the Haskell data type @a@ + -- (which should also be the order in which 'modelRead' parses + -- them to an @a@ and 'modelWrite' marshalls them). + -- + -- Note that all queries generated by the library specify explicit + -- column names. Hence the order of columns does not need to + -- match their order in the database table. They should instead + -- match the order of fields in the Haskell data structure. + -- + -- The default, given by 'defaultModelColumns', is to use the + -- Haskell field names for @a@. This default will fail to compile + -- if @a@ is not defined using record syntax. + , modelPrimaryColumn :: !Int + -- ^ The 0-based index of the primary key column in + -- 'modelColumns'. This should be 0 when your data structure's + -- first field is its 'DBKey' (highly recommended, and required by + -- 'defaultModelGetPrimaryKey'). If you customize this field, you + -- must also customize 'modelGetPrimaryKey'--no check is made that + -- the two are consistent. + , modelGetPrimaryKey :: !(a -> DBKey) + -- ^ Return the primary key of a particular model instance. If + -- you customize this field, you must also customize + -- 'modelPrimaryColumn'--no check is made that the two are + -- consistent. + } + +instance Show (ModelInfo a) where + show a = intercalate " " [ + "Model", show $ modelTable a, show $ modelColumns a + , show $ modelPrimaryColumn a , "?"] + + +-- $HelperClasses +-- +-- These classes are used internally to manipulate the 'Rep' +-- representations of 'Generic' data structures. You should not be +-- defining instances of or using these classes directly. The names +-- are exported so that you can include them in the context of the +-- type signatures of your functions, should you wish to make use of +-- the various @default@... funcitons in this file. + +-- | This class returns the name of a datatype. +class GDatatypeName f where + gDatatypeName :: f p -> String +instance (Datatype c) => GDatatypeName (D1 c f) where + gDatatypeName a = datatypeName a +-- | The default name of the database table corresponding to a Haskell +-- type. The default is the same as the type name with the first +-- letter converted to lower-case. (The rationale is that Haskell +-- requires types to start with a capital letter, but all-lower-case +-- table names are easier to use in queries because PostgreSQL +-- generally does not require them to be quoted.) +defaultModelTable :: (Generic a, GDatatypeName (Rep a)) => a -> S.ByteString +defaultModelTable = fromString . caseFold. gDatatypeName . from + where caseFold (h:t) = toLower h:t + caseFold s = s + +-- | This class extracts the field names of a Haskell data structure. Only +-- defined for types with a single constructor that uses record syntax. +class GColumns f where + gColumns :: f p -> [S.ByteString] +instance GColumns U1 where + gColumns _ = [] +instance (Selector c) => GColumns (M1 S c f) where + gColumns s = [fromString $ selName s] +instance (GColumns a, GColumns b) => GColumns (a :*: b) where + gColumns ~(a :*: b) = gColumns a ++ gColumns b +instance (GColumns f) => GColumns (M1 C c f) where + gColumns ~(M1 fp) = gColumns fp +instance (GColumns f) => GColumns (M1 D c f) where + gColumns ~(M1 fp) = gColumns fp +-- | Returns the Haskell field names in a data structure. +defaultModelColumns :: (Generic a, GColumns (Rep a)) => a -> [S.ByteString] +defaultModelColumns = gColumns . from + +-- | This class extracts the first field in a data structure when the +-- field is of type 'DBKey'. If you get a compilation error because +-- of this class, then move the 'DBKey' first in your data structure. +class GPrimaryKey0 f where + gPrimaryKey0 :: f p -> DBKey +instance GPrimaryKey0 (S1 c (K1 i DBKey)) where + {-# INLINE gPrimaryKey0 #-} + gPrimaryKey0 (M1 (K1 k)) = k +instance (GPrimaryKey0 a) => GPrimaryKey0 (a :*: b) where + {-# INLINE gPrimaryKey0 #-} + gPrimaryKey0 (a :*: _) = gPrimaryKey0 a +instance (GPrimaryKey0 f) => GPrimaryKey0 (C1 c f) where + {-# INLINE gPrimaryKey0 #-} + gPrimaryKey0 (M1 fp) = gPrimaryKey0 fp +instance (GPrimaryKey0 f) => GPrimaryKey0 (D1 c f) where + {-# INLINE gPrimaryKey0 #-} + gPrimaryKey0 (M1 fp) = gPrimaryKey0 fp + +-- | Extract the primary key of type 'DBKey' from a model when the +-- 'DBKey' is the first element of the data structure. Fails to +-- compile if the first field is not of type 'DBKey'. +defaultModelGetPrimaryKey :: (Generic a, GPrimaryKey0 (Rep a)) => a -> DBKey +{-# INLINE defaultModelGetPrimaryKey #-} +defaultModelGetPrimaryKey = gPrimaryKey0 . from + + +class GFromRow f where + gFromRow :: RowParser (f p) +instance GFromRow U1 where + {-# INLINE gFromRow #-} + gFromRow = return U1 +instance (FromField c) => GFromRow (K1 i c) where + {-# INLINE gFromRow #-} + gFromRow = K1 <$> field +instance (GFromRow a, GFromRow b) => GFromRow (a :*: b) where + {-# INLINE gFromRow #-} + gFromRow = (:*:) <$> gFromRow <*> gFromRow +instance (GFromRow f) => GFromRow (M1 i c f) where + {-# INLINE gFromRow #-} + gFromRow = M1 <$> gFromRow +-- | This function provides a 'fromRow' function for 'Generic' types, +-- suitable as a default of the 'FromRow' class. This module uses it +-- as the default implementation of 'modelRead'. +defaultFromRow :: (Generic a, GFromRow (Rep a)) => RowParser a +{-# INLINE defaultFromRow #-} +defaultFromRow = to <$> gFromRow + + +class GToRow f where + gToRow :: f p -> [Action] +instance GToRow U1 where + gToRow _ = [] +instance (ToField c) => GToRow (K1 i c) where + gToRow (K1 c) = [toField c] +instance (GToRow a, GToRow b) => GToRow (a :*: b) where + gToRow (a :*: b) = gToRow a ++ gToRow b +instance (GToRow f) => GToRow (M1 i c f) where + gToRow (M1 fp) = gToRow fp +-- | This function provides a 'toRow' function for 'Generic' types +-- that marshalls each field of the data type in the order in which it +-- appears in the type definition. This function is /not/ a suitable +-- implementation of 'modelWrite' (since it marshals the primary key, +-- which is not supposed to be written). However, it is required +-- internally by 'defaultModelWrite', and exposed in the unlikely +-- event it is of use to alternate generic 'modelWrite' functions. +-- You probably don't want to call this function. +defaultToRow :: (Generic a, GToRow (Rep a)) => a -> [Action] +defaultToRow = gToRow . from + +-- | Removes a single element from the list at the position specified. +-- (Internal) +deleteAt :: Int -> [a] -> [a] +deleteAt 0 (_:t) = t +deleteAt n (h:t) = h:deleteAt (n-1) t +deleteAt _ _ = [] + +-- | Returns a series of 'Action's serializing each field of a data +-- structure (in the order of the Haskell datatype definition), +-- /except/ the primary key, since the primary key should never be +-- written to a database. Every field must be an instance of +-- 'ToField'. +defaultModelWrite :: forall a. (Model a, Generic a, GToRow (Rep a)) + => a -> [Action] +{-# INLINE defaultModelWrite #-} +defaultModelWrite a = deleteAt pki $ defaultToRow a + where pki = modelPrimaryColumn (modelInfo :: ModelInfo a) + +-- | The default definition of 'modelInfo'. See the documentation at +-- 'Model' for more information. Sets 'modelTable' to the name of the +-- type with the first character converted to lower-case. Sets +-- 'modelColumns' to the names of the Haskell field selectors. Sets +-- 'modelPrimaryColumn' to @0@ and extracts the first field of the +-- structure for 'modelGetPrimaryKey'. Will fail to compile unless +-- the data structure is defined with record syntax and that its first +-- field is of type 'DBKey'. +-- +-- Note that defaults for the individual fields are available in +-- separate functions (e.g., 'defaultModelTable') with fewer class +-- requirements in the context, in case you want to make piecemeal use +-- of defaults. The default for 'modelPrimaryColumn' is 0. If you +-- overwrite that, you will need to overwrite 'modelGetPrimaryKey' as +-- well (and likely vice versa). +defaultModelInfo :: forall a. + (Generic a, GDatatypeName (Rep a), GColumns (Rep a) + , GPrimaryKey0 (Rep a)) => ModelInfo a +defaultModelInfo = m + where m = ModelInfo { modelTable = defaultModelTable a + , modelColumns = defaultModelColumns a + , modelPrimaryColumn = 0 + , modelGetPrimaryKey = defaultModelGetPrimaryKey + } + a = undefined :: a + +-- | An alternate 'Model' pattern in which Haskell type and field +-- names are converted from camel-case to underscore notation. The +-- first argument is a prefix to be removed from field names (since +-- Haskell requires field names to be unique across data types, while +-- SQL allows the same column names to be used in different tables). +-- +-- For example: +-- +-- > data Bar = Bar { +-- > barId :: !DBKey +-- > , barNameOfBar :: !String +-- > , barParent :: !(Maybe (DBRef Bar)) +-- > } deriving (Show, Generic) +-- > +-- > instance Model Bar where modelInfo = underscoreModelInfo "bar" +-- +-- would associate type @Bar@ with a database table called @bar@ with +-- fields @id@, @name_of_bar@, and @parent@. +underscoreModelInfo :: (Generic a, GToRow (Rep a), GFromRow (Rep a) + , GPrimaryKey0 (Rep a), GColumns (Rep a) + , GDatatypeName (Rep a)) => + S.ByteString -> ModelInfo a +underscoreModelInfo prefix = def { + modelTable = toUnderscore True $ modelTable def + , modelColumns = map fixCol $ modelColumns def + } + where def = defaultModelInfo + plen = S.length prefix + fixCol c = toUnderscore False $ stripped + where stripped | prefix `S.isPrefixOf` c = S.drop plen c + | otherwise = c + +-- | Convert a name from camel-case to underscore notation. +-- I.e., names of the form "MSizeForm" are changed to "MSize_From". +-- @skipFirst@ determines if the first character should be ignored +-- in the conversion. +toUnderscore :: Bool -> S.ByteString -> S.ByteString +toUnderscore skipFirst | skipFirst = S8.pack . skip . S8.unpack + | otherwise = S8.pack . go True . S8.unpack + where skip "" = "" + skip (h:t) = toLower h : go True t + go _ "" = "" + go _ (h:t) | not (isUpper h) = h : go False t + go True (h:t) = toLower h : go True t + go False (h:t) = '_' : toLower h : go True t + + +-- | SQL table and column identifiers that should be copied verbatim +-- into queries. For normal models, these will simply be quoted +-- versions of the fields in the corresponding 'ModelInfo'. However, +-- for special cases, the fields of this structure can contain +-- unquoted SQL including @JOIN@ keywords. In the case of joins, +-- different elements of 'modelQColumns' may be qualified by different +-- table names. +-- +-- Note that 'modelQColumns' and 'modelQPrimaryColumn' both contain +-- table-qualified names (e.g., @\"\\\"my_type\\\".\\\"key\\\"\"@), +-- while 'modelQWriteColumns' contains only the quoted column names. +data ModelIdentifiers a = ModelIdentifiers { + modelQTable :: !S.ByteString + -- ^ Literal SQL for the name of the table. + , modelQColumns :: ![S.ByteString] + -- ^ Literal SQL for each, table-qualified column. + , modelQPrimaryColumn :: S.ByteString + -- ^ Literal SQL for the model's table-qualified primary key + -- column. + , modelQWriteColumns :: [S.ByteString] + -- ^ Literal SQL for all the columns except the primary key. + -- These are the columns that should be included in an @INSERT@ or + -- @UPDATE@. Note that unlike the other fields, these column + -- names should /not/ be table-qualified. + , modelQualifier :: !(Maybe S.ByteString) + -- ^ When all columns in 'modelQColumns' are qualified by the same + -- table name, this field contains 'Just' the table name. + -- For the ':.' type (in which different columns have different + -- table qualifications), this field is 'Nothing'. + -- + -- For normal models, this field will be identical to + -- 'modelQTable'. However, for 'As' models, 'modelQTable' will + -- contain unquoted SQL such as @\"\\\"MyType\\\" AS + -- \\\"my_alias\\\"\"@, in which case @modelQualifier@ will + -- contain @'Just' \"\\\"my_alias\\\"\"@. + , modelOrigTable :: !(Maybe S.ByteString) + -- ^ The original, unquoted name of the table representing the + -- model in the database. Ordinarily, this should be the same as + -- 'modelTable' in 'ModelInfo', but in the case of 'As' aliases, + -- the 'modelTable' is an alias, and 'modelOrigTable' is the + -- original table. 'Nothing' for joins. + } deriving (Show) + +-- | The default simply quotes the 'modelInfo' and 'modelColumns' +-- fields of 'ModelInfo' using 'quoteIdent'. +defaultModelIdentifiers :: ModelInfo a -> ModelIdentifiers a +defaultModelIdentifiers mi = ModelIdentifiers { + modelQTable = qtable + , modelQColumns = qcols + , modelQPrimaryColumn = qcols !! pki + , modelQWriteColumns = deleteAt pki $ map quoteIdent $ modelColumns mi + , modelQualifier = Just qtable + , modelOrigTable = Just $ modelTable mi + } + where qtable = quoteIdent (modelTable mi) + qcol c = S.concat [qtable, ".", quoteIdent c] + qcols = map qcol $ modelColumns mi + pki = modelPrimaryColumn mi + +-- | Standard CRUD (create\/read\/update\/delete) queries on a model. +data ModelQueries a = ModelQueries { + modelLookupQuery :: !Query + -- ^ A query template for looking up a model by its primary key. + -- Expects a single query parameter, namely the 'DBKey' or 'DBRef' + -- being looked up. + , modelUpdateQuery :: !Query + -- ^ A query template for updating an existing 'Model' in the + -- database. Expects as query parameters a value for every column + -- of the model /except/ the primary key, followed by the primary + -- key. (The primary key is not written to the database, just + -- used to select the row to change.) + , modelInsertQuery :: !Query + -- ^ A query template for inserting a new 'Model' in the database. + -- The query parameters are values for all columns /except/ the + -- primary key. The query returns the full row as stored in the + -- database (including the values of fields, such as the primary + -- key, that have been chosen by the database server). + , modelDeleteQuery :: !Query + -- ^ A query template for deleting a 'Model' from the database. + -- Should have a single query parameter, namely the 'DBKey' of the + -- row to delete. + } deriving (Show) + +-- | Default SQL lookup query for a model. +defaultModelLookupQuery :: ModelIdentifiers a -> Query +defaultModelLookupQuery mi = Query $ S.concat [ + modelSelectFragment mi, " WHERE ", modelQPrimaryColumn mi, " = ?" + ] + +-- | Default SQL update query for a model. +defaultModelUpdateQuery :: ModelIdentifiers a -> Query +defaultModelUpdateQuery mi = Query $ S.concat [ + "UPDATE ", modelQTable mi, " SET " + , S.intercalate ", " $ map (<> " = ?") $ modelQWriteColumns mi + , " WHERE ", modelQPrimaryColumn mi, " = ?" + , " RETURNING ", S.intercalate ", " (modelQColumns mi) + ] + +-- | Default SQL insert query for a model. +defaultModelInsertQuery :: ModelIdentifiers a -> Query +defaultModelInsertQuery mi + | null (modelQWriteColumns mi) = Query $ S.concat [ + "INSERT INTO ", modelQTable mi, " DEFAULT VALUES RETURNING " + , S.intercalate ", " $ modelQColumns mi ] + | otherwise = Query $ S.concat $ [ + "INSERT INTO ", modelQTable mi + , " (", S.intercalate ", " $ modelQWriteColumns mi + , ") VALUES (", S.intercalate ", " $ map (const "?") $ modelQWriteColumns mi + , ") RETURNING ", S.intercalate ", " $ modelQColumns mi + ] + +-- | Default SQL delete query for a model. +defaultModelDeleteQuery :: ModelIdentifiers a -> Query +defaultModelDeleteQuery mi = Query $ S.concat [ + "DELETE FROM ", modelQTable mi + , " WHERE ", modelQPrimaryColumn mi, " = ?" + ] + +-- | The default value of 'modelQueries'. +defaultModelQueries :: ModelIdentifiers a -> ModelQueries a +defaultModelQueries mi = ModelQueries { + modelLookupQuery = defaultModelLookupQuery mi + , modelUpdateQuery = defaultModelUpdateQuery mi + , modelInsertQuery = defaultModelInsertQuery mi + , modelDeleteQuery = defaultModelDeleteQuery mi + } + +-- | Extra information for "Database.PostgreSQL.ORM.CreateTable". You +-- probably don't need to use this. +data ModelCreateInfo a = ModelCreateInfo { + modelCreateColumnTypeExceptions :: ![(S.ByteString, S.ByteString)] + -- ^ A list of (column-name, type) pairs for which you want to + -- override the default. + , modelCreateExtraConstraints :: !S.ByteString + -- ^ Extra constraints to stick at the end of the @CREATE TABLE@ + -- statement. + } deriving (Show) + +-- | A 'ModelCreateInfo' that doesn't imply any extra constraints or +-- exceptions. +emptyModelCreateInfo :: ModelCreateInfo a +emptyModelCreateInfo = ModelCreateInfo { + modelCreateColumnTypeExceptions = [] + , modelCreateExtraConstraints = S.empty + } + +-- | The class of data types that represent a database table. This +-- class conveys information necessary to move a Haskell data +-- structure in and out of a database table. The most important field +-- is 'modelInfo', which describes the database table and column +-- names. 'modelInfo' has a reasonable default implementation for +-- types that are members of the 'Generic' class (using GHC's +-- @DeriveGeneric@ extension), provided the following conditions hold: +-- +-- 1. The data type must have a single constructor that is defined +-- using record selector syntax. +-- +-- 2. The very first field of the data type must be a 'DBKey' to +-- represent the primary key. Other orders will cause a +-- compilation error. +-- +-- 3. Every field of the data structure must be an instance of +-- 'FromField' and 'ToField'. +-- +-- 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: +-- +-- > data MyType = MyType { myKey :: !DBKey +-- > , myName :: !S.ByteString +-- > , myCamelCase :: !Int +-- > , ... +-- > } deriving (Show, Generic) +-- > instance Model MyType +-- +-- The default 'modelInfo' method is called 'defaultModelInfo'. You +-- may wish to use almost all of the defaults, but tweak a few things. +-- This is easily accomplished by overriding a few fields of the +-- default structure. For example, suppose your database columns use +-- exactly the same name as your Haskell field names, but the name of +-- your database table is not the same as the name of the Haskell data +-- type. You can override the database table name (field +-- 'modelTable') as follows: +-- +-- > instance Model MyType where +-- > modelInfo = defaultModelInfo { modelTable = "my_type" } +-- +-- Finally, if you dislike the conventions followed by +-- 'defaultModelInfo', you can simply implement an alternate pattern. +-- An example of this is 'underscoreModelInfo', which strips a prefix +-- off every field name and converts everything from camel-case to +-- underscore notation: +-- +-- > instance Model MyType where +-- > modelInfo = underscoreModelInfo "my" +-- +-- The above code will associate @MyType@ with a database table +-- @my_type@ having column names @key@, @name@, @camel_case@, etc. +-- +-- You can implement other patterns like 'underscoreModelInfo' by +-- calling 'defaultModelInfo' and modifying the results. +-- Alternatively, you can directly call the lower-level functions from +-- which 'defaultModelInfo' is built ('defaultModelTable', +-- 'defaultModelColumns', 'defaultModelGetPrimaryKey'). +class Model a where + -- | @modelInfo@ provides information about how the Haskell data + -- type is stored in the database, in the form of a 'ModelInfo' data + -- structure. Among other things, this structure specifies the name + -- of the database table, the names of the database columns + -- corresponding to the Haskell data structure fields, and the + -- position of the primary key in both the database columns and the + -- Haskell data structure. + modelInfo :: ModelInfo a + default modelInfo :: (Generic a, GDatatypeName (Rep a), GColumns (Rep a) + , GPrimaryKey0 (Rep a)) => ModelInfo a + {-# INLINE modelInfo #-} + modelInfo = defaultModelInfo + + -- | 'modelIdentifiers' contains the table and column names verbatim + -- as they should be inserted into SQL queries. For normal models, + -- these are simply double-quoted (with 'quoteIdent') versions of + -- the names in 'modelInfo', with the column names qualified by the + -- double-quoted table name. However, for special cases such as + -- join relations (with ':.') or row aliases (with 'As'), + -- 'modelIdentifiers' can modify the table name with unquoted SQL + -- identifiers (such as @JOIN@ and @AS@) and change the qualified + -- column names appropriately. + modelIdentifiers :: ModelIdentifiers a + {-# INLINE modelIdentifiers #-} + modelIdentifiers = defaultModelIdentifiers modelInfo + + -- | @modelRead@ converts from a database 'query' result to the + -- Haskell data type of the @Model@, namely @a@. Note that if type + -- @a@ is an instance of 'FromRow', a fine definition of @modelRead@ + -- is @modelRead = fromRow@. The default is to construct a row + -- parser using the 'Generic' class. However, it is crucial that + -- the columns be parsed in the same order they are listed in the + -- 'modelColumns' field of @a@'s 'ModelInfo' structure, and this + -- should generally be the same order they are defined in the + -- Haskell data structure. Hence @modelRead@ should generally look + -- like: + -- + -- @ + -- -- Call 'field' as many times as there are fields in your type + -- modelRead = Constructor \<$> 'field' \<*> 'field' \<*> 'field' + -- @ + modelRead :: RowParser a + default modelRead :: (Generic a, GFromRow (Rep a)) => RowParser a + {-# INLINE modelRead #-} + modelRead = defaultFromRow + + -- | Marshal all fields of @a@ /except/ the primary key. As with + -- 'modelRead', the fields must be marshalled in the same order the + -- corresponding columns are listed in 'modelColumns', only with the + -- primary key (generally column 0) deleted. + -- + -- Do /not/ define this as 'toRow', even if @a@ is an instance of + -- 'ToRow', because 'toRow' would include the primary key. + -- Similarly, do /not/ define this as 'defaultToRow'. On the other + -- hand, it is reasonable for @modelWrite@ to return an error for + -- degenerate models (such as joins) that should never be 'save'd. + modelWrite :: a -> [Action] + default modelWrite :: (Generic a, GToRow (Rep a)) => a -> [Action] + {-# INLINE modelWrite #-} + modelWrite = defaultModelWrite + + -- | @modelQueries@ provides pre-formatted 'Query' templates for + -- 'findRow', 'save', and 'destroy'. The default 'modelQueries' + -- value is generated from 'modelIdentifiers' and should not be + -- modified. However, for degenerate tables (such as joins created + -- with ':.'), it is reasonable to make 'modelQueries' always throw + -- an exception, thereby disallowing ordinary queries and requiring + -- use of more general query functions. + -- + -- This method should either throw an exception or use the default + -- implementation. + modelQueries :: ModelQueries a + {-# INLINE modelQueries #-} + modelQueries = defaultModelQueries modelIdentifiers + + -- | Extra constraints, if any, to place in a @CREATE TABLE@ + -- statement. Only used by "Database.PostgreSQL.ORM.CreateTable". + modelCreateInfo :: ModelCreateInfo a + modelCreateInfo = emptyModelCreateInfo + + -- | Perform a validation of the model, returning any errors if + -- it is invalid. + modelValid :: a -> ValidationError + modelValid = const mempty + +-- | Degenerate instances of 'Model' for types in the 'ToRow' class +-- are to enable extra 'ToRow' types to be included with ':.' in the +-- result of 'dbSelect' queries. +degen_err :: a +degen_err = error "Attempt to use degenerate ToRow instance as Model" +#define DEGENERATE(ctx,t) \ +instance ctx => Model t where { \ + modelInfo = degen_err; \ + modelIdentifiers = degen_err; \ + modelRead = fromRow; \ + modelWrite _ = degen_err; \ + modelCreateInfo = degen_err; } + +DEGENERATE(FromField t, (Only t)) +DEGENERATE(FromField t, [t]) +DEGENERATE((FromField a, FromField b), (a, b)) +DEGENERATE((FromField a, FromField b, FromField c), (a, b, c)) +DEGENERATE((FromField a, FromField b, FromField c, FromField d), (a, b, c, d)) +DEGENERATE((FromField a, FromField b, FromField c, FromField d, FromField e), \ + (a, b, c, d, e)) + +#undef DEGEN_ERR +#undef DEGENERATE + +-- | A degenerate model that lifts any model to a Maybe version. Returns +-- 'Nothing' on a parse failure. Useful, for example, for performing outer +-- joins: +-- @ +-- dbJoin modelDBSelect "LEFT OUTER JOIN" +-- (addWhere 'foo = 123' $ modelDBSelect) +-- "USING a.id = b.a_id" :: (A :. Maybe B) +-- @ +-- +instance forall a. Model a => Model (Maybe a) where + modelInfo = mi_a { modelGetPrimaryKey = getPrimaryKey } + where mi_a = modelInfo :: ModelInfo a + getPrimaryKey Nothing = NullKey + getPrimaryKey (Just a) = modelGetPrimaryKey mi_a a + + modelIdentifiers = mi_a { modelQTable = modelQTable mi_a } + where mi_a = modelIdentifiers :: ModelIdentifiers a + + modelQueries = mi_a { modelLookupQuery = modelLookupQuery mi_a } + where mi_a = modelQueries :: ModelQueries a + + modelCreateInfo = error + "Attempt to use degenerate Maybe (Model a) instance for ModelCreateInfo" + + modelValid = maybe mempty modelValid + + modelWrite = maybe [] modelWrite + + modelRead = + Just `fmap` (modelRead :: RowParser a) + <|> do + let n = length $ modelColumns (modelInfo :: ModelInfo a) + replicateM_ n (field :: RowParser AnyField) + return Nothing + +-- | AnyField parses (simply by consuming) any SQL column. +data AnyField = AnyField + +instance FromField AnyField where + fromField _ _ = pure AnyField + +joinModelIdentifiers :: forall a b. (Model a, Model b) + => ModelIdentifiers (a :. b) +joinModelIdentifiers = r + where r = ModelIdentifiers { + modelQTable = qtable + , modelQColumns = modelQColumns mia ++ modelQColumns mib + , modelQWriteColumns = error "attempt to write join relation" + , modelQPrimaryColumn = + error "attempt to use primary key of join relation" + , modelQualifier = Nothing + , modelOrigTable = Nothing + } + qtable | S.null $ modelQTable mib = modelQTable mia + | S.null $ modelQTable mia = modelQTable mib + | otherwise = S.concat [modelQTable mia, " CROSS JOIN " + , modelQTable mib] + mia = modelIdentifiers :: ModelIdentifiers a + mib = modelIdentifiers :: ModelIdentifiers b + +-- | A degenerate instance of model representing a database join. The +-- ':.' instance does not allow normal model operations such as +-- 'findRow', 'save', and 'destroy'. Attempts to use such functions +-- will result in an exception. +instance (Model a, Model b) => Model (a :. b) where + modelInfo = error "attempt to access ModelInfo of join type :." + modelIdentifiers = joinModelIdentifiers + modelRead = (:.) <$> modelRead <*> modelRead + modelWrite _ = error "attempt to write join type :. as a normal Model" + modelQueries = error "attempt to perform standard query on join type :." + + +class GUnitType f where + gUnitTypeName :: f p -> String +instance GUnitType (C1 c U1) where + gUnitTypeName _ = error "gUnitTypeName" +instance GUnitType V1 where + gUnitTypeName _ = error "gUnitTypeName" +instance (Datatype c, GUnitType f) => GUnitType (D1 c f) where + gUnitTypeName = datatypeName + +-- | The class of types that can be used as tags in as 'As' alias. +-- Such types should be unit types--in other words, have exactly one +-- constructor where the constructor is nullary (take no arguments). +-- The reason for this class is that the 'Model' instance for 'As' +-- requires a way to extract the name of the row alias without having +-- a concrete instance of the type. This is provided by the +-- 'rowAliasName' method (which must be non-strict). +class RowAlias a where + rowAliasName :: g a row -> S.ByteString + -- ^ Return the SQL identifier for the row alias. This method must + -- be non-strict in its argument. Hence, it should discard the + -- argument and return the name of the alias. For example: + -- + -- > {-# LANGUAGE OverloadedStrings #-} + -- > + -- > data My_alias = My_alias + -- > instance RowAlias My_alias where rowAliasName _ = "my_alias" + -- + -- Keep in mind that PostgreSQL folds unquoted identifiers to + -- lower-case. However, this library quotes row aliases in @SELECT@ + -- statements, thereby preserving case. Hence, if you want to call + -- construct a @WHERE@ clause without double-quoting row aliases in + -- your 'Query', you should avoid capital letters in alias names. + -- + -- A default implementation of @rowAliasName@ exists for unit types + -- (as well as empty data declarations) in the 'Generic' class. The + -- default converts the first character of the type name to + -- lower-case, following the logic of 'defaultModelTable'. + default rowAliasName :: (Generic a, GUnitType (Rep a)) => + g a row -> S.ByteString + rowAliasName _ = fromString $ caseFold $ gUnitTypeName . from $ a + where caseFold (h:t) = toLower h:t -- fold first character only + caseFold [] = [] + a = undefined :: a + +-- | The newtype @As@ can be wrapped around an existing type to give +-- it a table name alias in a query. This is necessary when a model +-- is being joined with itself, to distinguish the two joined +-- instances of the same table. +-- +-- For example: +-- +-- @{-\# LANGUAGE OverloadedStrings #-} +-- +--data X = X +--instance 'RowAlias' X where rowAliasName = const \"x\" +-- +-- \ ... +-- r <- 'dbSelect' c $ addWhere_ \"bar.bar_key = x.bar_parent\" modelDBSelect +-- :: IO [Bar :. As X Bar] +-- @ +newtype As alias row = As { unAs :: row } +instance (RowAlias alias, Show row) => Show (As alias row) where + showsPrec d as@(As row) = showParen (d > 10) $ \rest -> + "As " ++ S8.unpack (rowAliasName as) ++ + " (" ++ showsPrec 11 row (")" ++ rest) + + +-- | @fromAs@ extracts the @row@ from an @'As' alias row@, but +-- constrains the type of @alias@ to be the same as its first argument +-- (which is non-strict). This can save you from explicitly +-- specifying types. For example: +-- +-- > data X = X deriving (Generic) +-- > instance RowAlias X where rowAliasName = const "x" +-- > +-- > ... +-- > r <- map (\(b1 :. b2) -> (b1, fromAs X b2)) <$> +-- > dbSelect c $ addWhere \"bar.bar_key = x.bar_parent\" modelDBSelect +fromAs :: alias -> As alias row -> row +{-# INLINE fromAs #-} +fromAs _ (As row) = row + +-- | A type-restricted wrapper around the 'As' constructor, under the +-- same rationale as 'fromAs'. Not strict in its first argument. +toAs :: alias -> row -> As alias row +{-# INLINE toAs #-} +toAs _ = As + +aliasModelInfo :: forall a alias. + (Model a, RowAlias alias) => + ModelInfo a -> ModelInfo (As alias a) +aliasModelInfo mi = r + where alias = rowAliasName (undefined :: As alias a) + r = mi { modelTable = alias + , modelGetPrimaryKey = modelGetPrimaryKey mi . unAs + } + +aliasModelIdentifiers :: forall a alias. (Model a, RowAlias alias) + => ModelInfo a -> ModelIdentifiers (As alias a) +aliasModelIdentifiers mi + | not ok = error $ "aliasModelIdentifiers: degenerate model " ++ + show (modelQTable ida ) + | otherwise = r + where r = ModelIdentifiers { + modelQTable = S.concat [quoteIdent orig, " AS ", alias] + , modelQColumns = qcols + , modelQPrimaryColumn = qcols !! pki + , modelQWriteColumns = deleteAt pki qcols + , modelQualifier = Just alias + , modelOrigTable = Just orig + } + ida = modelIdentifiers :: ModelIdentifiers a + ok = Just (modelQTable ida) == modelQualifier ida + && isJust (modelOrigTable ida) + Just orig = modelOrigTable ida + alias = quoteIdent $ rowAliasName (undefined :: As alias a) + qcol c = S.concat [alias, ".", quoteIdent c] + qcols = map qcol $ modelColumns mi + pki = modelPrimaryColumn mi + +-- | A degenerate instance of 'Model' that re-names the row with a SQL +-- @AS@ keyword. This is primarily useful when joining a model with +-- itself. Hence, standard operations ('findRow', 'save', 'destroy') +-- are not allowed on 'As' models. +instance (Model a, RowAlias as) => Model (As as a) where + {-# INLINE modelInfo #-} + modelInfo = aliasModelInfo modelInfo + {-# INLINE modelRead #-} + modelRead = As <$> modelRead + modelWrite = error "attempt to write \"As\" alias as normal Model" + {-# INLINE modelIdentifiers #-} + modelIdentifiers = aliasModelIdentifiers modelInfo + modelQueries = error "attempt to perform standard query on AS table alias" + + +-- | Lookup the 'modelTable' of a 'Model' (@modelName _ = 'modelTable' +-- ('modelInfo' :: 'ModelInfo' a)@). +modelName :: forall a. (Model a) => a -> S.ByteString +{-# INLINE modelName #-} +modelName _ = modelTable (modelInfo :: ModelInfo a) + +-- | Lookup the primary key of a 'Model'. +primaryKey :: (Model a) => a -> DBKey +{-# INLINE primaryKey #-} +primaryKey a = modelGetPrimaryKey modelInfo a + +-- | Generate a SQL @SELECT@ statement with no @WHERE@ predicate. For +-- example, 'defaultModelLookupQuery' consists of +-- @modelSelectFragment@ followed by \"@WHERE@ /primary-key/ = ?\". +modelSelectFragment :: ModelIdentifiers a -> S.ByteString +modelSelectFragment mi = S.concat [ + "SELECT ", S.intercalate ", " $ modelQColumns mi, " FROM ", modelQTable mi ] + +-- | A newtype wrapper in the 'FromRow' class, permitting every model +-- to be used as the result of a database query. +newtype LookupRow a = LookupRow { lookupRow :: a } deriving (Show) +instance (Model a) => FromRow (LookupRow a) where + fromRow = LookupRow <$> modelRead + +-- | A newtype wrapper in the 'ToRow' class, which marshalls every +-- field except the primary key. For use with 'modelInsertQuery'. +newtype InsertRow a = InsertRow a deriving (Show) +instance (Model a) => ToRow (InsertRow a) where + toRow (InsertRow a) = modelWrite a + +-- | A newtype wrapper in the 'ToRow' class, which marshalls every +-- field except the primary key, followed by the primary key. For use +-- with 'modelUpdateQuery'. +newtype UpdateRow a = UpdateRow a deriving (Show) +instance (Model a) => ToRow (UpdateRow a) where + toRow (UpdateRow a) = toRow $ InsertRow a :. Only (primaryKey a) + +-- | Dump an entire model. Useful for development and debugging only, +-- as every row will be read into memory before the function returns. +-- +-- Note that unlike the other primary model operations, it is OK to +-- call 'findAll' even on degenerate models such as 'As' and ':.'. +findAll :: forall r. (Model r) => Connection -> IO [r] +findAll c = action + where mi = modelIdentifiers :: ModelIdentifiers r + q = Query $ modelSelectFragment mi + action = map lookupRow <$> query_ c q + +-- | Follow a 'DBRef' or 'DBRefUnique' and fetch the target row from +-- the database into a 'Model' type @r@. +findRow :: forall r rt. (Model r) => Connection -> GDBRef rt r -> IO (Maybe r) +findRow c k = action + where qs = modelQueries :: ModelQueries r + action = do rs <- query c (modelLookupQuery qs) (Only k) + case rs of [r] -> return $ Just $ lookupRow $ r + _ -> return Nothing + +-- | Like 'trySave' but instead of returning an 'Either', throws a +-- 'ValidationError' if the 'Model' is invalid. +save :: (Model r) + => Connection -> r -> IO r +save c r = do + eResp <- trySave c r + case eResp of + Right resp -> return resp + Left errs -> throwIO errs + +-- | 'save' but returning '()' instead of the saved model. +save_ :: (Model r) + => Connection -> r -> IO () +save_ c r = void $ save c r + +-- | Write a 'Model' to the database. If the primary key is +-- 'NullKey', the item is written with an @INSERT@ query, read back +-- from the database, and returned with its primary key filled in. If +-- the primary key is not 'NullKey', then the 'Model' is written with +-- an @UPDATE@ query and returned as-is. +-- +-- If the 'Model' is invalid (i.e. the return value of 'modelValid' is +-- non-empty), a list of 'InvalidError' is returned instead. +trySave :: forall r. Model r + => Connection -> r -> IO (Either ValidationError r) +trySave c r | not . H.null $ validationErrors errors = return $ Left errors + | NullKey <- primaryKey r = do + rs <- query c (modelInsertQuery qs) (InsertRow r) + case rs of [r'] -> return $ Right $ lookupRow r' + _ -> fail "save: database did not return row" + | otherwise = do + rows <- query c (modelUpdateQuery qs) (UpdateRow r) + case rows of [r'] -> return $ Right $ lookupRow r' + _ -> fail $ "save: database updated " + ++ show (length rows) + ++ " records" + where qs = modelQueries :: ModelQueries r + errors = modelValid r + +-- | Remove the row corresponding to a particular data structure from +-- the database. This function only looks at the primary key in the +-- data structure. It is an error to call this function if the +-- primary key is not set. +destroy :: forall a. (Model a) + => Connection -> a -> IO (Either ValidationError Bool) +destroy c a = + case primaryKey a of + NullKey -> fail "destroy: NullKey" + DBKey k -> destroyByRef_ "destroy" c (DBRef k :: DBRef a) + +-- | Remove a row from the database without fetching it first. +destroyByRef :: forall a rt. (Model a) + => Connection -> GDBRef rt a -> IO (Either ValidationError Bool) +destroyByRef = destroyByRef_ "destroyByRef" + +destroyByRef_ :: forall a rt. (Model a) + => T.Text -> Connection -> GDBRef rt a -> IO (Either ValidationError Bool) +destroyByRef_ msg c a = action + where mq = modelQueries :: ModelQueries a + mi = modelIdentifiers :: ModelIdentifiers a + pkCol = modelQPrimaryColumn mi + action = do + n <- execute c (modelDeleteQuery mq) (Only a) + return $ case n of + 0 -> Right False + 1 -> Right True + _ -> Left $ validationError (T.decodeUtf8 pkCol) $ + msg <> ": DELETE modified " <> T.pack (show n) <> + " rows. This may indicate that your primary key" <> + " accessor field is not actually a primary key." + +-- | Print to stdout the query statement. +printq :: Query -> IO () +printq (Query bs) = S8.putStrLn bs diff --git a/src/Database/PostgreSQL/ORM/SqlType.hs b/src/Database/PostgreSQL/ORM/SqlType.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/ORM/SqlType.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Database.PostgreSQL.ORM.SqlType (SqlType(..), getTypeOid) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Int +import Data.Monoid +import qualified Data.Text as ST +import qualified Data.Text.Lazy as LT +import Data.Time +import Data.Typeable +import qualified Data.Vector as V +import Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.Time +import Database.PostgreSQL.Simple.ToField +import Database.PostgreSQL.Simple.TypeInfo.Static +import Database.PostgreSQL.Simple.Types + +import Database.PostgreSQL.ORM.Model + +newtype ExtractTypeOid = ExtractTypeOid Oid +instance FromField ExtractTypeOid where + fromField f _ = return $ ExtractTypeOid $ typeOid f + +-- | Retreive the 'Oid' corresponding to a type. You can subsequently +-- use the 'Oid' to call 'getTypeInfo' for more information on the +-- type. +getTypeOid :: Connection -> S.ByteString -> IO Oid +getTypeOid c tname = do + [Only (ExtractTypeOid ti)] <- query_ c $ Query $ "SELECT NULL :: " <> tname + return ti + +-- | The class of Haskell types that can be converted to and from a +-- particular SQL type. For most instances, you only need to define +-- 'sqlBaseType'. +class (ToField a, FromField a) => SqlType a where + sqlBaseType :: a -> S.ByteString + -- ^ The name of the SQL type corresponding to Haskell type @a@, + -- when a value of @a@ can be null. This is the SQL type to and + -- from which a @'Maybe' a@ will be converted (where 'Nothing' + -- corresponds to the SQL value null). + sqlType :: a -> S.ByteString + -- ^ The name of the SQL type corresponding to Haskell type @a@, + -- when @a@ is not wrapped in 'Maybe' and hence cannot be null. If + -- @sqlType@ is unspecified, the default is to append \"@NOT NULL@\" + -- to 'sqlBaseType'. + {-# INLINE sqlType #-} + sqlType _ = (sqlBaseType (undefined :: a)) <> " NOT NULL" + +#define TYPE(hs, sql) \ + instance SqlType (hs) where sqlBaseType _ = typname (sql) +TYPE(Bool, bool) +TYPE(Double, float8) +TYPE(Float, float4) +TYPE(Int16, int2) +TYPE(Int32, int4) +TYPE(Int64, int8) +TYPE(S.ByteString, text) +TYPE(L.ByteString, text) +TYPE(ST.Text, text) +TYPE(LT.Text, text) +TYPE(Oid,oid) +TYPE(LocalTime, timestamp) +TYPE(ZonedTime, timestamptz) +TYPE(TimeOfDay, time) +TYPE(UTCTime, timestamptz) +TYPE(Day, date) +TYPE(Date, date) +TYPE(ZonedTimestamp, timestamptz) +TYPE(UTCTimestamp, timestamptz) +TYPE(LocalTimestamp, timestamp) +TYPE(String, text) +TYPE(Binary S.ByteString, bytea) +TYPE(Binary L.ByteString, bytea) + +#undef TYPE + +instance SqlType DBKey where + sqlType _ = "bigserial UNIQUE NOT NULL PRIMARY KEY" + sqlBaseType _ = error "DBKey should not be wrapped in type" + +instance (SqlType a) => SqlType (Maybe a) where + sqlType _ = sqlBaseType (undefined :: a) + sqlBaseType _ = error "Table field Maybe should not be wrapped in other type" + +instance (Typeable a, SqlType a) => SqlType (V.Vector a) where + sqlBaseType _ = sqlBaseType (undefined :: a) <> "[]" + +instance (Model a) => SqlType (DBRef a) where + sqlBaseType (DBRef k) = sqlBaseType k <> ref + where t = modelInfo :: ModelInfo a + Just orig = modelOrigTable (modelIdentifiers :: ModelIdentifiers a) + ref = S.concat [ + " REFERENCES ", quoteIdent orig, "(" + , quoteIdent (modelColumns t !! modelPrimaryColumn t), ")" ] + +instance (Model a) => SqlType (DBRefUnique a) where + sqlBaseType (DBRef k) = sqlBaseType k <> ref + where t = modelInfo :: ModelInfo a + Just orig = modelOrigTable (modelIdentifiers :: ModelIdentifiers a) + ref = S.concat [ + " UNIQUE REFERENCES ", quoteIdent orig , "(" + , quoteIdent (modelColumns t !! modelPrimaryColumn t), ")" ] diff --git a/src/Database/PostgreSQL/ORM/Validations.hs b/src/Database/PostgreSQL/ORM/Validations.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/ORM/Validations.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP, FlexibleContexts, DeriveDataTypeable, OverloadedStrings #-} +module Database.PostgreSQL.ORM.Validations where + +import Control.Exception +import Data.Aeson +import qualified Data.HashMap.Strict as H +#if __GLASGOW_HASKELL__ < 710 +import Data.Monoid +#endif +import qualified Data.Text as T +import Data.Typeable +#if __GLASGOW_HASKELL >= 806 +import Data.Semigroup +#endif + +newtype ValidationError = ValidationError + { validationErrors :: H.HashMap T.Text [T.Text] } deriving (Show, Typeable) + +instance Exception ValidationError + +#if __GLASGOW_HASKELL__ >= 806 +instance Semigroup ValidationError where + ein <> zwei = ValidationError $! + H.unionWith mappend (validationErrors ein) (validationErrors zwei) +#endif + +instance Monoid ValidationError where + mempty = ValidationError mempty +#if __GLASGOW_HASKELL < 806 + mappend ein zwei = ValidationError $! + H.unionWith mappend (validationErrors ein) (validationErrors zwei) +#endif + +instance ToJSON ValidationError where + toJSON = toJSON . validationErrors + +instance FromJSON ValidationError where + parseJSON val = ValidationError `fmap` parseJSON val + +type ValidationFunc a = a -> ValidationError + +validationError :: T.Text -> T.Text -> ValidationError +validationError columnName description = + ValidationError $ H.singleton columnName [description] + +validate :: (a -> Bool) + -> T.Text -- ^ Column name + -> T.Text -- ^ Error description + -> ValidationFunc a +validate validator columnName desc = \a -> + if validator a + then mempty + else validationError columnName desc + +validateNotEmpty :: (a -> T.Text) + -> T.Text + -> T.Text + -> ValidationFunc a +validateNotEmpty accessor = validate (not . T.null . accessor) + diff --git a/static/CompilerUtils.hs b/static/CompilerUtils.hs new file mode 100644 --- /dev/null +++ b/static/CompilerUtils.hs @@ -0,0 +1,97 @@ +{-# 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 Database.PostgreSQL.Migrate (initializeDb) +import System.Environment (getArgs, getProgName) + +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 + "init":[] -> initializeDb + "list":[] -> listMigrations migrations + "migrate":[] -> runMigrations migrations + "rollback":[] -> runRollback migrations + _ -> do + progName <- getProgName + putStrLn $ "Usage: " ++ progName ++ " migrate|rollback" + putStrLn $ " " ++ progName ++ " list" + putStrLn $ " " ++ progName ++ " init" + +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!"