postgresql-simple 0.0.4 → 0.1
raw patch · 17 files changed
+1022/−943 lines, 17 filesdep +transformersdep +vectordep ~attoparsec
Dependencies added: transformers, vector
Dependency ranges changed: attoparsec
Files
- postgresql-simple.cabal +18/−8
- src/Database/PostgreSQL/Simple.hs +117/−84
- src/Database/PostgreSQL/Simple/Compat.hs +25/−0
- src/Database/PostgreSQL/Simple/Field.hs +0/−15
- src/Database/PostgreSQL/Simple/FromField.hs +301/−0
- src/Database/PostgreSQL/Simple/FromRow.hs +156/−0
- src/Database/PostgreSQL/Simple/Internal.hs +27/−10
- src/Database/PostgreSQL/Simple/LargeObjects.hs +0/−3
- src/Database/PostgreSQL/Simple/Notification.hs +1/−0
- src/Database/PostgreSQL/Simple/Ok.hs +55/−0
- src/Database/PostgreSQL/Simple/Param.hs +0/−206
- src/Database/PostgreSQL/Simple/QueryParams.hs +0/−85
- src/Database/PostgreSQL/Simple/QueryResults.hs +0/−245
- src/Database/PostgreSQL/Simple/Result.hs +0/−287
- src/Database/PostgreSQL/Simple/ToField.hs +208/−0
- src/Database/PostgreSQL/Simple/ToRow.hs +90/−0
- src/Database/PostgreSQL/Simple/Types.hs +24/−0
postgresql-simple.cabal view
@@ -1,5 +1,5 @@ Name: postgresql-simple-Version: 0.0.4+Version: 0.1 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple.@@ -19,18 +19,21 @@ Exposed-modules: Database.PostgreSQL.Simple Database.PostgreSQL.Simple.BuiltinTypes- Database.PostgreSQL.Simple.Field+ Database.PostgreSQL.Simple.FromField+ Database.PostgreSQL.Simple.FromRow Database.PostgreSQL.Simple.LargeObjects Database.PostgreSQL.Simple.Notification- Database.PostgreSQL.Simple.Param- Database.PostgreSQL.Simple.QueryParams- Database.PostgreSQL.Simple.QueryResults- Database.PostgreSQL.Simple.Result+ Database.PostgreSQL.Simple.Ok Database.PostgreSQL.Simple.SqlQQ+ Database.PostgreSQL.Simple.ToField+ Database.PostgreSQL.Simple.ToRow Database.PostgreSQL.Simple.Types -- Other-modules: Database.PostgreSQL.Simple.Internal + Other-modules:+ Database.PostgreSQL.Simple.Compat+ Build-depends: attoparsec >= 0.8.5.3, base < 5,@@ -44,8 +47,15 @@ old-locale, template-haskell, text >= 0.11.1,- time+ time,+ transformers,+ vector + extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns+ TypeOperators++ ghc-options: -Wall -fno-warn-name-shadowing+ source-repository head type: git location: http://github.com/lpsmith/postgresql-simple@@ -53,4 +63,4 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple- tag: v0.0.4+ tag: v0.1
src/Database/PostgreSQL/Simple.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE BangPatterns, DeriveDataTypeable, OverloadedStrings #-}-{-# LANGUAGE DoAndIfThenElse, RecordWildCards, NamedFieldPuns #-}+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, NamedFieldPuns #-}+ ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple@@ -104,30 +104,38 @@ , formatQuery ) where -import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)-import Blaze.ByteString.Builder.Char8 (fromChar)-import Control.Applicative ((<$>), pure)-import Control.Concurrent.MVar-import Control.Exception (Exception, bracket, onException, throw, throwIO, finally)-import Control.Monad (foldM)-import Control.Monad.Fix (fix)-import Data.ByteString (ByteString)-import Data.Char(ord)-import Data.Int (Int64)+import Blaze.ByteString.Builder+ ( 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 )+import Control.Monad (foldM)+import Data.ByteString (ByteString)+import Data.Char(ord)+import Data.Int (Int64) import qualified Data.IntMap as IntMap-import Data.List (intersperse)-import Data.Monoid (mappend, mconcat)-import Data.Typeable (Typeable)-import Database.PostgreSQL.Simple.BuiltinTypes (oid2builtin, builtin2typname)-import Database.PostgreSQL.Simple.Param (Action(..), inQuotes)-import Database.PostgreSQL.Simple.QueryParams (QueryParams(..))-import Database.PostgreSQL.Simple.Result (ResultError(..))-import Database.PostgreSQL.Simple.QueryResults (QueryResults(..))-import Database.PostgreSQL.Simple.Types (Binary(..), In(..), Only(..), Query(..))-import Database.PostgreSQL.Simple.Internal as Base+import Data.List (intersperse)+import Data.Monoid (mappend, mconcat)+import Data.Typeable (Typeable)+import Database.PostgreSQL.Simple.BuiltinTypes+ ( oid2builtin, builtin2typname )+import Database.PostgreSQL.Simple.Compat ( mask )+import Database.PostgreSQL.Simple.FromField (ResultError(..))+import Database.PostgreSQL.Simple.FromRow (FromRow(..))+import Database.PostgreSQL.Simple.Ok+import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes)+import Database.PostgreSQL.Simple.ToRow (ToRow(..))+import Database.PostgreSQL.Simple.Types+ ( Binary(..), In(..), Only(..), Query(..) )+import Database.PostgreSQL.Simple.Internal as Base import qualified Database.PostgreSQL.LibPQ as PQ-import Text.Regex.PCRE.Light (compile, caseless, match)+import Text.Regex.PCRE.Light (compile, caseless, match) import qualified Data.ByteString.Char8 as B+import qualified Data.Vector as V+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict -- | Exception thrown if a 'Query' could not be formatted correctly. -- This may occur if the number of \'@?@\' characters in the query@@ -159,11 +167,11 @@ -- -- Throws 'FormatError' if the query string could not be formatted -- correctly.-formatQuery :: QueryParams q => Connection -> Query -> q -> IO ByteString+formatQuery :: ToRow q => Connection -> Query -> q -> IO ByteString formatQuery conn q@(Query template) qs | null xs && '?' `B.notElem` template = return template | otherwise = toByteString <$> buildQuery conn q template xs- where xs = renderParams qs+ where xs = toRow qs -- | Format a query string with a variable number of rows. --@@ -178,12 +186,12 @@ -- -- Throws 'FormatError' if the query string could not be formatted -- correctly.-formatMany :: (QueryParams q) => Connection -> Query -> [q] -> IO ByteString+formatMany :: (ToRow q) => Connection -> Query -> [q] -> IO ByteString formatMany _ q [] = fmtError "no rows supplied" q [] formatMany conn q@(Query template) qs = do case match re template [] of Just [_,before,qbits,after] -> do- bs <- mapM (buildQuery conn q qbits . renderParams) qs+ bs <- mapM (buildQuery conn q qbits . toRow) qs return . toByteString . mconcat $ fromByteString before : intersperse (fromChar ',') bs ++ [fromByteString after]@@ -194,6 +202,7 @@ \([^?]*)$" [caseless] +escapeStringConn :: Connection -> ByteString -> IO (Maybe ByteString) escapeStringConn conn s = withConnection conn $ \c -> do PQ.escapeStringConn c s @@ -217,7 +226,7 @@ -- Returns the number of rows affected. -- -- Throws 'FormatError' if the query could not be formatted correctly.-execute :: (QueryParams q) => Connection -> Query -> q -> IO Int64+execute :: (ToRow q) => Connection -> Query -> q -> IO Int64 execute conn template qs = do result <- exec conn =<< formatQuery conn template qs finishExecute conn template result@@ -234,14 +243,14 @@ -- Returns the number of rows affected. -- -- Throws 'FormatError' if the query could not be formatted correctly.-executeMany :: (QueryParams q) => Connection -> Query -> [q] -> IO Int64+executeMany :: (ToRow q) => Connection -> Query -> [q] -> IO Int64 executeMany _ _ [] = return 0 executeMany conn q qs = do result <- exec conn =<< formatMany conn q qs finishExecute conn q result finishExecute :: Connection -> Query -> PQ.Result -> IO Int64-finishExecute conn q result = do+finishExecute _conn q result = do status <- PQ.resultStatus result case status of PQ.CommandOk -> do@@ -293,14 +302,14 @@ -- using 'execute' instead of 'query'). -- -- * 'ResultError': result conversion failed.-query :: (QueryParams q, QueryResults r)+query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] query conn template qs = do result <- exec conn =<< formatQuery conn template qs finishQuery conn template result -- | A version of 'query' that does not perform query substitution.-query_ :: (QueryResults r) => Connection -> Query -> IO [r]+query_ :: (FromRow r) => Connection -> Query -> IO [r] query_ conn q@(Query que) = do result <- exec conn que finishQuery conn q result@@ -324,7 +333,7 @@ -- -- * 'ResultError': result conversion failed. -fold :: ( QueryResults row, QueryParams params )+fold :: ( FromRow row, ToRow params ) => Connection -> Query -> params@@ -343,12 +352,13 @@ transactionMode :: !TransactionMode } +defaultFoldOptions :: FoldOptions defaultFoldOptions = FoldOptions { fetchQuantity = Automatic, transactionMode = TransactionMode ReadCommitted ReadOnly } -foldWithOptions :: ( QueryResults row, QueryParams params )+foldWithOptions :: ( FromRow row, ToRow params ) => FoldOptions -> Connection -> Query@@ -361,7 +371,7 @@ doFold opts conn template (Query q) a f -- | A version of 'fold' that does not perform query substitution.-fold_ :: (QueryResults r) =>+fold_ :: (FromRow r) => Connection -> Query -- ^ Query. -> a -- ^ Initial state for result consumer.@@ -370,7 +380,7 @@ fold_ = foldWithOptions_ defaultFoldOptions -foldWithOptions_ :: (QueryResults r) =>+foldWithOptions_ :: (FromRow r) => FoldOptions -> Connection -> Query -- ^ Query.@@ -380,7 +390,7 @@ foldWithOptions_ opts conn query a f = doFold opts conn query query a f -doFold :: ( QueryResults row )+doFold :: ( FromRow row ) => FoldOptions -> Connection -> Query@@ -426,7 +436,7 @@ if null rs then return a else foldM f a rs >>= loop -- | A version of 'fold' that does not transform a state value.-forEach :: (QueryParams q, QueryResults r) =>+forEach :: (ToRow q, FromRow r) => Connection -> Query -- ^ Query template. -> q -- ^ Query parameters.@@ -436,7 +446,7 @@ {-# INLINE forEach #-} -- | A version of 'forEach' that does not perform query substitution.-forEach_ :: (QueryResults r) =>+forEach_ :: (FromRow r) => Connection -> Query -- ^ Query template. -> (r -> IO ()) -- ^ Result consumer.@@ -453,7 +463,7 @@ a <- m n loop (n-1) (a:as) -finishQuery :: (QueryResults r) => Connection -> Query -> PQ.Result -> IO [r]+finishQuery :: (FromRow r) => Connection -> Query -> PQ.Result -> IO [r] finishQuery conn q result = do status <- PQ.resultStatus result case status of@@ -461,40 +471,62 @@ throwIO $ QueryError "query resulted in a command response" q PQ.TuplesOk -> do ncols <- PQ.nfields result- fields <- forM' 0 (ncols-1) $ \column -> do- type_oid <- PQ.ftype result column- typename <- getTypename conn type_oid- return Field{..}+ 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- values <- forM' 0 (ncols-1) (\col -> PQ.getvalue result row col)- case convertResults fields values of- Left err -> throwIO err- Right a -> return a- PQ.CopyIn -> fail "FIXME: postgresql-simple does not currently support COPY IN"- PQ.CopyOut -> fail "FIXME: postgresql-simple does not currently support COPY OUT"- _ -> do- errormsg <- maybe "" id <$> PQ.resultErrorMessage result- statusmsg <- PQ.resStatus status- state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate- throwIO $ SqlError { sqlState = state- , sqlNativeError = fromEnum status- , sqlErrorMsg = B.concat [ "query: ", statusmsg- , ": ", errormsg ]}+ let rw = Row row typenames result+ case runStateT (runReaderT (unRP fromRow) rw) 0 of+ Ok (val,col) | col == ncols -> return val+ | otherwise -> do+ vals <- forM' 0 (ncols-1) $ \c -> do+ v <- PQ.getvalue result row c+ return ( typenames V.! unCol c+ , fmap ellipsis v )+ throw (ConversionFailed+ (show (unCol ncols) ++ " values: " ++ show vals)+ (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 [x] -> throwIO x+ Errors xs -> throwIO $ ManyErrors xs +ellipsis :: ByteString -> ByteString+ellipsis bs+ | 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 <http://www.postgresql.org/docs/9.1/static/transaction-iso.html>--- for more information.+-- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead'+-- was equivalent to 'Serializable'. data IsolationLevel- = ReadCommitted+ = 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- = ReadWrite+ = 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) @@ -504,13 +536,15 @@ } deriving (Show, Eq) defaultTransactionMode :: TransactionMode-defaultTransactionMode = TransactionMode ReadCommitted ReadWrite+defaultTransactionMode = TransactionMode+ defaultIsolationLevel+ defaultReadWriteMode defaultIsolationLevel :: IsolationLevel-defaultIsolationLevel = ReadCommitted+defaultIsolationLevel = DefaultIsolationLevel defaultReadWriteMode :: ReadWriteMode-defaultReadWriteMode = ReadWrite+defaultReadWriteMode = DefaultReadWriteMode -- | Execute an action inside a SQL transaction. --@@ -532,11 +566,12 @@ -- | Execute an action inside a SQL transaction with a given transaction mode. withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a-withTransactionMode mode conn act = do- beginMode mode conn- r <- act `onException` rollback conn- commit conn- return r+withTransactionMode mode conn act =+ mask $ \restore -> do+ beginMode mode conn+ r <- restore act `onException` rollback conn+ commit conn+ return r -- | Rollback a transaction. rollback :: Connection -> IO ()@@ -557,20 +592,18 @@ -- | Begin a transaction with a given transaction mode beginMode :: TransactionMode -> Connection -> IO () beginMode mode conn = do- execute_ conn $! case mode of- TransactionMode ReadCommitted ReadWrite ->- "BEGIN"- TransactionMode ReadCommitted ReadOnly ->- "BEGIN READ ONLY"- TransactionMode RepeatableRead ReadWrite ->- "BEGIN ISOLATION LEVEL REPEATABLE READ"- TransactionMode RepeatableRead ReadOnly ->- "BEGIN ISOLATION LEVEL REPEATABLE READ READ ONLY"- TransactionMode Serializable ReadWrite ->- "BEGIN ISOLATION LEVEL SERIALIZABLE"- TransactionMode Serializable ReadOnly ->- "BEGIN ISOLATION LEVEL SERIALIZABLE READ ONLY"- return ()+ _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode])+ return ()+ where+ isolevel = case isolationLevel mode of+ DefaultIsolationLevel -> ""+ ReadCommitted -> " READ COMMITTED"+ RepeatableRead -> " REPEATABLE READ"+ Serializable -> " SERIALIZABLE"+ readmode = case readWriteMode mode of+ DefaultReadWriteMode -> ""+ ReadWrite -> " READ WRITE"+ ReadOnly -> " READ ONLY" fmtError :: String -> Query -> [Action] -> a fmtError msg q xs = throw FormatError {@@ -759,7 +792,7 @@ -- $result -- -- The 'query' and 'query_' functions return a list of values in the--- 'QueryResults' typeclass. This class performs automatic extraction+-- 'FromRow' typeclass. This class performs automatic extraction -- and type conversion of rows from a query result. -- -- Here is a simple example of how to extract results:
+ src/Database/PostgreSQL/Simple/Compat.hs view
@@ -0,0 +1,25 @@+{-# 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 .+module Database.PostgreSQL.Simple.Compat+ ( mask+ ) where++import qualified Control.Exception as E++-- | Like 'E.mask', but backported to base before version 4.3.0.+--+-- Note that the restore callback is monomorphic, unlike in 'E.mask'. This+-- could be fixed by changing the type signature, but it would require us to+-- enable the RankNTypes extension (since 'E.mask' has a rank-3 type). The+-- 'withTransactionMode' function calls the restore callback only once, so we+-- don't need that polymorphism.+mask :: ((IO a -> IO a) -> IO b) -> IO b+#if MIN_VERSION_base(4,3,0)+mask io = E.mask $ \restore -> io restore+#else+mask io = do+ b <- E.blocked+ E.block $ io $ \m -> if b then m else E.unblock m+#endif+{-# INLINE mask #-}
− src/Database/PostgreSQL/Simple/Field.hs
@@ -1,15 +0,0 @@-module Database.PostgreSQL.Simple.Field- ( Field- , typename- , name- , tableOid- , tableColumn- , format- , typeOid- , Oid- , Format(..)- , RawResult(..)- ) where--import Database.PostgreSQL.Simple.Internal-import Database.PostgreSQL.LibPQ (Format(..), Oid)
+ src/Database/PostgreSQL/Simple/FromField.hs view
@@ -0,0 +1,301 @@+{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, FlexibleInstances #-}+{-# LANGUAGE PatternGuards, ScopedTypeVariables #-}+------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.FromField+-- Copyright: (c) 2011 MailRank, Inc.+-- (c) 2011 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- The 'Result' typeclass, for converting a single value in a row+-- returned by a SQL query into a more useful Haskell representation.+--+-- 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.+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.FromField+ (+ FromField(..)+ , ResultError(..)+ , returnError++ , Field+ , typename+ , name+ , tableOid+ , tableColumn+ , format+ , typeOid+ , PQ.Oid(..)+ , PQ.Format(..)+ ) where++#include "MachDeps.h"++import Control.Applicative+ ( Applicative, (<|>), (<$>), (<*>), (<*), pure )+import Control.Exception (SomeException(..), Exception)+import Data.Attoparsec.Char8 hiding (Result)+import Data.Bits ((.&.), (.|.), shiftL)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Int (Int16, Int32, Int64)+import Data.List (foldl')+import Data.Ratio (Ratio)+import Data.Time.Calendar (Day, fromGregorian)+import Data.Time.Clock (UTCTime)+import Data.Time.Format (parseTime)+import Data.Time.LocalTime (TimeOfDay, makeTimeOfDayValid)+import Data.Typeable (Typeable, typeOf)+import Data.Word (Word64)+import Database.PostgreSQL.Simple.Internal+import Database.PostgreSQL.Simple.BuiltinTypes+-- import qualified Database.PostgreSQ+import Database.PostgreSQL.Simple.Ok+import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))+import qualified Database.PostgreSQL.LibPQ as PQ+-- import Database.PostgreSQL.LibPQ (Format(..), Oid(..))+import System.IO.Unsafe (unsafePerformIO)+import System.Locale (defaultTimeLocale)+import qualified Data.ByteString as SB+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text as ST+import qualified Data.Text.Encoding as ST+import qualified Data.Text.Lazy as LT++-- | Exception thrown if conversion from a SQL value to a Haskell+-- value fails.+data ResultError = Incompatible { errSQLType :: String+ , errHaskellType :: String+ , errMessage :: String }+ -- ^ The SQL and Haskell types are not compatible.+ | UnexpectedNull { errSQLType :: String+ , errHaskellType :: String+ , errMessage :: String }+ -- ^ A SQL @NULL@ was encountered when the Haskell+ -- type did not permit it.+ | ConversionFailed { errSQLType :: String+ , errHaskellType :: String+ , errMessage :: String }+ -- ^ The SQL value could not be parsed, or could not+ -- be represented as a valid Haskell value, or an+ -- unexpected low-level error occurred (e.g. mismatch+ -- between metadata and actual data in a row).+ deriving (Eq, Show, Typeable)++instance Exception ResultError++left :: Exception a => a -> Ok b+left = Errors . (:[]) . SomeException++-- | A type that may be converted from a SQL type.+class FromField a where+ fromField :: Field -> Maybe ByteString -> Ok a+ -- ^ Convert a SQL value to a Haskell value.+ --+ -- Returns a list of exceptions if the conversion fails. In the case of+ -- library instances, this will usually be a single 'ResultError', but+ -- may be a 'UnicodeException'.+ --+ -- Implementations of 'fromField' should not retain any references to+ -- the 'Field' nor the 'ByteString' arguments after the result has+ -- been evaluated to WHNF. Such a reference causes the entire+ -- @LibPQ.'PQ.Result'@ to be retained.+ --+ -- For example, the instance for 'ByteString' uses 'B.copy' to avoid+ -- such a reference, and that using bytestring functions such as 'B.drop'+ -- and 'B.takeWhile' alone will also trigger this memory leak.++instance (FromField a) => FromField (Maybe a) where+ fromField _ Nothing = pure Nothing+ fromField f bs = Just <$> fromField f bs++instance FromField Null where+ fromField _ Nothing = pure Null+ fromField f (Just _) = returnError ConversionFailed f "data is not null"++instance FromField Bool where+ fromField f bs+ | typeOid f /= builtin2oid Bool = returnError Incompatible f ""+ | bs == Nothing = returnError UnexpectedNull f ""+ | bs == Just "t" = pure True+ | bs == Just "f" = pure False+ | otherwise = returnError ConversionFailed f ""++instance FromField Int16 where+ fromField = atto ok16 $ signed decimal++instance FromField Int32 where+ fromField = atto ok32 $ signed decimal++instance FromField Int where+ fromField = atto okInt $ signed decimal++instance FromField Int64 where+ fromField = atto ok64 $ signed decimal++instance FromField Integer where+ fromField = atto ok64 $ signed decimal++instance FromField Float where+ fromField = atto ok (realToFrac <$> double)+ where ok = mkCompats [Float4,Int2]++instance FromField Double where+ fromField = atto ok double+ where ok = mkCompats [Float4,Float8,Int2,Int4]++instance FromField (Ratio Integer) where+ fromField = atto ok rational+ where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric]++unBinary :: Binary t -> t+unBinary (Binary x) = x++instance FromField SB.ByteString where+ fromField f dat = if typeOid f == builtin2oid Bytea+ then unBinary <$> fromField f dat+ else doFromField f okText' (pure . B.copy) dat++instance FromField PQ.Oid where+ fromField f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat++instance FromField LB.ByteString where+ 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+ Nothing -> returnError ConversionFailed f "unescapeBytea failed"+ Just str -> pure (Binary str)++instance FromField (Binary SB.ByteString) where+ fromField f dat = case format f of+ PQ.Text -> doFromField f okBinary (unescapeBytea f) dat+ PQ.Binary -> doFromField f okBinary (pure . Binary . B.copy) dat++instance FromField (Binary LB.ByteString) where+ fromField f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> fromField f dat++instance FromField ST.Text where+ fromField f = doFromField f okText $ (either left pure . ST.decodeUtf8')+ -- FIXME: check character encoding++instance FromField LT.Text where+ fromField f dat = LT.fromStrict <$> fromField f dat++instance FromField [Char] where+ fromField f dat = ST.unpack <$> fromField f dat++instance FromField UTCTime where+ fromField f =+ case oid2builtin (typeOid f) of+ Just Timestamp -> doIt "%F %T%Q" id+ Just TimestampWithTimeZone -> doIt "%F %T%Q%z" (++ "00")+ _ -> const $ returnError Incompatible f "types incompatible"+ where+ doIt _ _ Nothing = returnError UnexpectedNull f ""+ doIt fmt preprocess (Just bs) =+ case parseTime defaultTimeLocale fmt str of+ Just t -> pure t+ Nothing -> returnError ConversionFailed f "could not parse"+ where str = preprocess (B8.unpack bs)++instance FromField Day where+ fromField f = atto ok date f+ where ok = mkCompats [Date]+ date = fromGregorian <$> (decimal <* char '-')+ <*> (decimal <* char '-')+ <*> decimal++instance FromField TimeOfDay where+ fromField f = atto' ok time f+ where ok = mkCompats [Time]+ time = do+ hours <- decimal <* char ':'+ mins <- decimal <* char ':'+ secs <- decimal :: Parser Int+ case makeTimeOfDayValid hours mins (fromIntegral secs) of+ Just t -> return (pure t)+ _ -> return (returnError ConversionFailed f "could not parse")++instance (FromField a, FromField b) => FromField (Either a b) where+ fromField f dat = (Right <$> fromField f dat)+ <|> (Left <$> fromField f dat)++newtype Compat = Compat Word64++mkCompats :: [BuiltinType] -> Compat+mkCompats = foldl' f (Compat 0) . map mkCompat+ where f (Compat a) (Compat b) = Compat (a .|. b)++mkCompat :: BuiltinType -> Compat+mkCompat = Compat . shiftL 1 . fromEnum++compat :: Compat -> Compat -> Bool+compat (Compat a) (Compat b) = a .&. b /= 0++okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat+okText = mkCompats [Name,Text,Char,Bpchar,Varchar]+okText' = mkCompats [Name,Text,Char,Bpchar,Varchar,Unknown]+okBinary = mkCompats [Bytea]+ok16 = mkCompats [Int2]+ok32 = mkCompats [Int2,Int4]+ok64 = mkCompats [Int2,Int4,Int8]+#if WORD_SIZE_IN_BITS < 64+okInt = ok32+#else+okInt = ok64+#endif++doFromField :: forall a . (Typeable a)+ => Field -> Compat -> (ByteString -> Ok a)+ -> Maybe ByteString -> Ok a+doFromField f types cvt (Just bs)+ | Just typ <- oid2builtin (typeOid f)+ , mkCompat typ `compat` types = cvt bs+ | otherwise = returnError Incompatible f "types incompatible"+doFromField f _ _ _ = returnError UnexpectedNull f ""+++-- | Given one of the constructors from 'ResultError', the field,+-- and an 'errMessage', this fills in the other fields in the+-- 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)))++atto :: forall a. (Typeable a)+ => Compat -> Parser a -> Field -> Maybe ByteString+ -> Ok a+atto types p0 f dat = doFromField f types (go p0) dat+ where+ go :: Parser a -> ByteString -> Ok a+ go p s =+ case parseOnly p s of+ Left err -> returnError ConversionFailed f err+ Right v -> pure v++atto' :: forall a. (Typeable a)+ => Compat -> Parser (Ok a) -> Field -> Maybe ByteString+ -> Ok a+atto' types p0 f dat = doFromField f types (go p0) dat+ where+ go :: Parser (Ok a) -> ByteString -> Ok a+ go p s =+ case parseOnly p s of+ Left err -> returnError ConversionFailed f err+ Right v -> v
+ src/Database/PostgreSQL/Simple/FromRow.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE RecordWildCards #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.FromRow+-- Copyright: (c) 2011 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- The 'FromRow' typeclass, for converting a row of results+-- returned by a SQL query into a more useful Haskell representation.+--+-- Predefined instances are provided for tuples containing up to ten+-- elements.+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.FromRow+ ( FromRow(..)+ , RowParser+ , field+ , numFieldsRemaining+ ) 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.FromField+import Database.PostgreSQL.Simple.Types++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.+--+-- Note that instances can defined outside of postgresql-simple, which is+-- often useful. For example, here's an instance for a user-defined pair:+--+-- @data User = User { name :: String, fileQuota :: Int }+--+-- instance 'FromRow' User where+-- fromRow = User \<$\> 'field' \<*\> 'field'+-- @+--+-- The number of calls to 'field' must match the number of fields returned+-- in a single row of the query result. Otherwise, a 'ConversionFailed'+-- exception will be thrown.+--+-- Note that 'field' evaluates it's result to WHNF, so the caveats listed in+-- previous versions of postgresql-simple no longer apply. Instead, look+-- at the caveats associated with user-defined implementations of 'fromRow'.++class FromRow a where+ fromRow :: RowParser a++field :: FromField a => RowParser a+field = RP $ do+ let unCol (PQ.Col x) = fromIntegral x :: Int+ 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)+ ("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]))+ else do+ let typename = typenames ! unCol column+ result = rowresult+ field = Field{..}+ lift (lift (fromField field (getvalue result row column)))++ellipsis :: ByteString -> ByteString+ellipsis bs+ | B.length bs > 15 = B.take 10 bs `B.append` "[...]"+ | otherwise = bs++numFieldsRemaining :: RowParser Int+numFieldsRemaining = RP $ do+ Row{..} <- ask+ column <- lift get+ return $! (\(PQ.Col x) -> fromIntegral x) (nfields rowresult - column)++instance (FromField a) => FromRow (Only a) where+ fromRow = Only <$> field++instance (FromField a, FromField b) => FromRow (a,b) where+ fromRow = (,) <$> field <*> field++instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where+ fromRow = (,,) <$> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d) =>+ FromRow (a,b,c,d) where+ fromRow = (,,,) <$> field <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e) =>+ FromRow (a,b,c,d,e) where+ fromRow = (,,,,) <$> field <*> field <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f) =>+ FromRow (a,b,c,d,e,f) where+ fromRow = (,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g) =>+ FromRow (a,b,c,d,e,f,g) where+ fromRow = (,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h) =>+ FromRow (a,b,c,d,e,f,g,h) where+ fromRow = (,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i) =>+ FromRow (a,b,c,d,e,f,g,h,i) where+ fromRow = (,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field++instance (FromField a, FromField b, FromField c, FromField d, FromField e,+ FromField f, FromField g, FromField h, FromField i, FromField j) =>+ FromRow (a,b,c,d,e,f,g,h,i,j) where+ fromRow = (,,,,,,,,,) <$> field <*> field <*> field <*> field <*> field+ <*> field <*> field <*> field <*> field <*> field++instance FromField a => FromRow [a] where+ fromRow = do+ n <- numFieldsRemaining+ replicateM n field++instance (FromRow a, FromRow b) => FromRow (a :. b) where+ fromRow = (:.) <$> fromRow <*> fromRow
src/Database/PostgreSQL/Simple/Internal.hs view
@@ -1,5 +1,4 @@-{-# LANGUAGE OverloadedStrings, NamedFieldPuns, RecordWildCards #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Internal@@ -10,10 +9,10 @@ -- Portability: portable -- -- Internal bits. This interface is less stable and can change at any time.--- In particular this means that while the rest of the postgresql-simple --- package endeavors to follow the package versioning policy, this module --- does not. Also, at the moment there are things in here that aren't --- particularly internal and are exported elsewhere; these will eventually +-- In particular this means that while the rest of the postgresql-simple+-- package endeavors to follow the package versioning policy, this module+-- does not. Also, at the moment there are things in here that aren't+-- particularly internal and are exported elsewhere; these will eventually -- disappear from this module. -- ------------------------------------------------------------------------------@@ -33,6 +32,10 @@ import Database.PostgreSQL.LibPQ(Oid(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.BuiltinTypes (BuiltinType)+import Database.PostgreSQL.Simple.Ok+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@@ -42,9 +45,9 @@ -- just the field metadata data Field = Field {- result :: PQ.Result- , column :: PQ.Column- , typename :: ByteString+ result :: !PQ.Result+ , column :: {-# UNPACK #-} !PQ.Column+ , typename :: !ByteString } name :: Field -> Maybe ByteString@@ -195,6 +198,7 @@ Just res -> do return res +disconnectedError :: SqlError disconnectedError = SqlError { sqlNativeError = -1, sqlErrorMsg = "connection disconnected",@@ -224,4 +228,17 @@ connectionObjects <- newMVar IntMap.empty return Connection{..} -data RawResult = RawResult { rawField :: Field, rawData :: Maybe ByteString }+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 }+ deriving ( Functor, Applicative, Alternative, Monad )++getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString+getvalue result row col = unsafePerformIO (PQ.getvalue result row col)++nfields :: PQ.Result -> PQ.Column+nfields result = unsafePerformIO (PQ.nfields result)
src/Database/PostgreSQL/Simple/LargeObjects.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- ----------------------------------------------------------------------------- -- | -- Module : Database.PostgreSQL.Simple.LargeObjects@@ -36,7 +34,6 @@ import Database.PostgreSQL.LibPQ (Oid(..),LoFd(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Internal-import Foreign.C.Types (CInt) import System.IO (IOMode(..),SeekMode(..)) liftPQ :: B.ByteString -> Connection -> (PQ.Connection -> IO (Maybe a)) -> IO a
src/Database/PostgreSQL/Simple/Notification.hs view
@@ -29,6 +29,7 @@ , notificationData :: B.ByteString } +errfd :: String errfd = "Database.PostgreSQL.Simple.Notification.getNotification: \ \failed to fetch file descriptor"
+ src/Database/PostgreSQL/Simple/Ok.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}++module Database.PostgreSQL.Simple.Ok where++import Control.Applicative+import Control.Exception+import Control.Monad(MonadPlus(..))+import Data.Typeable++newtype ManyErrors = ManyErrors [SomeException] + deriving (Show, Typeable)++instance Exception ManyErrors++-- FIXME: [SomeException] should probably be a difference list++data Ok a = Errors [SomeException] | Ok !a+ deriving(Show, Typeable, Functor)++instance Eq a => Eq (Ok a) where+ Errors _ == Errors _ = True+ Ok a == Ok b = a == b+ _ == _ = False++instance Applicative Ok where+ pure = Ok++ Errors es <*> _ = Errors es+ _ <*> Errors es = Errors es+ Ok f <*> Ok a = Ok (f a)++instance Alternative Ok where+ empty = Errors []++ a@(Ok _) <|> _ = a+ Errors _ <|> b@(Ok _) = b+ Errors as <|> Errors bs = Errors (as ++ bs)+++instance MonadPlus Ok where+ mzero = empty+ mplus = (<|>)++instance Monad Ok where+ return = Ok++ Errors es >>= _ = Errors es+ Ok a >>= f = f a+ -- TODO: add a definition for "fail", akin to++ -- fail str = Errors [SomeException (error str)]++ -- but *correct*, as this will throw an exception if you try to+ -- examine the exception.
− src/Database/PostgreSQL/Simple/Param.hs
@@ -1,206 +0,0 @@-{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances,- OverloadedStrings #-}---- |--- Module: Database.PostgreSQL.Simple.Param--- Copyright: (c) 2011 MailRank, Inc.--- (c) 2011 Leon P Smith--- License: BSD3--- Maintainer: Leon P Smith <leon@melding-monads.com>--- Stability: experimental--- Portability: portable------ The 'Param' typeclass, for rendering a parameter to a SQL query.--module Database.PostgreSQL.Simple.Param- (- Action(..)- , Param(..)- , inQuotes- ) where--import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString,- toByteString)-import Blaze.ByteString.Builder.Char8 (fromChar)-import Blaze.Text (integral, double, float)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Base16 as B16-import qualified Data.ByteString.Base16.Lazy as L16-import Data.Int (Int8, Int16, Int32, Int64)-import Data.List (intersperse)-import Data.Monoid (mappend)-import Data.Time.Calendar (Day, showGregorian)-import Data.Time.Clock (UTCTime)-import Data.Time.Format (formatTime)-import Data.Time.LocalTime (TimeOfDay)-import Data.Typeable (Typeable)-import Data.Word (Word, Word8, Word16, Word32, Word64)-import Database.PostgreSQL.Simple.Types (Binary(..), In(..), Null)-import System.Locale (defaultTimeLocale)-import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8-import qualified Data.ByteString as SB-import qualified Data.ByteString.Lazy as LB-import qualified Data.Text as ST-import qualified Data.Text.Encoding as ST-import qualified Data.Text.Lazy as LT-import qualified Database.PostgreSQL.LibPQ as PQ---- | How to render an element when substituting it into a query.-data Action =- Plain Builder- -- ^ Render without escaping or quoting. Use for non-text types- -- such as numbers, when you are /certain/ that they will not- -- introduce formatting vulnerabilities via use of characters such- -- as spaces or \"@'@\".- | Escape ByteString- -- ^ Escape and enclose in quotes before substituting. Use for all- -- text-like types, and anything else that may contain unsafe- -- characters when rendered.- | Many [Action]- -- ^ Concatenate a series of rendering actions.- deriving (Typeable)--instance Show Action where- show (Plain b) = "Plain " ++ show (toByteString b)- show (Escape b) = "Escape " ++ show b- show (Many b) = "Many " ++ show b---- | A type that may be used as a single parameter to a SQL query.-class Param a where- render :: a -> Action- -- ^ Prepare a value for substitution into a query string.--instance Param Action where- render a = a- {-# INLINE render #-}--instance (Param a) => Param (Maybe a) where- render Nothing = renderNull- render (Just a) = render a- {-# INLINE render #-}--instance (Param a) => Param (In [a]) where- render (In []) = Plain $ fromByteString "(null)"- render (In xs) = Many $- Plain (fromChar '(') :- (intersperse (Plain (fromChar ',')) . map render $ xs) ++- [Plain (fromChar ')')]--instance Param (Binary SB.ByteString) where- render (Binary bs) = Plain $ fromByteString "'\\x" `mappend`- fromByteString (B16.encode bs) `mappend`- fromChar '\''--instance Param (Binary LB.ByteString) where- render (Binary bs) = Plain $ fromByteString "'\\x" `mappend`- fromLazyByteString (L16.encode bs) `mappend`- fromChar '\''--renderNull :: Action-renderNull = Plain (fromByteString "null")--instance Param Null where- render _ = renderNull- {-# INLINE render #-}--instance Param Bool where- render True = Plain (fromByteString "true")- render False = Plain (fromByteString "false")- {-# INLINE render #-}--instance Param Int8 where- render = Plain . integral- {-# INLINE render #-}--instance Param Int16 where- render = Plain . integral- {-# INLINE render #-}--instance Param Int32 where- render = Plain . integral- {-# INLINE render #-}--instance Param Int where- render = Plain . integral- {-# INLINE render #-}--instance Param Int64 where- render = Plain . integral- {-# INLINE render #-}--instance Param Integer where- render = Plain . integral- {-# INLINE render #-}--instance Param Word8 where- render = Plain . integral- {-# INLINE render #-}--instance Param Word16 where- render = Plain . integral- {-# INLINE render #-}--instance Param Word32 where- render = Plain . integral- {-# INLINE render #-}--instance Param Word where- render = Plain . integral- {-# INLINE render #-}--instance Param Word64 where- render = Plain . integral- {-# INLINE render #-}--instance Param PQ.Oid where- render = Plain . integral . \(PQ.Oid x) -> x- {-# INLINE render #-}--instance Param Float where- render v | isNaN v || isInfinite v = Plain (inQuotes (float v))- | otherwise = Plain (float v)- {-# INLINE render #-}--instance Param Double where- render v | isNaN v || isInfinite v = Plain (inQuotes (double v))- | otherwise = Plain (double v)- {-# INLINE render #-}--instance Param SB.ByteString where- render = Escape- {-# INLINE render #-}--instance Param LB.ByteString where- render = render . SB.concat . LB.toChunks- {-# INLINE render #-}--instance Param ST.Text where- render = Escape . ST.encodeUtf8- {-# INLINE render #-}--instance Param [Char] where- render = Escape . toByteString . Utf8.fromString- {-# INLINE render #-}--instance Param LT.Text where- render = render . LT.toStrict- {-# INLINE render #-}--instance Param UTCTime where- render = Plain . Utf8.fromString . formatTime defaultTimeLocale "'%F %T%Q+00'"- {-# INLINE render #-}--instance Param Day where- render = Plain . inQuotes . Utf8.fromString . showGregorian- {-# INLINE render #-}--instance Param TimeOfDay where- render = Plain . inQuotes . Utf8.fromString . show- {-# INLINE render #-}---- | Surround a string with single-quote characters: \"@'@\"------ This function /does not/ perform any other escaping.-inQuotes :: Builder -> Builder-inQuotes b = quote `mappend` b `mappend` quote- where quote = Utf8.fromChar '\''
− src/Database/PostgreSQL/Simple/QueryParams.hs
@@ -1,85 +0,0 @@--- |--- Module: Database.PostgreSQL.Simple.QueryParams--- Copyright: (c) 2011 MailRank, Inc.--- (c) 2011 Leon P Smith--- License: BSD3--- Maintainer: Leon P Smith <leon@melding-monads.com>--- Stability: experimental--- Portability: portable------ The 'QueryParams' typeclass, for rendering a collection of--- parameters to a SQL query.------ Predefined instances are provided for tuples containing up to ten--- elements.--module Database.PostgreSQL.Simple.QueryParams- (- QueryParams(..)- ) where--import Database.PostgreSQL.Simple.Param (Action(..), Param(..))-import Database.PostgreSQL.Simple.Types (Only(..))---- | A collection type that can be turned into a list of rendering--- 'Action's.------ Instances should use the 'render' method of the 'Param' class--- to perform conversion of each element of the collection.-class QueryParams a where- renderParams :: a -> [Action]- -- ^ Render a collection of values.--instance QueryParams () where- renderParams _ = []--instance (Param a) => QueryParams (Only a) where- renderParams (Only v) = [render v]--instance (Param a, Param b) => QueryParams (a,b) where- renderParams (a,b) = [render a, render b]--instance (Param a, Param b, Param c) => QueryParams (a,b,c) where- renderParams (a,b,c) = [render a, render b, render c]--instance (Param a, Param b, Param c, Param d) => QueryParams (a,b,c,d) where- renderParams (a,b,c,d) = [render a, render b, render c, render d]--instance (Param a, Param b, Param c, Param d, Param e)- => QueryParams (a,b,c,d,e) where- renderParams (a,b,c,d,e) =- [render a, render b, render c, render d, render e]--instance (Param a, Param b, Param c, Param d, Param e, Param f)- => QueryParams (a,b,c,d,e,f) where- renderParams (a,b,c,d,e,f) =- [render a, render b, render c, render d, render e, render f]--instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g)- => QueryParams (a,b,c,d,e,f,g) where- renderParams (a,b,c,d,e,f,g) =- [render a, render b, render c, render d, render e, render f, render g]--instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,- Param h)- => QueryParams (a,b,c,d,e,f,g,h) where- renderParams (a,b,c,d,e,f,g,h) =- [render a, render b, render c, render d, render e, render f, render g,- render h]--instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,- Param h, Param i)- => QueryParams (a,b,c,d,e,f,g,h,i) where- renderParams (a,b,c,d,e,f,g,h,i) =- [render a, render b, render c, render d, render e, render f, render g,- render h, render i]--instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,- Param h, Param i, Param j)- => QueryParams (a,b,c,d,e,f,g,h,i,j) where- renderParams (a,b,c,d,e,f,g,h,i,j) =- [render a, render b, render c, render d, render e, render f, render g,- render h, render i, render j]--instance (Param a) => QueryParams [a] where- renderParams = map render
− src/Database/PostgreSQL/Simple/QueryResults.hs
@@ -1,245 +0,0 @@-{-# LANGUAGE BangPatterns, OverloadedStrings #-}----------------------------------------------------------------------------------- |--- Module: Database.PostgreSQL.Simple.QueryResults--- Copyright: (c) 2011 MailRank, Inc.--- (c) 2011 Leon P Smith--- License: BSD3--- Maintainer: Leon P Smith <leon@melding-monads.com>--- Stability: experimental--- Portability: portable------ The 'QueryResults' typeclass, for converting a row of results--- returned by a SQL query into a more useful Haskell representation.------ Predefined instances are provided for tuples containing up to ten--- elements.---------------------------------------------------------------------------------module Database.PostgreSQL.Simple.QueryResults- (- QueryResults(..)- , convertError- ) where--import Control.Applicative (Applicative(..), (<$>))-import Control.Exception (SomeException(..), throw)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import Data.Either()-import Database.PostgreSQL.Simple.Internal-import Database.PostgreSQL.Simple.Result (ResultError(..), Result(..))-import Database.PostgreSQL.Simple.Types (Only(..))-import qualified Database.PostgreSQL.LibPQ as LibPQ (Result)---- | A collection type that can be converted from a list of strings.------ Instances should use the 'convert' method of the 'Result' class--- to perform conversion of each element of the collection.------ This example instance demonstrates how to convert a two-column row--- into a Haskell pair. Each field in the metadata is paired up with--- each value from the row, and the two are passed to 'convert'.------ @--- instance ('Result' a, 'Result' b) => 'QueryResults' (a,b) where--- 'convertResults' [fa,fb] [va,vb] = do--- !a <- 'convert' fa va--- !b <- 'convert' fb vb--- 'return' (a,b)--- 'convertResults' fs vs = 'convertError' fs vs 2--- @------ Notice that this instance evaluates each element to WHNF before--- constructing the pair. This property is important enough that its--- a rule all 'QueryResult' instances should follow:------ * Evaluate every 'Result' value to WHNF before constructing--- the result------ Doing so keeps resource usage under local control by preventing the--- construction of potentially long-lived thunks that are forced--- (or not) by the consumer.------ This is important to postgresql-simple-0.0.4 because a wayward thunk--- causes the entire LibPQ.'LibPQ.Result' to be retained. This could lead--- to a memory leak, depending on how the thunk is consumed.------ Note that instances can be defined outside of postgresql-simple,--- which is often useful. For example, here is an attempt at an--- instance for a user-defined pair:------ @--- data User = User { firstName :: String, lastName :: String }------ instance 'QueryResults' User where--- 'convertResults' [fa,qfb] [va,vb] = User \<$\> a \<*\> b--- where !a = 'convert' fa va--- !b = 'convert' fb vb--- 'convertResults' fs vs = 'convertError' fs vs 2--- @------ In this example, the bang patterns are not used correctly. They force--- the data constructors of the 'Either' type, and are not forcing the--- 'Result' values we need to force. This gives the consumer of the--- 'QueryResult' the ability to cause the memory leak, which is an--- undesirable state of affairs.--class QueryResults a where- convertResults :: [Field] -> [Maybe ByteString] -> Either SomeException a- -- ^ Convert values from a row into a Haskell collection.- --- -- This function will return a 'ResultError' if conversion of the- -- collection fails.--instance (Result a) => QueryResults (Only a) where- convertResults [fa] [va] = do- !a <- convert fa va- return (Only a)- convertResults fs vs = convertError fs vs 1--instance (Result a, Result b) => QueryResults (a,b) where- convertResults [fa,fb] [va,vb] = do- !a <- convert fa va- !b <- convert fb vb- return (a,b)- convertResults fs vs = convertError fs vs 2--instance (Result a, Result b, Result c) => QueryResults (a,b,c) where- convertResults [fa,fb,fc] [va,vb,vc] = do- !a <- convert fa va- !b <- convert fb vb- !c <- convert fc vc- return (a,b,c)- convertResults fs vs = convertError fs vs 3--instance (Result a, Result b, Result c, Result d) =>- QueryResults (a,b,c,d) where- convertResults [fa,fb,fc,fd] [va,vb,vc,vd] = do- !a <- convert fa va- !b <- convert fb vb- !c <- convert fc vc- !d <- convert fd vd- return (a,b,c,d)- convertResults fs vs = convertError fs vs 4--instance (Result a, Result b, Result c, Result d, Result e) =>- QueryResults (a,b,c,d,e) where- convertResults [fa,fb,fc,fd,fe] [va,vb,vc,vd,ve] = do- !a <- convert fa va- !b <- convert fb vb- !c <- convert fc vc- !d <- convert fd vd- !e <- convert fe ve- return (a,b,c,d,e)- convertResults fs vs = convertError fs vs 5--instance (Result a, Result b, Result c, Result d, Result e, Result f) =>- QueryResults (a,b,c,d,e,f) where- convertResults [fa,fb,fc,fd,fe,ff] [va,vb,vc,vd,ve,vf] = do- !a <- convert fa va- !b <- convert fb vb- !c <- convert fc vc- !d <- convert fd vd- !e <- convert fe ve- !f <- convert ff vf- return (a,b,c,d,e,f)- convertResults fs vs = convertError fs vs 6--instance (Result a, Result b, Result c, Result d, Result e, Result f,- Result g) =>- QueryResults (a,b,c,d,e,f,g) where- convertResults [fa,fb,fc,fd,fe,ff,fg] [va,vb,vc,vd,ve,vf,vg] = do- !a <- convert fa va- !b <- convert fb vb- !c <- convert fc vc- !d <- convert fd vd- !e <- convert fe ve- !f <- convert ff vf- !g <- convert fg vg- return (a,b,c,d,e,f,g)- convertResults fs vs = convertError fs vs 7--instance (Result a, Result b, Result c, Result d, Result e, Result f,- Result g, Result h) =>- QueryResults (a,b,c,d,e,f,g,h) where- convertResults [fa,fb,fc,fd,fe,ff,fg,fh] [va,vb,vc,vd,ve,vf,vg,vh] = do- !a <- convert fa va- !b <- convert fb vb- !c <- convert fc vc- !d <- convert fd vd- !e <- convert fe ve- !f <- convert ff vf- !g <- convert fg vg- !h <- convert fh vh- return (a,b,c,d,e,f,g,h)- convertResults fs vs = convertError fs vs 8--instance (Result a, Result b, Result c, Result d, Result e, Result f,- Result g, Result h, Result i) =>- QueryResults (a,b,c,d,e,f,g,h,i) where- convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi] [va,vb,vc,vd,ve,vf,vg,vh,vi] =- do- !a <- convert fa va- !b <- convert fb vb- !c <- convert fc vc- !d <- convert fd vd- !e <- convert fe ve- !f <- convert ff vf- !g <- convert fg vg- !h <- convert fh vh- !i <- convert fi vi- return (a,b,c,d,e,f,g,h,i)- convertResults fs vs = convertError fs vs 9--instance (Result a, Result b, Result c, Result d, Result e, Result f,- Result g, Result h, Result i, Result j) =>- QueryResults (a,b,c,d,e,f,g,h,i,j) where- convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj]- [va,vb,vc,vd,ve,vf,vg,vh,vi,vj] =- do- !a <- convert fa va- !b <- convert fb vb- !c <- convert fc vc- !d <- convert fd vd- !e <- convert fe ve- !f <- convert ff vf- !g <- convert fg vg- !h <- convert fh vh- !i <- convert fi vi- !j <- convert fj vj- return (a,b,c,d,e,f,g,h,i,j)- convertResults fs vs = convertError fs vs 10--f <$!> (!x) = f <$> x-infixl 4 <$!>--instance Result a => QueryResults [a] where- convertResults fs vs = foldr convert' (pure []) (zip fs vs)- where convert' (f,v) as = (:) <$!> convert f v <*> as- {-# INLINE convertResults #-}---- | Throw a 'ConversionFailed' exception, indicating a mismatch--- between the number of columns in the 'Field' and row, and the--- number in the collection to be converted to.-convertError :: [Field]- -- ^ Descriptors of fields to be converted.- -> [Maybe ByteString]- -- ^ Contents of the row to be converted.- -> Int- -- ^ Number of columns expected for conversion. For- -- instance, if converting to a 3-tuple, the number to- -- provide here would be 3.- -> Either SomeException a-convertError fs vs n = Left . SomeException $ ConversionFailed- (show (length fs) ++ " values: " ++ show (zip (map typename fs)- (map (fmap ellipsis) vs)))- (show n ++ " slots in target type")- "mismatch between number of columns to convert and number in target type"--ellipsis :: ByteString -> ByteString-ellipsis bs- | B.length bs > 15 = B.take 10 bs `B.append` "[...]"- | otherwise = bs-
− src/Database/PostgreSQL/Simple/Result.hs
@@ -1,287 +0,0 @@-{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, FlexibleInstances #-}-{-# LANGUAGE PatternGuards, ScopedTypeVariables, OverloadedStrings #-}---------------------------------------------------------------------------------- |--- Module: Database.PostgreSQL.Simple.QueryResults--- Copyright: (c) 2011 MailRank, Inc.--- (c) 2011 Leon P Smith--- License: BSD3--- Maintainer: Leon P Smith <leon@melding-monads.com>--- Stability: experimental--- Portability: portable------ The 'Result' typeclass, for converting a single value in a row--- returned by a SQL query into a more useful Haskell representation.------ 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.------------------------------------------------------------------------------------module Database.PostgreSQL.Simple.Result- (- Result(..)- , ResultError(..)- , returnError- ) where--#include "MachDeps.h"--import Control.Applicative (Applicative, (<$>), (<*>), (<*), pure)-import Control.Exception (SomeException(..), Exception, throw)-import Data.Attoparsec.Char8 hiding (Result)-import Data.Bits ((.&.), (.|.), shiftL)-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as B-import Data.Int (Int16, Int32, Int64)-import Data.List (foldl')-import Data.Ratio (Ratio)-import Data.Time.Calendar (Day, fromGregorian)-import Data.Time.Clock (UTCTime)-import Data.Time.Format (parseTime)-import Data.Time.LocalTime (TimeOfDay, makeTimeOfDayValid)-import Data.Typeable (TypeRep, Typeable, typeOf)-import Data.Word (Word64)-import Database.PostgreSQL.Simple.Internal-import Database.PostgreSQL.Simple.Field (Field(..), RawResult(..))-import Database.PostgreSQL.Simple.BuiltinTypes-import Database.PostgreSQL.Simple.Types (Binary(..), Null(..))-import qualified Database.PostgreSQL.LibPQ as PQ-import System.IO.Unsafe (unsafePerformIO)-import System.Locale (defaultTimeLocale)-import qualified Data.ByteString as SB-import qualified Data.ByteString.Char8 as B8-import qualified Data.ByteString.Lazy as LB-import qualified Data.Text as ST-import qualified Data.Text.Encoding as ST-import qualified Data.Text.Encoding.Error (UnicodeException)-import qualified Data.Text.Lazy as LT---- | Exception thrown if conversion from a SQL value to a Haskell--- value fails.-data ResultError = Incompatible { errSQLType :: String- , errHaskellType :: String- , errMessage :: String }- -- ^ The SQL and Haskell types are not compatible.- | UnexpectedNull { errSQLType :: String- , errHaskellType :: String- , errMessage :: String }- -- ^ A SQL @NULL@ was encountered when the Haskell- -- type did not permit it.- | ConversionFailed { errSQLType :: String- , errHaskellType :: String- , errMessage :: String }- -- ^ The SQL value could not be parsed, or could not- -- be represented as a valid Haskell value, or an- -- unexpected low-level error occurred (e.g. mismatch- -- between metadata and actual data in a row).- deriving (Eq, Show, Typeable)--instance Exception ResultError--type Status = Either SomeException--left :: Exception a => a -> Status b-left = Left . SomeException---- | A type that may be converted from a SQL type.-class Result a where- convert :: Field -> Maybe ByteString -> Either SomeException a- -- ^ Convert a SQL value to a Haskell value.- --- -- Returns an exception if the conversion fails. In the case of- -- library instances, this will usually be a 'ResultError', but may- -- be a 'UnicodeException'.--instance (Result a) => Result (Maybe a) where- convert _ Nothing = pure Nothing- convert f bs = Just <$> convert f bs--instance Result Null where- convert _ Nothing = pure Null- convert f (Just _) = returnError ConversionFailed f "data is not null"--instance Result Bool where- convert f bs- | typeOid f /= builtin2oid Bool = returnError Incompatible f ""- | bs == Nothing = returnError UnexpectedNull f ""- | bs == Just "t" = pure True- | bs == Just "f" = pure False- | otherwise = returnError ConversionFailed f ""--instance Result Int16 where- convert = atto ok16 $ signed decimal--instance Result Int32 where- convert = atto ok32 $ signed decimal--instance Result Int where- convert = atto okInt $ signed decimal--instance Result Int64 where- convert = atto ok64 $ signed decimal--instance Result Integer where- convert = atto ok64 $ signed decimal--instance Result Float where- convert = atto ok (realToFrac <$> double)- where ok = mkCompats [Float4,Int2]--instance Result Double where- convert = atto ok double- where ok = mkCompats [Float4,Float8,Int2,Int4]--instance Result (Ratio Integer) where- convert = atto ok rational- where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric]--unBinary (Binary x) = x--instance Result SB.ByteString where- convert f dat = if typeOid f == builtin2oid Bytea- then unBinary <$> convert f dat- else doConvert f okText' (pure . B.copy) dat--instance Result PQ.Oid where- convert f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat--instance Result LB.ByteString where- convert f dat = LB.fromChunks . (:[]) <$> convert f dat--unescapeBytea :: Field -> SB.ByteString- -> Status (Binary SB.ByteString)-unescapeBytea f str = case unsafePerformIO (PQ.unescapeBytea str) of- Nothing -> returnError ConversionFailed f "unescapeBytea failed"- Just str -> pure (Binary str)--instance Result (Binary SB.ByteString) where- convert f dat = case format f of- PQ.Text -> doConvert f okBinary (unescapeBytea f) dat- PQ.Binary -> doConvert f okBinary (pure . Binary . B.copy) dat--instance Result (Binary LB.ByteString) where- convert f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> convert f dat--instance Result ST.Text where- convert f = doConvert f okText $ (either left Right . ST.decodeUtf8')- -- FIXME: check character encoding--instance Result LT.Text where- convert f dat = LT.fromStrict <$> convert f dat--instance Result [Char] where- convert f dat = ST.unpack <$> convert f dat--instance Result UTCTime where- convert f =- case oid2builtin (typeOid f) of- Just Timestamp -> doIt "%F %T%Q" id- Just TimestampWithTimeZone -> doIt "%F %T%Q%z" (++ "00")- _ -> const $ returnError Incompatible f "types incompatible"- where- doIt _ _ Nothing = returnError UnexpectedNull f ""- doIt fmt preprocess (Just bs) =- case parseTime defaultTimeLocale fmt str of- Just t -> Right t- Nothing -> returnError ConversionFailed f "could not parse"- where str = preprocess (B8.unpack bs)--instance Result Day where- convert f = atto ok date f- where ok = mkCompats [Date]- date = fromGregorian <$> (decimal <* char '-')- <*> (decimal <* char '-')- <*> decimal--instance Result TimeOfDay where- convert f = atto' ok time f- where ok = mkCompats [Time]- time = do- hours <- decimal <* char ':'- mins <- decimal <* char ':'- secs <- decimal :: Parser Int- case makeTimeOfDayValid hours mins (fromIntegral secs) of- Just t -> return (pure t)- _ -> return (returnError ConversionFailed f "could not parse")--instance (Result a, Result b) => Result (Either a b) where- convert f dat = case convert f dat of- Right x -> Right (Right x)- Left _ -> case convert f dat of- Right x -> Right (Left x)- Left e -> Left e--newtype Compat = Compat Word64--mkCompats :: [BuiltinType] -> Compat-mkCompats = foldl' f (Compat 0) . map mkCompat- where f (Compat a) (Compat b) = Compat (a .|. b)--mkCompat :: BuiltinType -> Compat-mkCompat = Compat . shiftL 1 . fromEnum--compat :: Compat -> Compat -> Bool-compat (Compat a) (Compat b) = a .&. b /= 0--okText, okText', ok16, ok32, ok64 :: Compat-okText = mkCompats [Name,Text,Char,Bpchar,Varchar]-okText' = mkCompats [Name,Text,Char,Bpchar,Varchar,Unknown]-okBinary = mkCompats [Bytea]-ok16 = mkCompats [Int2]-ok32 = mkCompats [Int2,Int4]-ok64 = mkCompats [Int2,Int4,Int8]-#if WORD_SIZE_IN_BITS < 64-okInt = ok32-#else-okInt = ok64-#endif--doConvert :: forall a . (Typeable a)- => Field -> Compat -> (ByteString -> Status a)- -> Maybe ByteString -> Status a-doConvert f types cvt (Just bs)- | Just typ <- oid2builtin (typeOid f)- , mkCompat typ `compat` types = cvt bs- | otherwise = returnError Incompatible f "types incompatible"-doConvert f _ _ _ = returnError UnexpectedNull f ""----- | Given one of the constructors from 'ResultError', the field,--- and an 'errMessage', this fills in the other fields in the--- exception value and returns it in a 'Left . SomeException'--- constructor.-returnError :: forall a err . (Typeable a, Exception err)- => (String -> String -> String -> err)- -> Field -> String -> Either SomeException a-returnError mkErr f = left . mkErr (B.unpack (typename f))- (show (typeOf (undefined :: a)))--atto :: forall a. (Typeable a)- => Compat -> Parser a -> Field -> Maybe ByteString- -> Status a-atto types p0 f dat = doConvert f types (go p0) dat- where- go :: Parser a -> ByteString -> Status a- go p s =- case parseOnly p s of- Left err -> returnError ConversionFailed f err- Right v -> Right v--atto' :: forall a. (Typeable a)- => Compat -> Parser (Status a) -> Field -> Maybe ByteString- -> Status a-atto' types p0 f dat = doConvert f types (go p0) dat- where- go :: Parser (Status a) -> ByteString -> Status a- go p s =- case parseOnly p s of- Left err -> returnError ConversionFailed f err- Right v -> v--instance Result RawResult where- convert field rawData = Right (RawResult field rawData)
+ src/Database/PostgreSQL/Simple/ToField.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.ToField+-- Copyright: (c) 2011 MailRank, Inc.+-- (c) 2011 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- The 'ToField' typeclass, for rendering a parameter to a SQL query.+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.ToField+ (+ Action(..)+ , ToField(..)+ , inQuotes+ ) where++import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString,+ toByteString)+import Blaze.ByteString.Builder.Char8 (fromChar)+import Blaze.Text (integral, double, float)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Base16.Lazy as L16+import Data.Int (Int8, Int16, Int32, Int64)+import Data.List (intersperse)+import Data.Monoid (mappend)+import Data.Time.Calendar (Day, showGregorian)+import Data.Time.Clock (UTCTime)+import Data.Time.Format (formatTime)+import Data.Time.LocalTime (TimeOfDay)+import Data.Typeable (Typeable)+import Data.Word (Word, Word8, Word16, Word32, Word64)+import Database.PostgreSQL.Simple.Types (Binary(..), In(..), Null)+import System.Locale (defaultTimeLocale)+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8+import qualified Data.ByteString as SB+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text as ST+import qualified Data.Text.Encoding as ST+import qualified Data.Text.Lazy as LT+import qualified Database.PostgreSQL.LibPQ as PQ++-- | How to render an element when substituting it into a query.+data Action =+ Plain Builder+ -- ^ Render without escaping or quoting. Use for non-text types+ -- such as numbers, when you are /certain/ that they will not+ -- introduce formatting vulnerabilities via use of characters such+ -- as spaces or \"@'@\".+ | Escape ByteString+ -- ^ Escape and enclose in quotes before substituting. Use for all+ -- text-like types, and anything else that may contain unsafe+ -- characters when rendered.+ | Many [Action]+ -- ^ Concatenate a series of rendering actions.+ deriving (Typeable)++instance Show Action where+ show (Plain b) = "Plain " ++ show (toByteString b)+ show (Escape b) = "Escape " ++ show b+ show (Many b) = "Many " ++ show b++-- | A type that may be used as a single parameter to a SQL query.+class ToField a where+ toField :: a -> Action+ -- ^ Prepare a value for substitution into a query string.++instance ToField Action where+ toField a = a+ {-# INLINE toField #-}++instance (ToField a) => ToField (Maybe a) where+ toField Nothing = renderNull+ toField (Just a) = toField a+ {-# INLINE toField #-}++instance (ToField a) => ToField (In [a]) where+ toField (In []) = Plain $ fromByteString "(null)"+ toField (In xs) = Many $+ Plain (fromChar '(') :+ (intersperse (Plain (fromChar ',')) . map toField $ xs) +++ [Plain (fromChar ')')]++instance ToField (Binary SB.ByteString) where+ toField (Binary bs) = Plain $ fromByteString "'\\x" `mappend`+ fromByteString (B16.encode bs) `mappend`+ fromChar '\''++instance ToField (Binary LB.ByteString) where+ toField (Binary bs) = Plain $ fromByteString "'\\x" `mappend`+ fromLazyByteString (L16.encode bs) `mappend`+ fromChar '\''++renderNull :: Action+renderNull = Plain (fromByteString "null")++instance ToField Null where+ toField _ = renderNull+ {-# INLINE toField #-}++instance ToField Bool where+ toField True = Plain (fromByteString "true")+ toField False = Plain (fromByteString "false")+ {-# INLINE toField #-}++instance ToField Int8 where+ toField = Plain . integral+ {-# INLINE toField #-}++instance ToField Int16 where+ toField = Plain . integral+ {-# INLINE toField #-}++instance ToField Int32 where+ toField = Plain . integral+ {-# INLINE toField #-}++instance ToField Int where+ toField = Plain . integral+ {-# INLINE toField #-}++instance ToField Int64 where+ toField = Plain . integral+ {-# INLINE toField #-}++instance ToField Integer where+ toField = Plain . integral+ {-# INLINE toField #-}++instance ToField Word8 where+ toField = Plain . integral+ {-# INLINE toField #-}++instance ToField Word16 where+ toField = Plain . integral+ {-# INLINE toField #-}++instance ToField Word32 where+ toField = Plain . integral+ {-# INLINE toField #-}++instance ToField Word where+ toField = Plain . integral+ {-# INLINE toField #-}++instance ToField Word64 where+ toField = Plain . integral+ {-# INLINE toField #-}++instance ToField PQ.Oid where+ toField = Plain . integral . \(PQ.Oid x) -> x+ {-# INLINE toField #-}++instance ToField Float where+ toField v | isNaN v || isInfinite v = Plain (inQuotes (float v))+ | otherwise = Plain (float v)+ {-# INLINE toField #-}++instance ToField Double where+ toField v | isNaN v || isInfinite v = Plain (inQuotes (double v))+ | otherwise = Plain (double v)+ {-# INLINE toField #-}++instance ToField SB.ByteString where+ toField = Escape+ {-# INLINE toField #-}++instance ToField LB.ByteString where+ toField = toField . SB.concat . LB.toChunks+ {-# INLINE toField #-}++instance ToField ST.Text where+ toField = Escape . ST.encodeUtf8+ {-# INLINE toField #-}++instance ToField [Char] where+ toField = Escape . toByteString . Utf8.fromString+ {-# INLINE toField #-}++instance ToField LT.Text where+ toField = toField . LT.toStrict+ {-# INLINE toField #-}++instance ToField UTCTime where+ toField = Plain . Utf8.fromString . formatTime defaultTimeLocale "'%F %T%Q+00'"+ {-# INLINE toField #-}++instance ToField Day where+ toField = Plain . inQuotes . Utf8.fromString . showGregorian+ {-# INLINE toField #-}++instance ToField TimeOfDay where+ toField = Plain . inQuotes . Utf8.fromString . show+ {-# INLINE toField #-}++-- | Surround a string with single-quote characters: \"@'@\"+--+-- This function /does not/ perform any other escaping.+inQuotes :: Builder -> Builder+inQuotes b = quote `mappend` b `mappend` quote+ where quote = Utf8.fromChar '\''
+ src/Database/PostgreSQL/Simple/ToRow.hs view
@@ -0,0 +1,90 @@+------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.QueryParams+-- Copyright: (c) 2011 MailRank, Inc.+-- (c) 2011 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- The 'QueryParams' typeclass, for rendering a collection of+-- parameters to a SQL query.+--+-- Predefined instances are provided for tuples containing up to ten+-- elements.+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.ToRow+ (+ ToRow(..)+ ) where++import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..))+import Database.PostgreSQL.Simple.Types (Only(..))++-- | A collection type that can be turned into a list of rendering+-- 'Action's.+--+-- Instances should use the 'render' method of the 'Param' class+-- to perform conversion of each element of the collection.+class ToRow a where+ toRow :: a -> [Action]+ -- ^ ToField a collection of values.++instance ToRow () where+ toRow _ = []++instance (ToField a) => ToRow (Only a) where+ toRow (Only v) = [toField v]++instance (ToField a, ToField b) => ToRow (a,b) where+ toRow (a,b) = [toField a, toField b]++instance (ToField a, ToField b, ToField c) => ToRow (a,b,c) where+ toRow (a,b,c) = [toField a, toField b, toField c]++instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a,b,c,d) where+ toRow (a,b,c,d) = [toField a, toField b, toField c, toField d]++instance (ToField a, ToField b, ToField c, ToField d, ToField e)+ => ToRow (a,b,c,d,e) where+ toRow (a,b,c,d,e) =+ [toField a, toField b, toField c, toField d, toField e]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f)+ => ToRow (a,b,c,d,e,f) where+ toRow (a,b,c,d,e,f) =+ [toField a, toField b, toField c, toField d, toField e, toField f]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g)+ => ToRow (a,b,c,d,e,f,g) where+ toRow (a,b,c,d,e,f,g) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h)+ => ToRow (a,b,c,d,e,f,g,h) where+ toRow (a,b,c,d,e,f,g,h) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i)+ => ToRow (a,b,c,d,e,f,g,h,i) where+ toRow (a,b,c,d,e,f,g,h,i) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i]++instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f,+ ToField g, ToField h, ToField i, ToField j)+ => ToRow (a,b,c,d,e,f,g,h,i,j) where+ toRow (a,b,c,d,e,f,g,h,i,j) =+ [toField a, toField b, toField c, toField d, toField e, toField f,+ toField g, toField h, toField i, toField j]++instance (ToField a) => ToRow [a] where+ toRow = map toField
src/Database/PostgreSQL/Simple/Types.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-} +------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Types -- Copyright: (c) 2011 MailRank, Inc.@@ -10,6 +11,8 @@ -- Portability: portable -- -- Basic types.+--+------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Types (@@ -19,6 +22,7 @@ , Binary(..) , Query(..) , Oid(..)+ , (:.)(..) ) where import Blaze.ByteString.Builder (toByteString)@@ -106,3 +110,23 @@ -- | Wrap a mostly-binary string to be escaped in hexadecimal. newtype Binary a = Binary a deriving (Eq, Ord, Read, Show, Typeable, Functor)++-- | A composite type to parse your custom data structures without+-- having to define dummy newtype wrappers every time.+--+--+-- > instance FromRow MyData where ...+--+-- > instance FromRow MyData2 where ...+--+--+-- then I can do the following for free:+--+-- @+-- res <- query' c "..."+-- forM res $ \\(MyData{..} :. MyData2{..}) -> do+-- ....+-- @+data h :. t = h :. t deriving (Eq,Ord,Show,Read,Typeable)++infixr 3 :.