diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -5,4 +5,7 @@ Joey Adams Rekado Leonid Onokhov +Bas van Dijk Jason Dusek +Jeff Chu +Oliver Charles diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -1,5 +1,5 @@ Name: postgresql-simple -Version: 0.2.4.1 +Version: 0.3.0.0 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple. @@ -21,6 +21,7 @@ hs-source-dirs: src Exposed-modules: Database.PostgreSQL.Simple + Database.PostgreSQL.Simple.Arrays Database.PostgreSQL.Simple.BuiltinTypes Database.PostgreSQL.Simple.FromField Database.PostgreSQL.Simple.FromRow @@ -32,13 +33,18 @@ Database.PostgreSQL.Simple.Time.Internal Database.PostgreSQL.Simple.ToField Database.PostgreSQL.Simple.ToRow + Database.PostgreSQL.Simple.Transaction + Database.PostgreSQL.Simple.TypeInfo + Database.PostgreSQL.Simple.TypeInfo.Static Database.PostgreSQL.Simple.Types + Database.PostgreSQL.Simple.Errors -- Other-modules: Database.PostgreSQL.Simple.Internal Other-modules: Database.PostgreSQL.Simple.Compat Database.PostgreSQL.Simple.Time.Implementation + Database.PostgreSQL.Simple.TypeInfo.Types Build-depends: attoparsec >= 0.8.5.3, @@ -66,7 +72,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple - tag: v0.2.4.1 + tag: v0.3.0.0 test-suite test type: exitcode-stdio-1.0 @@ -75,18 +81,21 @@ main-is: Main.hs other-modules: Common - Bytea - ExecuteMany Notify Serializable Time + Build-depends: + vector + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind extensions: NamedFieldPuns , OverloadedStrings , Rank2Types , RecordWildCards + , PatternGuards + , ScopedTypeVariables build-depends: base , base16-bytestring diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs --- a/src/Database/PostgreSQL/Simple.hs +++ b/src/Database/PostgreSQL/Simple.hs @@ -67,6 +67,7 @@ , (:.)(..) -- ** Exceptions , SqlError(..) + , PQ.ExecStatus(..) , FormatError(fmtMessage, fmtQuery, fmtParams) , QueryError(qeMessage, qeQuery) , ResultError(errSQLType, errHaskellType, errMessage) @@ -97,20 +98,8 @@ -- , Base.insertID -- * Transaction handling , withTransaction - , withTransactionSerializable - , TransactionMode(..) - , IsolationLevel(..) - , ReadWriteMode(..) - , defaultTransactionMode - , defaultIsolationLevel - , defaultReadWriteMode - , withTransactionLevel - , withTransactionMode - , withTransactionModeRetry -- , Base.autocommit , begin - , beginLevel - , beginMode , commit , rollback -- * Helper functions @@ -122,19 +111,15 @@ ( Builder, fromByteString, toByteString ) import Blaze.ByteString.Builder.Char8 (fromChar) import Control.Applicative ((<$>), pure) -import Control.Concurrent.MVar import Control.Exception - ( Exception, onException, throw, throwIO, finally - , try, SomeException, fromException ) + ( Exception, throw, throwIO, finally ) import Control.Monad (foldM) import Data.ByteString (ByteString) import Data.Int (Int64) -import qualified Data.IntMap as IntMap import Data.List (intersperse) -import Data.Monoid (mappend, mconcat) +import Data.Monoid (mconcat) import Data.Typeable (Typeable) -import Database.PostgreSQL.Simple.BuiltinTypes ( oid2typname ) -import Database.PostgreSQL.Simple.Compat ( mask ) +import Database.PostgreSQL.Simple.Compat ( (<>) ) import Database.PostgreSQL.Simple.FromField (ResultError(..)) import Database.PostgreSQL.Simple.FromRow (FromRow(..)) import Database.PostgreSQL.Simple.Ok @@ -143,11 +128,12 @@ import Database.PostgreSQL.Simple.Types ( Binary(..), In(..), Only(..), Query(..), (:.)(..) ) import Database.PostgreSQL.Simple.Internal as Base +import Database.PostgreSQL.Simple.Transaction +import Database.PostgreSQL.Simple.TypeInfo import qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import qualified Data.Vector as V import Control.Monad.Trans.Reader import Control.Monad.Trans.State.Strict @@ -322,7 +308,7 @@ sub (Many ys) = mconcat <$> mapM sub ys split s = fromByteString h : if B.null t then [] else split (B.tail t) where (h,t) = B.break (=='?') s - zipParams (t:ts) (p:ps) = t `mappend` p `mappend` zipParams ts ps + zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps zipParams [t] [] = t zipParams _ _ = fmtError (show (B.count '?' template) ++ " '?' characters, but " ++ @@ -496,8 +482,7 @@ where go = do -- FIXME: what about name clashes with already-declared cursors? - _ <- execute_ conn ("DECLARE fold NO SCROLL CURSOR FOR " - `mappend` q) + _ <- execute_ conn ("DECLARE fold NO SCROLL CURSOR FOR " <> q) loop a `finally` execute_ conn "CLOSE fold" -- FIXME: choose the Automatic chunkSize more intelligently @@ -550,28 +535,28 @@ PQ.CommandOk -> do throwIO $ QueryError "query resulted in a command response" q PQ.TuplesOk -> do - ncols <- PQ.nfields result let unCol (PQ.Col x) = fromIntegral x :: Int - typenames <- V.generateM (unCol ncols) - (\(PQ.Col . fromIntegral -> col) -> do - getTypename conn =<< PQ.ftype result col) nrows <- PQ.ntuples result ncols <- PQ.nfields result forM' 0 (nrows-1) $ \row -> do - let rw = Row row typenames result - case runStateT (runReaderT (unRP fromRow) rw) 0 of + let rw = Row row result + okvc <- runConversion (runStateT (runReaderT (unRP fromRow) rw) 0) conn + case okvc of Ok (val,col) | col == ncols -> return val | otherwise -> do vals <- forM' 0 (ncols-1) $ \c -> do + tinfo <- getTypeInfo conn =<< PQ.ftype result c v <- PQ.getvalue result row c - return ( typenames V.! unCol c + return ( tinfo , fmap ellipsis v ) throw (ConversionFailed (show (unCol ncols) ++ " values: " ++ show vals) + Nothing + "" (show (unCol col) ++ " slots in target type") "mismatch between number of columns to \ \convert and number in target type") - Errors [] -> throwIO $ ConversionFailed "" "" "unknown error" + Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error" Errors [x] -> throwIO x Errors xs -> throwIO $ ManyErrors xs PQ.CopyOut -> @@ -587,160 +572,6 @@ | B.length bs > 15 = B.take 10 bs `B.append` "[...]" | otherwise = bs - --- | Of the four isolation levels defined by the SQL standard, --- these are the three levels distinguished by PostgreSQL as of version 9.0. --- See --- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead' --- was equivalent to 'Serializable'. - -data IsolationLevel - = DefaultIsolationLevel -- ^ the isolation level will be taken from - -- PostgreSQL's per-connection - -- @default_transaction_isolation@ variable, - -- which is initialized according to the - -- server's config. The default configuration - -- is 'ReadCommitted'. - | ReadCommitted - | RepeatableRead - | Serializable - deriving (Show, Eq, Ord, Enum, Bounded) - -data ReadWriteMode - = DefaultReadWriteMode -- ^ the read-write mode will be taken from - -- PostgreSQL's per-connection - -- @default_transaction_read_only@ variable, - -- which is initialized according to the - -- server's config. The default configuration - -- is 'ReadWrite'. - | ReadWrite - | ReadOnly - deriving (Show, Eq, Ord, Enum, Bounded) - -data TransactionMode = TransactionMode { - isolationLevel :: !IsolationLevel, - readWriteMode :: !ReadWriteMode - } deriving (Show, Eq) - -defaultTransactionMode :: TransactionMode -defaultTransactionMode = TransactionMode - defaultIsolationLevel - defaultReadWriteMode - -defaultIsolationLevel :: IsolationLevel -defaultIsolationLevel = DefaultIsolationLevel - -defaultReadWriteMode :: ReadWriteMode -defaultReadWriteMode = DefaultReadWriteMode - --- | Execute an action inside a SQL transaction. --- --- This function initiates a transaction with a \"@begin --- transaction@\" statement, then executes the supplied action. If --- the action succeeds, the transaction will be completed with --- 'Base.commit' before this function returns. --- --- If the action throws /any/ kind of exception (not just a --- PostgreSQL-related exception), the transaction will be rolled back using --- 'rollback', then the exception will be rethrown. -withTransaction :: Connection -> IO a -> IO a -withTransaction = withTransactionMode defaultTransactionMode - --- | Execute an action inside of a 'Serializable' transaction. If a --- serialization failure occurs, roll back the transaction and try again. --- Be warned that this may execute the IO action multiple times. --- --- A 'Serializable' transaction creates the illusion that your program has --- exclusive access to the database. This means that, even in a concurrent --- setting, you can perform queries in sequence without having to worry about --- what might happen between one statement and the next. --- --- Think of it as STM, but without @retry@. -withTransactionSerializable :: Connection -> IO a -> IO a -withTransactionSerializable = - withTransactionModeRetry - TransactionMode - { isolationLevel = Serializable - , readWriteMode = ReadWrite - } - --- | Execute an action inside a SQL transaction with a given isolation level. -withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a -withTransactionLevel lvl - = withTransactionMode defaultTransactionMode { isolationLevel = lvl } - --- | Execute an action inside a SQL transaction with a given transaction mode. -withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a -withTransactionMode mode conn act = - mask $ \restore -> do - beginMode mode conn - r <- restore act `onException` rollback conn - commit conn - return r - --- | Like 'withTransactionMode', but if a 'SqlError' arises whose 'sqlState' is --- @\"40001\"@ (@serialization_failure@), this will issue a @ROLLBACK@, then --- try the action again. If any other exception arises, this will issue a --- @ROLLBACK@, but will propagate the exception instead of retrying. --- --- This is used to implement 'withTransactionSerializable'. -withTransactionModeRetry :: TransactionMode -> Connection -> IO a -> IO a -withTransactionModeRetry mode conn act = - mask $ \restore -> - retryLoop $ try $ do - a <- restore act - commit conn - return a - where - retryLoop :: IO (Either SomeException a) -> IO a - retryLoop act' = do - beginMode mode conn - r <- act' - case r of - Left e -> do - rollback conn - case fromException e of - Just SqlError{..} | sqlState == serialization_failure - -> retryLoop act' - _ -> throwIO e - Right a -> - return a - - -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html - serialization_failure = "40001" - --- | Rollback a transaction. -rollback :: Connection -> IO () -rollback conn = execute_ conn "ABORT" >> return () - --- | Commit a transaction. -commit :: Connection -> IO () -commit conn = execute_ conn "COMMIT" >> return () - --- | Begin a transaction. -begin :: Connection -> IO () -begin = beginMode defaultTransactionMode - --- | Begin a transaction with a given isolation level -beginLevel :: IsolationLevel -> Connection -> IO () -beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl } - --- | Begin a transaction with a given transaction mode -beginMode :: TransactionMode -> Connection -> IO () -beginMode mode conn = do - _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode]) - return () - where - isolevel = case isolationLevel mode of - DefaultIsolationLevel -> "" - ReadCommitted -> " ISOLATION LEVEL READ COMMITTED" - RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ" - Serializable -> " ISOLATION LEVEL SERIALIZABLE" - readmode = case readWriteMode mode of - DefaultReadWriteMode -> "" - ReadWrite -> " READ WRITE" - ReadOnly -> " READ ONLY" - fmtError :: String -> Query -> [Action] -> a fmtError msg q xs = throw FormatError { fmtMessage = msg @@ -1014,25 +845,3 @@ -- UTF-8. If you use some other encoding, decoding may fail or give -- wrong results. In such cases, write a @newtype@ wrapper and a -- custom 'Result' instance to handle your encoding. - -getTypename :: Connection -> PQ.Oid -> IO ByteString -getTypename conn@Connection{..} oid = - case oid2typname oid of - Just name -> return name - Nothing -> modifyMVar connectionObjects $ \oidmap -> do - case IntMap.lookup (oid2int oid) oidmap of - Just name -> return (oidmap, name) - Nothing -> do - names <- query conn "SELECT typname FROM pg_type WHERE oid=?" - (Only oid) - name <- case names of - [] -> return $ throw SqlError { - sqlNativeError = -1, - sqlErrorMsg = "invalid type oid", - sqlState = "" - } - [Only x] -> return x - _ -> fail "typename query returned more than one result" - -- oid is a primary key, so the query should - -- never return more than one result - return (IntMap.insert (oid2int oid) name oidmap, name) diff --git a/src/Database/PostgreSQL/Simple.hs-boot b/src/Database/PostgreSQL/Simple.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple.hs-boot @@ -0,0 +1,23 @@ +module Database.PostgreSQL.Simple + ( Connection + , Query + , query + , query_ + , execute + , execute_ + , executeMany + ) where + +import Data.Int(Int64) +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.Types +import {-# SOURCE #-} Database.PostgreSQL.Simple.FromRow +import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow + +query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] + +query_ :: FromRow r => Connection -> Query -> IO [r] + +execute :: ToRow q => Connection -> Query -> q -> IO Int64 + +executeMany :: ToRow q => Connection -> Query -> [q] -> IO Int64 diff --git a/src/Database/PostgreSQL/Simple/Arrays.hs b/src/Database/PostgreSQL/Simple/Arrays.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Arrays.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE PatternGuards #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.Arrays +-- Copyright: (c) 2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- Portability: portable +-- +-- A Postgres array parser and pretty-printer. +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.Arrays where + +import Control.Applicative (Applicative(..), Alternative(..), (<$>)) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Monoid +import Data.Attoparsec.Char8 + + +-- | Parse one of three primitive field formats: array, quoted and plain. +arrayFormat :: Char -> Parser ArrayFormat +arrayFormat delim = Array <$> array delim + <|> Plain <$> plain delim + <|> Quoted <$> quoted + +data ArrayFormat = Array [ArrayFormat] + | Plain ByteString + | Quoted ByteString + deriving (Eq, Show, Ord) + +array :: Char -> Parser [ArrayFormat] +array delim = char '{' *> option [] (arrays <|> strings) <* char '}' + where + strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim) + arrays = sepBy1 (Array <$> array delim) (char ',') + -- NB: Arrays seem to always be delimited by commas. + +-- | Recognizes a quoted string. +quoted :: Parser ByteString +quoted = char '"' *> option "" contents <* char '"' + where + esc = char '\\' *> (char '\\' <|> char '"') + unQ = takeWhile1 (notInClass "\"\\") + contents = mconcat <$> many (unQ <|> B.singleton <$> esc) + +-- | Recognizes a plain string literal, not containing quotes or brackets and +-- not containing the delimiter character. +plain :: Char -> Parser ByteString +plain delim = takeWhile1 (notInClass (delim:"\"{}")) + +-- Mutually recursive 'fmt' and 'delimit' separate out value formatting +-- from the subtleties of delimiting. + +-- | Format an array format item, using the delimiter character if the item is +-- itself an array. +fmt :: Char -> ArrayFormat -> ByteString +fmt = fmt' False + +-- | Format a list of array format items, inserting the appropriate delimiter +-- between them. When the items are arrays, they will be delimited with +-- commas; otherwise, they are delimited with the passed-in-delimiter. +delimit :: Char -> [ArrayFormat] -> ByteString +delimit _ [] = "" +delimit c [x] = fmt' True c x +delimit c (x:y:z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y:z) + where + c' | Array _ <- x = ',' + | otherwise = c + +-- | Format an array format item, using the delimiter character if the item is +-- itself an array, optionally applying quoting rules. Creates copies for +-- safety when used in 'FromField' instances. +fmt' :: Bool -> Char -> ArrayFormat -> ByteString +fmt' quoting c x = + case x of + Array items -> '{' `B.cons` (delimit c items `B.snoc` '}') + Plain bytes -> B.copy bytes + Quoted q | quoting -> '"' `B.cons` (esc q `B.snoc` '"') + | otherwise -> B.copy q + -- NB: The 'snoc' and 'cons' functions always copy. + +-- | Escape a string according to Postgres double-quoted string format. +esc :: ByteString -> ByteString +esc = B.concatMap f + where + f '"' = "\\\"" + f '\\' = "\\\\" + f c = B.singleton c + -- TODO: Implement easy performance improvements with unfoldr. + diff --git a/src/Database/PostgreSQL/Simple/Compat.hs b/src/Database/PostgreSQL/Simple/Compat.hs --- a/src/Database/PostgreSQL/Simple/Compat.hs +++ b/src/Database/PostgreSQL/Simple/Compat.hs @@ -1,12 +1,24 @@ {-# LANGUAGE CPP #-} --- | This is a module of its own, because it uses the CPP extension, which --- doesn't play well with the regex string literal in Simple.hs . +-- | This is a module of its own, partly because it uses the CPP extension, +-- which doesn't play well with backslash-broken string literals. module Database.PostgreSQL.Simple.Compat ( mask + , (<>) + , unsafeDupablePerformIO ) where import qualified Control.Exception as E +import Data.Monoid +#if __GLASGOW_HASKELL__ >= 702 +import System.IO.Unsafe (unsafeDupablePerformIO) +#elif __GLASGOW_HASKELL__ >= 611 +import GHC.IO (unsafeDupablePerformIO) +#else +import GHC.IOBase (unsafeDupablePerformIO) +#endif + + -- | Like 'E.mask', but backported to base before version 4.3.0. -- -- Note that the restore callback is monomorphic, unlike in 'E.mask'. This @@ -23,3 +35,11 @@ E.block $ io $ \m -> if b then m else E.unblock m #endif {-# INLINE mask #-} + +#if !MIN_VERSION_base(4,5,0) +infixr 6 <> + +(<>) :: Monoid m => m -> m -> m +(<>) = mappend +{-# INLINE (<>) #-} +#endif diff --git a/src/Database/PostgreSQL/Simple/Errors.hs b/src/Database/PostgreSQL/Simple/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Errors.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Module for parsing errors from posgresql error messages. +-- Currently in only parses integrity violation errors (class 23). +-- +-- /Note: Success of parsing may depend on language settings./ +---------------------------------------------------------- +module Database.PostgreSQL.Simple.Errors + ( ConstraintViolation(..) + , constraintViolation + , constraintViolationE + , catchViolation + ) + where + +import Prelude hiding (catch) + +import Control.Applicative +import Control.Exception + +import Data.Attoparsec.Char8 +import Data.ByteString (ByteString) +import Data.Typeable + +import Database.PostgreSQL.Simple.Internal + +-- Examples of parsed error messages +-- +-- `ERROR: new row for relation "users" violates check +-- constraint "user_kind_check"` +-- +-- `ERROR: insert or update on table "user_group_map" violates foreign key +-- constraint "user_id"` +-- +-- `ERROR: null value in column "login" violates not-null constraint` +-- +-- `ERROR: duplicate key value violates unique constraint "users_login_key"` + +data ConstraintViolation + = NotNullViolation ByteString + -- ^ The field is a column name + | ForeignKeyViolation ByteString ByteString + -- ^ Table name and name of violated constraint + | UniqueViolation ByteString + -- ^ Name of violated constraint + | CheckViolation ByteString ByteString + -- ^ Relation name (usually table), constraint name + deriving (Show, Eq, Ord, Typeable) + +-- Default instance should be enough +instance Exception ConstraintViolation + + +-- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and +-- succeedes only if able to parse sqlErrorMsg. +-- +-- > createUser = catchJust constraintViolation catcher $ execute conn ... +-- > where +-- > catcher UniqueViolation "user_login_key" = ... +-- > catcher _ = ... +constraintViolation :: SqlError -> Maybe ConstraintViolation +constraintViolation e = + case sqlState e of + "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg + "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg + "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg + "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg + _ -> Nothing + where msg = sqlErrorMsg e + + +-- | Like constraintViolation, but also packs original SqlError. +-- +-- > createUser = catchJust constraintViolationE catcher $ execute conn ... +-- > where +-- > catcher (_, UniqueViolation "user_login_key") = ... +-- > catcher (e, _) = throw e +-- +constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation) +constraintViolationE e = fmap ((,) e) $ constraintViolation e + +-- | Catches SqlError, tries to convert to ConstraintViolation, re-throws +-- on fail. Provides alternative interface to catchJust +-- +-- > createUser = catchViolation catcher $ execute conn ... +-- > where +-- > catcher _ (UniqueViolation "user_login_key") = ... +-- > catcher e _ = throw e +catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a +catchViolation f m = catch m + (\e -> maybe (throw e) (f e) $ constraintViolation e) + +-- Parsers just try to extract quoted strings from error messages, number +-- of quoted strings depend on error type. +scanTillQuote :: Parser ByteString +scanTillQuote = scan False go + where go True _ = Just False -- escaped character + go False '"' = Nothing -- end parse + go False '\\' = Just True -- next one is escaped + go _ _ = Just False + +parseQ1 :: Parser ByteString +parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"' + +parseQ2 :: Parser (ByteString, ByteString) +parseQ2 = (,) <$> parseQ1 <*> parseQ1 + +parseMaybe :: Parser a -> ByteString -> Maybe a +parseMaybe p b = either (const Nothing) Just $ parseOnly p b diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -1,6 +1,7 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE PatternGuards, ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ -- | @@ -18,21 +19,63 @@ -- A Haskell numeric type is considered to be compatible with all -- PostgreSQL numeric types that are less accurate than it. For instance, -- the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit --- @Int@ type because it can represent a @Int@ exactly. On the other hand, --- since a 'Double' might lose precision if representing a 64-bit @BigInt@, --- the two are /not/ considered compatible. +-- @int@ type because it can represent a @int@ exactly. On the other hand, +-- since a 'Double' might lose precision if representing PostgreSQL's 64-bit +-- @bigint@, the two are /not/ considered compatible. -- +-- Because 'FromField' is a typeclass, one may provide conversions to +-- additional Haskell types without modifying postgresql-simple. This is +-- particularly useful for supporting PostgreSQL types that postgresql-simple +-- does not support out-of-box. Here's an example of what such an instance +-- might look like for a UUID type that implements the @Read@ class: +-- +-- @ +-- import Data.UUID ( UUID ) +-- import Database.PostgreSQL.Simple.BuiltinTypes +-- ( BuiltinType(UUID), builtin2oid ) +-- import qualified Data.ByteString as B +-- +-- instance FromField UUID where +-- fromField f mdata = +-- if typeOid f /= builtin2oid UUID +-- then returnError Incompatible f "" +-- else case B.unpack `fmap` mdata of +-- Nothing -> returnError UnexpectedNull f "" +-- Just data -> +-- case [ x | (x,t) <- reads data, ("","") <- lex t ] of +-- [x] -> Ok x +-- _ -> returnError ConversionError f data +-- @ +-- +-- Note that because PostgreSQL's @uuid@ type is built into postgres and is +-- not provided by an extension, the 'typeOid' of @uuid@ does not change and +-- thus we can examine it directly. Here, we simply pull the type oid out +-- of the static table provided by postgresql-simple. +-- +-- On the other hand if the type is provided by an extension, such as +-- @PostGIS@ or @hstore@, then the 'typeOid' is not stable and can vary from +-- database to database. In this case it is recommended that FromField +-- instances use 'typename' instead. +-- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.FromField ( FromField(..) , FieldParser + , Conversion() + + , runConversion + , conversionMap + , conversionError , ResultError(..) , returnError , Field , typename + , TypeInfo(..) + , typeInfo + , typeInfoByOid , name , tableOid , tableColumn @@ -46,7 +89,7 @@ import Control.Applicative ( Applicative, (<|>), (<$>), pure ) -import Control.Exception (SomeException(..), Exception) +import Control.Exception (Exception) import Data.Attoparsec.Char8 hiding (Result) import Data.Bits ((.&.), (.|.), shiftL) import Data.ByteString (ByteString) @@ -56,14 +99,19 @@ import Data.Ratio (Ratio) import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay ) import Data.Typeable (Typeable, typeOf) +import Data.Vector (Vector) +import qualified Data.Vector as V import Data.Word (Word64) import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.BuiltinTypes +import Database.PostgreSQL.Simple.Compat import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.Types (Binary(..), Null(..)) +import Database.PostgreSQL.Simple.TypeInfo as TypeInfo +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TypeInfo import Database.PostgreSQL.Simple.Time +import Database.PostgreSQL.Simple.Arrays as Arrays import qualified Database.PostgreSQL.LibPQ as PQ -import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString as SB import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as LB @@ -74,15 +122,21 @@ -- | Exception thrown if conversion from a SQL value to a Haskell -- value fails. data ResultError = Incompatible { errSQLType :: String + , errSQLTableOid :: Maybe PQ.Oid + , errSQLField :: String , errHaskellType :: String , errMessage :: String } -- ^ The SQL and Haskell types are not compatible. | UnexpectedNull { errSQLType :: String + , errSQLTableOid :: Maybe PQ.Oid + , errSQLField :: String , errHaskellType :: String , errMessage :: String } -- ^ A SQL @NULL@ was encountered when the Haskell -- type did not permit it. | ConversionFailed { errSQLType :: String + , errSQLTableOid :: Maybe PQ.Oid + , errSQLField :: String , errHaskellType :: String , errMessage :: String } -- ^ The SQL value could not be parsed, or could not @@ -93,10 +147,10 @@ instance Exception ResultError -left :: Exception a => a -> Ok b -left = Errors . (:[]) . SomeException +left :: Exception a => a -> Conversion b +left = conversionError -type FieldParser a = Field -> Maybe ByteString -> Ok a +type FieldParser a = Field -> Maybe ByteString -> Conversion a -- | A type that may be converted from a SQL type. class FromField a where @@ -116,6 +170,61 @@ -- such a reference, and that using bytestring functions such as 'B.drop' -- and 'B.takeWhile' alone will also trigger this memory leak. +-- | Returns the data type name. This is the preferred way of identifying +-- types that do not have a stable type oid, such as types provided by +-- extensions to PostgreSQL. +-- +-- More concretely, it returns the @typname@ column associated with the +-- type oid in the @pg_type@ table. First, postgresql-simple will check +-- built-in, static table. If the type oid is not there, postgresql-simple +-- will check a per-connection cache, and then finally query the database's +-- meta-schema. + +typename :: Field -> Conversion ByteString +typename field = typname <$> typeInfo field + +typeInfo :: Field -> Conversion TypeInfo +typeInfo Field{..} = Conversion $ \conn -> do + Ok <$> (getTypeInfo conn =<< PQ.ftype result column) + +typeInfoByOid :: PQ.Oid -> Conversion TypeInfo +typeInfoByOid oid = Conversion $ \conn -> do + Ok <$> (getTypeInfo conn oid) + +-- | Returns the name of the column. This is often determined by a table +-- definition, but it can be set using an @as@ clause. + +name :: Field -> Maybe ByteString +name Field{..} = unsafeDupablePerformIO (PQ.fname result column) + +-- | Returns the name of the object id of the @table@ associated with the +-- column, if any. Returns 'Nothing' when there is no such table; +-- for example a computed column does not have a table associated with it. +-- Analogous to libpq's @PQftable@. + +tableOid :: Field -> Maybe PQ.Oid +tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column)) + where + toMaybeOid x + = if x == PQ.invalidOid + then Nothing + else Just x + +-- | If the column has a table associated with it, this returns the number +-- off the associated table column. Numbering starts from 0. Analogous +-- to libpq's @PQftablecol@. + +tableColumn :: Field -> Int +tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column)) + where + fromCol (PQ.Col x) = fromIntegral x + +-- | This returns whether the data was returned in a binary or textual format. +-- Analogous to libpq's @PQfformat@. + +format :: Field -> PQ.Format +format Field{..} = unsafeDupablePerformIO (PQ.fformat result column) + instance (FromField a) => FromField (Maybe a) where fromField _ Nothing = pure Nothing fromField f bs = Just <$> fromField f bs @@ -126,7 +235,7 @@ instance FromField Bool where fromField f bs - | typeOid f /= builtin2oid Bool = returnError Incompatible f "" + | typeOid f /= typoid (TypeInfo.bool) = returnError Incompatible f "" | bs == Nothing = returnError UnexpectedNull f "" | bs == Just "t" = pure True | bs == Just "f" = pure False @@ -163,7 +272,7 @@ unBinary (Binary x) = x instance FromField SB.ByteString where - fromField f dat = if typeOid f == builtin2oid ByteA + fromField f dat = if typeOid f == typoid TypeInfo.bytea then unBinary <$> fromField f dat else doFromField f okText' (pure . B.copy) dat @@ -174,8 +283,8 @@ fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat unescapeBytea :: Field -> SB.ByteString - -> Ok (Binary SB.ByteString) -unescapeBytea f str = case unsafePerformIO (PQ.unescapeBytea str) of + -> Conversion (Binary SB.ByteString) +unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of Nothing -> returnError ConversionFailed f "unescapeBytea failed" Just str -> pure (Binary str) @@ -198,49 +307,79 @@ fromField f dat = ST.unpack <$> fromField f dat instance FromField UTCTime where - fromField = ff TimestampTZ "UTCTime" parseUTCTime + fromField = ff TypeInfo.timestamptz "UTCTime" parseUTCTime instance FromField ZonedTime where - fromField = ff TimestampTZ "ZonedTime" parseZonedTime + fromField = ff TypeInfo.timestamptz "ZonedTime" parseZonedTime instance FromField LocalTime where - fromField = ff Timestamp "LocalTime" parseLocalTime + fromField = ff TypeInfo.timestamp "LocalTime" parseLocalTime instance FromField Day where - fromField = ff Date "Day" parseDay + fromField = ff TypeInfo.date "Day" parseDay instance FromField TimeOfDay where - fromField = ff Time "TimeOfDay" parseTimeOfDay + fromField = ff TypeInfo.time "TimeOfDay" parseTimeOfDay instance FromField UTCTimestamp where - fromField = ff TimestampTZ "UTCTimestamp" parseUTCTimestamp + fromField = ff TypeInfo.timestamptz "UTCTimestamp" parseUTCTimestamp instance FromField ZonedTimestamp where - fromField = ff TimestampTZ "ZonedTimestamp" parseZonedTimestamp + fromField = ff TypeInfo.timestamptz "ZonedTimestamp" parseZonedTimestamp instance FromField LocalTimestamp where - fromField = ff Timestamp "LocalTimestamp" parseLocalTimestamp + fromField = ff TypeInfo.timestamp "LocalTimestamp" parseLocalTimestamp instance FromField Date where - fromField = ff Date "Date" parseDate + fromField = ff TypeInfo.date "Date" parseDate -ff :: BuiltinType -> String -> (B8.ByteString -> Either String a) - -> Field -> Maybe B8.ByteString -> Ok a -ff pgType hsType parse f mstr - | typeOid f /= builtin2oid pgType - = left (Incompatible (B8.unpack (typename f)) hsType "") - | Nothing <- mstr - = left (UnexpectedNull (B8.unpack (typename f)) hsType "") - | Just str <- mstr - = case parse str of - Left msg -> left (ConversionFailed (B8.unpack (typename f)) hsType msg) - Right val -> return val +ff :: TypeInfo -> String -> (B8.ByteString -> Either String a) + -> Field -> Maybe B8.ByteString -> Conversion a +ff pgType hsType parse f mstr = + if typeOid f /= typoid pgType + then err Incompatible "" + else case mstr of + Nothing -> err UnexpectedNull "" + Just str -> case parse str of + Left msg -> err ConversionFailed msg + Right val -> return val + where + err errC msg = do + typnam <- typename f + left $ errC (B8.unpack typnam) + (tableOid f) + (maybe "" B8.unpack (name f)) + hsType + msg {-# INLINE ff #-} instance (FromField a, FromField b) => FromField (Either a b) where fromField f dat = (Right <$> fromField f dat) <|> (Left <$> fromField f dat) +instance (FromField a, Typeable a) => FromField (Vector a) where + fromField f mdat = do + info <- typeInfo f + case info of + TypeInfo.Array{} -> + case mdat of + Nothing -> returnError UnexpectedNull f "" + Just dat -> do + case parseOnly (fromArray info f) dat of + Left err -> returnError ConversionFailed f err + Right conv -> V.fromList <$> conv + _ -> returnError Incompatible f "" + +fromArray :: (FromField a) + => TypeInfo -> Field -> Parser (Conversion [a]) +fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim + where + delim = typdelim (typelem typeInfo) + fElem = f{ typeOid = typoid (typelem typeInfo) } + parseIt item = (fromField f' . Just . fmt delim) item + where f' | Arrays.Array _ <- item = f + | otherwise = fElem + newtype Compat = Compat Word64 mkCompats :: [BuiltinType] -> Compat @@ -267,8 +406,8 @@ #endif doFromField :: forall a . (Typeable a) - => Field -> Compat -> (ByteString -> Ok a) - -> Maybe ByteString -> Ok a + => Field -> Compat -> (ByteString -> Conversion a) + -> Maybe ByteString -> Conversion a doFromField f types cvt (Just bs) | Just typ <- oid2builtin (typeOid f) , mkCompat typ `compat` types = cvt bs @@ -281,17 +420,22 @@ -- exception value and returns it in a 'Left . SomeException' -- constructor. returnError :: forall a err . (Typeable a, Exception err) - => (String -> String -> String -> err) - -> Field -> String -> Ok a -returnError mkErr f = left . mkErr (B.unpack (typename f)) - (show (typeOf (undefined :: a))) + => (String -> Maybe PQ.Oid -> String -> String -> String -> err) + -> Field -> String -> Conversion a +returnError mkErr f msg = do + typnam <- typename f + left $ mkErr (B.unpack typnam) + (tableOid f) + (maybe "" B.unpack (name f)) + (show (typeOf (undefined :: a))) + msg atto :: forall a. (Typeable a) => Compat -> Parser a -> Field -> Maybe ByteString - -> Ok a + -> Conversion a atto types p0 f dat = doFromField f types (go p0) dat where - go :: Parser a -> ByteString -> Ok a + go :: Parser a -> ByteString -> Conversion a go p s = case parseOnly p s of Left err -> returnError ConversionFailed f err diff --git a/src/Database/PostgreSQL/Simple/FromField.hs-boot b/src/Database/PostgreSQL/Simple/FromField.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromField.hs-boot @@ -0,0 +1,10 @@ +module Database.PostgreSQL.Simple.FromField where + +import Data.ByteString(ByteString) +import Database.PostgreSQL.Simple.Types + +class FromField a + +instance FromField Oid +instance FromField ByteString +instance FromField a => FromField (Maybe a) diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs b/src/Database/PostgreSQL/Simple/FromRow.hs --- a/src/Database/PostgreSQL/Simple/FromRow.hs +++ b/src/Database/PostgreSQL/Simple/FromRow.hs @@ -25,23 +25,22 @@ ) where import Control.Applicative (Applicative(..), (<$>)) -import Control.Exception (SomeException(..)) import Control.Monad (replicateM) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Database.PostgreSQL.Simple.Types (Only(..)) -import Database.PostgreSQL.Simple.Ok import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.Compat import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.Types ((:.)(..)) +import Database.PostgreSQL.Simple.TypeInfo import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class -import Data.Vector ((!)) - -- | A collection type that can be converted from a sequence of fields. -- Instances are provided for tuples up to 10 elements and lists of any length. -- @@ -65,30 +64,45 @@ class FromRow a where fromRow :: RowParser a +getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString +getvalue result row col = unsafeDupablePerformIO (PQ.getvalue result row col) + +nfields :: PQ.Result -> PQ.Column +nfields result = unsafeDupablePerformIO (PQ.nfields result) + +getTypeInfoByCol :: Row -> PQ.Column -> Conversion TypeInfo +getTypeInfoByCol Row{..} col = + Conversion $ \conn -> do + oid <- PQ.ftype rowresult col + Ok <$> getTypeInfo conn oid + +getTypenameByCol :: Row -> PQ.Column -> Conversion ByteString +getTypenameByCol row col = typname <$> getTypeInfoByCol row col + fieldWith :: FieldParser a -> RowParser a fieldWith fieldP = RP $ do let unCol (PQ.Col x) = fromIntegral x :: Int - Row{..} <- ask + r@Row{..} <- ask column <- lift get lift (put (column + 1)) let ncols = nfields rowresult if (column >= ncols) - then do - let vals = map (\c -> ( typenames ! (unCol c) - , fmap ellipsis (getvalue rowresult row c) )) - [0..ncols-1] - convertError = ConversionFailed - (show (unCol ncols) ++ " values: " ++ show vals) + then lift $ lift $ do + vals <- mapM (getTypenameByCol r) [0..ncols-1] + let err = ConversionFailed + (show (unCol ncols) ++ " values: " ++ show (map ellipsis vals)) + Nothing + "" ("at least " ++ show (unCol column + 1) ++ " slots in target type") "mismatch between number of columns to \ \convert and number in target type" - lift (lift (Errors [SomeException convertError])) + conversionError err else do - let typename = typenames ! unCol column - result = rowresult - field = Field{..} - lift (lift (fieldP field (getvalue result row column))) + let !result = rowresult + !typeOid = unsafeDupablePerformIO (PQ.ftype result column) + !field = Field{..} + lift (lift (fieldP field (getvalue result row column))) field :: FromField a => RowParser a field = fieldWith fromField diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs-boot b/src/Database/PostgreSQL/Simple/FromRow.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromRow.hs-boot @@ -0,0 +1,8 @@ +module Database.PostgreSQL.Simple.FromRow where + +import {-# SOURCE #-} Database.PostgreSQL.Simple.FromField + +class FromRow a + +instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a,b,c,d) +instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a,b,c,d,e) diff --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs --- a/src/Database/PostgreSQL/Simple/Internal.hs +++ b/src/Database/PostgreSQL/Simple/Internal.hs @@ -24,24 +24,24 @@ import Control.Applicative import Control.Exception import Control.Concurrent.MVar +import Control.Monad(MonadPlus(..)) import Data.ByteString(ByteString) -import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 import Data.Char (ord) import Data.Int (Int64) import qualified Data.IntMap as IntMap +import Data.Maybe(fromMaybe) import Data.String import Data.Typeable import Data.Word import Database.PostgreSQL.LibPQ(Oid(..)) import qualified Database.PostgreSQL.LibPQ as PQ -import Database.PostgreSQL.Simple.BuiltinTypes (BuiltinType) +import Database.PostgreSQL.LibPQ(ExecStatus(..)) import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.Types (Query(..)) +import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader -import qualified Data.Vector as V -import System.IO.Unsafe (unsafePerformIO) -- | A Field represents metadata about a particular field -- @@ -52,43 +52,29 @@ data Field = Field { result :: !PQ.Result , column :: {-# UNPACK #-} !PQ.Column - , typename :: !ByteString + , typeOid :: {-# UNPACK #-} !PQ.Oid + -- ^ This returns the type oid associated with the column. Analogous + -- to libpq's @PQftype@. } -name :: Field -> Maybe ByteString -name Field{..} = unsafePerformIO (PQ.fname result column) - -tableOid :: Field -> PQ.Oid -tableOid Field{..} = unsafePerformIO (PQ.ftable result column) - -tableColumn :: Field -> Int -tableColumn Field{..} = fromCol (unsafePerformIO (PQ.ftablecol result column)) - where - fromCol (PQ.Col x) = fromIntegral x - - -format :: Field -> PQ.Format -format Field{..} = unsafePerformIO (PQ.fformat result column) - -typeOid :: Field -> PQ.Oid -typeOid Field{..} = unsafePerformIO (PQ.ftype result column) - +type TypeInfoCache = IntMap.IntMap TypeInfo data Connection = Connection { connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection) - , connectionObjects :: {-# UNPACK #-} !(MVar (IntMap.IntMap ByteString)) + , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache) } -data SqlType - = Builtin BuiltinType - | Other Oid - data SqlError = SqlError { sqlState :: ByteString - , sqlNativeError :: Int + , sqlExecStatus :: ExecStatus , sqlErrorMsg :: ByteString + , sqlErrorDetail :: ByteString + , sqlErrorHint :: ByteString } deriving (Show, Typeable) +fatalError :: ByteString -> SqlError +fatalError msg = SqlError "" FatalError msg "" "" + instance Exception SqlError -- | Exception thrown if 'query' is used to perform an @INSERT@-like @@ -162,9 +148,7 @@ return wconn _ -> do msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn - throwIO $ SqlError { sqlNativeError = -1 -- FIXME? - , sqlErrorMsg = msg - , sqlState = "" } + throwIO $ fatalError msg -- | Turns a 'ConnectInfo' data structure into a libpq connection string. @@ -213,9 +197,7 @@ case mres of Nothing -> do msg <- maybe "execute error" id <$> PQ.errorMessage h - throwIO $ SqlError { sqlNativeError = -1 -- FIXME? - , sqlErrorMsg = msg - , sqlState = "" } + throwIO $ fatalError msg Just res -> do return res @@ -260,21 +242,22 @@ else error ("finishExecute: not an int: " ++ B8.unpack str) throwResultError :: ByteString -> PQ.Result -> PQ.ExecStatus -> IO a -throwResultError context result status = do - errormsg <- maybe "" id <$> PQ.resultErrorMessage result - statusmsg <- PQ.resStatus status +throwResultError _ result status = do + errormsg <- fromMaybe "" <$> + PQ.resultErrorField result PQ.DiagMessagePrimary + detail <- fromMaybe "" <$> + PQ.resultErrorField result PQ.DiagMessageDetail + hint <- fromMaybe "" <$> + PQ.resultErrorField result PQ.DiagMessageHint state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate throwIO $ SqlError { sqlState = state - , sqlNativeError = fromEnum status - , sqlErrorMsg = B.concat [ context, ": ", statusmsg - , ": ", errormsg ]} + , sqlExecStatus = status + , sqlErrorMsg = errormsg + , sqlErrorDetail = detail + , sqlErrorHint = hint } disconnectedError :: SqlError -disconnectedError = SqlError { - sqlNativeError = -1, - sqlErrorMsg = "connection disconnected", - sqlState = "" - } +disconnectedError = fatalError "connection disconnected" -- | Atomically perform an action with the database handle, if there is one. withConnection :: Connection -> (PQ.Connection -> IO a) -> IO a @@ -301,15 +284,47 @@ data Row = Row { row :: {-# UNPACK #-} !PQ.Row - , typenames :: !(V.Vector ByteString) , rowresult :: !PQ.Result } -newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Ok) a } +newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Conversion) a } deriving ( Functor, Applicative, Alternative, Monad ) -getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString -getvalue result row col = unsafePerformIO (PQ.getvalue result row col) +newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) } -nfields :: PQ.Result -> PQ.Column -nfields result = unsafePerformIO (PQ.nfields result) +instance Functor Conversion where + fmap f m = Conversion $ \conn -> (fmap . fmap) f (runConversion m conn) + +instance Applicative Conversion where + pure a = Conversion $ \_conn -> pure (pure a) + mf <*> ma = Conversion $ \conn -> do + okf <- runConversion mf conn + case okf of + Ok f -> (fmap . fmap) f (runConversion ma conn) + Errors errs -> return (Errors errs) + +instance Alternative Conversion where + empty = Conversion $ \_conn -> pure empty + ma <|> mb = Conversion $ \conn -> do + oka <- runConversion ma conn + case oka of + Ok _ -> return oka + Errors _ -> (oka <|>) <$> runConversion mb conn + +instance Monad Conversion where + return a = Conversion $ \_conn -> return (return a) + m >>= f = Conversion $ \conn -> do + oka <- runConversion m conn + case oka of + Ok a -> runConversion (f a) conn + Errors err -> return (Errors err) + +instance MonadPlus Conversion where + mzero = empty + mplus = (<|>) + +conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b +conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn + +conversionError :: Exception err => err -> Conversion a +conversionError err = Conversion $ \_ -> return (Errors [SomeException err]) diff --git a/src/Database/PostgreSQL/Simple/LargeObjects.hs b/src/Database/PostgreSQL/Simple/LargeObjects.hs --- a/src/Database/PostgreSQL/Simple/LargeObjects.hs +++ b/src/Database/PostgreSQL/Simple/LargeObjects.hs @@ -51,9 +51,7 @@ case res of Nothing -> do msg <- maybe str id <$> PQ.errorMessage c - throwIO $ SqlError { sqlNativeError = -1 -- FIXME? - , sqlErrorMsg = msg - , sqlState = "" } + throwIO $ fatalError msg Just x -> return x loCreat :: Connection -> IO Oid diff --git a/src/Database/PostgreSQL/Simple/SqlQQ.hs b/src/Database/PostgreSQL/Simple/SqlQQ.hs --- a/src/Database/PostgreSQL/Simple/SqlQQ.hs +++ b/src/Database/PostgreSQL/Simple/SqlQQ.hs @@ -29,14 +29,16 @@ -- -- This quasiquoter attempts to mimimize whitespace; otherwise the -- above query would consist of approximately half whitespace when sent --- to the database backend. +-- to the database backend. It also recognizes and strips out standard +-- sql comments "--". -- -- The implementation of the whitespace reducer is currently incomplete. -- Thus it can mess up your syntax in cases where whitespace should be -- preserved as-is. It does preserve whitespace inside standard SQL string -- literals. But it can get confused by the non-standard PostgreSQL string -- literal syntax (which is the default setting in PostgreSQL 8 and below), --- the extended escape string syntax, and other similar constructs. +-- the extended escape string syntax, quoted identifiers, and other similar +-- constructs. -- -- Of course, this caveat only applies to text written inside the SQL -- quasiquoter; whitespace reduction is a compile-time computation and @@ -58,19 +60,28 @@ } sqlExp :: String -> Q Exp -sqlExp = stringE . outstring . dropSpace +sqlExp = stringE . minimizeSpace + +minimizeSpace :: String -> String +minimizeSpace = drop 1 . reduceSpace where - dropSpace = dropWhile isSpace + needsReduced [] = False + needsReduced ('-':'-':_) = True + needsReduced (x:_) = isSpace x - outstring ('\'':xs) = '\'' : instring xs - outstring (x:xs) | isSpace x = case dropSpace xs of - [] -> [] - ys -> ' ' : outstring ys - | otherwise = x : outstring xs - outstring [] = [] + reduceSpace xs = + case dropWhile isSpace xs of + [] -> [] + ('-':'-':ys) -> reduceSpace (dropWhile (/= '\n') ys) + ys -> ' ' : insql ys + insql ('\'':xs) = '\'' : instring xs + insql xs | needsReduced xs = reduceSpace xs + insql (x:xs) = x : insql xs + insql [] = [] + instring ('\'':'\'':xs) = '\'':'\'': instring xs - instring ('\'':xs) = '\'': outstring xs + instring ('\'':xs) = '\'': insql xs instring (x:xs) = x : instring xs instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ \ string literal not terminated" diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -39,6 +39,8 @@ import qualified Data.Text as ST import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT +import Data.Vector (Vector) +import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Time @@ -220,6 +222,14 @@ instance ToField Date where toField = Plain . inQuotes . dateToBuilder {-# INLINE toField #-} + +instance (ToField a) => ToField (Vector a) where + toField xs = Many $ + Plain (fromByteString "ARRAY[") : + (intersperse (Plain (fromChar ',')) . map toField $ V.toList xs) ++ + [Plain (fromChar ']')] + -- Because the ARRAY[...] input syntax is being used, it is possible + -- that the use of type-specific separator characters is unnecessary. -- | Surround a string with single-quote characters: \"@'@\" -- diff --git a/src/Database/PostgreSQL/Simple/ToField.hs-boot b/src/Database/PostgreSQL/Simple/ToField.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/ToField.hs-boot @@ -0,0 +1,7 @@ +module Database.PostgreSQL.Simple.ToField where + +import Database.PostgreSQL.Simple.Types + +class ToField a + +instance ToField Oid diff --git a/src/Database/PostgreSQL/Simple/ToRow.hs-boot b/src/Database/PostgreSQL/Simple/ToRow.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/ToRow.hs-boot @@ -0,0 +1,8 @@ +module Database.PostgreSQL.Simple.ToRow where + +import Database.PostgreSQL.Simple.Types +import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField + +class ToRow a + +instance ToField a => ToRow (Only a) diff --git a/src/Database/PostgreSQL/Simple/Transaction.hs b/src/Database/PostgreSQL/Simple/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Transaction.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE RecordWildCards #-} + +module Database.PostgreSQL.Simple.Transaction + ( + -- * Transaction handling + withTransaction + , withTransactionLevel + , withTransactionMode + , withTransactionModeRetry + , withTransactionSerializable + , isSerializationError + , TransactionMode(..) + , IsolationLevel(..) + , ReadWriteMode(..) + , defaultTransactionMode + , defaultIsolationLevel + , defaultReadWriteMode +-- , Base.autocommit + , begin + , beginLevel + , beginMode + , commit + , rollback + ) where + +import Control.Exception hiding (mask) +import qualified Data.ByteString as B +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.Types +import Database.PostgreSQL.Simple.Compat(mask) + + +-- | Of the four isolation levels defined by the SQL standard, +-- these are the three levels distinguished by PostgreSQL as of version 9.0. +-- See +-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead' +-- was equivalent to 'Serializable'. + +data IsolationLevel + = DefaultIsolationLevel -- ^ the isolation level will be taken from + -- PostgreSQL's per-connection + -- @default_transaction_isolation@ variable, + -- which is initialized according to the + -- server's config. The default configuration + -- is 'ReadCommitted'. + | ReadCommitted + | RepeatableRead + | Serializable + deriving (Show, Eq, Ord, Enum, Bounded) + +data ReadWriteMode + = DefaultReadWriteMode -- ^ the read-write mode will be taken from + -- PostgreSQL's per-connection + -- @default_transaction_read_only@ variable, + -- which is initialized according to the + -- server's config. The default configuration + -- is 'ReadWrite'. + | ReadWrite + | ReadOnly + deriving (Show, Eq, Ord, Enum, Bounded) + +data TransactionMode = TransactionMode { + isolationLevel :: !IsolationLevel, + readWriteMode :: !ReadWriteMode + } deriving (Show, Eq) + +defaultTransactionMode :: TransactionMode +defaultTransactionMode = TransactionMode + defaultIsolationLevel + defaultReadWriteMode + +defaultIsolationLevel :: IsolationLevel +defaultIsolationLevel = DefaultIsolationLevel + +defaultReadWriteMode :: ReadWriteMode +defaultReadWriteMode = DefaultReadWriteMode + +-- | Execute an action inside a SQL transaction. +-- +-- This function initiates a transaction with a \"@begin +-- transaction@\" statement, then executes the supplied action. If +-- the action succeeds, the transaction will be completed with +-- 'Base.commit' before this function returns. +-- +-- If the action throws /any/ kind of exception (not just a +-- PostgreSQL-related exception), the transaction will be rolled back using +-- 'rollback', then the exception will be rethrown. +withTransaction :: Connection -> IO a -> IO a +withTransaction = withTransactionMode defaultTransactionMode + +-- | Execute an action inside of a 'Serializable' transaction. If a +-- serialization failure occurs, roll back the transaction and try again. +-- Be warned that this may execute the IO action multiple times. +-- +-- A 'Serializable' transaction creates the illusion that your program has +-- exclusive access to the database. This means that, even in a concurrent +-- setting, you can perform queries in sequence without having to worry about +-- what might happen between one statement and the next. +-- +-- Think of it as STM, but without @retry@. +withTransactionSerializable :: Connection -> IO a -> IO a +withTransactionSerializable = + withTransactionModeRetry + TransactionMode + { isolationLevel = Serializable + , readWriteMode = ReadWrite + } + isSerializationError + + +isSerializationError :: SqlError -> Bool +isSerializationError exception = + case exception of + SqlError{..} | sqlState == serialization_failure + -> True + _ -> False + where + -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html + serialization_failure = "40001" + +-- | Execute an action inside a SQL transaction with a given isolation level. +withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a +withTransactionLevel lvl + = withTransactionMode defaultTransactionMode { isolationLevel = lvl } + +-- | Execute an action inside a SQL transaction with a given transaction mode. +withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a +withTransactionMode mode conn act = + mask $ \restore -> do + beginMode mode conn + r <- restore act `onException` rollback conn + commit conn + return r + +-- | Like 'withTransactionMode', but also takes a custom callback to +-- determine if a transaction should be retried if an 'SqlError' occurs. +-- If the callback returns True, then the transaction will be retried. +-- If the callback returns False, or an exception other than an 'SqlError' +-- occurs then the transaction will be rolled back and the exception rethrown. +-- +-- This is used to implement 'withTransactionSerializable'. +withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a +withTransactionModeRetry mode shouldRetry conn act = + mask $ \restore -> + retryLoop $ try $ do + a <- restore act + commit conn + return a + where + retryLoop :: IO (Either SomeException a) -> IO a + retryLoop act' = do + beginMode mode conn + r <- act' + case r of + Left e -> do + rollback conn + case fmap shouldRetry (fromException e) of + Just True -> retryLoop act' + _ -> throwIO e + Right a -> + return a + +-- | Rollback a transaction. +rollback :: Connection -> IO () +rollback conn = execute_ conn "ABORT" >> return () + +-- | Commit a transaction. +commit :: Connection -> IO () +commit conn = execute_ conn "COMMIT" >> return () + +-- | Begin a transaction. +begin :: Connection -> IO () +begin = beginMode defaultTransactionMode + +-- | Begin a transaction with a given isolation level +beginLevel :: IsolationLevel -> Connection -> IO () +beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl } + +-- | Begin a transaction with a given transaction mode +beginMode :: TransactionMode -> Connection -> IO () +beginMode mode conn = do + _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode]) + return () + where + isolevel = case isolationLevel mode of + DefaultIsolationLevel -> "" + ReadCommitted -> " ISOLATION LEVEL READ COMMITTED" + RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ" + Serializable -> " ISOLATION LEVEL SERIALIZABLE" + readmode = case readWriteMode mode of + DefaultReadWriteMode -> "" + ReadWrite -> " READ WRITE" + ReadOnly -> " READ ONLY" diff --git a/src/Database/PostgreSQL/Simple/TypeInfo.hs b/src/Database/PostgreSQL/Simple/TypeInfo.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/TypeInfo.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE RecordWildCards #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.TypeInfo +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.TypeInfo + ( getTypeInfo + , TypeInfo(..) + ) where + +import qualified Data.ByteString.Char8 as B8 +import qualified Data.IntMap as IntMap +import Control.Concurrent.MVar +import Control.Exception (throw) + +import qualified Database.PostgreSQL.LibPQ as PQ +import {-# SOURCE #-} Database.PostgreSQL.Simple +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.Types +import Database.PostgreSQL.Simple.TypeInfo.Types +import Database.PostgreSQL.Simple.TypeInfo.Static + +getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo +getTypeInfo conn@Connection{..} oid = + case staticTypeInfo oid of + Just name -> return name + Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid + +getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache + -> IO (TypeInfoCache, TypeInfo) +getTypeInfo' conn oid oidmap = + case IntMap.lookup (oid2int oid) oidmap of + Just typeinfo -> return (oidmap, typeinfo) + Nothing -> do + names <- query conn "SELECT oid, typcategory, typdelim, typname, typelem\ + \ FROM pg_type WHERE oid = ?" + (Only oid) + (oidmap', typeInfo) <- + case names of + [] -> return $ throw (fatalError "invalid type oid") + [(typoid, typcategory_, typdelim_, typname, typelem_)] -> do + let !typcategory = B8.index typcategory_ 0 + !typdelim = B8.index typdelim_ 0 + if typcategory == 'A' + then do + (oidmap', typelem) <- getTypeInfo' conn typelem_ oidmap + let !typeInfo = Array{..} + return (oidmap', typeInfo) + else do + let !typeInfo = Basic{..} + return (oidmap, typeInfo) + _ -> fail "typename query returned more than one result" + -- oid is a primary key, so the query should + -- never return more than one result + let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap' + return $! (oidmap'', typeInfo) diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs @@ -0,0 +1,487 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.TypeInfo +-- Copyright: (c) 2011-2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- Note that this module is semi-internal, and you probably want to use +-- Database.PostgreSQL.Simple.TypeInfo instead. +-- +------------------------------------------------------------------------------ + +-- Note that this file is generated by tools/GenTypeInfo.hs, and should +-- not be edited directly + +module Database.PostgreSQL.Simple.TypeInfo.Static + ( TypeInfo(..) + , staticTypeInfo + , bool + , bytea + , char + , name + , int8 + , int2 + , int4 + , regproc + , text + , oid + , tid + , xid + , cid + , xml + , point + , lseg + , path + , box + , polygon + , line + , cidr + , float4 + , float8 + , abstime + , reltime + , tinterval + , unknown + , circle + , money + , macaddr + , inet + , bpchar + , varchar + , date + , time + , timestamp + , timestamptz + , interval + , timetz + , bit + , varbit + , numeric + , refcursor + , record + , void + , uuid + ) where + +import Database.PostgreSQL.LibPQ (Oid(..)) +import Database.PostgreSQL.Simple.TypeInfo.Types + +staticTypeInfo :: Oid -> Maybe TypeInfo +staticTypeInfo (Oid x) = case x of + 16 -> Just bool + 17 -> Just bytea + 18 -> Just char + 19 -> Just name + 20 -> Just int8 + 21 -> Just int2 + 23 -> Just int4 + 24 -> Just regproc + 25 -> Just text + 26 -> Just oid + 27 -> Just tid + 28 -> Just xid + 29 -> Just cid + 142 -> Just xml + 600 -> Just point + 601 -> Just lseg + 602 -> Just path + 603 -> Just box + 604 -> Just polygon + 628 -> Just line + 650 -> Just cidr + 700 -> Just float4 + 701 -> Just float8 + 702 -> Just abstime + 703 -> Just reltime + 704 -> Just tinterval + 705 -> Just unknown + 718 -> Just circle + 790 -> Just money + 829 -> Just macaddr + 869 -> Just inet + 1042 -> Just bpchar + 1043 -> Just varchar + 1082 -> Just date + 1083 -> Just time + 1114 -> Just timestamp + 1184 -> Just timestamptz + 1186 -> Just interval + 1266 -> Just timetz + 1560 -> Just bit + 1562 -> Just varbit + 1700 -> Just numeric + 1790 -> Just refcursor + 2249 -> Just record + 2278 -> Just void + 2950 -> Just uuid + _ -> Nothing + +bool :: TypeInfo +bool = Basic { + typoid = Oid 16, + typcategory = 'B', + typdelim = ',', + typname = "bool" + } + +bytea :: TypeInfo +bytea = Basic { + typoid = Oid 17, + typcategory = 'U', + typdelim = ',', + typname = "bytea" + } + +char :: TypeInfo +char = Basic { + typoid = Oid 18, + typcategory = 'S', + typdelim = ',', + typname = "char" + } + +name :: TypeInfo +name = Basic { + typoid = Oid 19, + typcategory = 'S', + typdelim = ',', + typname = "name" + } + +int8 :: TypeInfo +int8 = Basic { + typoid = Oid 20, + typcategory = 'N', + typdelim = ',', + typname = "int8" + } + +int2 :: TypeInfo +int2 = Basic { + typoid = Oid 21, + typcategory = 'N', + typdelim = ',', + typname = "int2" + } + +int4 :: TypeInfo +int4 = Basic { + typoid = Oid 23, + typcategory = 'N', + typdelim = ',', + typname = "int4" + } + +regproc :: TypeInfo +regproc = Basic { + typoid = Oid 24, + typcategory = 'N', + typdelim = ',', + typname = "regproc" + } + +text :: TypeInfo +text = Basic { + typoid = Oid 25, + typcategory = 'S', + typdelim = ',', + typname = "text" + } + +oid :: TypeInfo +oid = Basic { + typoid = Oid 26, + typcategory = 'N', + typdelim = ',', + typname = "oid" + } + +tid :: TypeInfo +tid = Basic { + typoid = Oid 27, + typcategory = 'U', + typdelim = ',', + typname = "tid" + } + +xid :: TypeInfo +xid = Basic { + typoid = Oid 28, + typcategory = 'U', + typdelim = ',', + typname = "xid" + } + +cid :: TypeInfo +cid = Basic { + typoid = Oid 29, + typcategory = 'U', + typdelim = ',', + typname = "cid" + } + +xml :: TypeInfo +xml = Basic { + typoid = Oid 142, + typcategory = 'U', + typdelim = ',', + typname = "xml" + } + +point :: TypeInfo +point = Basic { + typoid = Oid 600, + typcategory = 'G', + typdelim = ',', + typname = "point" + } + +lseg :: TypeInfo +lseg = Basic { + typoid = Oid 601, + typcategory = 'G', + typdelim = ',', + typname = "lseg" + } + +path :: TypeInfo +path = Basic { + typoid = Oid 602, + typcategory = 'G', + typdelim = ',', + typname = "path" + } + +box :: TypeInfo +box = Basic { + typoid = Oid 603, + typcategory = 'G', + typdelim = ';', + typname = "box" + } + +polygon :: TypeInfo +polygon = Basic { + typoid = Oid 604, + typcategory = 'G', + typdelim = ',', + typname = "polygon" + } + +line :: TypeInfo +line = Basic { + typoid = Oid 628, + typcategory = 'G', + typdelim = ',', + typname = "line" + } + +cidr :: TypeInfo +cidr = Basic { + typoid = Oid 650, + typcategory = 'I', + typdelim = ',', + typname = "cidr" + } + +float4 :: TypeInfo +float4 = Basic { + typoid = Oid 700, + typcategory = 'N', + typdelim = ',', + typname = "float4" + } + +float8 :: TypeInfo +float8 = Basic { + typoid = Oid 701, + typcategory = 'N', + typdelim = ',', + typname = "float8" + } + +abstime :: TypeInfo +abstime = Basic { + typoid = Oid 702, + typcategory = 'D', + typdelim = ',', + typname = "abstime" + } + +reltime :: TypeInfo +reltime = Basic { + typoid = Oid 703, + typcategory = 'T', + typdelim = ',', + typname = "reltime" + } + +tinterval :: TypeInfo +tinterval = Basic { + typoid = Oid 704, + typcategory = 'T', + typdelim = ',', + typname = "tinterval" + } + +unknown :: TypeInfo +unknown = Basic { + typoid = Oid 705, + typcategory = 'X', + typdelim = ',', + typname = "unknown" + } + +circle :: TypeInfo +circle = Basic { + typoid = Oid 718, + typcategory = 'G', + typdelim = ',', + typname = "circle" + } + +money :: TypeInfo +money = Basic { + typoid = Oid 790, + typcategory = 'N', + typdelim = ',', + typname = "money" + } + +macaddr :: TypeInfo +macaddr = Basic { + typoid = Oid 829, + typcategory = 'U', + typdelim = ',', + typname = "macaddr" + } + +inet :: TypeInfo +inet = Basic { + typoid = Oid 869, + typcategory = 'I', + typdelim = ',', + typname = "inet" + } + +bpchar :: TypeInfo +bpchar = Basic { + typoid = Oid 1042, + typcategory = 'S', + typdelim = ',', + typname = "bpchar" + } + +varchar :: TypeInfo +varchar = Basic { + typoid = Oid 1043, + typcategory = 'S', + typdelim = ',', + typname = "varchar" + } + +date :: TypeInfo +date = Basic { + typoid = Oid 1082, + typcategory = 'D', + typdelim = ',', + typname = "date" + } + +time :: TypeInfo +time = Basic { + typoid = Oid 1083, + typcategory = 'D', + typdelim = ',', + typname = "time" + } + +timestamp :: TypeInfo +timestamp = Basic { + typoid = Oid 1114, + typcategory = 'D', + typdelim = ',', + typname = "timestamp" + } + +timestamptz :: TypeInfo +timestamptz = Basic { + typoid = Oid 1184, + typcategory = 'D', + typdelim = ',', + typname = "timestamptz" + } + +interval :: TypeInfo +interval = Basic { + typoid = Oid 1186, + typcategory = 'T', + typdelim = ',', + typname = "interval" + } + +timetz :: TypeInfo +timetz = Basic { + typoid = Oid 1266, + typcategory = 'D', + typdelim = ',', + typname = "timetz" + } + +bit :: TypeInfo +bit = Basic { + typoid = Oid 1560, + typcategory = 'V', + typdelim = ',', + typname = "bit" + } + +varbit :: TypeInfo +varbit = Basic { + typoid = Oid 1562, + typcategory = 'V', + typdelim = ',', + typname = "varbit" + } + +numeric :: TypeInfo +numeric = Basic { + typoid = Oid 1700, + typcategory = 'N', + typdelim = ',', + typname = "numeric" + } + +refcursor :: TypeInfo +refcursor = Basic { + typoid = Oid 1790, + typcategory = 'U', + typdelim = ',', + typname = "refcursor" + } + +record :: TypeInfo +record = Basic { + typoid = Oid 2249, + typcategory = 'P', + typdelim = ',', + typname = "record" + } + +void :: TypeInfo +void = Basic { + typoid = Oid 2278, + typcategory = 'P', + typdelim = ',', + typname = "void" + } + +uuid :: TypeInfo +uuid = Basic { + typoid = Oid 2950, + typcategory = 'U', + typdelim = ',', + typname = "uuid" + } diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs @@ -0,0 +1,30 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.TypeInfo.Types +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.TypeInfo.Types where + +import Data.ByteString(ByteString) +import Database.PostgreSQL.LibPQ(Oid) + +data TypeInfo + + = Basic { typoid :: {-# UNPACK #-} !Oid + , typcategory :: {-# UNPACK #-} !Char + , typdelim :: {-# UNPACK #-} !Char + , typname :: !ByteString + } + + | Array { typoid :: {-# UNPACK #-} !Oid + , typcategory :: {-# UNPACK #-} !Char + , typdelim :: {-# UNPACK #-} !Char + , typname :: !ByteString + , typelem :: !TypeInfo + } + deriving (Show) diff --git a/test/Bytea.hs b/test/Bytea.hs deleted file mode 100644 --- a/test/Bytea.hs +++ /dev/null @@ -1,25 +0,0 @@ -module Bytea (testBytea) where - -import Common -import qualified Data.ByteString as B - -testBytea :: TestEnv -> Test -testBytea TestEnv{..} = TestList - [ testStr "empty" [] - , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String) - , testStr "ascending" [0..255] - , testStr "descending" [255,254..0] - , testStr "ascending, doubled up" $ doubleUp [0..255] - , testStr "descending, doubled up" $ doubleUp [255,254..0] - ] - where - testStr label bytes = TestLabel label $ TestCase $ do - let bs = B.pack bytes - - [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs] - assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h - - [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs] - assertBool "SQL -> Haskell conversion altered the string" $ bs == r - - doubleUp = concatMap (\x -> [x, x]) diff --git a/test/ExecuteMany.hs b/test/ExecuteMany.hs deleted file mode 100644 --- a/test/ExecuteMany.hs +++ /dev/null @@ -1,23 +0,0 @@ -module ExecuteMany (testExecuteMany) where - -import Common - -import Data.ByteString (ByteString) - -testExecuteMany :: TestEnv -> Test -testExecuteMany TestEnv{..} = TestCase $ do - execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)" - - let rows :: [(Int, String, Binary ByteString)] - rows = [ (1, "hello", Binary "bye") - , (2, "world", Binary "\0\r\t\n") - , (3, "?", Binary "") - ] - - count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows - assertEqual "count" (fromIntegral $ length rows) count - - rows' <- query_ conn "SELECT * FROM tmp_executeMany" - assertEqual "rows" rows rows' - - return () diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,11 +1,15 @@ +{-# LANGUAGE ScopedTypeVariables #-} import Common -import Control.Exception (bracket) -import Control.Monad (when) -import System.Exit (exitFailure) +import Database.PostgreSQL.Simple.FromField (FromField) +import Control.Exception as E +import Control.Monad +import Data.ByteString (ByteString) +import Data.Typeable +import qualified Data.ByteString as B +import System.Exit (exitFailure) import System.IO +import qualified Data.Vector as V -import Bytea -import ExecuteMany import Notify import Serializable import Time @@ -13,11 +17,94 @@ tests :: [TestEnv -> Test] tests = [ TestLabel "Bytea" . testBytea - , TestLabel "Notify" . testNotify , TestLabel "ExecuteMany" . testExecuteMany - , TestLabel "Time" . testTime + , TestLabel "Fold" . testFold + , TestLabel "Notify" . testNotify , TestLabel "Serializable" . testSerializable + , TestLabel "Time" . testTime + , TestLabel "Array" . testArray ] + +testBytea :: TestEnv -> Test +testBytea TestEnv{..} = TestList + [ testStr "empty" [] + , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String) + , testStr "ascending" [0..255] + , testStr "descending" [255,254..0] + , testStr "ascending, doubled up" $ doubleUp [0..255] + , testStr "descending, doubled up" $ doubleUp [255,254..0] + ] + where + testStr label bytes = TestLabel label $ TestCase $ do + let bs = B.pack bytes + + [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs] + assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h + + [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs] + assertBool "SQL -> Haskell conversion altered the string" $ bs == r + + doubleUp = concatMap (\x -> [x, x]) + +testExecuteMany :: TestEnv -> Test +testExecuteMany TestEnv{..} = TestCase $ do + execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)" + + let rows :: [(Int, String, Binary ByteString)] + rows = [ (1, "hello", Binary "bye") + , (2, "world", Binary "\0\r\t\n") + , (3, "?", Binary "") + ] + + count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows + count @?= fromIntegral (length rows) + + rows' <- query_ conn "SELECT * FROM tmp_executeMany" + rows' @?= rows + + return () + +testFold :: TestEnv -> Test +testFold TestEnv{..} = TestCase $ do + xs <- fold_ conn "SELECT generate_series(1,10000)" + [] $ \xs (Only x) -> return (x:xs) + reverse xs @?= ([1..10000] :: [Int]) + + -- TODO: add more complete tests, e.g.: + -- + -- * Fold in a transaction + -- + -- * Fold in a transaction after a previous fold has been performed + -- + -- * Nested fold + + return () + +queryFailure :: forall a. (FromField a, Typeable a, Show a) + => Connection -> Query -> a -> Assertion +queryFailure conn q resultType = do + x :: Either SomeException [Only a] <- E.try $ query_ conn q + case x of + Left _ -> return () + Right val -> assertFailure ("Did not fail as expected: " + ++ show q + ++ " :: " + ++ show (typeOf resultType) + ++ " -> " ++ show val) + + +testArray :: TestEnv -> Test +testArray TestEnv{..} = TestCase $ do + xs <- query_ conn "SELECT '{1,2,3,4}'::_int4" + xs @?= [Only (V.fromList [1,2,3,4 :: Int])] + xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4" + xs @?= [Only (V.fromList [V.fromList [1,2], + V.fromList [3,4 :: Int]])] + queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool) + queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int) + + +------------------------------------------------------------------------ -- | Action for connecting to the database that will be used for testing. -- diff --git a/test/Serializable.hs b/test/Serializable.hs --- a/test/Serializable.hs +++ b/test/Serializable.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE ScopedTypeVariables #-} module Serializable (testSerializable) where import Common import Control.Concurrent import Control.Exception as E import Data.IORef +import Database.PostgreSQL.Simple.Transaction initCounter :: Connection -> IO () initCounter conn = do diff --git a/test/Time.hs b/test/Time.hs --- a/test/Time.hs +++ b/test/Time.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE QuasiQuotes, ScopedTypeVariables #-} +{-# LANGUAGE QuasiQuotes #-} {-