diff --git a/pg-store.cabal b/pg-store.cabal --- a/pg-store.cabal +++ b/pg-store.cabal @@ -1,8 +1,8 @@ name: pg-store -version: 0.0.1 +version: 0.1.0 category: Database -synopsis: Dead simple storage interface to PostgreSQL -description: Dead simple storage interface to PostgreSQL +synopsis: Simple storage interface to PostgreSQL +description: Simple storage interface to PostgreSQL homepage: https://github.com/vapourismo/pg-store license: BSD3 license-file: LICENSE @@ -17,28 +17,28 @@ location: https://github.com/vapourismo/pg-store.git library - ghc-options: -Wall -fprof-auto -fno-warn-unused-do-bind -fno-warn-tabs - -fno-warn-name-shadowing + ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-tabs -fno-warn-name-shadowing default-language: Haskell2010 - build-depends: base >= 4.8.2.0 && < 5, - template-haskell, bytestring, text, postgresql-libpq, transformers, - attoparsec + build-depends: base >= 4.9 && < 5, + template-haskell >= 2.11 && < 3, + bytestring, text, postgresql-libpq, attoparsec, mtl, time hs-source-dirs: src - exposed-modules: Database.PostgreSQL.Store, - Database.PostgreSQL.Store.Table, + exposed-modules: Database.PostgreSQL.Store.Result, Database.PostgreSQL.Store.Columns, Database.PostgreSQL.Store.Query, - Database.PostgreSQL.Store.Result, - Database.PostgreSQL.Store.Errand + Database.PostgreSQL.Store.Errand, + Database.PostgreSQL.Store.Table, + Database.PostgreSQL.Store.OIDs, + Database.PostgreSQL.Store test-suite tests type: exitcode-stdio-1.0 - ghc-options: -Wall -fprof-auto -fno-warn-unused-do-bind -fno-warn-tabs - -fno-warn-name-shadowing + ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-tabs -fno-warn-name-shadowing default-language: Haskell2010 - build-depends: base, pg-store, hspec, QuickCheck, bytestring, text, postgresql-libpq + build-depends: base, pg-store, hspec, QuickCheck, bytestring, text, postgresql-libpq, mtl hs-source-dirs: tests - other-modules: Database.PostgreSQL.Store.ColumnsSpec, - Database.PostgreSQL.Store.TableSpec, - Database.PostgreSQL.Store.QuerySpec + other-modules: Test.Database.PostgreSQL.Store.Query, + Test.Database.PostgreSQL.Store.Columns, + Test.Database.PostgreSQL.Store.Table, + Test.Database.PostgreSQL.Store main-is: Main.hs diff --git a/src/Database/PostgreSQL/Store.hs b/src/Database/PostgreSQL/Store.hs --- a/src/Database/PostgreSQL/Store.hs +++ b/src/Database/PostgreSQL/Store.hs @@ -4,31 +4,49 @@ -- License: BSD3 -- Maintainer: Ole Krüger module Database.PostgreSQL.Store ( - -- * Tables - TableConstraint (..), - mkTable, - Row (..), - Reference (..), + -- * Errands + Errand, + ErrandError (..), + ErrorCode (..), + ExecStatus (..), + runErrand, + execute, + query, + query_, + queryWith, -- * Queries Query (..), pgsq, - mkCreateQuery, + pgss, - -- * Errands + QueryTable (..), + SelectorElement (..), + + -- * Values + Value (..), + Column (..), + + -- * Results + Result (..), + ResultProcessor, ResultError (..), - ErrandError (..), - Errand, - runErrand, - query, - query_, - insert, - find, - update, - delete + skipColumn, + unpackColumn, + + Single (..), + Reference (..), + + -- * Tables + Table (..), + mkCreateQuery, + + mkTable, + TableConstraint (..) ) where -import Database.PostgreSQL.Store.Table -import Database.PostgreSQL.Store.Query +import Database.PostgreSQL.Store.Columns import Database.PostgreSQL.Store.Errand +import Database.PostgreSQL.Store.Query import Database.PostgreSQL.Store.Result +import Database.PostgreSQL.Store.Table diff --git a/src/Database/PostgreSQL/Store/Columns.hs b/src/Database/PostgreSQL/Store/Columns.hs --- a/src/Database/PostgreSQL/Store/Columns.hs +++ b/src/Database/PostgreSQL/Store/Columns.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards, FlexibleInstances, TemplateHaskell #-} -- | -- Module: Database.PostgreSQL.Store.Columns @@ -10,85 +10,42 @@ Value (..), -- * - ColumnDescription (..), - makeColumnDescription, - - -- * - sanitizeName, - sanitizeName', - identField, - identField', - - -- * - Column (..), + Column (..) ) where -import Language.Haskell.TH - import Data.Int import Data.Word import Data.Bits +import Data.Time import Data.Monoid import Data.Typeable -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy as TL -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as BL import Data.ByteString.Builder import Data.Attoparsec.ByteString import Data.Attoparsec.ByteString.Char8 (signed, decimal) -import qualified Database.PostgreSQL.LibPQ as P +import Database.PostgreSQL.LibPQ (Oid) +import qualified Database.PostgreSQL.Store.OIDs as OID -- | Query parameter or value of a column - see 'pack' on how to generate 'Value's manually but -- conveniently. data Value = Value { -- | Type object identifier - valueType :: P.Oid, + valueType :: Oid, -- | Data value - valueData :: B.ByteString, - - -- | Data format - valueFormat :: P.Format + valueData :: B.ByteString } | NullValue deriving (Show, Eq, Ord) --- | Description of a column -data ColumnDescription = ColumnDescription { - -- | Type name (e.g. bool, integer) - columnTypeName :: String, - - -- | Can the column be null? - columnTypeNull :: Bool -} deriving (Show, Eq, Ord) - --- | Generate column description in SQL. Think @CREATE TABLE@. -makeColumnDescription :: ColumnDescription -> String -makeColumnDescription ColumnDescription {..} = - columnTypeName ++ (if columnTypeNull then "" else " NOT NULL") - --- | Generate the sanitized representation of a name. -sanitizeName :: Name -> String -sanitizeName = show - --- | Similiar to "sanitizeName" but encloses the name in quotes. -sanitizeName' :: Name -> String -sanitizeName' name = "\"" ++ sanitizeName name ++ "\"" - --- | Generate the name for the identifying field. -identField :: Name -> String -identField name = show name ++ "$id" - --- | Similiar to "identField" but encloses the name in quotes. -identField' :: Name -> String -identField' name = "\"" ++ identField name ++ "\"" - --- | Column type +-- | Types which implement this type class may be used as column types. class Column a where -- | Pack column value. pack :: a -> Value @@ -96,192 +53,258 @@ -- | Unpack column value. unpack :: Value -> Maybe a - -- | Descripe the column type. - describeColumn :: Proxy a -> ColumnDescription + -- | Name of the underlying SQL type. + columnTypeName :: Proxy a -> String + -- | May the column be NULL? + columnAllowNull :: Proxy a -> Bool + columnAllowNull _proxy = False + + -- | A condition that must hold true for the column. + columnCheck :: Proxy a -> String -> Maybe String + columnCheck _proxy _identifier = Nothing + + -- | Generate column description in SQL. Think @CREATE TABLE@. + columnDescription :: Proxy a -> String -> String + columnDescription proxy identifier = + identifier ++ " " ++ + columnTypeName proxy ++ + if columnAllowNull proxy then "" else " NOT NULL" ++ + case columnCheck proxy identifier of + Just stmt -> " CHECK (" ++ stmt ++ ")" + Nothing -> "" + +instance Column Value where + pack = id + unpack = Just + columnTypeName _ = "blob" + instance (Column a) => Column (Maybe a) where pack = maybe NullValue pack unpack NullValue = Just Nothing - unpack val = fmap Just (unpack val) + unpack val = Just <$> unpack val - describeColumn proxy = - (describeColumn (transformProxy proxy)) {columnTypeNull = True} - where - transformProxy :: Proxy (Maybe a) -> Proxy a - transformProxy _ = Proxy + columnTypeName proxy = columnTypeName ((const Proxy :: Proxy (Maybe b) -> Proxy b) proxy) + columnAllowNull _ = True + columnCheck proxy = columnCheck ((const Proxy :: Proxy (Maybe b) -> Proxy b) proxy) instance Column Bool where - pack v = - Value { - valueType = P.Oid 16, - valueData = if v then "true" else "false", - valueFormat = P.Text - } + pack True = Value $(OID.bool) "true" + pack _ = Value $(OID.bool) "false" - unpack (Value (P.Oid 16) "true" P.Text) = Just True - unpack (Value (P.Oid 16) "TRUE" P.Text) = Just True - unpack (Value (P.Oid 16) "t" P.Text) = Just True - unpack (Value (P.Oid 16) "y" P.Text) = Just True - unpack (Value (P.Oid 16) "yes" P.Text) = Just True - unpack (Value (P.Oid 16) "on" P.Text) = Just True - unpack (Value (P.Oid 16) "1" P.Text) = Just True - unpack (Value (P.Oid 16) _ P.Text) = Just False - unpack _ = Nothing + unpack (Value $(OID.bool) "true") = Just True + unpack (Value $(OID.bool) "TRUE") = Just True + unpack (Value $(OID.bool) "t" ) = Just True + unpack (Value $(OID.bool) "y" ) = Just True + unpack (Value $(OID.bool) "yes" ) = Just True + unpack (Value $(OID.bool) "YES" ) = Just True + unpack (Value $(OID.bool) "on" ) = Just True + unpack (Value $(OID.bool) "ON" ) = Just True + unpack (Value $(OID.bool) "1" ) = Just True + unpack (Value $(OID.bool) _ ) = Just False + unpack _ = Nothing - describeColumn _ = - ColumnDescription { - columnTypeName = "bool", - columnTypeNull = False - } + columnTypeName _ = "bool" instance Column Int where - pack n = - Value { - valueType = P.Oid 23, - valueData = buildByteString intDec n, - valueFormat = P.Text - } + pack n = Value $(OID.int8) (buildByteString intDec n) - unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat - unpack (Value (P.Oid 23) dat P.Text) = parseMaybe (signed decimal) dat - unpack _ = Nothing + unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat + unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat + unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat + unpack _ = Nothing - describeColumn _ = - ColumnDescription { - columnTypeName = "integer", - columnTypeNull = False - } + columnTypeName _ = "int8" + columnCheck _ nm = + Just (nm ++ " >= " ++ show (minBound :: Int) ++ + " AND " ++ + nm ++ " <= " ++ show (maxBound :: Int)) + instance Column Int8 where - pack n = - Value { - valueType = P.Oid 21, - valueData = buildByteString int8Dec n, - valueFormat = P.Text - } + pack n = Value $(OID.int2) (buildByteString int8Dec n) - unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat - unpack _ = Nothing + unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat + unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat + unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat + unpack _ = Nothing - describeColumn _ = - ColumnDescription { - columnTypeName = "smallint", - columnTypeNull = False - } + columnTypeName _ = "int2" instance Column Int16 where - pack n = - Value { - valueType = P.Oid 21, - valueData = buildByteString int16Dec n, - valueFormat = P.Text - } + pack n = Value $(OID.int2) (buildByteString int16Dec n) - unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat - unpack _ = Nothing + unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat + unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat + unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat + unpack _ = Nothing - describeColumn _ = - ColumnDescription { - columnTypeName = "smallint", - columnTypeNull = False - } + columnTypeName _ = "int2" instance Column Int32 where - pack n = - Value { - valueType = P.Oid 23, - valueData = buildByteString int32Dec n, - valueFormat = P.Text - } + pack n = Value $(OID.int4) (buildByteString int32Dec n) - unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat - unpack (Value (P.Oid 23) dat P.Text) = parseMaybe (signed decimal) dat - unpack _ = Nothing + unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat + unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat + unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat + unpack _ = Nothing - describeColumn _ = - ColumnDescription { - columnTypeName = "integer", - columnTypeNull = False - } + columnTypeName _ = "int4" instance Column Int64 where - pack n = - Value { - valueType = P.Oid 20, - valueData = buildByteString int64Dec n, - valueFormat = P.Text - } + pack n = Value $(OID.int8) (buildByteString int64Dec n) - unpack (Value (P.Oid 20) dat P.Text) = parseMaybe (signed decimal) dat - unpack (Value (P.Oid 21) dat P.Text) = parseMaybe (signed decimal) dat - unpack (Value (P.Oid 23) dat P.Text) = parseMaybe (signed decimal) dat - unpack _ = Nothing + unpack (Value $(OID.int2) dat) = parseMaybe (signed decimal) dat + unpack (Value $(OID.int4) dat) = parseMaybe (signed decimal) dat + unpack (Value $(OID.int8) dat) = parseMaybe (signed decimal) dat + unpack _ = Nothing - describeColumn _ = - ColumnDescription { - columnTypeName = "bigint", - columnTypeNull = False - } + columnTypeName _ = "int8" +-- | Does "Word" require to be stored in type "numeric"? +wordRequiresNumeric :: Bool +wordRequiresNumeric = + -- int8 upper bound is 2^63 - 1 (9223372036854775807) + (fromIntegral (maxBound :: Word) :: Integer) > 9223372036854775807 + +instance Column Word where + pack n | wordRequiresNumeric = Value $(OID.numeric) (buildByteString wordDec n) + | otherwise = Value $(OID.int8) (buildByteString wordDec n) + + unpack (Value $(OID.int2) dat) = parseMaybe decimal dat + unpack (Value $(OID.int4) dat) = parseMaybe decimal dat + unpack (Value $(OID.int8) dat) = parseMaybe decimal dat + unpack (Value $(OID.numeric) dat) = parseMaybe decimal dat + unpack _ = Nothing + + columnTypeName _ = if wordRequiresNumeric then "numeric(20, 0)" else "int8" + + columnCheck _ nm = + Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word)) + +instance Column Word8 where + pack n = Value $(OID.int2) (buildByteString word8Dec n) + + unpack (Value $(OID.int2) dat) = parseMaybe decimal dat + unpack (Value $(OID.int4) dat) = parseMaybe decimal dat + unpack (Value $(OID.int8) dat) = parseMaybe decimal dat + unpack _ = Nothing + + columnTypeName _ = "int2" + + columnCheck _ nm = + Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word8)) + +instance Column Word16 where + pack n = Value $(OID.int4) (buildByteString word16Dec n) + + unpack (Value $(OID.int2) dat) = parseMaybe decimal dat + unpack (Value $(OID.int4) dat) = parseMaybe decimal dat + unpack (Value $(OID.int8) dat) = parseMaybe decimal dat + unpack _ = Nothing + + columnTypeName _ = "int4" + + columnCheck _ nm = + Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word16)) + +instance Column Word32 where + pack n = Value $(OID.int8) (buildByteString word32Dec n) + + unpack (Value $(OID.int2) dat) = parseMaybe decimal dat + unpack (Value $(OID.int4) dat) = parseMaybe decimal dat + unpack (Value $(OID.int8) dat) = parseMaybe decimal dat + unpack _ = Nothing + + columnTypeName _ = "bigint" + + columnCheck _ nm = + Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word32)) + +instance Column Word64 where + pack n = Value $(OID.numeric) (buildByteString word64Dec n) + + unpack (Value $(OID.int2) dat) = parseMaybe decimal dat + unpack (Value $(OID.int4) dat) = parseMaybe decimal dat + unpack (Value $(OID.int8) dat) = parseMaybe decimal dat + unpack (Value $(OID.numeric) dat) = parseMaybe decimal dat + unpack _ = Nothing + + columnTypeName _ = "numeric(20, 0)" + + columnCheck _ nm = + Just (nm ++ " >= 0 AND " ++ nm ++ " <= " ++ show (maxBound :: Word64)) + +instance Column Integer where + pack n = Value $(OID.numeric) (buildByteString integerDec n) + + unpack (Value $(OID.int2) dat) = parseMaybe decimal dat + unpack (Value $(OID.int4) dat) = parseMaybe decimal dat + unpack (Value $(OID.int8) dat) = parseMaybe decimal dat + unpack (Value $(OID.numeric) dat) = parseMaybe decimal dat + unpack _ = Nothing + + columnTypeName _ = "numeric" + +instance Column UTCTime where + pack t = Value $(OID.timestamp) (C8.pack (formatTime defaultTimeLocale "%F %T%Q" t)) + + unpack (Value $(OID.timestamp) dat) = + parseTimeM False defaultTimeLocale "%F %T%Q" (C8.unpack dat) + unpack _ = Nothing + + columnTypeName _ = "timestamp" + instance Column [Char] where - pack str = - pack (buildByteString stringUtf8 str) + pack str = Value $(OID.text) (buildByteString stringUtf8 str) - unpack val = - T.unpack . T.decodeUtf8 <$> unpack val + unpack (Value $(OID.varchar) dat) = pure (T.unpack (T.decodeUtf8 dat)) + unpack (Value $(OID.char) dat) = pure (T.unpack (T.decodeUtf8 dat)) + unpack (Value $(OID.text) dat) = pure (T.unpack (T.decodeUtf8 dat)) + unpack _ = Nothing - describeColumn _ = - describeColumn (Proxy :: Proxy B.ByteString) + columnTypeName _ = "text" instance Column T.Text where - pack txt = - pack (T.encodeUtf8 txt) + pack txt = Value $(OID.text) (T.encodeUtf8 txt) - unpack val = - T.decodeUtf8 <$> unpack val + unpack (Value $(OID.varchar) dat) = pure (T.decodeUtf8 dat) + unpack (Value $(OID.char) dat) = pure (T.decodeUtf8 dat) + unpack (Value $(OID.text) dat) = pure (T.decodeUtf8 dat) + unpack _ = Nothing - describeColumn _ = - describeColumn (Proxy :: Proxy B.ByteString) + columnTypeName _ = "text" instance Column TL.Text where - pack txt = - pack (TL.encodeUtf8 txt) + pack txt = pack (TL.toStrict txt) - unpack val = - TL.decodeUtf8 <$> unpack val + unpack val = TL.fromStrict <$> unpack val - describeColumn _ = - describeColumn (Proxy :: Proxy BL.ByteString) + columnTypeName _ = columnTypeName (Proxy :: Proxy T.Text) + columnAllowNull _ = columnAllowNull (Proxy :: Proxy T.Text) + columnCheck _ = columnCheck (Proxy :: Proxy T.Text) instance Column B.ByteString where - pack bs = - Value { - valueType = P.Oid 17, - valueData = toTextByteArray bs, - valueFormat = P.Text - } + pack bs = Value $(OID.bytea) (encodeByteaHex bs) - unpack (Value (P.Oid 17) dat P.Binary) = pure dat - unpack (Value (P.Oid 17) dat P.Text) = fromTextByteArray dat - unpack _ = Nothing + unpack (Value $(OID.varchar) dat) = pure dat + unpack (Value $(OID.char) dat) = pure dat + unpack (Value $(OID.text) dat) = pure dat + unpack (Value $(OID.bytea) dat) = decodeByteaHex dat + unpack _ = Nothing - describeColumn _ = - ColumnDescription { - columnTypeName = "bytea", - columnTypeNull = False - } + columnTypeName _ = "bytea" instance Column BL.ByteString where - pack bs = - pack (BL.toStrict bs) + pack bs = pack (BL.toStrict bs) - unpack val = - BL.fromStrict <$> unpack val + unpack val = BL.fromStrict <$> unpack val - describeColumn _ = - describeColumn (Proxy :: Proxy B.ByteString) + columnTypeName _ = columnTypeName (Proxy :: Proxy B.ByteString) + columnAllowNull _ = columnAllowNull (Proxy :: Proxy B.ByteString) + columnCheck _ = columnCheck (Proxy :: Proxy B.ByteString) -- | Produce the two-digit hexadecimal representation of a 8-bit word. word8ToHex :: Word8 -> B.ByteString @@ -316,8 +339,8 @@ } -- | Unpack a byte array in textual representation. -fromTextByteArray :: B.ByteString -> Maybe B.ByteString -fromTextByteArray bs +decodeByteaHex :: B.ByteString -> Maybe B.ByteString +decodeByteaHex bs | B.length bs >= 2 && mod (B.length bs) 2 == 0 && B.isPrefixOf "\\x" bs = Just (B.pack (unfoldHex (B.drop 2 bs))) | otherwise = Nothing @@ -326,8 +349,8 @@ unfoldHex bs = hexToWord8 (B.take 2 bs) : unfoldHex (B.drop 2 bs) -- | Pack textual representation of a byte array. -toTextByteArray :: B.ByteString -> B.ByteString -toTextByteArray bs = +encodeByteaHex :: B.ByteString -> B.ByteString +encodeByteaHex bs = "\\x" <> B.concatMap word8ToHex bs -- | Finish the parsing process. diff --git a/src/Database/PostgreSQL/Store/Errand.hs b/src/Database/PostgreSQL/Store/Errand.hs --- a/src/Database/PostgreSQL/Store/Errand.hs +++ b/src/Database/PostgreSQL/Store/Errand.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} -- | -- Module: Database.PostgreSQL.Store.Errand @@ -6,19 +6,29 @@ -- License: BSD3 -- Maintainer: Ole Krüger module Database.PostgreSQL.Store.Errand ( + -- * Errand ErrandError (..), + ErrorCode (..), + P.ExecStatus (..), + Errand, runErrand, - raiseErrandError, - executeQuery, + + execute, query, - query_ + query_, + queryWith, + + -- * Result parser + Result (..), + Single (..) ) where -import Control.Monad.Trans.Class -import Control.Monad.Trans.Except -import Control.Monad.Trans.Reader +import Control.Monad.Trans +import Control.Monad.Except +import Control.Monad.Reader +import Data.Maybe import qualified Data.ByteString as B import qualified Database.PostgreSQL.LibPQ as P @@ -29,60 +39,133 @@ -- | Error during errand data ErrandError = NoResult - | ExecError P.ExecStatus (Maybe B.ByteString) - | ResultError ResultError - | UnexpectedEmptyResult + -- ^ No 'Result' has been returned. + | EmptyResult + -- ^ Result set is empty. | UserError String + -- ^ A user has thrown an error. + | ExecError P.ExecStatus ErrorCode B.ByteString B.ByteString B.ByteString + -- ^ Query execution failed. + | ResultError ResultError + -- ^ Result processing failed. deriving (Show, Eq) +-- | Error codes +data ErrorCode + = UnknownErrorCause B.ByteString + | IntegrityViolation + | RestrictViolation + | NotNullViolation + | ForeignKeyViolation + | UniqueViolation + | CheckViolation + | ExclusionViolation + deriving (Show, Eq) + -- | An interaction with the database -type Errand = ReaderT P.Connection (ExceptT ErrandError IO) +newtype Errand a = Errand (ReaderT P.Connection (ExceptT ErrandError IO) a) + deriving (Functor, Applicative, Monad, MonadIO, MonadError ErrandError) -- | Run an errand. runErrand :: P.Connection -> Errand a -> IO (Either ErrandError a) -runErrand con errand = +runErrand con (Errand errand) = runExceptT (runReaderT errand con) --- | Raise an error. -raiseErrandError :: ErrandError -> Errand a -raiseErrandError err = - lift (ExceptT (pure (Left err))) +-- | Execute a query and return the internal raw result. +execute :: Query -> Errand P.Result +execute (Query statement params) = Errand . ReaderT $ \ con -> do + res <- ExceptT $ + transformResult <$> P.execParams con statement (map transformParam params) P.Text + status <- lift (P.resultStatus res) --- | Execute a query and return its result. -executeQuery :: Query -> Errand P.Result -executeQuery (Query statement params) = do - con <- ask - lift $ do - res <- ExceptT (transformResult <$> P.execParams con statement transformedParams P.Text) - status <- lift (P.resultStatus res) + case status of + P.CommandOk -> pure res + P.TuplesOk -> pure res - case status of - P.CommandOk -> pure res - P.TuplesOk -> pure res + other -> do + (state, msg, detail, hint) <- lift $ + (,,,) <$> P.resultErrorField res P.DiagSqlstate + <*> P.resultErrorField res P.DiagMessagePrimary + <*> P.resultErrorField res P.DiagMessageDetail + <*> P.resultErrorField res P.DiagMessageHint - other -> do - msg <- lift (P.resultErrorMessage res) - throwE (ExecError other msg) + let cause = + case fromMaybe B.empty state of + "23000" -> IntegrityViolation + "23001" -> RestrictViolation + "23502" -> NotNullViolation + "23503" -> ForeignKeyViolation + "23505" -> UniqueViolation + "23514" -> CheckViolation + "23P01" -> ExclusionViolation + code -> UnknownErrorCause code + throwError (ExecError other + cause + (fromMaybe B.empty msg) + (fromMaybe B.empty detail) + (fromMaybe B.empty hint)) + where - transformResult = - maybe (Left NoResult) pure + -- Turn 'Maybe P.Result' into 'Either ErrandError P.Result' + transformResult = maybe (throwError NoResult) pure - transformParam Value {..} = Just (valueType, valueData, valueFormat) - transformParam NullValue = Nothing + -- Turn 'Value' into 'Maybe (P.Oid, B.ByteString, P.Format)' + transformParam (Value typ dat) = Just (typ, dat, P.Text) + transformParam NullValue = Nothing - transformedParams = - map transformParam params +-- | Allows you to implement a custom result parser for your type. +-- 'mkTable' can implement this for your type. +class Result a where + queryResultProcessor :: ResultProcessor a +-- | Combine result parsers sequencially. +instance (Result a, Result b) => Result (a, b) where + queryResultProcessor = + (,) <$> queryResultProcessor <*> queryResultProcessor + +instance (Result a, Result b, Result c) => Result (a, b, c) where + queryResultProcessor = + (,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor + +instance (Result a, Result b, Result c, Result d) => Result (a, b, c, d) where + queryResultProcessor = + (,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor + +instance (Result a, Result b, Result c, Result d, Result e) => Result (a, b, c, d, e) where + queryResultProcessor = + (,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor + +instance (Result a, Result b, Result c, Result d, Result e, Result f) => Result (a, b, c, d, e, f) where + queryResultProcessor = + (,,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor + +instance (Result a, Result b, Result c, Result d, Result e, Result f, Result g) => Result (a, b, c, d, e, f, g) where + queryResultProcessor = + (,,,,,,) <$> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor <*> queryResultProcessor + -- | Execute a query and process its result set. --- It is essential that all fields required by the underlying result parser are present. query :: (Result a) => Query -> Errand [a] -query qry = do - result <- executeQuery qry - lift (withExceptT ResultError (runResultProcessor result resultProcessor)) +query qry = + queryWith qry queryResultProcessor --- | Execute a query. +-- | Execute a query and dismiss its result. query_ :: Query -> Errand () query_ qry = - () <$ executeQuery qry + () <$ execute qry +-- | Execute a query and process its result set using the provided result processor. +queryWith :: Query -> ResultProcessor a -> Errand [a] +queryWith qry proc = do + result <- execute qry + Errand (lift (withExceptT ResultError (processResult result proc))) + +-- | Helper type to capture an single column. +newtype Single a = Single { fromSingle :: a } + deriving (Eq, Ord) + +instance (Show a) => Show (Single a) where + show = show . fromSingle + +instance (Column a) => Result (Single a) where + queryResultProcessor = Single <$> unpackColumn diff --git a/src/Database/PostgreSQL/Store/OIDs.hs b/src/Database/PostgreSQL/Store/OIDs.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Store/OIDs.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, RankNTypes #-} + +-- | +-- Module: Database.PostgreSQL.Store.OIDs +-- Copyright: (c) Ole Krüger 2016 +-- License: BSD3 +-- Maintainer: Ole Krüger +module Database.PostgreSQL.Store.OIDs ( + OIDQ, + + bool, + int2, + int4, + int8, + float4, + float8, + numeric, + char, + varchar, + text, + bytea, + timestamp, + timestamptz +) where + +import Language.Haskell.TH +import qualified Database.PostgreSQL.LibPQ as P + +class GenOID a where + genOID :: Integer -> Q a + +instance GenOID Exp where + genOID oid = [e| P.Oid $(litE (IntegerL oid)) |] + +instance GenOID Pat where + genOID oid = [p| P.Oid $(pure (LitP (IntegerL oid))) |] + +-- | A type which can be coerced into @Q Exp@ or @Q Pat@. +type OIDQ = forall a . GenOID a => Q a + +-- | Boolean +bool :: OIDQ +bool = genOID 16 + +-- | 16-bit integer +int2 :: OIDQ +int2 = genOID 21 + +-- | 32-bit integer +int4 :: OIDQ +int4 = genOID 23 + +-- | 64-bit integer +int8 :: OIDQ +int8 = genOID 20 + +-- | Single-precision floating-point number +float4 :: OIDQ +float4 = genOID 700 + +-- | Double-precision floating-point number +float8 :: OIDQ +float8 = genOID 701 + +-- | Arbitrary precision number +numeric :: OIDQ +numeric = genOID 1700 + +-- | Fixed-length string +char :: OIDQ +char = genOID 1042 + +-- | Variable-length string +varchar :: OIDQ +varchar = genOID 1043 + +-- | Unlimited variable-length string +text :: OIDQ +text = genOID 25 + +-- | Byte array +bytea :: OIDQ +bytea = genOID 17 + +-- | Timestamp without timezone +timestamp :: OIDQ +timestamp = genOID 1114 + +-- | Timestamp with timezone +timestamptz :: OIDQ +timestamptz = genOID 1184 diff --git a/src/Database/PostgreSQL/Store/Query.hs b/src/Database/PostgreSQL/Store/Query.hs --- a/src/Database/PostgreSQL/Store/Query.hs +++ b/src/Database/PostgreSQL/Store/Query.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell, BangPatterns #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, BangPatterns, + GeneralizedNewtypeDeriving, MultiParamTypeClasses, FunctionalDependencies, + FlexibleInstances, FlexibleContexts, TypeFamilies #-} -- | -- Module: Database.PostgreSQL.Store.Query @@ -6,62 +8,59 @@ -- License: BSD3 -- Maintainer: Ole Krüger module Database.PostgreSQL.Store.Query ( - -- * Tables - TableDescription (..), - DescribableTable (..), - - -- * Querying + -- * Query Query (..), - pgsq + SelectorElement (..), + QueryTable (..), + pgsq, + pgss, + + -- * Helpers + quoteIdentifier, + + -- * Query builder + QueryCode, + QueryBuildable, + QueryBuilder, + runQueryBuilder, + writeCode, + writeStringCode, + writeIdentifier, + writeAbsIdentifier, + writeParam, + writeColumn, + intercalateBuilder ) where import Language.Haskell.TH import Language.Haskell.TH.Quote import Control.Applicative -import Control.Monad.Trans.Class -import Control.Monad.Trans.State +import Control.Monad.State.Strict -import Data.Char +import Data.List +import Data.Proxy +import Data.Monoid import Data.String -import Data.Typeable -import Data.Attoparsec.Text -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import qualified Data.Text as T import qualified Data.ByteString as B -import Database.PostgreSQL.Store.Columns - --- | Description of a table type -data TableDescription = TableDescription { - -- | Table name - tableName :: String, - - -- | Identifier column name - tableIdentifier :: String -} deriving (Show, Eq, Ord) - --- | Attach meta data to a table type -class DescribableTable a where - -- | Describe the table. - describeTable :: Proxy a -> TableDescription - describeTable proxy = - TableDescription { - tableName = describeTableName proxy, - tableIdentifier = describeTableIdentifier proxy - } +import Data.Char +import Data.Attoparsec.Text - -- | Describe table name. - describeTableName :: Proxy a -> String - describeTableName proxy = - tableName (describeTable proxy) +import Database.PostgreSQL.Store.Columns - -- | Describe table identifier. - describeTableIdentifier :: Proxy a -> String - describeTableIdentifier proxy = - tableIdentifier (describeTable proxy) +-- | Properly quote an identifier. +quoteIdentifier :: String -> String +quoteIdentifier name = + '"' : stripQuotes name ++ "\"" + where + stripQuotes [] = [] + stripQuotes ('"' : xs) = '"' : '"' : stripQuotes xs + stripQuotes (x : xs) = x : stripQuotes xs --- | Query including statement and parameters. +-- | Query including statement and parameters +-- -- Use the 'pgsq' quasi-quoter to conveniently create queries. data Query = Query { -- | Statement @@ -71,72 +70,248 @@ queryParams :: ![Value] } deriving (Show, Eq, Ord) --- | Generate a 'Query' from a SQL statement. +-- | @SELECT@ expression +data SelectorElement + = SelectorField String + -- ^ Select a field. The field nme will be quoted and properly escaped. + | SelectorSpecial String + -- ^ Select a special expression. The expression will be inlined as is. + deriving (Show, Eq, Ord) + +-- | A type which implements this class can be used as a table in a quasi-quoted query. +-- 'mkTable' can implement this for you. +class QueryTable a where + -- | Unquoted name of the table + tableName :: Proxy a -> String + + -- | Unquoted name of the ID field + tableIDName :: Proxy a -> String + + -- | Selectors needed to retrieve all fields necessary to construct the type - think @SELECT@. + tableSelectors :: Proxy a -> [SelectorElement] + +-- | Generate the quoted identifier for a table. +makeTableIdentifier :: (QueryTable a, IsString b) => Proxy a -> b +makeTableIdentifier proxy = + fromString (quoteIdentifier (tableName proxy)) + +-- | Generate the quoted identifier for table's id column. +makeTableIDIdentifier :: (QueryTable a, IsString b) => Proxy a -> b +makeTableIDIdentifier proxy = + fromString (quoteIdentifier (tableName proxy) ++ + "." ++ + quoteIdentifier (tableIDName proxy)) + +-- | Generate the list of expression used as selector. +makeTableSelectors :: (QueryTable a, IsString b) => Proxy a -> b +makeTableSelectors proxy = + fromString (intercalate ", " (map makeElement (tableSelectors proxy))) + where + makeElement (SelectorField name) = + quoteIdentifier (tableName proxy) ++ "." ++ quoteIdentifier name + makeElement (SelectorSpecial expr) = + expr + +-- | Query segment +data Segment + = SSelector String + | STable String + | SVariable String + | SIdentifier String + | SQuote Char String + | SOther String + +-- | Name +name :: Parser String +name = + (:) <$> (letter <|> char '_') <*> many (satisfy isAlphaNum <|> char '_') + +-- | Type name +typeName :: Parser String +typeName = + (:) <$> satisfy isUpper <*> many (satisfy isAlphaNum <|> char '_') + +-- | Qualified type name +qualifiedTypeName :: Parser String +qualifiedTypeName = do + intercalate "." <$> sepBy1 typeName (char '.') + +-- | Quote +quote :: Char -> Parser Segment +quote delim = do + char delim + cnt <- concat <$> many (choice [escapedDelim, notDelim]) + char delim + pure (SQuote delim cnt) + where + escapedDelim = (\ a b -> [a, b]) <$> char '\\' <*> char delim + notDelim = (: []) <$> notChar delim + +-- | Segments +segments :: Parser [Segment] +segments = + many (choice [quote '"', + quote '\'', + char '#' >> SSelector <$> qualifiedTypeName, + char '@' >> STable <$> qualifiedTypeName, + char '&' >> SIdentifier <$> qualifiedTypeName, + char '$' >> SVariable <$> name, + SOther "#" <$ char '#', + SOther "@" <$ char '@', + SOther "&" <$ char '&', + SOther "$" <$ char '$', + SOther <$> some (satisfy (notInClass "\"'#@&$"))]) + +-- | Reduce segments in order to resolve names and collect query parameters. +reduceSegment :: Segment -> QueryBuilder [Q Exp] (Q Exp) +reduceSegment seg = + case seg of + SOther str -> + writeStringCode str + + SQuote delim cnt -> + writeStringCode (delim : cnt ++ [delim]) + + SVariable varName -> writeParam $ do + mbName <- lookupValueName varName + case mbName of + Just name -> [e| pack $(varE name) |] + Nothing -> fail ("'" ++ varName ++ "' does not refer to anything") + + STable tableName -> writeCode $ do + mbName <- lookupTypeName tableName + case mbName of + Just table -> [e| makeTableIdentifier (Proxy :: Proxy $(conT table)) |] + Nothing -> fail ("'" ++ tableName ++ "' does not refer to anything") + + SSelector tableName -> writeCode $ do + mbName <- lookupTypeName tableName + case mbName of + Just table -> [e| makeTableSelectors (Proxy :: Proxy $(conT table)) |] + Nothing -> fail ("'" ++ tableName ++ "' does not refer to anything") + + SIdentifier tableName -> writeCode $ do + mbName <- lookupTypeName tableName + case mbName of + Just table -> [e| makeTableIDIdentifier (Proxy :: Proxy $(conT table)) |] + Nothing -> fail ("'" ++ tableName ++ "' does not refer to anything") + +-- | Parse quasi-quoted query. +parseStoreQueryE :: String -> Q Exp +parseStoreQueryE code = do + case parseOnly (segments <* endOfInput) (T.pack code) of + Left msg -> + fail msg + + Right xs -> do + runQueryBuilder (mapM_ reduceSegment xs) + +-- | This quasi-quoter allows you to generate instances of 'Query'. It lets you write SQL with some +-- small enhancements. 'pgsq' heavily relies on 'QueryTable' which can be implemented by 'mkTable' +-- for a type of your choice. -- --- = Table and column names +-- Some syntax definitions that might be useful later on: -- --- All plain identifiers will be treated as Haskell names. They are going to be resolved to their --- fully-qualified and quoted version. Beware, the use of names which don't refer to a table type --- or field will likely result in unknown table or column errors. The associated table name of a --- type is retrieved using 'describeTableName'. --- If you don't want a name to be resolved use a quoted identifier. +-- > TypeName ::= UpperAlpha {AlphaNumeric | '_'} +-- > Name ::= (Alpha | '_') {AlphaNumeric | '_'} +-- > QualifiedTypeName ::= {TypeName '.'} TypeName -- --- Example: +-- @Alpha@ includes all alphabetical characters; @UpperAlpha@ includes all upper-case alphabetical +-- characters; @AlphaNumeric@ includes all alpha-numeric characters. -- --- @ --- {-\# LANGUAGE QuasiQuotes \#-} --- module MyModule where +-- = Embed values +-- You can embed values whose types implement 'Column'. -- --- ... +-- > ValueExp ::= '$' Name -- --- data Table = Table { myField :: Int } --- 'mkTable' ''Table [] +-- > magicNumber :: Int +-- > magicNumber = 1337 +-- > +-- > myQuery :: Query +-- > myQuery = +-- > [pgsq| SELECT * FROM table t WHERE t.column1 > $magicNumber AND t.column2 < $otherNumber |] +-- > where otherNumber = magicNumber * 2 -- --- myQuery :: 'Query' --- myQuery = ['pgsq'| SELECT * FROM Table WHERE myField > 1337 |] --- @ +-- @$magicNumber@ and @$otherNumber@ are references to values @magicNumber@ and @otherNumber@. -- --- The SQL statement associated with @myQuery@ will be: +-- The quasi-quoter will generate a 'Query' expression similar to the following. -- --- > SELECT * FROM "MyModule.Table" WHERE "MyModule.myField" > 1337 +-- > Query "SELECT * FROM table t WHERE t.column1 > $1 AND t.column2 < $2" +-- > [pack magicNumber, pack otherNumber] -- --- = Variables +-- = Table names +-- Types that implement 'QueryTable' associate a table name with themselves. Since the table name is +-- not always known to the user, one can insert it dynamically. -- --- You can use reference variables with @$myVariable@. The variable's type has to be an instance of --- 'Column', otherwise it cannot be attached as query parameter. +-- > TableNameExp ::= '@' QualifiedTypeName -- --- Example: +-- The @\@@-operators is also an alias for the function @ABS@. If you have an expression that +-- triggers the quasi-quoter such as @\@A@, but you would like to use the @ABS@ functionality, then +-- simply reformat your expression to @\@(A)@ or @\@\"A\"@ or @ABS(A)@. -- --- @ --- magicNumber :: Int --- magicNumber = 1337 +-- > instance QueryTable YourType where +-- > tableName _ = "YourTable" +-- > +-- > myQuery :: Query +-- > myQuery = +-- > [pgsq| SELECT * FROM @Table WHERE @Table.column = 1337 |] -- --- myQuery :: 'Query' --- myQuery = ['pgsq'| SELECT * FROM Table WHERE myField > $magicNumber |] --- @ +-- The table name will be inlined which results in the following. -- --- = Row identifiers +-- > Query "SELECT * FROM \"YourTable\" WHERE \"YourTable\".column = 1337" [] -- --- Each instance of @('Table' a) => 'Row' a@, @('Table' a) => 'Reference' a@ and each row of the actual table inside the database --- has an identifier value. These identifiers are used to reference specific rows. The identifier --- column is exposed via the @&MyTable@ pattern. Identifier field names are resolved using --- 'describeTableIdentifier'. +-- = Identifier column names +-- Each instance of 'QueryTable' also provides the name of the identifier column. Using this column +-- name you can identify specific rows of a certain table. -- --- Example: +-- > TableIdentExp ::= '&' TypeName -- --- @ --- ['pgsq'| SELECT * --- FROM TableA, TableB --- WHERE refToB = &TableB |] --- @ +-- @&@ is also the operator for bitwise-AND. To resolve the ambiguity for expressions like @A&B@, +-- simply reformat it to @A & B@ or @A&(B)@ or @A&\"B\"@. -- --- Note @refToB@ is a field of @TableA@. --- In different circumstances one would write such query as follows. +-- > instance QueryTable YourType where +-- > tableName _ = "YourTable" +-- > tableIDName _ = "id" +-- > +-- > listIDs :: Query +-- > listIDs = +-- > [pgsq| SELECT &YourType FROM @YourType |] -- --- > SELECT * --- > FROM TableA a, Table b --- > WHERE a.refToB = b.id +-- @listIDs@ is now a query which lists the IDs of each row. This is especially useful in +-- combination with 'Reference'. -- +-- > fetchIDs :: Errand [Reference YourType] +-- > fetchIDs = +-- > query [pgsq| SELECT &YourType FROM @YourType |] +-- +-- Note, just like @\@@, the operator @&@ is reserved. Although @A&B@ is a valid SQL expression, it +-- will trigger the quasi-quoter. To avoid this, you reform your expression to @A & B@ or @A&(B)@. +-- +-- = Selectors +-- 'mkTable' will automatically implement 'Result' and 'QueryTable' for you. This allows you to make +-- use of the selector expander. +-- +-- > SelectorExp ::= '#' QualifiedTypeName +-- +-- @#@ is also the operator for bitwise-XOR. To resolve the ambiguity for expressions like @A#B@, +-- simply reformat it to @A # B@ or @A#(B)@ or @A#\"B\"@. +-- +-- > data Actor = Actor { +-- > actorName :: String, +-- > actorAge :: Word +-- > } deriving (Show, Eq, Ord) +-- > +-- > mkTable ''Actor [] +-- > +-- > fetchOldActors :: Errand [Actor] +-- > fetchOldActors = +-- > query [pgsq| SELECT #Actor FROM @Actor a WHERE a.actorAge >= $oldAge |] +-- > where oldAge = 70 +-- +-- @#Actor@ will expand to a list of columns that are necessary to construct an instance of @Actor@. +-- In this case it is equivalent to +-- +-- > @Actor.actorName, @Actor.actorAge pgsq :: QuasiQuoter pgsq = QuasiQuoter { @@ -146,205 +321,127 @@ quoteDec = const (fail "Cannot use 'pgsq' in declaration") } --- | List of relevant SQL keywords -reservedSQLKeywords :: [T.Text] -reservedSQLKeywords = - ["ABS", "ABSOLUTE", "ACTION", "ADD", "ALL", "ALLOCATE", "ALTER", "ANALYSE", "ANALYZE", "AND", - "ANY", "ARE", "ARRAY", "ARRAY_AGG", "ARRAY_MAX_CARDINALITY", "AS", "ASC", "ASENSITIVE", - "ASSERTION", "ASYMMETRIC", "AT", "ATOMIC", "AUTHORIZATION", "AVG", "BEGIN", "BEGIN_FRAME", - "BEGIN_PARTITION", "BETWEEN", "BIGINT", "BINARY", "BIT", "BIT_LENGTH", "BLOB", "BOOLEAN", - "BOTH", "BY", "CALL", "CALLED", "CARDINALITY", "CASCADE", "CASCADED", "CASE", "CAST", "CATALOG", - "CEIL", "CEILING", "CHAR", "CHARACTER", "CHARACTER_LENGTH", "CHAR_LENGTH", "CHECK", "CLOB", - "CLOSE", "COALESCE", "COLLATE", "COLLATION", "COLLECT", "COLUMN", "COMMIT", "CONCURRENTLY", - "CONDITION", "CONNECT", "CONNECTION", "CONSTRAINT", "CONSTRAINTS", "CONTAINS", "CONTINUE", - "CONVERT", "CORR", "CORRESPONDING", "COUNT", "COVAR_POP", "COVAR_SAMP", "CREATE", "CROSS", - "CUBE", "CUME_DIST", "CURRENT", "CURRENT_CATALOG", "CURRENT_DATE", - "CURRENT_DEFAULT_TRANSFORM_GROUP", "CURRENT_PATH", "CURRENT_ROLE", - "CURRENT_ROW", "CURRENT_SCHEMA", "CURRENT_TIME", "CURRENT_TIMESTAMP", - "CURRENT_TRANSFORM_GROUP_FOR_TYPE", "CURRENT_USER", "CURSOR", "CYCLE", "DATALINK", "DATE", - "DAY", "DEALLOCATE", "DEC", "DECIMAL", "DECLARE", "DEFAULT", "DEFERRABLE", "DEFERRED", "DELETE", - "DENSE_RANK", "DEREF", "DESC", "DESCRIBE", "DESCRIPTOR", "DETERMINISTIC", "DIAGNOSTICS", - "DISCONNECT", "DISTINCT", "DLNEWCOPY", "DLPREVIOUSCOPY", "DLURLCOMPLETE", "DLURLCOMPLETEONLY", - "DLURLCOMPLETEWRITE", "DLURLPATH", "DLURLPATHONLY", "DLURLPATHWRITE", "DLURLSCHEME", - "DLURLSERVER", "DLVALUE", "DO", "DOMAIN", "DOUBLE", "DROP", "DYNAMIC", "EACH", "ELEMENT", - "ELSE", "END", "END", "END_FRAME", "END_PARTITION", "EQUALS", "ESCAPE", "EVERY", "EXCEPT", - "EXCEPTION", "EXEC", "EXECUTE", "EXISTS", "EXP", "EXTERNAL", "EXTRACT", "FALSE", "FETCH", - "FILTER", "FIRST", "FIRST_VALUE", "FLOAT", "FLOOR", "FOR", "FOREIGN", "FOUND", "FRAME_ROW", - "FREE", "FREEZE", "FROM", "FULL", "FUNCTION", "FUSION", "GET", "GLOBAL", "GO", "GOTO", "GRANT", - "GROUP", "GROUPING", "GROUPS", "HAVING", "HOLD", "HOUR", "IDENTITY", "ILIKE", "IMMEDIATE", - "IMPORT", "IN", "INDICATOR", "INITIALLY", "INNER", "INOUT", "INPUT", "INSENSITIVE", "INSERT", - "INT", "INTEGER", "INTERSECT", "INTERSECTION", "INTERVAL", "INTO", "IS", "ISNULL", "ISOLATION", - "JOIN", "KEY", "LAG", "LANGUAGE", "LARGE", "LAST", "LAST_VALUE", "LATERAL", "LEAD", "LEADING", - "LEFT", "LEVEL", "LIKE", "LIKE_REGEX", "LIMIT", "LN", "LOCAL", "LOCALTIME", "LOCALTIMESTAMP", - "LOWER", "MATCH", "MAX", "MAX_CARDINALITY", "MEMBER", "MERGE", "METHOD", "MIN", "MINUTE", "MOD", - "MODIFIES", "MODULE", "MONTH", "MULTISET", "NAMES", "NATIONAL", "NATURAL", "NCHAR", "NCLOB", - "NEW", "NEXT", "NO", "NONE", "NORMALIZE", "NOT", "NOTNULL", "NTH_VALUE", "NTILE", "NULL", - "NULLIF", "NUMERIC", "OCCURRENCES_REGEX", "OCTET_LENGTH", "OF", "OFFSET", "OLD", "ON", "ONLY", - "OPEN", "OPTION", "OR", "ORDER", "OUT", "OUTER", "OUTPUT", "OVER", "OVERLAPS", "OVERLAY", "PAD", - "PARAMETER", "PARTIAL", "PARTITION", "PERCENT", "PERCENTILE_CONT", "PERCENTILE_DISC", - "PERCENT_RANK", "PERIOD", "PLACING", "PORTION", "POSITION", "POSITION_REGEX", "POWER", - "PRECEDES", "PRECISION", "PREPARE", "PRESERVE", "PRIMARY", "PRIOR", "PRIVILEGES", "PROCEDURE", - "PUBLIC", "RANGE", "RANK", "READ", "READS", "REAL", "RECURSIVE", "REF", "REFERENCES", - "REFERENCING", "REGR_AVGX", "REGR_AVGY", "REGR_COUNT", "REGR_INTERCEPT", "REGR_R2", - "REGR_SLOPE", "REGR_SXX", "REGR_SXY", "REGR_SYY", "RELATIVE", "RELEASE", "RESTRICT", "RESULT", - "RETURN", "RETURNING", "RETURNS", "REVOKE", "RIGHT", "ROLLBACK", "ROLLUP", "ROW", "ROWS", - "ROW_NUMBER", "SAVEPOINT", "SCHEMA", "SCOPE", "SCROLL", "SEARCH", "SECOND", "SECTION", "SELECT", - "SENSITIVE", "SESSION", "SESSION_USER", "SET", "SIMILAR", "SIZE", "SMALLINT", "SOME", "SPACE", - "SPECIFIC", "SPECIFICTYPE", "SQL", "SQLCODE", "SQLERROR", "SQLEXCEPTION", "SQLSTATE", - "SQLWARNING", "SQRT", "START", "STATIC", "STDDEV_POP", "STDDEV_SAMP", "SUBMULTISET", - "SUBSTRING", "SUBSTRING_REGEX", "SUCCEEDS", "SUM", "SYMMETRIC", "SYSTEM", "SYSTEM_TIME", - "SYSTEM_USER", "TABLE", "TABLESAMPLE", "TEMPORARY", "THEN", "TIME", "TIMESTAMP", - "TIMEZONE_HOUR", "TIMEZONE_MINUTE", "TO", "TRAILING", "TRANSACTION", "TRANSLATE", - "TRANSLATE_REGEX", "TRANSLATION", "TREAT", "TRIGGER", "TRIM", "TRIM_ARRAY", "TRUE", "TRUNCATE", - "UESCAPE", "UNION", "UNIQUE", "UNKNOWN", "UNNEST", "UPDATE", "UPPER", "USAGE", "USER", "USING", - "VALUE", "VALUES", "VALUE_OF", "VARBINARY", "VARCHAR", "VARIADIC", "VARYING", "VAR_POP", - "VAR_SAMP", "VERBOSE", "VERSIONING", "VIEW", "WHEN", "WHENEVER", "WHERE", "WIDTH_BUCKET", - "WINDOW", "WITH", "WITHIN", "WITHOUT", "WORK", "WRITE", "XML", "XMLAGG", "XMLATTRIBUTES", - "XMLBINARY", "XMLCAST", "XMLCOMMENT", "XMLCONCAT", "XMLDOCUMENT", "XMLELEMENT", "XMLEXISTS", - "XMLFOREST", "XMLITERATE", "XMLNAMESPACES", "XMLPARSE", "XMLPI", "XMLQUERY", "XMLSERIALIZE", - "XMLTABLE", "XMLTEXT", "XMLVALIDATE", "YEAR", "ZONE"] +-- | Parse quasi-quoted query but return only statement. +parseStoreStatementE :: String -> Q Exp +parseStoreStatementE code = do + case parseOnly (segments <* endOfInput) (T.pack code) of + Left msg -> + fail (show msg) --- | Query segment -data Segment - = Keyword T.Text - | PossibleName T.Text - | Variable T.Text - | Identifier T.Text - | Quote Char T.Text - | Other Char + Right xs -> do + [e| mconcat $(listE (runQueryBuilder_ (mapM_ reduceSegment xs))) |] --- | SQL keyword -keyword :: Parser Segment -keyword = - Keyword <$> choice (asciiCI <$> reservedSQLKeywords) +-- | Just like 'pgsq' but only produces the statement associated with the query. Referenced +-- values are not inlined, they are simply dismissed. +pgss :: QuasiQuoter +pgss = + QuasiQuoter { + quoteExp = parseStoreStatementE, + quotePat = const (fail "Cannot use 'pgss' in pattern"), + quoteType = const (fail "Cannot use 'pgss' in type"), + quoteDec = const (fail "Cannot use 'pgss' in declaration") + } --- | Alpha numeric character -alphaNum :: Parser Char -alphaNum = satisfy isAlphaNum +-- | Internal state for every builder +data BuilderState s p = BuilderState s Word [p] --- | Underscore -underscore :: Parser Char -underscore = char '_' +-- | +class QueryCode s where + type Code s --- | Dot -dot :: Parser Char -dot = char '.' + appendCode :: s -> Code s -> s --- | Name -name :: Parser T.Text -name = - bake <$> (letter <|> underscore) <*> many (alphaNum <|> underscore <|> dot) - where - bake h t = T.pack (h : t) + appendStringCode :: s -> String -> s --- | Possible name -possibleName :: Parser Segment -possibleName = - PossibleName <$> name +instance QueryCode B.ByteString where + type Code B.ByteString = B.ByteString --- | Variable -variable :: Parser Segment -variable = do - char '$' - Variable <$> name + appendCode = B.append --- | Identifier -identifier :: Parser Segment -identifier = do - char '&' - Identifier <$> name + appendStringCode bs str = bs <> fromString str --- | Quote -quote :: Char -> Parser Segment -quote delim = do - char delim - cnt <- scan (False, T.empty) scanner - char delim - pure (Quote delim cnt) - where - scanner (False, _) chr | chr == delim = Nothing - scanner (esc, cnt) chr = Just (not esc && chr == '\\', cnt `T.snoc` chr) +instance QueryCode [Q Exp] where + type Code [Q Exp] = Q Exp --- | Segments -segments :: Parser [Segment] -segments = - many (choice [ - quote '"', - quote '\'', - variable, - identifier, - keyword, - possibleName, - Other <$> anyChar - ]) + appendCode segments exp = segments ++ [exp] --- | Turn "Text" into a UTF-8-encoded "ByteString" expression. -textE :: T.Text -> StateT (Int, [Exp]) Q Exp -textE txt = - lift (stringE (T.unpack txt)) + appendStringCode segments str = appendCode segments [e| fromString $(stringE str) |] --- | Reduce segments in order to resolve names and collect query parameters. -reduceSegment :: Segment -> StateT (Int, [Exp]) Q Exp -reduceSegment seg = - case seg of - Keyword kw -> - textE kw +instance QueryCode String where + type Code String = String - Other o -> - lift (stringE [o]) + appendCode segments code = segments ++ code - Quote delim cnt -> - lift (stringE (delim : T.unpack cnt ++ [delim])) + appendStringCode = appendCode - Variable varName -> do - mbName <- lift (lookupValueName (T.unpack varName)) - case mbName of - Just name -> do - -- Generate the pack expression - lit <- lift [e| pack $(varE name) |] +-- | Can build @o@ using @s@ and @[p]@. +class QueryBuildable s p o | s p -> o where + buildQuery :: s -> [p] -> o - -- Register parameter - (numParams, params) <- get - put (numParams + 1, params ++ [lit]) +instance QueryBuildable B.ByteString Value Query where + buildQuery = Query - lift (stringE ("$" ++ show (numParams + 1))) +instance QueryBuildable String (Q Exp) (Q Exp) where + buildQuery code params = + [e| Query (fromString $(stringE code)) $(listE params) |] - Nothing -> - lift (fail ("\ESC[34m" ++ T.unpack varName ++ - "\ESC[0m does not refer to anything")) +instance QueryBuildable [Q Exp] (Q Exp) (Q Exp) where + buildQuery codeSegments params = + [e| Query (B.concat $(listE codeSegments)) $(listE params) |] - PossibleName posName -> do - let strName = T.unpack posName - mbName <- lift ((,) <$> lookupTypeName strName <*> lookupValueName strName) - case mbName of - (Just typName, _) -> - lift [e| "\"" ++ describeTableName (Proxy :: Proxy $(conT typName)) ++ "\"" |] +-- | Query builder +type QueryBuilder s p = State (BuilderState s p) () - (_, Just varName) -> - lift (stringE (sanitizeName' varName)) +-- | Run query builder. +runQueryBuilder :: (QueryBuildable s p o, Monoid s) => QueryBuilder s p -> o +runQueryBuilder builder = + buildQuery code params + where + BuilderState code _ params = execState builder (BuilderState mempty 1 []) - _ -> textE posName +-- | Run query builder, return only the statement. +runQueryBuilder_ :: (Monoid s) => QueryBuilder s p -> s +runQueryBuilder_ builder = + code + where + BuilderState code _ _ = execState builder (BuilderState mempty 1 []) - Identifier idnName -> do - mbName <- lift (lookupTypeName (T.unpack idnName)) - case mbName of - Just name -> - lift [e| "\"" ++ describeTableIdentifier (Proxy :: Proxy $(conT name)) ++ "\"" |] +-- | Write code. +writeCode :: (QueryCode s) => Code s -> QueryBuilder s p +writeCode code = + modify $ \ (BuilderState stmt idx params) -> + BuilderState (appendCode stmt code) idx params - Nothing -> - lift (fail ("\ESC[34m" ++ T.unpack idnName ++ - "\ESC[0m does not refer to anything")) +-- | Write string code. +writeStringCode :: (QueryCode s) => String -> QueryBuilder s p +writeStringCode code = + modify $ \ (BuilderState stmt idx params) -> + BuilderState (appendStringCode stmt code) idx params --- | Parse quasi-quoted PG Store Query. -parseStoreQueryE :: String -> Q Exp -parseStoreQueryE code = do - case parseOnly segments (fromString code) of - Left msg -> - fail msg +-- | Add an identifier. +writeIdentifier :: (QueryCode s) => String -> QueryBuilder s p +writeIdentifier name = + writeStringCode (quoteIdentifier name) - Right xs -> do - (parts, (_, params)) <- runStateT (mapM reduceSegment xs) (0, []) - [e| Query { - queryStatement = T.encodeUtf8 (T.pack (concat $(pure (ListE parts)))), - queryParams = $(pure (ListE params)) - } |] +-- | Add an absolute identifier. +writeAbsIdentifier :: (QueryCode s) => String -> String -> QueryBuilder s p +writeAbsIdentifier ns name = do + writeIdentifier ns + writeStringCode "." + writeIdentifier name + +-- | Embed a parameter. +writeParam :: (QueryCode s) => p -> QueryBuilder s p +writeParam param = do + modify $ \ (BuilderState code idx params) -> + BuilderState (appendStringCode code ("$" ++ show idx)) (idx + 1) (params ++ [param]) + +-- | Embed a value parameter. +writeColumn :: (Column p, QueryCode s) => p -> QueryBuilder s Value +writeColumn param = + writeParam (pack param) + +-- | Do something between other builders. +intercalateBuilder :: QueryBuilder s p -> [QueryBuilder s p] -> QueryBuilder s p +intercalateBuilder x xs = + sequence_ (intersperse x xs) diff --git a/src/Database/PostgreSQL/Store/Result.hs b/src/Database/PostgreSQL/Store/Result.hs --- a/src/Database/PostgreSQL/Store/Result.hs +++ b/src/Database/PostgreSQL/Store/Result.hs @@ -1,192 +1,82 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + -- | -- Module: Database.PostgreSQL.Store.Result -- Copyright: (c) Ole Krüger 2015-2016 -- License: BSD3 -- Maintainer: Ole Krüger module Database.PostgreSQL.Store.Result ( - -- * + -- * Result processor ResultError (..), ResultProcessor, - ColumnInfo, - runResultProcessor, - columnNumber, - columnType, - columnFormat, - columnInfo, - foreachRow, - cellValue, - unpackCellValue, + processResult, + processOneResult, - -- * Result - Result (..), - RawRow (..) + skipColumn, + unpackColumn ) where import Control.Monad -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader -import Control.Monad.Trans.Except - -import Data.List -import Data.Typeable -import qualified Data.ByteString as B +import Control.Monad.Trans +import Control.Monad.Reader +import Control.Monad.State.Strict +import Control.Monad.Except import qualified Database.PostgreSQL.LibPQ as P import Database.PostgreSQL.Store.Columns -- | Error that occured during result processing data ResultError - = ColumnMissing B.ByteString - | ValueError P.Row P.Column P.Oid P.Format ColumnDescription + = TooFewColumnsError P.Column + -- ^ Occurs when you're trying to access a column that does not exist. + | UnpackError P.Row P.Column P.Oid P.Format + -- ^ The value at a given row and column could not be unpacked. deriving (Show, Eq) -- | Result processor -type ResultProcessor = ReaderT P.Result (ExceptT ResultError IO) - --- | Column information -type ColumnInfo = (P.Column, P.Oid, P.Format) - --- | Process the result. -runResultProcessor :: P.Result -> ResultProcessor a -> ExceptT ResultError IO a -runResultProcessor = flip runReaderT - --- | Get the number of columns. -numColumns :: ResultProcessor P.Column -numColumns = do - result <- ask - lift (lift (P.nfields result)) - --- | Get the column number for a column name. -columnNumber :: B.ByteString -> ResultProcessor P.Column -columnNumber name = do - result <- ask - lift (ExceptT (maybe (Left (ColumnMissing name)) pure <$> P.fnumber result name)) - --- | Get the type of a column. -columnType :: P.Column -> ResultProcessor P.Oid -columnType col = do - result <- ask - lift (lift (P.ftype result col)) - --- | Get the format of a column. -columnFormat :: P.Column -> ResultProcessor P.Format -columnFormat col = do - result <- ask - lift (lift (P.fformat result col)) - --- | Get information about a column. -columnInfo :: B.ByteString -> ResultProcessor ColumnInfo -columnInfo name = do - col <- columnNumber name - (,,) col <$> columnType col <*> columnFormat col - --- | Do something for each row. -foreachRow :: (P.Row -> ResultProcessor a) -> ResultProcessor [a] -foreachRow rowProcessor = do - result <- ask - numRows <- lift (lift (P.ntuples result)) - mapM rowProcessor [0 .. numRows - 1] - --- | Get cell value. -cellValue :: P.Row -> ColumnInfo -> ResultProcessor Value -cellValue row (col, oid, fmt) = do - result <- ask - value <- lift (lift (P.getvalue' result row col)) - - case value of - Just dat -> pure (Value oid dat fmt) - Nothing -> pure NullValue - --- | Get cell value. -cellValue' :: P.Row -> P.Column -> ResultProcessor Value -cellValue' row col = do - result <- ask - (oid, fmt, value) <- lift (lift ((,,) <$> P.ftype result col - <*> P.fformat result col - <*> P.getvalue' result row col)) - - case value of - Just dat -> pure (Value oid dat fmt) - Nothing -> pure NullValue - - --- | Unpack cell value. -unpackCellValue :: (Column a) => P.Row -> ColumnInfo -> ResultProcessor a -unpackCellValue row info = - withProxy Proxy - where - withProxy :: (Column a) => Proxy a -> ResultProcessor a - withProxy proxy = do - value <- cellValue row info - lift (ExceptT (make (describeColumn proxy) (unpack value))) - - (col, oid, fmt) = info - - valueError desc = - pure (Left (ValueError row col oid fmt desc)) - - make desc = - maybe (valueError desc) (pure . pure) - --- | Result row -class Result a where - -- | Extract rows from the given result. - resultProcessor :: ResultProcessor [a] +newtype ResultProcessor a = + ResultProcessor (StateT P.Column (ReaderT (P.Result, P.Row, P.Column) (ExceptT ResultError IO)) a) + deriving (Functor, Applicative, Monad, MonadIO, MonadError ResultError) -instance Result () where - resultProcessor = foreachRow (const (pure ())) +-- | Move cursor to the next column. +skipColumn :: ResultProcessor () +skipColumn = + ResultProcessor (modify (+ 1)) -instance (Result a, Result b) => Result (a, b) where - resultProcessor = - zip <$> resultProcessor - <*> resultProcessor +-- | Unpack the current column and move the cursor to the next column. +unpackColumn :: (Column a) => ResultProcessor a +unpackColumn = do + -- Gather information + col <- ResultProcessor get + (res, row, numCol) <- ResultProcessor ask -instance (Result a, Result b, Result c) => Result (a, b, c) where - resultProcessor = - zip3 <$> resultProcessor - <*> resultProcessor - <*> resultProcessor + -- Make sure we're not trying to unpack a non-existing column + when (col >= numCol) (throwError (TooFewColumnsError numCol)) -instance (Result a, Result b, Result c, Result d) => Result (a, b, c, d) where - resultProcessor = - zip4 <$> resultProcessor - <*> resultProcessor - <*> resultProcessor - <*> resultProcessor + -- Retrieve column-specific information + (typ, mbData) <- liftIO $ + (,) <$> P.ftype res col <*> P.getvalue' res row col -instance (Result a, Result b, Result c, Result d, Result e) => Result (a, b, c, d, e) where - resultProcessor = - zip5 <$> resultProcessor - <*> resultProcessor - <*> resultProcessor - <*> resultProcessor - <*> resultProcessor + -- Try to unpack the value + case unpack (maybe NullValue (Value typ) mbData) of + Just ret -> ResultProcessor (put (col + 1) >> pure ret) + Nothing -> throwError (UnpackError row col typ P.Text) -instance (Result a, Result b, Result c, Result d, Result e, Result f) => Result (a, b, c, d, e, f) where - resultProcessor = - zip6 <$> resultProcessor - <*> resultProcessor - <*> resultProcessor - <*> resultProcessor - <*> resultProcessor - <*> resultProcessor +-- | Process the entire result set. +processResult :: P.Result -> ResultProcessor a -> ExceptT ResultError IO [a] +processResult res (ResultProcessor proc) = do + (rows, cols) <- liftIO ((,) <$> P.ntuples res <*> P.nfields res) -instance (Result a, Result b, Result c, Result d, Result e, Result f, Result g) => Result (a, b, c, d, e, f, g) where - resultProcessor = - zip7 <$> resultProcessor - <*> resultProcessor - <*> resultProcessor - <*> resultProcessor - <*> resultProcessor - <*> resultProcessor - <*> resultProcessor + -- Iterate over each row number and run the row processor + forM [0 .. rows - 1] $ \ row -> + runReaderT (evalStateT proc 0) (res, row, cols) --- | A row containing all a list of all column values. -newtype RawRow = RawRow [Value] - deriving (Show, Eq, Ord) +-- | Process one row of the result set. +processOneResult :: P.Result -> ResultProcessor a -> ExceptT ResultError IO (Maybe a) +processOneResult res (ResultProcessor proc) = do + (rows, cols) <- liftIO ((,) <$> P.ntuples res <*> P.nfields res) -instance Result RawRow where - resultProcessor = do - ncols <- numColumns - foreachRow $ \ row -> - RawRow <$> forM [0 .. ncols - 1] (cellValue' row) + if rows > 0 then + Just <$> runReaderT (evalStateT proc 0) (res, 0, cols) + else + pure Nothing diff --git a/src/Database/PostgreSQL/Store/Table.hs b/src/Database/PostgreSQL/Store/Table.hs --- a/src/Database/PostgreSQL/Store/Table.hs +++ b/src/Database/PostgreSQL/Store/Table.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell, RecordWildCards, BangPatterns #-} +{-# LANGUAGE TemplateHaskell, BangPatterns #-} -- | -- Module: Database.PostgreSQL.Store.Table @@ -6,341 +6,366 @@ -- License: BSD3 -- Maintainer: Ole Krüger module Database.PostgreSQL.Store.Table ( - TableDescription (..), - Table (..), - Row (..), + -- * Auxiliary data types Reference (..), - HasID (..), + + -- * Table types + Table (..), + mkCreateQuery, + + -- * Table generation TableConstraint (..), - mkTable, - mkCreateQuery + mkTable ) where import Control.Monad -import Control.Monad.Trans.Class +import Control.Monad.Except import Data.Int -import Data.List +import Data.List hiding (insert) +import Data.Proxy import Data.String -import Data.Typeable +import qualified Data.ByteString as B + import Language.Haskell.TH +import Language.Haskell.TH.Syntax import Database.PostgreSQL.Store.Query import Database.PostgreSQL.Store.Columns import Database.PostgreSQL.Store.Result import Database.PostgreSQL.Store.Errand --- | Resolved row -data Row a = Row { - -- | Identifier - rowID :: !Int64, - - -- | Value - rowValue :: !a -} deriving (Show, Eq, Ord) +-- | Reference a row of type @a@. +newtype Reference a = Reference { referenceID :: Int64 } + deriving (Eq, Ord) --- | Reference to a row -newtype Reference a = Reference Int64 - deriving (Show, Eq, Ord) +instance Show (Reference a) where + show (Reference n) = show n -instance (Table a) => Column (Reference a) where - pack ref = - pack (referenceID ref) +instance (QueryTable a) => Column (Reference a) where + pack ref = pack (referenceID ref) - unpack val = - Reference <$> unpack val + unpack val = Reference <$> unpack val - describeColumn proxy = - ColumnDescription { - columnTypeName = "bigint references \"" ++ tableName ++ "\" (\"" ++ tableIdentifier ++ "\")", - columnTypeNull = False - } + columnTypeName proxy = + "BIGINT REFERENCES " ++ quoteIdentifier (tableName tableProxy) ++ + " (" ++ quoteIdentifier (tableIDName tableProxy) ++ ")" where - coerceProxy :: Proxy (Reference a) -> Proxy a - coerceProxy _ = Proxy + tableProxy = (const Proxy :: Proxy (Reference a) -> Proxy a) proxy - TableDescription {..} = - describeTable (coerceProxy proxy) + columnAllowNull _ = False -class (DescribableTable a) => Table a where +instance Result (Reference a) where + queryResultProcessor = Reference <$> unpackColumn + +-- | Qualify @a@ as a table type. 'mkTable' can implement this class for you. +class Table a where -- | Insert a row into the table and return a 'Reference' to the inserted row. insert :: a -> Errand (Reference a) + -- | Insert multiple rows into the table at once. + insertMany :: [a] -> Errand [Reference a] + insertMany = mapM insert + -- | Find the row identified by the given reference. - find :: (HasID i) => i a -> Errand (Row a) + find :: Reference a -> Errand a -- | Update an existing row. - update :: (HasID i) => i a -> a -> Errand () + update :: Reference a -> a -> Errand () -- | Delete a row from the table. - delete :: (HasID i) => i a -> Errand () + delete :: Reference a -> Errand () -- | Generate the query which creates this table inside the database. - -- Use @mkCreateQuery@ for convenience. - createQuery :: Proxy a -> Query + -- Use 'mkCreateQuery' for convenience. + createTableQuery :: Proxy a -> Query - -- | Extract rows from a result set. - tableResultProcessor :: ResultProcessor [Row a] +-- | Table field declaration +data TableField = TableField String Type Name - -- | Extract only a 'Reference' to each row. - tableRefResultProcessor :: ResultProcessor [Reference a] +-- | Table type declaration +data TableDec = TableDec Name Name [TableField] Pat -instance (Table a) => Result (Row a) where - resultProcessor = tableResultProcessor +-- | Generate an identifier for a table type. +tableIdentifier :: Name -> String +tableIdentifier name = quoteIdentifier (show name) -instance (Table a) => Result (Reference a) where - resultProcessor = tableRefResultProcessor +-- | Make a comma-seperated list of identifiers which correspond to given fields. +tableFieldIdentifiers :: [TableField] -> String +tableFieldIdentifiers fields = + intercalate ", " (map (\ (TableField name _ _) -> quoteIdentifier name) fields) --- | A value of that type contains an ID. -class HasID a where - -- | Retrieve the underlying ID. - referenceID :: a b -> Int64 +-- | Beginning of a insert statement. +tableInsertStatementBegin :: TableDec -> String +tableInsertStatementBegin (TableDec table _ fields _) = + "INSERT INTO " ++ + tableIdentifier table ++ + " (" ++ + tableFieldIdentifiers fields ++ + ") VALUES " -instance HasID Row where - referenceID (Row rid _) = rid +-- | End of a insert statement. +tableInsertStatementEnd :: String +tableInsertStatementEnd = + " RETURNING \"$id\"" -instance HasID Reference where - referenceID (Reference rid) = rid +-- | Call a constructor with some variables. +callConstructor :: Name -> [Name] -> Exp +callConstructor ctor params = + foldl AppE (ConE ctor) (map VarE params) --- | Unqualify a name. -unqualifyName :: Name -> Name -unqualifyName = mkName . nameBase +-- | Generate the list of selectors. +makeQuerySelectors :: [TableField] -> Q Exp +makeQuerySelectors fields = + ListE <$> mapM (\ (TableField field _ _) -> [e| SelectorField $(stringE field) |]) fields --- | Generate the insert query for a table. -insertQueryE :: Name -> [Name] -> Q Exp -insertQueryE name fields = - [e| fromString $(stringE query) |] +-- | Generate the result processor for a table. +makeResultProcessor :: TableDec -> Q Exp +makeResultProcessor (TableDec _ ctor fields _) = do + bindingNames <- mapM (\ (TableField name _ _) -> newName name) fields + pure (DoE (map makeBinding bindingNames ++ + [makeConstruction bindingNames])) where - query = - "INSERT INTO " ++ sanitizeName' name ++ " (" ++ - intercalate ", " columns ++ - ") VALUES (" ++ - intercalate ", " values ++ - ") RETURNING " ++ identField' name + -- Bind expression 'name <- unpackColumn' + makeBinding name = + BindS (VarP name) (VarE 'unpackColumn) - columns = - map (\ nm -> "\"" ++ sanitizeName nm ++ "\"") fields + -- Last expression 'pure (ctor boundNames...)' + makeConstruction names = + NoBindS (AppE (VarE 'pure) (callConstructor ctor names)) - values = - map (\ idx -> "$" ++ show idx) [1 .. length fields] +-- | Generate the create query. +makeCreateQuery :: TableDec -> [TableConstraint] -> Q Exp +makeCreateQuery (TableDec table _ fields _) constraints = + runQueryBuilder $ do + writeStringCode "CREATE TABLE IF NOT EXISTS " :: QueryBuilder [Q Exp] (Q Exp) + writeIdentifier (show table) + writeStringCode " (" --- | Generate the select query for a table row. -findQueryE :: Name -> Q Exp -findQueryE name = - [e| fromString $(stringE query) |] - where - query = - "SELECT * FROM " ++ sanitizeName' name ++ - " WHERE " ++ identField' name ++ " = $1 LIMIT 1" + intercalateBuilder (writeStringCode ", ") $ + identDescription : + map describeField fields ++ + map describeConstraint constraints --- | Generate the update query for a table. -updateQueryE :: Name -> [Name] -> Q Exp -updateQueryE name fields = - [e| fromString $(stringE query) |] + writeStringCode ")" where - query = - "UPDATE " ++ sanitizeName' name ++ - " SET " ++ intercalate ", " values ++ - " WHERE " ++ identField' name ++ " = $1" + identDescription = do + writeIdentifier "$id" + writeStringCode "BIGSERIAL NOT NULL PRIMARY KEY" - values = - map (\ (nm, idx) -> sanitizeName' nm ++ " = $" ++ show idx) - (zip fields [2 .. length fields + 1]) + describeField :: TableField -> QueryBuilder [Q Exp] (Q Exp) + describeField (TableField name typ _) = + writeCode [e| fromString (columnDescription (Proxy :: Proxy $(pure typ)) + $(stringE (quoteIdentifier name))) |] --- | Generate the delete query for a table. -deleteQueryE :: Name -> Q Exp -deleteQueryE name = - [e| fromString $(stringE query) |] - where - query = - "DELETE FROM " ++ sanitizeName' name ++ - " WHERE " ++ identField' name ++ " = $1" + describeConstraint :: TableConstraint -> QueryBuilder [Q Exp] (Q Exp) + describeConstraint (Unique names) = do + writeStringCode "UNIQUE (" + intercalateBuilder (writeStringCode ", ") $ + map (writeIdentifier . nameBase) names + writeStringCode ")" --- | Generate the create query for a table. -createQueryE :: Name -> [(Name, Type)] -> [TableConstraint] -> Q Exp -createQueryE name fields constraints = - [e| fromString ($(stringE queryBegin) ++ - intercalate ", " ($(stringE anchorDescription) : - $fieldList ++ - $constraintList) ++ - $(stringE queryEnd)) |] - where - queryBegin = "CREATE TABLE IF NOT EXISTS " ++ sanitizeName' name ++ " (" - queryEnd = ")" + describeConstraint (Check code) = do + writeStringCode "CHECK (" + writeStringCode code + writeStringCode ")" - anchorDescription = - identField' name ++ " BIGSERIAL NOT NULL PRIMARY KEY" +-- | Generate the query which insert a row. +makeInsertQuery :: TableDec -> Q Exp +makeInsertQuery (TableDec table _ fields _) = + runQueryBuilder $ do + writeCode "INSERT INTO " :: QueryBuilder String (Q Exp) + writeIdentifier (show table) + writeCode " (" + intercalateBuilder (writeCode ", ") $ + map (\ (TableField name _ _) -> writeIdentifier name) fields + writeCode ") VALUES (" + intercalateBuilder (writeCode ", ") $ + map (\ (TableField _ _ boundName) -> writeParam [e| pack $(varE boundName) |]) fields + writeCode ") RETURNING " + writeIdentifier "$id" - fieldList = - ListE <$> mapM describeField fields +-- | Generate the query which inserts multiple rows at once. +makeInsertManyQuery :: Name -> TableDec -> Q Exp +makeInsertManyQuery rows dec@(TableDec _ _ fields destructPat) = + [e| + let + writeTuple $(pure destructPat) = do + writeStringCode "(" :: QueryBuilder B.ByteString Value + intercalateBuilder (writeStringCode ",") $(ListE <$> mapM packColumn fields) + writeStringCode ")" + in runQueryBuilder $ do + writeStringCode $(stringE (tableInsertStatementBegin dec)) + intercalateBuilder (writeStringCode ",") (map writeTuple $(varE rows)) + writeStringCode $(stringE tableInsertStatementEnd) + |] + where + packColumn (TableField _ _ boundName) = [e| writeColumn $(varE boundName) |] - describeField (fname, ftype) = - [e| $(stringE (sanitizeName' fname)) ++ " " ++ - makeColumnDescription (describeColumn (Proxy :: Proxy $(pure ftype))) |] +-- | Generate the query for finding a row. +makeFindQuery :: Name -> TableDec -> Q Exp +makeFindQuery ref (TableDec table _ fields _) = + runQueryBuilder $ do + writeCode "SELECT " :: QueryBuilder String (Q Exp) + intercalateBuilder (writeCode ", ") $ + map (\ (TableField name _ _) -> writeIdentifier name) fields + writeCode " FROM " + writeIdentifier (show table) + writeCode " WHERE " + writeIdentifier "$id" + writeCode " = " + writeParam [e| pack $(varE ref) |] - constraintList = - ListE <$> mapM describeConstraint constraints +-- | Generate the query for updating a row. +makeUpdateQuery :: Name -> TableDec -> Q Exp +makeUpdateQuery ref (TableDec table _ fields _) = + runQueryBuilder $ do + writeCode "UPDATE " :: QueryBuilder String (Q Exp) + writeIdentifier (show table) + writeCode " SET " + intercalateBuilder (writeCode ", ") $ + flip map fields $ \ (TableField name _ boundName) -> do + writeIdentifier name + writeCode " = " + writeParam [e| pack $(varE boundName) |] + writeCode " WHERE " + writeIdentifier "$id" + writeCode " = " + writeParam [e| pack $(varE ref) |] - describeConstraint cont = - case cont of - Unique names -> - stringE ("UNIQUE (" ++ intercalate ", " (map sanitizeName' names) ++ ")") +-- | Generate the query for deleting a row. +makeDeleteQuery :: Name -> Name -> Q Exp +makeDeleteQuery ref table = + runQueryBuilder $ do + writeCode "DELETE FROM " :: QueryBuilder String (Q Exp) + writeIdentifier (show table) + writeCode " WHERE " + writeIdentifier "$id" + writeCode " = " + writeParam [e| pack $(varE ref) |] - ForeignKey names table tableNames -> - stringE ("FOREIGN KEY (" ++ intercalate ", " (map sanitizeName' names) ++ - ") REFERENCES " ++ sanitizeName' table ++ - "(" ++ intercalate ", " (map sanitizeName' tableNames) ++ ")") +-- | Implement relevant instances for the given table type. +implementClasses :: TableDec -> [TableConstraint] -> Q [Dec] +implementClasses dec@(TableDec table _ fields destructPat) constraints = + [d| + instance QueryTable $(conT table) where + tableName _ = $(stringE (show table)) + tableIDName _ = "$id" + tableSelectors _ = $(makeQuerySelectors fields) --- | Generate an expression which gathers all records from a type and packs them into a list. --- `packParamsE 'row ['field1, 'field2]` generates `[pack (field1 row), pack (field2 row)]` -packParamsE :: Name -> [Name] -> Q Exp -packParamsE row fields = - ListE <$> mapM extract fields - where - extract name = - [e| pack ($(varE name) $(varE row)) |] + instance Result $(conT table) where + queryResultProcessor = $(makeResultProcessor dec) --- | Generate an expression which gathers information about a column. -columnInfoE :: Name -> Q Exp -columnInfoE name = - [e| columnInfo (fromString $(stringE (sanitizeName' name))) |] + instance Table $(conT table) where + insert $(pure destructPat) = do + rs <- query $(makeInsertQuery dec) + case rs of + (ref : _) -> pure ref + _ -> throwError EmptyResult --- | Generate a query which binds information about a column to the column's info name. -bindColumnInfoS :: Name -> Q Stmt -bindColumnInfoS name = - BindS (VarP (columnInfoName name)) <$> columnInfoE name + insertMany [] = pure [] + insertMany rows = + query $(makeInsertManyQuery 'rows dec) --- | Generate a name which is reserved for information about a column. -columnInfoName :: Name -> Name -columnInfoName name = - mkName (nameBase name ++ "_info") + find ref = do + rs <- query $(makeFindQuery 'ref dec) + case rs of + (row : _) -> pure row + _ -> throwError EmptyResult --- | Generate an expression which unpacks a column at a given row. -unpackColumnE :: Name -> Name -> Q Exp -unpackColumnE row name = - [e| unpackCellValue $(varE row) $(varE (columnInfoName name)) |] + update ref $(pure destructPat) = + query_ $(makeUpdateQuery 'ref dec) --- | Generate a query which binds the unpacked data for a column at a given row to the column's name. -bindColumnS :: Name -> Name -> Q Stmt -bindColumnS row name = - BindS (VarP (unqualifyName name)) <$> unpackColumnE row name + delete ref = + query_ $(makeDeleteQuery 'ref table) --- | Generate an expression which uses a record constructor with variables that correspond to its fields. -constructRecordE :: Name -> [Name] -> Q Exp -constructRecordE ctor fields = - [e| lift (pure $(pure construction)) |] - where - construction = RecConE ctor (map (\ n -> (n, VarE (unqualifyName n))) fields) + createTableQuery _ = + $(makeCreateQuery dec constraints) + |] --- | Generate an expression which unpacks a table instance from a given row. -unpackRowE :: Name -> Name -> [Name] -> Q Exp -unpackRowE ctor row fields = do - boundFields <- mapM (bindColumnS row) fields - unboundConstruction <- constructRecordE ctor fields - pure (DoE (boundFields ++ [NoBindS unboundConstruction])) +-- | Check that each field's type has an implementation of 'Column'. +checkRecordFields :: [VarBangType] -> Q [TableField] +checkRecordFields fields = + forM fields $ \ (name, _, typ) -> do + ii <- isInstance ''Column [typ] + unless ii $ + fail ("Type of field '" ++ show name ++ "' ('" ++ show typ ++ + "') type does not implement '" ++ show ''Column ++ "'") --- | Generate an expression which traverses all rows in order to unpack table instances from them. -unpackRowsE :: Name -> Name -> [Name] -> Q Exp -unpackRowsE table ctor fields = - [e| do idNfo <- columnInfo (fromString $(stringE (identField' table))) - foreachRow $ \ row -> - Row <$> unpackCellValue row idNfo - <*> $(unpackRowE ctor 'row fields) |] + TableField (nameBase name) typ <$> newName (nameBase name) --- | Generate an expression which retrieves a table instance from each row. -tableResultProcessorE :: Name -> Name -> [Name] -> Q Exp -tableResultProcessorE table ctor fields = do - infoBinds <- mapM bindColumnInfoS fields - rowTraversal <- unpackRowsE table ctor fields - pure (DoE (infoBinds ++ [NoBindS rowTraversal])) +-- | Check that each constructor parameter type implements 'Column'. +checkNormalFields :: [BangType] -> Q [TableField] +checkNormalFields fields = do + forM (fields `zip` [1 .. length fields]) $ \ ((_, typ), idx) -> do + ii <- isInstance ''Column [typ] + unless ii $ + fail ("Type of constructor parameter #" ++ show idx ++ " ('" ++ show typ ++ + "') type does not implement '" ++ show ''Column ++ "'") --- | Generate an expression which retrieves a reference to each row. -tableRefResultProcessorE :: Name -> Q Exp -tableRefResultProcessorE table = - [e| do idNfo <- columnInfo (fromString $(stringE (identField' table))) - foreachRow (\ row -> Reference <$> unpackCellValue row idNfo) |] + TableField ("column" ++ show idx) typ <$> newName ("column" ++ show idx) --- | Implement an instance 'Table' for the given type. -implementTableD :: Name -> Name -> [(Name, Type)] -> [TableConstraint] -> Q [Dec] -implementTableD table ctor fields constraints = - [d| instance DescribableTable $(conT table) where - describeTableName _ = - $(stringE (sanitizeName table)) +-- | +makeCtorPattern :: Name -> [TableField] -> Pat +makeCtorPattern ctor fields = + ConP ctor (map (\ (TableField _ _ name) -> VarP name) fields) - describeTableIdentifier _ = - $(stringE (identField table)) +-- | Verify that the given constructor is viable and construct a 'TableDec'. +checkTableCtor :: Name -> Con -> Q TableDec +checkTableCtor table (RecC ctor ctorFields) = do + when (length ctorFields < 1) + (fail ("'" ++ show ctor ++ "' must have at least one field")) - instance Table $(conT table) where - insert row = do - rs <- query Query { - queryStatement = $(insertQueryE table fieldNames), - queryParams = $(packParamsE 'row fieldNames) - } + fields <- checkRecordFields ctorFields + pure (TableDec table ctor fields (makeCtorPattern ctor fields)) - case rs of - (ref : _) -> pure ref - _ -> raiseErrandError UnexpectedEmptyResult +checkTableCtor table (NormalC ctor ctorFields) = do + when (length ctorFields < 1) + (fail ("'" ++ show ctor ++ "' must have at least one field")) - find ref = do - rs <- query Query { - queryStatement = $(findQueryE table), - queryParams = [pack (referenceID ref)] - } + fields <- checkNormalFields ctorFields + pure (TableDec table ctor fields (makeCtorPattern ctor fields)) - case rs of - (row : _) -> pure row - _ -> raiseErrandError UnexpectedEmptyResult +checkTableCtor table _ = + fail ("'" ++ show table ++ "' must have a normal or record constructor") - update ref row = - query_ Query { - queryStatement = $(updateQueryE table fieldNames), - queryParams = pack (referenceID ref) : $(packParamsE 'row fieldNames) - } +-- | Make sure the given declaration can be used, then construct a 'TableDec'. +checkTableDec :: Name -> Dec -> Q TableDec +checkTableDec _ (DataD ctx tableName typeVars kind ctorNames _) = do + when (length ctx > 0) + (fail ("'" ++ show tableName ++ "' must not have a context")) - delete ref = - query_ Query { - queryStatement = $(deleteQueryE table), - queryParams = [pack (referenceID ref)] - } + when (length typeVars > 0) + (fail ("'" ++ show tableName ++ "' must not use type variables")) - createQuery _ = - Query { - queryStatement = $(createQueryE table fields constraints), - queryParams = [] - } + when (length ctorNames /= 1) + (fail ("'" ++ show tableName ++ "' must have 1 constructor")) - tableResultProcessor = - $(tableResultProcessorE table ctor fieldNames) + when (kind /= Nothing && kind /= Just StarT) + (fail ("'" ++ show tableName ++ "' must have kind *")) - tableRefResultProcessor = - $(tableRefResultProcessorE table) |] - where - fieldNames = map fst fields + let [ctorName] = ctorNames --- | Check that all field types have an instance of Column. -validateFields :: [(Name, Type)] -> Q () -validateFields fields = - forM_ fields $ \ (name, typ) -> do - ii <- isInstance ''Column [typ] - unless ii $ - fail ("\ESC[35m" ++ show name ++ "\ESC[0m's type does not have an instance of \ESC[34mColumn\ESC[0m") + checkTableCtor tableName ctorName +checkTableDec tableName _ = + fail ("'" ++ show tableName ++ "' must declare a data type") + -- | Options to 'mkTable'. data TableConstraint = Unique [Name] -- ^ A combination of fields must be unique. - -- @Unique ['name1, 'name2, ...]@ works analogous to the following table constraint: - -- @UNIQUE (name1, name2, ...)@ - | ForeignKey [Name] Name [Name] - -- ^ A combination of fields references another combination of fields from a different table. - -- @ForeignKey ['name1, 'name2, ...] ''RefTable ['refname1, 'refname2, ...]@ works like this - -- table constraint in SQL: - -- @FOREIGN KEY (name1, name2, ...) REFERENCES RefTable(refname1, refname2, ...)@ + -- @Unique ['name1, 'name2, ...]@ works analogous to the table constraint + -- @UNIQUE (name1, name2, ...)@ in SQL. + | Check String + -- ^ The given statement must evaluate to true. Just like @CHECK (statement)@ in SQL. deriving (Show, Eq, Ord) --- | Implement 'Table' for a data type. The given type must fulfill these requirements: +-- | Implement the type classes 'QueryTable', 'Table' and 'Result' for the given type. -- +-- The given type must fulfill these requirements: +-- -- * Data type -- * No type context -- * No type variables @@ -350,65 +375,45 @@ -- Example: -- -- @ --- {-\# LANGUAGE TemplateHaskell \#-} +-- {-\# LANGUAGE TemplateHaskell, QuasiQuotes \#-} -- module Movies where -- -- ... -- -- data Movie = Movie { --- movieTitle :: String, --- movieYear :: Int --- } deriving Show +-- movieTitle :: 'String', +-- movieYear :: 'Int' +-- } deriving 'Show' -- -- 'mkTable' ''Movie [] -- -- data Actor = Actor { --- actorName :: String, --- actorAge :: Int --- } deriving Show +-- actorName :: 'String', +-- actorAge :: 'Int' +-- } deriving 'Show' -- --- 'mkTable' ''Actor [] +-- 'mkTable' ''Actor ['Unique' ['actorName], 'Check' ['pgss'| actorAge >= 18 |]] -- -- data MovieCast = MovieCast { -- movieCastMovie :: 'Reference' Movie, -- movieCastActor :: 'Reference' Actor --- } deriving Show +-- } deriving 'Show' -- --- 'mkTable' ''MovieCast [] +-- 'mkTable' ''MovieCast ['Unique' ['movieCastMovie, 'movieCastActor]] -- @ -- +-- In this example, 'Reference' takes care of adding the @FOREIGN KEY@ constraint, so we don't have +-- to. +-- mkTable :: Name -> [TableConstraint] -> Q [Dec] mkTable name constraints = do info <- reify name case info of - TyConI dec -> - case dec of - DataD [] _ [] [RecC ctor records@(_ : _)] _ -> do - let fields = map (\ (fn, _, ft) -> (fn, ft)) records - validateFields fields - implementTableD name ctor fields constraints - - DataD (_ : _) _ _ _ _ -> - fail ("\ESC[34m" ++ show name ++ "\ESC[0m has a context") - - DataD _ _ (_ : _) _ _ -> - fail ("\ESC[34m" ++ show name ++ "\ESC[0m has one or more type variables") - - DataD _ _ _ [] _ -> - fail ("\ESC[34m" ++ show name ++ "\ESC[0m does not have a constructor") - - DataD _ _ _ (_ : _ : _) _ -> - fail ("\ESC[34m" ++ show name ++ "\ESC[0m has more than one constructor") - - DataD _ _ _ [RecC _ []] _ -> - fail ("\ESC[34m" ++ show name ++ "\ESC[0m has an empty record constructor") - - DataD _ _ _ [_] _ -> - fail ("\ESC[34m" ++ show name ++ "\ESC[0m does not have a record constructor") - - _ -> fail ("\ESC[34m" ++ show name ++ "\ESC[0m is not an eligible data type") + TyConI dec -> do + tableDec <- checkTableDec name dec + implementClasses tableDec constraints - _ -> fail ("\ESC[34m" ++ show name ++ "\ESC[0m is not a type constructor") + _ -> fail ("'" ++ show name ++ "' is not a type constructor") -- | Check if the given name refers to a type. isType :: Name -> Q Bool @@ -418,7 +423,7 @@ TyConI _ -> True _ -> False --- | Generate a 'Query' which will create the table described my the given type. +-- | Generate a 'Query' expression which will create the table described by the given type. -- -- Example: -- @@ -436,4 +441,4 @@ unless it (fail "Given name does not refer to a type.") -- Actual splice - [e| createQuery (Proxy :: Proxy $(pure (ConT name))) |] + [e| createTableQuery (Proxy :: Proxy $(pure (ConT name))) |] diff --git a/tests/Database/PostgreSQL/Store/ColumnsSpec.hs b/tests/Database/PostgreSQL/Store/ColumnsSpec.hs deleted file mode 100644 --- a/tests/Database/PostgreSQL/Store/ColumnsSpec.hs +++ /dev/null @@ -1,121 +0,0 @@ -module Database.PostgreSQL.Store.ColumnsSpec (columnsSpec) where - -import Data.Int -import Data.Typeable -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - -import Test.QuickCheck -import Test.Hspec - -import Database.PostgreSQL.Store.Columns - --- | Pack and unpack value to test if the input value is the same as the output value. -testColumnIsomorphism :: (Column a, Show a, Eq a) => a -> Expectation -testColumnIsomorphism val = - shouldBe (unpack (pack val)) (Just val) - --- | Quick check an instance of Column to see if it behaves isomorphic. -propColumnIsomorphism :: (Column a, Arbitrary a, Eq a, Show a) => Proxy a -> Property -propColumnIsomorphism proxy = - property (compare proxy) - where - compare :: (Column a, Arbitrary a, Eq a, Show a) => Proxy a -> a -> Bool - compare _ x = - unpack (pack x) == Just x - --- | Quick check an instance of Column which has to be generated first, because it does not have an --- instance of Arbitrary. -propColumnIsomorphism' :: (Arbitrary b, Show b, Column a, Eq a, Show a) => ([b] -> a) -> Property -propColumnIsomorphism' make = - property (\ xs -> unpack (pack (make xs)) == Just (make xs)) - --- | Test for instances of Column -columnsSpec :: Spec -columnsSpec = do - describe "instance Column Bool" $ - it "must behave isomorphic" $ do - testColumnIsomorphism True - testColumnIsomorphism False - - describe "instance Column Int" $ do - it "must behave isomorphic" $ do - testColumnIsomorphism (minBound :: Int) - testColumnIsomorphism (0 :: Int) - testColumnIsomorphism (maxBound :: Int) - - it "must behave isomorphic (using QuickCheck)" $ - propColumnIsomorphism (Proxy :: Proxy Int) - - describe "instance Column Int8" $ do - it "must behave isomorphic" $ do - testColumnIsomorphism (minBound :: Int8) - testColumnIsomorphism (0 :: Int8) - testColumnIsomorphism (maxBound :: Int8) - - it "must behave isomorphic (using QuickCheck)" $ - propColumnIsomorphism (Proxy :: Proxy Int8) - - describe "instance Column Int16" $ do - it "must behave isomorphic" $ do - testColumnIsomorphism (minBound :: Int16) - testColumnIsomorphism (0 :: Int16) - testColumnIsomorphism (maxBound :: Int16) - - it "must behave isomorphic (using QuickCheck)" $ - propColumnIsomorphism (Proxy :: Proxy Int16) - - describe "instance Column Int32" $ do - it "must behave isomorphic" $ do - testColumnIsomorphism (minBound :: Int32) - testColumnIsomorphism (0 :: Int32) - testColumnIsomorphism (maxBound :: Int32) - - it "must behave isomorphic (using QuickCheck)" $ - propColumnIsomorphism (Proxy :: Proxy Int32) - - describe "instance Column Int64" $ do - it "must behave isomorphic" $ do - testColumnIsomorphism (minBound :: Int64) - testColumnIsomorphism (0 :: Int64) - testColumnIsomorphism (maxBound :: Int64) - - it "must behave isomorphic (using QuickCheck)" $ - propColumnIsomorphism (Proxy :: Proxy Int64) - - describe "instance Column [Char]" $ do - it "must behave isomorphic" $ - testColumnIsomorphism ([] :: [Char]) - - it "must behave isomorphic (using QuickCheck)" $ - propColumnIsomorphism (Proxy :: Proxy [Char]) - - describe "instance Column B.ByteString" $ do - it "must behave isomorphic" $ - testColumnIsomorphism B.empty - - it "must behave isomorphic (using QuickCheck)" $ - propColumnIsomorphism' B.pack - - describe "instance Column BL.ByteString" $ do - it "must behave isomorphic" $ - testColumnIsomorphism BL.empty - - it "must behave isomorphic (using QuickCheck)" $ - propColumnIsomorphism' BL.pack - - describe "instance Column T.Text" $ do - it "must behave isomorphic" $ - testColumnIsomorphism T.empty - - it "must behave isomorphic (using QuickCheck)" $ - propColumnIsomorphism' T.pack - - describe "instance Column TL.Text" $ do - it "must behave isomorphic" $ - testColumnIsomorphism TL.empty - - it "must behave isomorphic (using QuickCheck)" $ - propColumnIsomorphism' TL.pack diff --git a/tests/Database/PostgreSQL/Store/QuerySpec.hs b/tests/Database/PostgreSQL/Store/QuerySpec.hs deleted file mode 100644 --- a/tests/Database/PostgreSQL/Store/QuerySpec.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-} - -module Database.PostgreSQL.Store.QuerySpec (querySpec) where - -import Test.Hspec - -import Data.String -import Data.Typeable - -import Database.PostgreSQL.Store -import Database.PostgreSQL.Store.Query -import Database.PostgreSQL.Store.Columns - -data MyType = MyConstructor Int - deriving (Show) - -instance DescribableTable MyType where - describeTableName _ = "InsertTableName" - describeTableIdentifier _ = "InsertTableIdentifier" - -testValue :: Int -testValue = 1337 - -querySpec :: Spec -querySpec = - describe "parseStoreQueryE" $ do - it "must resolve tables names correctly" $ - queryStatement [pgsq|MyType|] - `shouldBe` fromString ("\"" ++ describeTableName (Proxy :: Proxy MyType) ++ "\"") - - it "must resolve identifier column names correctly" $ - queryStatement [pgsq|&MyType|] - `shouldBe` fromString ("\"" ++ describeTableIdentifier (Proxy :: Proxy MyType) ++ "\"") - - it "must insert and pack variables correctly" $ - [pgsq|$testValue|] `shouldBe` Query "$1" [pack testValue] diff --git a/tests/Database/PostgreSQL/Store/TableSpec.hs b/tests/Database/PostgreSQL/Store/TableSpec.hs deleted file mode 100644 --- a/tests/Database/PostgreSQL/Store/TableSpec.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-} - -module Database.PostgreSQL.Store.TableSpec (tableSpec) where - -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Monadic - -import Data.Int -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL - -import Database.PostgreSQL.Store -import qualified Database.PostgreSQL.LibPQ as P - -data TestTable = TestTable { - ttBool :: Bool, - ttInt :: Int, - ttInt8 :: Int8, - ttInt16 :: Int16, - ttInt32 :: Int32, - ttInt64 :: Int64, - ttString :: String, - ttText :: T.Text, - ttLazyText :: TL.Text, - ttByteString :: B.ByteString, - ttLazyByteString :: BL.ByteString, - ttMaybeInt :: Maybe Int -} deriving (Show, Eq, Ord) - -instance Arbitrary TestTable where - arbitrary = - TestTable <$> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> arbitrary - <*> fmap T.pack arbitrary - <*> fmap TL.pack arbitrary - <*> fmap B.pack arbitrary - <*> fmap BL.pack arbitrary - <*> arbitrary - -mkTable ''TestTable [] - -tableSpec :: P.Connection -> Spec -tableSpec con = do - describe "Table" $ do - it "create" $ do - result <- runErrand con (query_ $(mkCreateQuery ''TestTable)) :: IO (Either ErrandError ()) - result `shouldBe` Right () - - describe "Row" $ do - it "insert/find/update/find/delete" $ monadicIO $ do - row1 <- pick arbitrary :: PropertyM IO TestTable - eRef <- run (runErrand con (insert row1)) - - assert $ - case eRef of - Right (Reference _) -> True - _ -> False - - let Right ref = eRef - eRow1 <- run (runErrand con (find ref)) - - assert $ - case eRow1 of - Right (Row _ row1') -> row1' == row1 - _ -> False - - row2 <- pick arbitrary :: PropertyM IO TestTable - eUpdate <- run (runErrand con (update ref row2)) - - assert (eUpdate == Right ()) - - eRow2 <- run (runErrand con (find ref)) - - assert $ - case eRow2 of - Right (Row _ row2') -> row2' == row2 - _ -> False - - eDelete <- run (runErrand con (delete ref)) - - assert (eDelete == Right ()) - - describe "Table" $ do - it "drop" $ do - result <- runErrand con (query_ [pgsq| DROP TABLE TestTable |]) :: IO (Either ErrandError ()) - result `shouldBe` Right () diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,40 +1,29 @@ module Main (main) where import Test.Hspec - -import Control.Monad +import Test.Database.PostgreSQL.Store -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import Data.String -import Database.PostgreSQL.Store.ColumnsSpec -import Database.PostgreSQL.Store.TableSpec -import Database.PostgreSQL.Store.QuerySpec import qualified Database.PostgreSQL.LibPQ as P import System.Environment --- | Test which will only be executed if 'PGINFO' environment variable is set -liveTests :: String -> Spec -liveTests pgInfo = do - (con, status) <- runIO $ do - con <- P.connectdb (T.encodeUtf8 (T.pack pgInfo)) - status <- P.status con - pure (con, status) - - describe "Database connection" $ - it "must be established" $ - status `shouldBe` P.ConnectionOk +connectMaybe :: String -> IO (Maybe P.Connection) +connectMaybe info = do + con <- P.connectdb (fromString info) + status <- P.status con - when (status == P.ConnectionOk) (afterAll_ (P.finish con) (tableSpec con)) + pure $ + if status == P.ConnectionOk then + Just con + else + Nothing -- | Test entry point main :: IO () -main = hspec $ do - columnsSpec - querySpec +main = do + mbInfo <- lookupEnv "PGINFO" + mbCon <- maybe (pure Nothing) connectMaybe mbInfo - mbPGInfo <- runIO (lookupEnv "PGINFO") - case mbPGInfo of - Just pgInfo -> liveTests pgInfo - Nothing -> runIO (putStrLn "Environment variable 'PGINFO' is missing") + hspec (allSpecs mbCon) diff --git a/tests/Test/Database/PostgreSQL/Store.hs b/tests/Test/Database/PostgreSQL/Store.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Database/PostgreSQL/Store.hs @@ -0,0 +1,17 @@ +module Test.Database.PostgreSQL.Store ( + allSpecs +) where + +import Test.Hspec + +import Test.Database.PostgreSQL.Store.Columns +import Test.Database.PostgreSQL.Store.Query +import Test.Database.PostgreSQL.Store.Table + +import qualified Database.PostgreSQL.LibPQ as P + +allSpecs :: Maybe P.Connection -> Spec +allSpecs mbCon = do + allColumnsSpecs mbCon + allTableSpecs mbCon + allQuerySpecs diff --git a/tests/Test/Database/PostgreSQL/Store/Columns.hs b/tests/Test/Database/PostgreSQL/Store/Columns.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Database/PostgreSQL/Store/Columns.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-} + +module Test.Database.PostgreSQL.Store.Columns ( + allColumnsSpecs +) where + +import Test.Hspec +import Test.QuickCheck +import Test.QuickCheck.Monadic + +import Control.Monad.Trans + +import Data.Int +import Data.Word +import Data.Proxy + +import Database.PostgreSQL.Store.Query +import Database.PostgreSQL.Store.Columns +import Database.PostgreSQL.Store.Result +import Database.PostgreSQL.Store.Errand + +import qualified Database.PostgreSQL.LibPQ as P + +testLivePackUnpack :: (Column a, Arbitrary a, Eq a, Show a) => Proxy a -> P.Connection -> Property +testLivePackUnpack proxy con = + property $ coerceParam proxy $ \ value -> monadicIO $ do + lift $ do + res <- runErrand con (queryWith (Query "SELECT $1" [pack value]) unpackColumn) + + shouldBe res (Right [value]) + where + coerceParam :: Proxy a -> (a -> b) -> a -> b + coerceParam _ f x = f x + +testPackUnpack :: (Column a, Arbitrary a, Eq a, Show a) => Proxy a -> Property +testPackUnpack proxy = + property (compare proxy) + where + compare :: (Column a, Eq a) => Proxy a -> a -> Bool + compare _ x = unpack (pack x) == Just x + +allColumnsSpecs :: Maybe P.Connection -> Spec +allColumnsSpecs mbCon = do + describe "Database.PostgreSQL.Store.Columns" $ do + describe "instance (Column a) => Column (Maybe a)" $ + it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy (Maybe Bool))) + + describe "instance Column Bool" $ + it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Bool)) + + describe "instance Column Int" $ + it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int)) + + describe "instance Column Int8" $ + it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int8)) + + describe "instance Column Int16" $ + it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int16)) + + describe "instance Column Int32" $ + it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int32)) + + describe "instance Column Int64" $ + it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Int64)) + + describe "instance Column Word" $ + it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word)) + + describe "instance Column Word8" $ + it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word8)) + + describe "instance Column Word16" $ + it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word16)) + + describe "instance Column Word32" $ + it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word32)) + + describe "instance Column Word64" $ + it "behaves isomorphic" (testPackUnpack (Proxy :: Proxy Word64)) + + maybe (pure ()) liveSpecs mbCon + +liveSpecs :: P.Connection -> Spec +liveSpecs con = + describe "Database.PostgreSQL.Store.Columns (live)" $ do + describe "instance Column Bool" $ + it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Bool) con) + + describe "instance Column Int" $ + it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int) con) + + describe "instance Column Int8" $ + it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int8) con) + + describe "instance Column Int16" $ + it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int16) con) + + describe "instance Column Int32" $ + it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int32) con) + + describe "instance Column Int64" $ + it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Int64) con) + + describe "instance Column Word" $ + it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word) con) + + describe "instance Column Word8" $ + it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word8) con) + + describe "instance Column Word16" $ + it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word16) con) + + describe "instance Column Word32" $ + it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word32) con) + + describe "instance Column Word64" $ + it "behaves isomorphic" (testLivePackUnpack (Proxy :: Proxy Word64) con) diff --git a/tests/Test/Database/PostgreSQL/Store/Query.hs b/tests/Test/Database/PostgreSQL/Store/Query.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Database/PostgreSQL/Store/Query.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-} + +module Test.Database.PostgreSQL.Store.Query ( + allQuerySpecs +) where + +import Test.Hspec + +import Database.PostgreSQL.Store.Query +import Database.PostgreSQL.Store.Columns + +data TestTable = TestTable + deriving (Show, Eq, Ord) + +instance QueryTable TestTable where + tableName _ = "T" + tableIDName _ = "a" + tableSelectors _ = [SelectorField "b", SelectorField "c"] + +testVariable :: Int +testVariable = 1337 + +allQuerySpecs :: Spec +allQuerySpecs = + describe "Database.PostgreSQL.Store.Query" $ + describe "pgsq" $ do + it "resolves table names" $ do + shouldBe [pgsq|@TestTable|] (Query "\"T\"" []) + shouldBe [pgsq|@Test.Database.PostgreSQL.Store.Query.TestTable|] [pgsq|@TestTable|] + shouldBe [pgsq|@TestTable.b|] (Query "\"T\".b" []) + shouldBe [pgsq|@TestTable."b"|] (Query "\"T\".\"b\"" []) + + it "resolves identifier fields" $ do + shouldBe [pgsq|&TestTable|] (Query "\"T\".\"a\"" []) + shouldBe [pgsq|&Test.Database.PostgreSQL.Store.Query.TestTable|] [pgsq|&TestTable|] + + it "resolves selectors" $ do + shouldBe [pgsq|#TestTable|] (Query "\"T\".\"b\", \"T\".\"c\"" []) + shouldBe [pgsq|#TestTable|] [pgsq|#Test.Database.PostgreSQL.Store.Query.TestTable|] + + it "embeds variables" $ do + let i = testVariable + shouldBe [pgsq|$testVariable $i|] (Query "$1 $2" [pack testVariable, pack i]) + + it "ignores operator #" $ do + shouldBe [pgsq|1 # 2|] (Query "1 # 2" []) + shouldBe [pgsq|a # b|] (Query "a # b" []) + shouldBe [pgsq|a # T|] (Query "a # T" []) + shouldBe [pgsq|a # T.a|] (Query "a # T.a" []) + shouldBe [pgsq|a # "T"|] (Query "a # \"T\"" []) + shouldBe [pgsq|a # "T"."a"|] (Query "a # \"T\".\"a\"" []) + shouldBe [pgsq|1#2|] (Query "1#2" []) + shouldBe [pgsq|a#b|] (Query "a#b" []) + shouldBe [pgsq|a#(T)|] (Query "a#(T)" []) + shouldBe [pgsq|a#(T.a)|] (Query "a#(T.a)" []) + shouldBe [pgsq|a#"T"|] (Query "a#\"T\"" []) + shouldBe [pgsq|a#"T"."a"|] (Query "a#\"T\".\"a\"" []) + + it "ignores operator &" $ do + shouldBe [pgsq|1 & 2|] (Query "1 & 2" []) + shouldBe [pgsq|a & b|] (Query "a & b" []) + shouldBe [pgsq|a & T|] (Query "a & T" []) + shouldBe [pgsq|a & T.a|] (Query "a & T.a" []) + shouldBe [pgsq|a & "T"|] (Query "a & \"T\"" []) + shouldBe [pgsq|a & "T"."a"|] (Query "a & \"T\".\"a\"" []) + shouldBe [pgsq|1&2|] (Query "1&2" []) + shouldBe [pgsq|a&b|] (Query "a&b" []) + shouldBe [pgsq|a&(T)|] (Query "a&(T)" []) + shouldBe [pgsq|a&(T.a)|] (Query "a&(T.a)" []) + shouldBe [pgsq|a&"T"|] (Query "a&\"T\"" []) + shouldBe [pgsq|a&"T"."a"|] (Query "a&\"T\".\"a\"" []) + + it "ignores operator @" $ do + shouldBe [pgsq|@-5|] (Query "@-5" []) + shouldBe [pgsq|@(-5)|] (Query "@(-5)" []) + shouldBe [pgsq|@a|] (Query "@a" []) + shouldBe [pgsq|@(a)|] (Query "@(a)" []) + shouldBe [pgsq|@(T)|] (Query "@(T)" []) + shouldBe [pgsq|@(T.a)|] (Query "@(T.a)" []) + shouldBe [pgsq|@"a"|] (Query "@\"a\"" []) + shouldBe [pgsq|@"T"|] (Query "@\"T\"" []) + shouldBe [pgsq|@"T"."a"|] (Query "@\"T\".\"a\"" []) + + it "ignores bad use of $" $ do + shouldBe [pgsq|$1|] (Query "$1" []) + shouldBe [pgsq|$(1)|] (Query "$(1)" []) + shouldBe [pgsq|$(a)|] (Query "$(a)" []) + shouldBe [pgsq|$(T)|] (Query "$(T)" []) + shouldBe [pgsq|$(T.a)|] (Query "$(T.a)" []) + shouldBe [pgsq|$"a"|] (Query "$\"a\"" []) + shouldBe [pgsq|$"T"|] (Query "$\"T\"" []) + shouldBe [pgsq|$"T"."a"|] (Query "$\"T\".\"a\"" []) diff --git a/tests/Test/Database/PostgreSQL/Store/Table.hs b/tests/Test/Database/PostgreSQL/Store/Table.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Database/PostgreSQL/Store/Table.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes #-} + +module Test.Database.PostgreSQL.Store.Table ( + allTableSpecs +) where + +import Test.Hspec + +import Data.Proxy + +import Database.PostgreSQL.Store.Table +import Database.PostgreSQL.Store.Query +import Database.PostgreSQL.Store.Errand + +import qualified Database.PostgreSQL.LibPQ as P + +data OnlyEvens = OnlyEvens { + value :: Int +} deriving (Show, Eq) + +mkTable ''OnlyEvens + [Unique ['value], + Check [pgss| value % 2 = 0 |]] + +allTableSpecs :: Maybe P.Connection -> Spec +allTableSpecs mbCon = do + maybe (pure ()) liveSpecs mbCon + +dropTable :: P.Connection -> IO () +dropTable con = + () <$ runErrand con (query_ [pgsq| DROP TABLE @OnlyEvens |]) + +clearTable :: P.Connection -> IO () +clearTable con = + () <$ runErrand con (query_ [pgsq| DELETE FROM @OnlyEvens |]) + +liveSpecs :: P.Connection -> Spec +liveSpecs con = + describe "Database.PostgreSQL.Store.Table (live)" $ + afterAll_ (dropTable con) $ describe "auto-generated instance Table" $ + after_ (clearTable con) $ do + it "creates tables" $ do + res1 <- runErrand con $ + query_ $(mkCreateQuery ''OnlyEvens) + shouldBe res1 (Right ()) + + -- Table exists now + let table = tableName (Proxy :: Proxy OnlyEvens) + res2 <- runErrand con $ + query [pgsq| SELECT COUNT(*) FROM pg_tables WHERE tablename = $table |] + shouldBe res2 (Right [Single (1 :: Int)]) + + it "inserts a rows" $ do + res1 <- runErrand con (insert (OnlyEvens 2)) + shouldSatisfy res1 $ \ r -> + case r of + Right (Reference _) -> True + _ -> False + + -- Has been inserted correctly + res2 <- runErrand con $ + query [pgsq| SELECT #OnlyEvens FROM @OnlyEvens |] + shouldBe res2 (Right [OnlyEvens 2]) + + it "respects constraints while inserting" $ do + -- Violate UNIQUE + res3 <- runErrand con $ do + insert (OnlyEvens 2) + insert (OnlyEvens 2) + shouldSatisfy res3 $ \ r -> + case r of + Left (ExecError _ UniqueViolation _ _ _) -> True + _ -> False + + -- Violate CHECK + res4 <- runErrand con (insert (OnlyEvens 1)) + shouldSatisfy res4 $ \ r -> + case r of + Left (ExecError _ CheckViolation _ _ _) -> True + _ -> False + + it "inserts many rows" $ do + res1 <- runErrand con (insertMany (map OnlyEvens [2, 4 .. 100])) + shouldSatisfy res1 $ \ r -> + case r of + Right xs -> length xs == 50 + _ -> False + + -- Verify that there are actually 50 present + res2 <- runErrand con $ + query [pgsq| SELECT COUNT(*) FROM @OnlyEvens |] + shouldBe res2 (Right [Single (50 :: Int)]) + + it "finds a row" $ do + res1 <- runErrand con $ do + ref <- insert (OnlyEvens 4) + find ref + shouldBe res1 (Right (OnlyEvens 4)) + + it "finds many rows" $ + pendingWith "Not yet implemented" + + it "updates a row" $ do + res1 <- runErrand con $ do + ref <- insert (OnlyEvens 4) + update ref (OnlyEvens 6) + find ref + shouldBe res1 (Right (OnlyEvens 6)) + + it "respects constraints while updating" $ do + -- Violate UNIQUE + res1 <- runErrand con $ do + insert (OnlyEvens 2) + ref <- insert (OnlyEvens 4) + update ref (OnlyEvens 2) + shouldSatisfy res1 $ \ r -> + case r of + Left (ExecError _ UniqueViolation _ _ _) -> True + _ -> False + + -- Vioate CHECK + res2 <- runErrand con $ do + ref <- insert (OnlyEvens 6) + update ref (OnlyEvens 7) + shouldSatisfy res2 $ \ r -> + case r of + Left (ExecError _ CheckViolation _ _ _) -> True + _ -> False + + it "updates many rows" $ + pendingWith "Not yet implemented" + + it "deletes a row" $ do + res1 <- runErrand con $ do + ref <- insert (OnlyEvens 2) + delete ref + shouldBe res1 (Right ()) + + it "deletes many rows" $ + pendingWith "Not yet implemented"