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.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 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 @@ -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 --- 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: diff --git a/src/Database/PostgreSQL/Simple/Compat.hs b/src/Database/PostgreSQL/Simple/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Compat.hs @@ -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 #-} diff --git a/src/Database/PostgreSQL/Simple/Field.hs b/src/Database/PostgreSQL/Simple/Field.hs deleted file mode 100644 --- a/src/Database/PostgreSQL/Simple/Field.hs +++ /dev/null @@ -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) diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -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 +-- 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 diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs b/src/Database/PostgreSQL/Simple/FromRow.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromRow.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE RecordWildCards #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.FromRow +-- Copyright: (c) 2011 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- 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 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 @@ -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) 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 @@ -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 diff --git a/src/Database/PostgreSQL/Simple/Notification.hs b/src/Database/PostgreSQL/Simple/Notification.hs --- a/src/Database/PostgreSQL/Simple/Notification.hs +++ b/src/Database/PostgreSQL/Simple/Notification.hs @@ -29,6 +29,7 @@ , notificationData :: B.ByteString } +errfd :: String errfd = "Database.PostgreSQL.Simple.Notification.getNotification: \ \failed to fetch file descriptor" diff --git a/src/Database/PostgreSQL/Simple/Ok.hs b/src/Database/PostgreSQL/Simple/Ok.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Ok.hs @@ -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. diff --git a/src/Database/PostgreSQL/Simple/Param.hs b/src/Database/PostgreSQL/Simple/Param.hs deleted file mode 100644 --- a/src/Database/PostgreSQL/Simple/Param.hs +++ /dev/null @@ -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 --- 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 '\'' diff --git a/src/Database/PostgreSQL/Simple/QueryParams.hs b/src/Database/PostgreSQL/Simple/QueryParams.hs deleted file mode 100644 --- a/src/Database/PostgreSQL/Simple/QueryParams.hs +++ /dev/null @@ -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 --- 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 diff --git a/src/Database/PostgreSQL/Simple/QueryResults.hs b/src/Database/PostgreSQL/Simple/QueryResults.hs deleted file mode 100644 --- a/src/Database/PostgreSQL/Simple/QueryResults.hs +++ /dev/null @@ -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 --- 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 - diff --git a/src/Database/PostgreSQL/Simple/Result.hs b/src/Database/PostgreSQL/Simple/Result.hs deleted file mode 100644 --- a/src/Database/PostgreSQL/Simple/Result.hs +++ /dev/null @@ -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 --- 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) diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -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 +-- 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 '\'' diff --git a/src/Database/PostgreSQL/Simple/ToRow.hs b/src/Database/PostgreSQL/Simple/ToRow.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/ToRow.hs @@ -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 +-- 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 diff --git a/src/Database/PostgreSQL/Simple/Types.hs b/src/Database/PostgreSQL/Simple/Types.hs --- a/src/Database/PostgreSQL/Simple/Types.hs +++ b/src/Database/PostgreSQL/Simple/Types.hs @@ -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 :.