diff --git a/Data/GetField.hs b/Data/GetField.hs new file mode 100644 --- /dev/null +++ b/Data/GetField.hs @@ -0,0 +1,240 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverlappingInstances #-} +{-# 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 (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 new file mode 100644 --- /dev/null +++ b/Data/RequireSelector.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} + +module Data.RequireSelector (RequireSelector) where + +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 + +-- | 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 +instance (IntentionallyCauseError NoSelector) => RequireSelector NoSelector +instance RequireSelector a diff --git a/Database/PostgreSQL/Describe.hs b/Database/PostgreSQL/Describe.hs new file mode 100644 --- /dev/null +++ b/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/Database/PostgreSQL/Devel.hs b/Database/PostgreSQL/Devel.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Devel.hs @@ -0,0 +1,206 @@ +{-# 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 +import Data.Functor +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 + +pgDirectives :: FilePath -> [(String, String)] +pgDirectives dir = [ + ("unix_socket_directory", "unix_socket_directory = '" ++ q dir ++ "'") + , ("logging_collector", "logging_collector = yes") + , ("listen_addresses", "listen_addresses = ''")] + where q ('\'':t) = "''" ++ q t + q (h:t) = h : q t + q [] = "" + +-- | Create a directory for a local database cluster entirely +-- self-contained within one directory. This is accomplished by +-- creating a new PostgreSQL database cluster in the directory and +-- setting the following configuration options in @postgresql.conf@: +-- +-- * @unix_socket_directory@ is set to the database directory itself, +-- so that no permissions are required on global directories such as +-- @\/var\/run@. +-- +-- * @listen_address@ is set to empty (i.e., @\'\'@), so that no TCP +-- socket is bound, avoiding conflicts with any other running instaces +-- of PostgreSQL. +-- +-- * @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" + 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 new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Escape.hs @@ -0,0 +1,257 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UnboxedTuples #-} + +-- | This module deals with escaping and sanitizing SQL templates. +module Database.PostgreSQL.Escape ( + fmtSql, quoteIdent, Id(..) + , buildSql, buildSqlFromActions + , buildAction, buildLiteral, buildByteA, buildIdent + ) where + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char8 (fromChar) +import Blaze.ByteString.Builder.Internal +import qualified Data.ByteString as S +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Unsafe as S +import Data.Monoid +import Data.String +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#, 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) + +c2b :: Char -> Word8 +c2b (C# i) = W8# (int2Word# (ord# i)) + +c2b# :: Char -> Word# +c2b# (C# i) = int2Word# (ord# i) + +fastFindIndex :: (Word# -> Bool) -> S.ByteString -> Maybe Int +{-# INLINE fastFindIndex #-} +fastFindIndex test bs = + S.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 | 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 [copyByteString start, escaped bs0, copyByteString end] + where escaped bs = case fastBreak escPred bs of + (h, t) | S.null t -> fromByteString h + | otherwise -> fromByteString 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 = copyByteString $ 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 +-- @'fromByteString' . '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 $ copyByteString "\"\"") 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 = toByteString . buildIdent + +-- | An identifier is a table or column name. When rendered into a +-- SQL query by 'fmtSql', it will be double-quoted, rather than +-- single-quoted. For example: +-- +-- >>> fmtSql "select * from ? where name = ?" (Id "MyTable", "A Name") +-- "select * from \"MyTable\" where name = E'A Name'" +newtype Id = Id S.ByteString deriving Show +instance IsString Id where + fromString = Id . fromString +instance ToField Id where + toField (Id name) = Plain $ buildIdent name + +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 = b `geWord#` 128## + esc b | b == c2b '\'' = copyByteString "''" + | b == c2b '\\' = copyByteString "\\\\" + | 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 $ + fromBuildStepCont $ \cont (BufRange (Ptr bb0) (Ptr be0)) -> + S.unsafeUseAsCStringLen bs $ \(Ptr inptr0, I# inlen0) -> do + let ine = plusAddr# inptr0 inlen0 + fill oute inp outp + | inp `geAddr#` ine = cont (BufRange (Ptr outp) (Ptr oute)) + | plusAddr# outp 2# `geAddr#` oute = return $ + bufferFull (2 * (I# (ine `minusAddr#` inp)) + 1) (Ptr outp) $ + \(BufRange (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 [fromByteString " E'\\\\x", b, fromChar '\''] + + + +buildAction :: Action -> Builder +buildAction (Plain b) = b +buildAction (Escape bs) = buildLiteral bs +buildAction (EscapeByteA bs) = buildByteA 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.breakByte (c2b '?') s of + (h,t) | S.null t -> [fromByteString h] + | otherwise -> fromByteString 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 $ toByteString $ buildSql q p diff --git a/Database/PostgreSQL/Migrate.hs b/Database/PostgreSQL/Migrate.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Migrate.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE 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 + , defaultMigrationsDir + , MigrationDetails(..) + ) where + +import Control.Monad +import Data.List +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.Cmd +import System.Process +import System.Directory +import System.FilePath +import System.Environment +import System.IO + +-- | The default relative path containing migrations: \".\/dir\/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 + dbUrl <- getEnvironment >>= return . maybe "" id . lookup "DATABASE_URL" + (_, out, err, ph) <- runInteractiveProcess "pg_dump" + [dbUrl, "--schema-only", "-O", "-x"] 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 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 version _) = do + rawSystem "runghc" + [file, "up", version, "--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 version _) = do + rawSystem "runghc" + [file, "down", version, "--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 + version = head parts + name = concat $ intersperse "_" $ tail parts + in MigrationDetails (dir file) version name + +isVersion :: (String -> Bool) -> MigrationDetails -> Bool +isVersion cond (MigrationDetails _ v _) = cond v + diff --git a/Database/PostgreSQL/Migrations.hs b/Database/PostgreSQL/Migrations.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/Migrations.hs @@ -0,0 +1,415 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/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 + , InvalidError(..), ValidationError(..), validate, validateNotEmpty + ) 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 new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/ORM/Association.hs @@ -0,0 +1,540 @@ +{-# 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 + +import Control.Applicative +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 new file mode 100644 --- /dev/null +++ b/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/Database/PostgreSQL/ORM/DBSelect.hs b/Database/PostgreSQL/ORM/DBSelect.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/ORM/DBSelect.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Database.PostgreSQL.ORM.DBSelect ( + -- * The DBSelect structure + DBSelect(..), FromClause(..) + -- * Executing DBSelects + , dbSelectParams, dbSelect + , renderDBSelect, buildDBSelect + -- * Creating DBSelects + , emptyDBSelect, expressionDBSelect + , modelDBSelect + , dbJoin, dbJoinModels + , dbProject, dbProject' + , dbNest, dbChain + -- * Altering DBSelects + , addWhere_, addWhere, setOrderBy, setLimit, setOffset, addExpression + ) where + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char.Utf8 (fromChar) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Data.Functor +import Data.Monoid +import Data.String +import Database.PostgreSQL.Simple +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 #-} + 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 #-} + q = renderDBSelect dbs + +-- | 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 new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/ORM/Model.hs @@ -0,0 +1,1083 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# 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, 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.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import Data.Char +import Data.Data +import Data.Int +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) + +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) + +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, RequireSelector 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 (RequireSelector c) => 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, " = ?" + ] + +-- | 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 -> [InvalidError] + modelValid = const [] + +-- | 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 + +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 $ ValidationError errs + +-- | 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 [InvalidError] r) +trySave c r | not . null $ 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 + n <- execute c (modelUpdateQuery qs) (UpdateRow r) + case n of 1 -> return $ Right r + _ -> fail $ "save: database updated " ++ show n + ++ " 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 () +destroy c a = + case primaryKey a of + NullKey -> fail "destroy: NullKey" + DBKey k -> void $ execute c + (modelDeleteQuery (modelQueries :: ModelQueries a)) (Only k) + +-- | Remove a row from the database without fetching it first. +destroyByRef :: forall a rt. (Model a) => Connection -> GDBRef rt a -> IO () +destroyByRef c a = + void $ execute c (modelDeleteQuery (modelQueries :: ModelQueries a)) (Only a) + +-- | 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 new file mode 100644 --- /dev/null +++ b/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/Database/PostgreSQL/ORM/Validations.hs b/Database/PostgreSQL/ORM/Validations.hs new file mode 100644 --- /dev/null +++ b/Database/PostgreSQL/ORM/Validations.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts, DeriveDataTypeable #-} +module Database.PostgreSQL.ORM.Validations where + +import Control.Exception +import qualified Data.Text as T +import Data.Typeable +import qualified Data.ByteString.Char8 as S8 + +data InvalidError = InvalidError + { invalidColumn :: !S8.ByteString + , invalidError :: !S8.ByteString } deriving (Show) + +newtype ValidationError = ValidationError [InvalidError] + deriving (Show, Typeable) + +instance Exception ValidationError + +type ValidationFunc a = a -> [InvalidError] + +validate :: (a -> Bool) + -> S8.ByteString -- ^ Column name + -> S8.ByteString -- ^ Error description + -> ValidationFunc a +validate validator columnName desc = \a -> + if validator a then + [] + else [InvalidError columnName desc] + +validateNotEmpty :: (a -> T.Text) + -> S8.ByteString + -> S8.ByteString + -> ValidationFunc a +validateNotEmpty accessor = validate (not . T.null . accessor) + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,675 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The GNU General Public License is a free, copyleft license for +software and other kinds of works. + + The licenses for most software and other practical works are designed +to take away your freedom to share and change the works. By contrast, +the GNU General Public License is intended to guarantee your freedom to +share and change all versions of a program--to make sure it remains free +software for all its users. We, the Free Software Foundation, use the +GNU General Public License for most of our software; it applies also to +any other work released this way by its authors. You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +them if you wish), that you receive source code or can get it if you +want it, that you can change the software or use pieces of it in new +free programs, and that you know you can do these things. + + To protect your rights, we need to prevent others from denying you +these rights or asking you to surrender the rights. Therefore, you have +certain responsibilities if you distribute copies of the software, or if +you modify it: responsibilities to respect the freedom of others. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must pass on to the recipients the same +freedoms that you received. You must make sure that they, too, receive +or can get the source code. And you must show them these terms so they +know their rights. + + Developers that use the GNU GPL protect your rights with two steps: +(1) assert copyright on the software, and (2) offer you this License +giving you legal permission to copy, distribute and/or modify it. + + For the developers' and authors' protection, the GPL clearly explains +that there is no warranty for this free software. For both users' and +authors' sake, the GPL requires that modified versions be marked as +changed, so that their problems will not be attributed erroneously to +authors of previous versions. + + Some devices are designed to deny users access to install or run +modified versions of the software inside them, although the manufacturer +can do so. This is fundamentally incompatible with the aim of +protecting users' freedom to change the software. The systematic +pattern of such abuse occurs in the area of products for individuals to +use, which is precisely where it is most unacceptable. Therefore, we +have designed this version of the GPL to prohibit the practice for those +products. If such problems arise substantially in other domains, we +stand ready to extend this provision to those domains in future versions +of the GPL, as needed to protect the freedom of users. + + Finally, every program is threatened constantly by software patents. +States should not allow patents to restrict development and use of +software on general-purpose computers, but in those that do, we wish to +avoid the special danger that patents applied to a free program could +make it effectively proprietary. To prevent this, the GPL assures that +patents cannot be used to render the program non-free. + + The precise terms and conditions for copying, distribution and +modification follow. + + TERMS AND CONDITIONS + + 0. Definitions. + + "This License" refers to version 3 of the GNU General Public License. + + "Copyright" also means copyright-like laws that apply to other kinds of +works, such as semiconductor masks. + + "The Program" refers to any copyrightable work licensed under this +License. Each licensee is addressed as "you". "Licensees" and +"recipients" may be individuals or organizations. + + To "modify" a work means to copy from or adapt all or part of the work +in a fashion requiring copyright permission, other than the making of an +exact copy. The resulting work is called a "modified version" of the +earlier work or a work "based on" the earlier work. + + A "covered work" means either the unmodified Program or a work based +on the Program. + + To "propagate" a work means to do anything with it that, without +permission, would make you directly or secondarily liable for +infringement under applicable copyright law, except executing it on a +computer or modifying a private copy. Propagation includes copying, +distribution (with or without modification), making available to the +public, and in some countries other activities as well. + + To "convey" a work means any kind of propagation that enables other +parties to make or receive copies. Mere interaction with a user through +a computer network, with no transfer of a copy, is not conveying. + + An interactive user interface displays "Appropriate Legal Notices" +to the extent that it includes a convenient and prominently visible +feature that (1) displays an appropriate copyright notice, and (2) +tells the user that there is no warranty for the work (except to the +extent that warranties are provided), that licensees may convey the +work under this License, and how to view a copy of this License. If +the interface presents a list of user commands or options, such as a +menu, a prominent item in the list meets this criterion. + + 1. Source Code. + + The "source code" for a work means the preferred form of the work +for making modifications to it. "Object code" means any non-source +form of a work. + + A "Standard Interface" means an interface that either is an official +standard defined by a recognized standards body, or, in the case of +interfaces specified for a particular programming language, one that +is widely used among developers working in that language. + + The "System Libraries" of an executable work include anything, other +than the work as a whole, that (a) is included in the normal form of +packaging a Major Component, but which is not part of that Major +Component, and (b) serves only to enable use of the work with that +Major Component, or to implement a Standard Interface for which an +implementation is available to the public in source code form. A +"Major Component", in this context, means a major essential component +(kernel, window system, and so on) of the specific operating system +(if any) on which the executable work runs, or a compiler used to +produce the work, or an object code interpreter used to run it. + + The "Corresponding Source" for a work in object code form means all +the source code needed to generate, install, and (for an executable +work) run the object code and to modify the work, including scripts to +control those activities. However, it does not include the work's +System Libraries, or general-purpose tools or generally available free +programs which are used unmodified in performing those activities but +which are not part of the work. For example, Corresponding Source +includes interface definition files associated with source files for +the work, and the source code for shared libraries and dynamically +linked subprograms that the work is specifically designed to require, +such as by intimate data communication or control flow between those +subprograms and other parts of the work. + + The Corresponding Source need not include anything that users +can regenerate automatically from other parts of the Corresponding +Source. + + The Corresponding Source for a work in source code form is that +same work. + + 2. Basic Permissions. + + All rights granted under this License are granted for the term of +copyright on the Program, and are irrevocable provided the stated +conditions are met. This License explicitly affirms your unlimited +permission to run the unmodified Program. The output from running a +covered work is covered by this License only if the output, given its +content, constitutes a covered work. This License acknowledges your +rights of fair use or other equivalent, as provided by copyright law. + + You may make, run and propagate covered works that you do not +convey, without conditions so long as your license otherwise remains +in force. You may convey covered works to others for the sole purpose +of having them make modifications exclusively for you, or provide you +with facilities for running those works, provided that you comply with +the terms of this License in conveying all material for which you do +not control copyright. Those thus making or running the covered works +for you must do so exclusively on your behalf, under your direction +and control, on terms that prohibit them from making any copies of +your copyrighted material outside their relationship with you. + + Conveying under any other circumstances is permitted solely under +the conditions stated below. Sublicensing is not allowed; section 10 +makes it unnecessary. + + 3. Protecting Users' Legal Rights From Anti-Circumvention Law. + + No covered work shall be deemed part of an effective technological +measure under any applicable law fulfilling obligations under article +11 of the WIPO copyright treaty adopted on 20 December 1996, or +similar laws prohibiting or restricting circumvention of such +measures. + + When you convey a covered work, you waive any legal power to forbid +circumvention of technological measures to the extent such circumvention +is effected by exercising rights under this License with respect to +the covered work, and you disclaim any intention to limit operation or +modification of the work as a means of enforcing, against the work's +users, your or third parties' legal rights to forbid circumvention of +technological measures. + + 4. Conveying Verbatim Copies. + + You may convey verbatim copies of the Program's source code as you +receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice; +keep intact all notices stating that this License and any +non-permissive terms added in accord with section 7 apply to the code; +keep intact all notices of the absence of any warranty; and give all +recipients a copy of this License along with the Program. + + You may charge any price or no price for each copy that you convey, +and you may offer support or warranty protection for a fee. + + 5. Conveying Modified Source Versions. + + You may convey a work based on the Program, or the modifications to +produce it from the Program, in the form of source code under the +terms of section 4, provided that you also meet all of these conditions: + + a) The work must carry prominent notices stating that you modified + it, and giving a relevant date. + + b) The work must carry prominent notices stating that it is + released under this License and any conditions added under section + 7. This requirement modifies the requirement in section 4 to + "keep intact all notices". + + c) You must license the entire work, as a whole, under this + License to anyone who comes into possession of a copy. This + License will therefore apply, along with any applicable section 7 + additional terms, to the whole of the work, and all its parts, + regardless of how they are packaged. This License gives no + permission to license the work in any other way, but it does not + invalidate such permission if you have separately received it. + + d) If the work has interactive user interfaces, each must display + Appropriate Legal Notices; however, if the Program has interactive + interfaces that do not display Appropriate Legal Notices, your + work need not make them do so. + + A compilation of a covered work with other separate and independent +works, which are not by their nature extensions of the covered work, +and which are not combined with it such as to form a larger program, +in or on a volume of a storage or distribution medium, is called an +"aggregate" if the compilation and its resulting copyright are not +used to limit the access or legal rights of the compilation's users +beyond what the individual works permit. Inclusion of a covered work +in an aggregate does not cause this License to apply to the other +parts of the aggregate. + + 6. Conveying Non-Source Forms. + + You may convey a covered work in object code form under the terms +of sections 4 and 5, provided that you also convey the +machine-readable Corresponding Source under the terms of this License, +in one of these ways: + + a) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by the + Corresponding Source fixed on a durable physical medium + customarily used for software interchange. + + b) Convey the object code in, or embodied in, a physical product + (including a physical distribution medium), accompanied by a + written offer, valid for at least three years and valid for as + long as you offer spare parts or customer support for that product + model, to give anyone who possesses the object code either (1) a + copy of the Corresponding Source for all the software in the + product that is covered by this License, on a durable physical + medium customarily used for software interchange, for a price no + more than your reasonable cost of physically performing this + conveying of source, or (2) access to copy the + Corresponding Source from a network server at no charge. + + c) Convey individual copies of the object code with a copy of the + written offer to provide the Corresponding Source. This + alternative is allowed only occasionally and noncommercially, and + only if you received the object code with such an offer, in accord + with subsection 6b. + + d) Convey the object code by offering access from a designated + place (gratis or for a charge), and offer equivalent access to the + Corresponding Source in the same way through the same place at no + further charge. You need not require recipients to copy the + Corresponding Source along with the object code. If the place to + copy the object code is a network server, the Corresponding Source + may be on a different server (operated by you or a third party) + that supports equivalent copying facilities, provided you maintain + clear directions next to the object code saying where to find the + Corresponding Source. Regardless of what server hosts the + Corresponding Source, you remain obligated to ensure that it is + available for as long as needed to satisfy these requirements. + + e) Convey the object code using peer-to-peer transmission, provided + you inform other peers where the object code and Corresponding + Source of the work are being offered to the general public at no + charge under subsection 6d. + + A separable portion of the object code, whose source code is excluded +from the Corresponding Source as a System Library, need not be +included in conveying the object code work. + + A "User Product" is either (1) a "consumer product", which means any +tangible personal property which is normally used for personal, family, +or household purposes, or (2) anything designed or sold for incorporation +into a dwelling. In determining whether a product is a consumer product, +doubtful cases shall be resolved in favor of coverage. For a particular +product received by a particular user, "normally used" refers to a +typical or common use of that class of product, regardless of the status +of the particular user or of the way in which the particular user +actually uses, or expects or is expected to use, the product. A product +is a consumer product regardless of whether the product has substantial +commercial, industrial or non-consumer uses, unless such uses represent +the only significant mode of use of the product. + + "Installation Information" for a User Product means any methods, +procedures, authorization keys, or other information required to install +and execute modified versions of a covered work in that User Product from +a modified version of its Corresponding Source. The information must +suffice to ensure that the continued functioning of the modified object +code is in no case prevented or interfered with solely because +modification has been made. + + If you convey an object code work under this section in, or with, or +specifically for use in, a User Product, and the conveying occurs as +part of a transaction in which the right of possession and use of the +User Product is transferred to the recipient in perpetuity or for a +fixed term (regardless of how the transaction is characterized), the +Corresponding Source conveyed under this section must be accompanied +by the Installation Information. But this requirement does not apply +if neither you nor any third party retains the ability to install +modified object code on the User Product (for example, the work has +been installed in ROM). + + The requirement to provide Installation Information does not include a +requirement to continue to provide support service, warranty, or updates +for a work that has been modified or installed by the recipient, or for +the User Product in which it has been modified or installed. Access to a +network may be denied when the modification itself materially and +adversely affects the operation of the network or violates the rules and +protocols for communication across the network. + + Corresponding Source conveyed, and Installation Information provided, +in accord with this section must be in a format that is publicly +documented (and with an implementation available to the public in +source code form), and must require no special password or key for +unpacking, reading or copying. + + 7. Additional Terms. + + "Additional permissions" are terms that supplement the terms of this +License by making exceptions from one or more of its conditions. +Additional permissions that are applicable to the entire Program shall +be treated as though they were included in this License, to the extent +that they are valid under applicable law. If additional permissions +apply only to part of the Program, that part may be used separately +under those permissions, but the entire Program remains governed by +this License without regard to the additional permissions. + + When you convey a copy of a covered work, you may at your option +remove any additional permissions from that copy, or from any part of +it. (Additional permissions may be written to require their own +removal in certain cases when you modify the work.) You may place +additional permissions on material, added by you to a covered work, +for which you have or can give appropriate copyright permission. + + Notwithstanding any other provision of this License, for material you +add to a covered work, you may (if authorized by the copyright holders of +that material) supplement the terms of this License with terms: + + a) Disclaiming warranty or limiting liability differently from the + terms of sections 15 and 16 of this License; or + + b) Requiring preservation of specified reasonable legal notices or + author attributions in that material or in the Appropriate Legal + Notices displayed by works containing it; or + + c) Prohibiting misrepresentation of the origin of that material, or + requiring that modified versions of such material be marked in + reasonable ways as different from the original version; or + + d) Limiting the use for publicity purposes of names of licensors or + authors of the material; or + + e) Declining to grant rights under trademark law for use of some + trade names, trademarks, or service marks; or + + f) Requiring indemnification of licensors and authors of that + material by anyone who conveys the material (or modified versions of + it) with contractual assumptions of liability to the recipient, for + any liability that these contractual assumptions directly impose on + those licensors and authors. + + All other non-permissive additional terms are considered "further +restrictions" within the meaning of section 10. If the Program as you +received it, or any part of it, contains a notice stating that it is +governed by this License along with a term that is a further +restriction, you may remove that term. If a license document contains +a further restriction but permits relicensing or conveying under this +License, you may add to a covered work material governed by the terms +of that license document, provided that the further restriction does +not survive such relicensing or conveying. + + If you add terms to a covered work in accord with this section, you +must place, in the relevant source files, a statement of the +additional terms that apply to those files, or a notice indicating +where to find the applicable terms. + + Additional terms, permissive or non-permissive, may be stated in the +form of a separately written license, or stated as exceptions; +the above requirements apply either way. + + 8. Termination. + + You may not propagate or modify a covered work except as expressly +provided under this License. Any attempt otherwise to propagate or +modify it is void, and will automatically terminate your rights under +this License (including any patent licenses granted under the third +paragraph of section 11). + + However, if you cease all violation of this License, then your +license from a particular copyright holder is reinstated (a) +provisionally, unless and until the copyright holder explicitly and +finally terminates your license, and (b) permanently, if the copyright +holder fails to notify you of the violation by some reasonable means +prior to 60 days after the cessation. + + Moreover, your license from a particular copyright holder is +reinstated permanently if the copyright holder notifies you of the +violation by some reasonable means, this is the first time you have +received notice of violation of this License (for any work) from that +copyright holder, and you cure the violation prior to 30 days after +your receipt of the notice. + + Termination of your rights under this section does not terminate the +licenses of parties who have received copies or rights from you under +this License. If your rights have been terminated and not permanently +reinstated, you do not qualify to receive new licenses for the same +material under section 10. + + 9. Acceptance Not Required for Having Copies. + + You are not required to accept this License in order to receive or +run a copy of the Program. Ancillary propagation of a covered work +occurring solely as a consequence of using peer-to-peer transmission +to receive a copy likewise does not require acceptance. However, +nothing other than this License grants you permission to propagate or +modify any covered work. These actions infringe copyright if you do +not accept this License. Therefore, by modifying or propagating a +covered work, you indicate your acceptance of this License to do so. + + 10. Automatic Licensing of Downstream Recipients. + + Each time you convey a covered work, the recipient automatically +receives a license from the original licensors, to run, modify and +propagate that work, subject to this License. You are not responsible +for enforcing compliance by third parties with this License. + + An "entity transaction" is a transaction transferring control of an +organization, or substantially all assets of one, or subdividing an +organization, or merging organizations. If propagation of a covered +work results from an entity transaction, each party to that +transaction who receives a copy of the work also receives whatever +licenses to the work the party's predecessor in interest had or could +give under the previous paragraph, plus a right to possession of the +Corresponding Source of the work from the predecessor in interest, if +the predecessor has it or can get it with reasonable efforts. + + You may not impose any further restrictions on the exercise of the +rights granted or affirmed under this License. For example, you may +not impose a license fee, royalty, or other charge for exercise of +rights granted under this License, and you may not initiate litigation +(including a cross-claim or counterclaim in a lawsuit) alleging that +any patent claim is infringed by making, using, selling, offering for +sale, or importing the Program or any portion of it. + + 11. Patents. + + A "contributor" is a copyright holder who authorizes use under this +License of the Program or a work on which the Program is based. The +work thus licensed is called the contributor's "contributor version". + + A contributor's "essential patent claims" are all patent claims +owned or controlled by the contributor, whether already acquired or +hereafter acquired, that would be infringed by some manner, permitted +by this License, of making, using, or selling its contributor version, +but do not include claims that would be infringed only as a +consequence of further modification of the contributor version. For +purposes of this definition, "control" includes the right to grant +patent sublicenses in a manner consistent with the requirements of +this License. + + Each contributor grants you a non-exclusive, worldwide, royalty-free +patent license under the contributor's essential patent claims, to +make, use, sell, offer for sale, import and otherwise run, modify and +propagate the contents of its contributor version. + + In the following three paragraphs, a "patent license" is any express +agreement or commitment, however denominated, not to enforce a patent +(such as an express permission to practice a patent or covenant not to +sue for patent infringement). To "grant" such a patent license to a +party means to make such an agreement or commitment not to enforce a +patent against the party. + + If you convey a covered work, knowingly relying on a patent license, +and the Corresponding Source of the work is not available for anyone +to copy, free of charge and under the terms of this License, through a +publicly available network server or other readily accessible means, +then you must either (1) cause the Corresponding Source to be so +available, or (2) arrange to deprive yourself of the benefit of the +patent license for this particular work, or (3) arrange, in a manner +consistent with the requirements of this License, to extend the patent +license to downstream recipients. "Knowingly relying" means you have +actual knowledge that, but for the patent license, your conveying the +covered work in a country, or your recipient's use of the covered work +in a country, would infringe one or more identifiable patents in that +country that you have reason to believe are valid. + + If, pursuant to or in connection with a single transaction or +arrangement, you convey, or propagate by procuring conveyance of, a +covered work, and grant a patent license to some of the parties +receiving the covered work authorizing them to use, propagate, modify +or convey a specific copy of the covered work, then the patent license +you grant is automatically extended to all recipients of the covered +work and works based on it. + + A patent license is "discriminatory" if it does not include within +the scope of its coverage, prohibits the exercise of, or is +conditioned on the non-exercise of one or more of the rights that are +specifically granted under this License. You may not convey a covered +work if you are a party to an arrangement with a third party that is +in the business of distributing software, under which you make payment +to the third party based on the extent of your activity of conveying +the work, and under which the third party grants, to any of the +parties who would receive the covered work from you, a discriminatory +patent license (a) in connection with copies of the covered work +conveyed by you (or copies made from those copies), or (b) primarily +for and in connection with specific products or compilations that +contain the covered work, unless you entered into that arrangement, +or that patent license was granted, prior to 28 March 2007. + + Nothing in this License shall be construed as excluding or limiting +any implied license or other defenses to infringement that may +otherwise be available to you under applicable patent law. + + 12. No Surrender of Others' Freedom. + + If conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot convey a +covered work so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you may +not convey it at all. For example, if you agree to terms that obligate you +to collect a royalty for further conveying from those to whom you convey +the Program, the only way you could satisfy both those terms and this +License would be to refrain entirely from conveying the Program. + + 13. Use with the GNU Affero General Public License. + + Notwithstanding any other provision of this License, you have +permission to link or combine any covered work with a work licensed +under version 3 of the GNU Affero General Public License into a single +combined work, and to convey the resulting work. The terms of this +License will continue to apply to the part which is the covered work, +but the special requirements of the GNU Affero General Public License, +section 13, concerning interaction through a network will apply to the +combination as such. + + 14. Revised Versions of this License. + + The Free Software Foundation may publish revised and/or new versions of +the GNU General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + + Each version is given a distinguishing version number. If the +Program specifies that a certain numbered version of the GNU General +Public License "or any later version" applies to it, you have the +option of following the terms and conditions either of that numbered +version or of any later version published by the Free Software +Foundation. If the Program does not specify a version number of the +GNU General Public License, you may choose any version ever published +by the Free Software Foundation. + + If the Program specifies that a proxy can decide which future +versions of the GNU General Public License can be used, that proxy's +public statement of acceptance of a version permanently authorizes you +to choose that version for the Program. + + Later license versions may give you additional or different +permissions. However, no additional obligations are imposed on any +author or copyright holder as a result of your choosing to follow a +later version. + + 15. Disclaimer of Warranty. + + THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY +APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT +HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY +OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, +THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR +PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM +IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF +ALL NECESSARY SERVICING, REPAIR OR CORRECTION. + + 16. Limitation of Liability. + + IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS +THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY +GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE +USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF +DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD +PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), +EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF +SUCH DAMAGES. + + 17. Interpretation of Sections 15 and 16. + + If the disclaimer of warranty and limitation of liability provided +above cannot be given local legal effect according to their terms, +reviewing courts shall apply local law that most closely approximates +an absolute waiver of all civil liability in connection with the +Program, unless a warranty or assumption of liability accompanies a +copy of the Program in return for a fee. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +state the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . + +Also add information on how to contact you by electronic and paper mail. + + If the program does terminal interaction, make it output a short +notice like this when it starts in an interactive mode: + + Copyright (C) + This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, your program's commands +might be different; for a GUI interface, you would use an "about box". + + You should also get your employer (if you work as a programmer) or school, +if any, to sign a "copyright disclaimer" for the program, if necessary. +For more information on this, and how to apply and follow the GNU GPL, see +. + + The GNU General Public License does not permit incorporating your program +into proprietary programs. If your program is a subroutine library, you +may consider it more useful to permit linking proprietary applications with +the library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. But first, please read +. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/man/man1/pg_migrate.1 b/man/man1/pg_migrate.1 new file mode 100644 --- /dev/null +++ b/man/man1/pg_migrate.1 @@ -0,0 +1,90 @@ +.TH pg_migrate 1 "" +.SH NAME +.PP +pg_migrate \- PostgreSQL ORM migrations runner +.SH SYNOPSIS +.IP +.nf +\f[C] +pg_migrate\ COMMAND\ [directory] +\f[] +.fi +.SH DESCRIPTION +.PP +pg_migrate is a utility for managing migrations on a PostgreSQL +database. +It allows you to run migrations from a directory, only running those not +yet applied and rollback to previous versions. +For example, in development, use pg_migrate to iterate on your database +schema, and in production, use it to retain a rollback path when pushing +code that requires a new schema. +.PP +Migrations are executable Haskell source code files that run a single +migration and corresponding rollback. +All migrations for a project should be stored in the same directory. +See pg_migrate(5) for details on how migrations are run. +.SS Migration File Names +.PP +Migrations files are underscore delimited and contain the version +followed by a descriptive name: +.IP +.nf +\f[C] +\ \ 201304021245_create_users_table.hs +\f[] +.fi +.PP +Versions are ordered lexically and can be any string not containing the +characters \[aq].\[aq] or \[aq]_\[aq]. +However, a common choice is the GMT time of creation formatted in +decreasing order of significance: %Y%m%d%H%M. +.SS Database format +.PP +The only requirement on the database is that it contain a table +schema_migrations with a VARCHAR column version. +running "\f[I]pg_migrate init\f[]" will create such a table, by running +the following SQL: +.IP +.nf +\f[C] +\ \ CREATE\ TABLE\ schema_migrations\ ( +\ \ \ \ version\ VARCHAR(28) +\ \ ); +\f[] +.fi +.PP +When a migration is run, it\[aq]s version is inserted into this table. +When it is rolled back, the version is removed. +Maintaining all migration versions in the database allows us to easily +run only new migrations. +.SH COMMANDS +.SS migrate [directory] +.PP +Run all migrations found in \f[I]directory\f[], starting with the oldest +migrations not yet commited to the database. +If not specified, \f[I]directory\f[] is "db/migrations". +.SS rollback [directory] +.PP +Rollback the newest migration in \f[I]directory\f[] committed to the +database. +If not specified, \f[I]directory\f[] is "db/migrations". +.SS init +.PP +Prepare the database for using migrations by creating the +"schema_migrations" table. +This command will fail if such a table already exists without destroying +the existing table. +.SS dump [file] +.PP +Dump the current database schema to the \f[I]file\f[], or +"db/schema.sql" if not \f[I]file\f[] is specified. +The current implementation simply runs pg_dump(1): +.IP +.nf +\f[C] +pg_dump\ \-\-schema\-only\ \-O\ \-x +\f[] +.fi +.SH SEE ALSO +.PP +pg_migrate(5), pg_dump(1) diff --git a/man/man5/pg_migrate.5 b/man/man5/pg_migrate.5 new file mode 100644 --- /dev/null +++ b/man/man5/pg_migrate.5 @@ -0,0 +1,44 @@ +.TH pg_migrate 5 "" +.SH NAME +.PP +PostgreSQL ORM migration +.SH SYNOPSIS +.IP +.nf +\f[C] +201305041232_migration_file.hs\ COMMAND\ [\-\-with\-db\-commit] +\f[] +.fi +.SH DESCRIPTION +.PP +A Migrations is an executable Haskell source file (e.g. +a Haskell source file with a "\f[C]main\ ::\ IO\ ()\f[]" function, +runnable by \f[C]runghc\f[]). +It must respond to the commands "up" and "down" by running a migration +and rollback, respectively. +Unless the "\-\-with\-db\-commit" flag is set, the result of the +migration or rollback should not be committed to the database. +.PP +While you can implement a migration however you like, the module +\f[C]Database.PostgreSQL.Migrations\f[] in the \f[C]postgresql\-orm\f[] +package defines a function called \f[C]defaultMain\f[] that implements +most of the boiler plate functionality of a migration. +You need only implement the actual migration and rollback code. +.SH COMMANDS +.SS up +.PP +Upgrade the database by running the migration +.SS down +.PP +Downgrade the database by rolling back the migration +.SH FLAGS +.SS \-\-with\-db\-commit +.PP +MUST be included in order to actually commit the migration or rollback +to the database. +If this argument is not included, a test run is implied, and the +migration should affect the database, probably by rolling back the +transaction before exiting. +.SH SEE ALSO +.PP +pg_migrate(1), runghc(1) diff --git a/pg_migrate.hs b/pg_migrate.hs new file mode 100644 --- /dev/null +++ b/pg_migrate.hs @@ -0,0 +1,28 @@ +import Database.PostgreSQL.Migrate +import System.Environment +import System.Exit +import System.FilePath +import System.IO + +main :: IO () +main = do + args <- getArgs + ec <- case args of + "init":[] -> initializeDb >> return ExitSuccess + "dump":[] -> withFile (defaultMigrationsDir ".." "schema.sql") + WriteMode $ dumpDb + "dump":file:[] -> withFile file WriteMode $ dumpDb + "migrate":[] -> runMigrationsForDir stdout defaultMigrationsDir + "migrate":dir:[] -> runMigrationsForDir stdout dir + "rollback":[] -> runRollbackForDir defaultMigrationsDir + "rollback":dir:[] -> runRollbackForDir dir + _ -> do + progName <- getProgName + putStrLn $ "Usage: " ++ progName ++ " migrate|rollback [DIRECTORY]" + putStrLn $ " " ++ progName ++ " init" + putStrLn $ " " ++ progName ++ " dump [FILE]" + return $ ExitFailure 1 + if ec == ExitSuccess then + return () + else exitWith ec + diff --git a/postgresql-orm.cabal b/postgresql-orm.cabal new file mode 100644 --- /dev/null +++ b/postgresql-orm.cabal @@ -0,0 +1,69 @@ +name: postgresql-orm +version: 0.1 +cabal-version: >= 1.14 +build-type: Simple +license: GPL +license-file: LICENSE +author: Amit Levy and David Mazieres +maintainer: amit@amitlevy.com +category: Databases +synopsis: An ORM (Object Relational Mapping) and migrations DSL for PostgreSQL. +data-files: man/man1/pg_migrate.1 man/man5/pg_migrate.5 +description: + An ORM (Object Relational Mapping) and migrations DSL for PostgreSQL. See + "Database.PostgreSQL.ORM" for documentation. + +executable pg_migrate + default-language: Haskell2010 + Main-is: pg_migrate.hs + ghc-options: -Wall + build-depends: base < 6 + , blaze-builder + , bytestring + , directory + , filepath + , ghc-prim + , mtl + , postgresql-simple + , process + +library + default-language: Haskell2010 + build-depends: base < 6 + , blaze-builder + , bytestring + , directory + , filepath + , ghc-prim + , mtl + , postgresql-simple + , process + , text + , time + , transformers + , unix + , vector + ghc-options: -Wall -fno-warn-unused-do-bind + exposed-modules: Data.GetField + , Data.RequireSelector + , Database.PostgreSQL.Devel + , Database.PostgreSQL.Describe + , Database.PostgreSQL.Escape + , Database.PostgreSQL.Migrate + , Database.PostgreSQL.Migrations + , Database.PostgreSQL.ORM + , Database.PostgreSQL.ORM.Association + , Database.PostgreSQL.ORM.CreateTable + , Database.PostgreSQL.ORM.DBSelect + , Database.PostgreSQL.ORM.Model + , Database.PostgreSQL.ORM.SqlType + , Database.PostgreSQL.ORM.Validations + other-extensions: FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , MultiParamTypeClasses + , OverlappingInstances + , OverloadedStrings + , ScopedTypeVariables + , TypeOperators + , UndecidableInstances