postgresql-simple (empty) → 0.0
raw patch · 15 files changed
+2519/−0 lines, 15 filesdep +attoparsecdep +basedep +base16-bytestringsetup-changed
Dependencies added: attoparsec, base, base16-bytestring, blaze-builder, blaze-textual, bytestring, containers, old-locale, pcre-light, postgresql-libpq, template-haskell, text, time
Files
- LICENSE +62/−0
- Setup.hs +2/−0
- postgresql-simple.cabal +56/−0
- src/Database/PostgreSQL/Simple.hs +749/−0
- src/Database/PostgreSQL/Simple/BuiltinTypes.hs +403/−0
- src/Database/PostgreSQL/Simple/Field.hs +15/−0
- src/Database/PostgreSQL/Simple/Internal.hs +172/−0
- src/Database/PostgreSQL/Simple/LargeObjects.hs +47/−0
- src/Database/PostgreSQL/Simple/Notification.hs +81/−0
- src/Database/PostgreSQL/Simple/Param.hs +206/−0
- src/Database/PostgreSQL/Simple/QueryParams.hs +85/−0
- src/Database/PostgreSQL/Simple/QueryResults.hs +222/−0
- src/Database/PostgreSQL/Simple/Result.hs +259/−0
- src/Database/PostgreSQL/Simple/SqlQQ.hs +52/−0
- src/Database/PostgreSQL/Simple/Types.hs +108/−0
+ LICENSE view
@@ -0,0 +1,62 @@+Copyright (c) 2011, Leon P Smith++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Leon P Smith nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++Copyright (c) 2011, MailRank, Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ postgresql-simple.cabal view
@@ -0,0 +1,56 @@+Name: postgresql-simple+Version: 0.0+Synopsis: Mid-Level PostgreSQL client library+Description:+ Mid-Level PostgreSQL client library, forked from mysql-simple.+License: BSD3+License-file: LICENSE+Author: Bryan O'Sullivan, Leon P Smith+Maintainer: Leon P Smith <leon@melding-monads.com>+Copyright: (c) 2011 MailRank, Inc.+ (c) 2011 Leon P Smith+Category: Database+Build-type: Simple++Cabal-version: >=1.6++Library+ hs-source-dirs: src+ Exposed-modules:+ Database.PostgreSQL.Simple+ Database.PostgreSQL.Simple.BuiltinTypes+ Database.PostgreSQL.Simple.Field+ 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.SqlQQ+ Database.PostgreSQL.Simple.Types+-- Other-modules:+ Database.PostgreSQL.Simple.Internal++ Build-depends:+ attoparsec >= 0.8.5.3,+ base < 5,+ base16-bytestring,+ blaze-builder,+ blaze-textual,+ bytestring >= 0.9,+ containers,+ postgresql-libpq >= 0.6,+ pcre-light,+ old-locale,+ template-haskell,+ text >= 0.11.0.2,+ time++source-repository head+ type: git+ location: http://github.com/lpsmith/postgresql-simple++source-repository this+ type: git+ location: http://github.com/lpsmith/postgresql-simple+ tag: v0.0
+ src/Database/PostgreSQL/Simple.hs view
@@ -0,0 +1,749 @@+{-# LANGUAGE BangPatterns, DeriveDataTypeable, OverloadedStrings #-}+{-# LANGUAGE DoAndIfThenElse, RecordWildCards, NamedFieldPuns #-}+------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple+-- Copyright: (c) 2011 MailRank, Inc.+-- (c) 2011 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- A mid-level client library for the PostgreSQL database, aimed at ease of+-- use and high performance.+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple+ (+ -- * Writing queries+ -- $use++ -- ** The Query type+ -- $querytype++ -- ** Parameter substitution+ -- $subst++ -- *** Type inference+ -- $inference++ -- ** Substituting a single parameter+ -- $only_param++ -- ** Representing a list of values+ -- $in++ -- ** Modifying multiple rows at once+ -- $many++ -- * Extracting results+ -- $result++ -- ** Handling null values+ -- $null++ -- ** Type conversions+ -- $types++ -- * Types+ Base.ConnectInfo(..)+ , Connection+ , Query+ , In(..)+ , Binary(..)+ , Only(..)+ -- ** Exceptions+ , FormatError(fmtMessage, fmtQuery, fmtParams)+ , QueryError(qeMessage, qeQuery)+ , ResultError(errSQLType, errHaskellType, errMessage)+ -- * Connection management+ , Base.connect+ , Base.connectPostgreSQL+ , Base.postgreSQLConnectionString+ , Base.defaultConnectInfo+ , Base.close+ -- * Queries that return results+ , query+ , query_+{--+ -- * Queries that stream results+ , fold+ , fold_+ , forEach+ , forEach_+--}+ -- * Statements that do not return results+ , execute+ , execute_+ , executeMany+-- , Base.insertID+ -- * Transaction handling+ , withTransaction+-- , Base.autocommit+ , begin+ , commit+ , rollback+ -- * Helper functions+ , formatMany+ , 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)+import Control.Monad (forM)+import Control.Monad.Fix (fix)+import Data.ByteString (ByteString)+-- import qualified Data.ByteString as B (unpack)+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.MySQL.Base (Connection, Result)+--import Database.MySQL.Base.Types (Field)+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.Result (ResultError(..))+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 qualified Data.ByteString.Char8 as B+--import qualified Database.MySQL.Base as Base++-- | Exception thrown if a 'Query' could not be formatted correctly.+-- This may occur if the number of \'@?@\' characters in the query+-- string does not match the number of parameters provided.+data FormatError = FormatError {+ fmtMessage :: String+ , fmtQuery :: Query+ , fmtParams :: [ByteString]+ } deriving (Eq, Show, Typeable)++instance Exception FormatError++-- | Exception thrown if 'query' is used to perform an @INSERT@-like+-- operation, or 'execute' is used to perform a @SELECT@-like operation.+data QueryError = QueryError {+ qeMessage :: String+ , qeQuery :: Query+ } deriving (Eq, Show, Typeable)++instance Exception QueryError++-- | Format a query string.+--+-- This function is exposed to help with debugging and logging. Do not+-- use it to prepare queries for execution.+--+-- String parameters are escaped according to the character set in use+-- on the 'Connection'.+--+-- Throws 'FormatError' if the query string could not be formatted+-- correctly.+formatQuery :: QueryParams 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++-- | Format a query string with a variable number of rows.+--+-- This function is exposed to help with debugging and logging. Do not+-- use it to prepare queries for execution.+--+-- The query string must contain exactly one substitution group,+-- identified by the SQL keyword \"@VALUES@\" (case insensitive)+-- followed by an \"@(@\" character, a series of one or more \"@?@\"+-- characters separated by commas, and a \"@)@\" character. White+-- space in a substitution group is permitted.+--+-- Throws 'FormatError' if the query string could not be formatted+-- correctly.+formatMany :: (QueryParams 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+ return . toByteString . mconcat $ fromByteString before :+ intersperse (fromChar ',') bs +++ [fromByteString after]+ _ -> error "foo"+ where+ re = compile "^([^?]+\\bvalues\\s*)\+ \(\\(\\s*[?](?:\\s*,\\s*[?])*\\s*\\))\+ \([^?]*)$"+ [caseless]++escapeStringConn conn s = withConnection conn $ \c -> do+ PQ.escapeStringConn c s++buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder+buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs+ where quote = inQuotes . fromByteString . maybe undefined id+ sub (Plain b) = pure b+ sub (Escape s) = quote <$> escapeStringConn conn s+ sub (Many ys) = mconcat <$> mapM sub ys+ split s = fromByteString h : if B.null t then [] else split (B.tail t)+ where (h,t) = B.break (=='?') s+ zipParams (t:ts) (p:ps) = t `mappend` p `mappend` zipParams ts ps+ zipParams [t] [] = t+ zipParams _ _ = fmtError (show (B.count '?' template) +++ " '?' characters, but " +++ show (length xs) ++ " parameters") q xs++-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not+-- expected to return results.+--+-- 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 conn template qs = do+ result <- exec conn =<< formatQuery conn template qs+ finishExecute conn template result++-- | A version of 'execute' that does not perform query substitution.+execute_ :: Connection -> Query -> IO Int64+execute_ conn q@(Query stmt) = do+ result <- exec conn stmt+ finishExecute conn q result++-- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not+-- expected to return results.+--+-- 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 _ _ [] = 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+ status <- PQ.resultStatus result+ case status of+ PQ.CommandOk -> do+ ncols <- PQ.nfields result+ if ncols /= 0+ then throwIO $ QueryError ("execute resulted in " ++ show ncols +++ "-column result") q+ else do+ nstr <- PQ.cmdTuples result+ return $ case nstr of+ Nothing -> 0 -- is this appropriate?+ Just str -> toInteger str+ PQ.TuplesOk -> do+ ncols <- PQ.nfields result+ throwIO $ QueryError ("execute resulted in " ++ show ncols +++ "-column result") q+ 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 [ "execute: ", statusmsg+ , ": ", errormsg ]}+ where+ toInteger str = B.foldl' delta 0 str+ where+ delta acc c =+ if '0' <= c && c <= '9'+ then 10 * acc + fromIntegral (ord c - ord '0')+ else error ("finishExecute: not an int: " ++ B.unpack str)++++-- | Perform a @SELECT@ or other SQL query that is expected to return+-- results. All results are retrieved and converted before this+-- function returns.+--+-- When processing large results, this function will consume a lot of+-- client-side memory. Consider using 'fold' instead.+--+-- Exceptions that may be thrown:+--+-- * 'FormatError': the query string could not be formatted correctly.+--+-- * 'QueryError': the result contains no columns (i.e. you should be+-- using 'execute' instead of 'query').+--+-- * 'ResultError': result conversion failed.+query :: (QueryParams q, QueryResults 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_ conn q@(Query que) = do+ result <- exec conn que+ finishQuery conn q result+{--+-- | Perform a @SELECT@ or other SQL query that is expected to return+-- results. Results are streamed incrementally from the server, and+-- consumed via a left fold.+--+-- The result consumer must be carefully written to execute+-- quickly. If the consumer is slow, server resources will be tied up,+-- and other clients may not be able to update the tables from which+-- the results are being streamed.+--+-- When dealing with small results, it may be simpler (and perhaps+-- faster) to use 'query' instead.+--+-- This fold is /not/ strict. The stream consumer is responsible for+-- forcing the evaluation of its result to avoid space leaks.+--+-- Exceptions that may be thrown:+--+-- * 'FormatError': the query string could not be formatted correctly.+--+-- * 'QueryError': the result contains no columns (i.e. you should be+-- using 'execute' instead of 'query').+--+-- * 'ResultError': result conversion failed.+fold :: (QueryParams q, QueryResults r) =>+ Connection+ -> Query -- ^ Query template.+ -> q -- ^ Query parameters.+ -> a -- ^ Initial state for result consumer.+ -> (a -> r -> IO a) -- ^ Result consumer.+ -> IO a+fold conn template qs z f = do+ Base.query conn =<< formatQuery conn template qs+ finishFold conn template z f+--}+{--+-- | A version of 'fold' that does not perform query substitution.+fold_ :: (QueryResults r) =>+ Connection+ -> Query -- ^ Query.+ -> a -- ^ Initial state for result consumer.+ -> (a -> r -> IO a) -- ^ Result consumer.+ -> IO a+fold_ conn q@(Query que) z f = do+ Base.query conn que+ finishFold conn q z f+--}+{--+-- | A version of 'fold' that does not transform a state value.+forEach :: (QueryParams q, QueryResults r) =>+ Connection+ -> Query -- ^ Query template.+ -> q -- ^ Query parameters.+ -> (r -> IO ()) -- ^ Result consumer.+ -> IO ()+forEach conn template qs = fold conn template qs () . const+{-# INLINE forEach #-}++-- | A version of 'forEach' that does not perform query substitution.+forEach_ :: (QueryResults r) =>+ Connection+ -> Query -- ^ Query template.+ -> (r -> IO ()) -- ^ Result consumer.+ -> IO ()+forEach_ conn template = fold_ conn template () . const+{-# INLINE forEach_ #-}+--}++forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a]+forM' lo hi m = loop hi []+ where+ loop !n !as+ | n < lo = return as+ | otherwise = do+ a <- m n+ loop (n-1) (a:as)++finishQuery :: (QueryResults r) => Connection -> Query -> PQ.Result -> IO [r]+finishQuery conn q result = do+ status <- PQ.resultStatus result+ case status of+ PQ.CommandOk -> do+ 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{..}+ nrows <- PQ.ntuples 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 ]}++{--+withResult (Base.storeResult conn) q $ \r fs -> do+ status <-+/ flip fix [] $ \loop acc -> do+ row <- Base.fetchRow r+ case row of+ [] -> return (reverse acc)+ _ -> let !c = convertResults fs row+ in loop (c:acc)+--}+{--+finishFold :: (QueryResults r) =>+ Connection -> Query -> a -> (a -> r -> IO a) -> IO a+finishFold conn q z0 f = withResult (Base.useResult conn) q $ \r fs ->+ flip fix z0 $ \loop z -> do+ row <- Base.fetchRow r+ case row of+ [] -> return z+ _ -> (f z $! convertResults fs row) >>= loop+--}+{--+withResult :: (IO Result) -> Query -> (Result -> [Field] -> IO a) -> IO a+withResult fetchResult q act = bracket fetchResult Base.freeResult $ \r -> do+ ncols <- Base.fieldCount (Right r)+ if ncols == 0+ then throwIO $ QueryError "query resulted in zero-column result" q+ else act r =<< Base.fetchFields r+--}+-- | Execute an action inside a SQL transaction.+--+-- This function initiates a transaction with a \"@begin+-- transaction@\" statement, then executes the supplied action. If+-- the action succeeds, the transaction will be completed with+-- 'Base.commit' before this function returns.+--+-- If the action throws /any/ kind of exception (not just a+-- PostgreSQL-related exception), the transaction will be rolled back using+-- 'rollback', then the exception will be rethrown.+withTransaction :: Connection -> IO a -> IO a+withTransaction conn act = do+ _ <- begin conn+ r <- act `onException` rollback conn+ commit conn+ return r++-- | Rollback a transaction.+-- rollback :: (MonadCatchIO m,MonadIO m) => Connection -> m ()+rollback :: Connection -> IO ()+rollback conn = do+ _ <- execute_ conn "ABORT"+ return ()++-- | Commit a transaction.+-- commit :: (MonadCatchIO m,MonadIO m) => Connection -> m ()+commit :: Connection -> IO ()+commit conn = do+ _ <- execute_ conn "COMMIT"+ return ()++-- | Begin a transaction.+-- begin :: (MonadCatchIO m,MonadIO m) => Connection -> m ()+begin :: Connection -> IO ()+begin conn = do+ _ <- execute_ conn "BEGIN"+ return ()++fmtError :: String -> Query -> [Action] -> a+fmtError msg q xs = throw FormatError {+ fmtMessage = msg+ , fmtQuery = q+ , fmtParams = map twiddle xs+ }+ where twiddle (Plain b) = toByteString b+ twiddle (Escape s) = s+ twiddle (Many ys) = B.concat (map twiddle ys)++-- $use+--+-- SQL-based applications are somewhat notorious for their+-- susceptibility to attacks through the injection of maliciously+-- crafted data. The primary reason for widespread vulnerability to+-- SQL injections is that many applications are sloppy in handling+-- user data when constructing SQL queries.+--+-- This library provides a 'Query' type and a parameter substitution+-- facility to address both ease of use and security.++-- $querytype+--+-- A 'Query' is a @newtype@-wrapped 'ByteString'. It intentionally+-- exposes a tiny API that is not compatible with the 'ByteString'+-- API; this makes it difficult to construct queries from fragments of+-- strings. The 'query' and 'execute' functions require queries to be+-- of type 'Query'.+--+-- To most easily construct a query, enable GHC's @OverloadedStrings@+-- language extension and write your query as a normal literal string.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- >+-- > import Database.PostgreSQL.Simple+-- >+-- > hello = do+-- > conn <- connect defaultConnectInfo+-- > query conn "select 2 + 2"+--+-- A 'Query' value does not represent the actual query that will be+-- executed, but is a template for constructing the final query.++-- $subst+--+-- Since applications need to be able to construct queries with+-- parameters that change, this library provides a query substitution+-- capability.+--+-- The 'Query' template accepted by 'query' and 'execute' can contain+-- any number of \"@?@\" characters. Both 'query' and 'execute'+-- accept a third argument, typically a tuple. When constructing the+-- real query to execute, these functions replace the first \"@?@\" in+-- the template with the first element of the tuple, the second+-- \"@?@\" with the second element, and so on. If necessary, each+-- tuple element will be quoted and escaped prior to substitution;+-- this defeats the single most common injection vector for malicious+-- data.+--+-- For example, given the following 'Query' template:+--+-- > select * from user where first_name = ? and age > ?+--+-- And a tuple of this form:+--+-- > ("Boris" :: String, 37 :: Int)+--+-- The query to be executed will look like this after substitution:+--+-- > select * from user where first_name = 'Boris' and age > 37+--+-- If there is a mismatch between the number of \"@?@\" characters in+-- your template and the number of elements in your tuple, a+-- 'FormatError' will be thrown.+--+-- Note that the substitution functions do not attempt to parse or+-- validate your query. It's up to you to write syntactically valid+-- SQL, and to ensure that each \"@?@\" in your query template is+-- matched with the right tuple element.++-- $inference+--+-- Automated type inference means that you will often be able to avoid+-- supplying explicit type signatures for the elements of a tuple.+-- However, sometimes the compiler will not be able to infer your+-- types. Consider a care where you write a numeric literal in a+-- parameter tuple:+--+-- > query conn "select ? + ?" (40,2)+--+-- The above query will be rejected by the compiler, because it does+-- not know the specific numeric types of the literals @40@ and @2@.+-- This is easily fixed:+--+-- > query conn "select ? + ?" (40 :: Double, 2 :: Double)+--+-- The same kind of problem can arise with string literals if you have+-- the @OverloadedStrings@ language extension enabled. Again, just+-- use an explicit type signature if this happens.++-- $only_param+--+-- Haskell lacks a single-element tuple type, so if you have just one+-- value you want substituted into a query, what should you do?+--+-- The obvious approach would appear to be something like this:+--+-- > instance (Param a) => QueryParam a where+-- > ...+--+-- Unfortunately, this wreaks havoc with type inference, so we take a+-- different tack. To represent a single value @val@ as a parameter, write+-- a singleton list @[val]@, use 'Just' @val@, or use 'Only' @val@.+--+-- Here's an example using a singleton list:+--+-- > execute conn "insert into users (first_name) values (?)"+-- > ["Nuala"]++-- $in+--+-- Suppose you want to write a query using an @IN@ clause:+--+-- > select * from users where first_name in ('Anna', 'Boris', 'Carla')+--+-- In such cases, it's common for both the elements and length of the+-- list after the @IN@ keyword to vary from query to query.+--+-- To address this case, use the 'In' type wrapper, and use a single+-- \"@?@\" character to represent the list. Omit the parentheses+-- around the list; these will be added for you.+--+-- Here's an example:+--+-- > query conn "select * from users where first_name in ?" $+-- > In ["Anna", "Boris", "Carla"]+--+-- If your 'In'-wrapped list is empty, the string @\"(null)\"@ will be+-- substituted instead, to ensure that your clause remains+-- syntactically valid.++-- $many+--+-- If you know that you have many rows of data to insert into a table,+-- it is much more efficient to perform all the insertions in a single+-- multi-row @INSERT@ statement than individually.+--+-- The 'executeMany' function is intended specifically for helping+-- with multi-row @INSERT@ and @UPDATE@ statements. Its rules for+-- query substitution are different than those for 'execute'.+--+-- What 'executeMany' searches for in your 'Query' template is a+-- single substring of the form:+--+-- > values (?,?,?)+--+-- The rules are as follows:+--+-- * The keyword @VALUES@ is matched case insensitively.+--+-- * There must be no other \"@?@\" characters anywhere in your+-- template.+--+-- * There must one or more \"@?@\" in the parentheses.+--+-- * Extra white space is fine.+--+-- The last argument to 'executeMany' is a list of parameter+-- tuples. These will be substituted into the query where the @(?,?)@+-- string appears, in a form suitable for use in a multi-row @INSERT@+-- or @UPDATE@.+--+-- Here is an example:+--+-- > executeMany conn+-- > "insert into users (first_name,last_name) values (?,?)"+-- > [("Boris","Karloff"),("Ed","Wood")]+--+-- The query that will be executed here will look like this+-- (reformatted for tidiness):+--+-- > insert into users (first_name,last_name) values+-- > ('Boris','Karloff'),('Ed','Wood')++-- $result+--+-- The 'query' and 'query_' functions return a list of values in the+-- 'QueryResults' 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:+--+-- > import qualified Data.Text as Text+-- >+-- > xs <- query_ conn "select name,age from users"+-- > forM_ xs $ \(name,age) ->+-- > putStrLn $ Text.unpack name ++ " is " ++ show (age :: Int)+--+-- Notice two important details about this code:+--+-- * The number of columns we ask for in the query template must+-- exactly match the number of elements we specify in a row of the+-- result tuple. If they do not match, a 'ResultError' exception+-- will be thrown.+--+-- * Sometimes, the compiler needs our help in specifying types. It+-- can infer that @name@ must be a 'Text', due to our use of the+-- @unpack@ function. However, we have to tell it the type of @age@,+-- as it has no other information to determine the exact type.++-- $null+--+-- The type of a result tuple will look something like this:+--+-- > (Text, Int, Int)+--+-- Although SQL can accommodate @NULL@ as a value for any of these+-- types, Haskell cannot. If your result contains columns that may be+-- @NULL@, be sure that you use 'Maybe' in those positions of of your+-- tuple.+--+-- > (Text, Maybe Int, Int)+--+-- If 'query' encounters a @NULL@ in a row where the corresponding+-- Haskell type is not 'Maybe', it will throw a 'ResultError'+-- exception.++-- $only_result+--+-- To specify that a query returns a single-column result, use the+-- 'Only' type.+--+-- > xs <- query_ conn "select id from users"+-- > forM_ xs $ \(Only dbid) -> {- ... -}++-- $types+--+-- Conversion of SQL values to Haskell values is somewhat+-- permissive. Here are the rules.+--+-- * For numeric types, any Haskell type that can accurately represent+-- all values of the given PostgreSQL type is considered \"compatible\".+-- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@+-- column to a Haskell 'Int'. The Haskell 'Float' type can accurately+-- represent a @SMALLINT@, so it is considered compatble with those types.+--+-- * A numeric compatibility check is based only on the type of a+-- column, /not/ on its values. For instance, a PostgreSQL 64-bit+-- @BIGINT@ column will be considered incompatible with a Haskell+-- 'Int16', even if it contains the value @1@.+--+-- * If a numeric incompatibility is found, 'query' will throw a+-- 'ResultError'.+--+-- * The 'String' and 'Text' types are assumed to be encoded as+-- UTF-8. If you use some other encoding, decoding may fail or give+-- wrong results. In such cases, write a @newtype@ wrapper and a+-- custom 'Result' instance to handle your encoding.++getTypename :: Connection -> PQ.Oid -> IO ByteString+getTypename conn@Connection{..} oid =+ case oid2builtin oid of+ Just builtin -> return $! builtin2typname builtin+ Nothing -> modifyMVar connectionObjects $ \oidmap -> do+ case IntMap.lookup (oid2int oid) oidmap of+ Just name -> return (oidmap, name)+ Nothing -> do+ names <- query conn "SELECT typname FROM pg_type WHERE oid=?"+ (Only oid)+ name <- case names of+ [] -> return $ throw SqlError {+ sqlNativeError = -1,+ sqlErrorMsg = "invalid type oid",+ sqlState = ""+ }+ [Only x] -> return x+ _ -> fail "typename query returned more than one result"+ -- oid is a primary key, so the query should+ -- never return more than one result+ return (IntMap.insert (oid2int oid) name oidmap, name)
+ src/Database/PostgreSQL/Simple/BuiltinTypes.hs view
@@ -0,0 +1,403 @@+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}++------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.BuiltinTypes+-- Copyright: (c) 2011 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+--+------------------------------------------------------------------------------++-- Note that this file is generated by tools/GenBuiltinTypes.hs, and should+-- not be edited directly++module Database.PostgreSQL.Simple.BuiltinTypes+ ( BuiltinType (..)+ , builtin2oid+ , oid2builtin+ , builtin2typname+ , oid2typname+ ) where++import Data.Typeable+import Data.ByteString (ByteString)+import qualified Database.PostgreSQL.LibPQ as PQ++data BuiltinType+ = Bool+ | Bytea+ | Char+ | Name+ | Int8+ | Int2+ | Int4+ | Regproc+ | Text+ | Oid+ | Tid+ | Xid+ | Cid+ | Xml+ | Point+ | Lseg+ | Path+ | Box+ | Polygon+ | Line+ | Cidr+ | Float4+ | Float8+ | Abstime+ | Reltime+ | Tinterval+ | Unknown+ | Circle+ | Money+ | Macaddr+ | Inet+ | Bpchar+ | Varchar+ | Date+ | Time+ | Timestamp+ | TimestampWithTimeZone+ | Interval+ | TimeWithTimeZone+ | Bit+ | Varbit+ | Numeric+ | Refcursor+ | Record+ | Void+ deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable)++builtin2oid :: BuiltinType -> PQ.Oid+builtin2oid typ = PQ.Oid $ case typ of+ Bool -> 16+ Bytea -> 17+ Char -> 18+ Name -> 19+ Int8 -> 20+ Int2 -> 21+ Int4 -> 23+ Regproc -> 24+ Text -> 25+ Oid -> 26+ Tid -> 27+ Xid -> 28+ Cid -> 29+ Xml -> 142+ Point -> 600+ Lseg -> 601+ Path -> 602+ Box -> 603+ Polygon -> 604+ Line -> 628+ Cidr -> 650+ Float4 -> 700+ Float8 -> 701+ Abstime -> 702+ Reltime -> 703+ Tinterval -> 704+ Unknown -> 705+ Circle -> 718+ Money -> 790+ Macaddr -> 829+ Inet -> 869+ Bpchar -> 1042+ Varchar -> 1043+ Date -> 1082+ Time -> 1083+ Timestamp -> 1114+ TimestampWithTimeZone -> 1184+ Interval -> 1186+ TimeWithTimeZone -> 1266+ Bit -> 1560+ Varbit -> 1562+ Numeric -> 1700+ Refcursor -> 1790+ Record -> 2249+ Void -> 2278++oid2builtin :: PQ.Oid -> Maybe BuiltinType+oid2builtin (PQ.Oid x) = case x of+ 16 -> Just Bool+ 17 -> Just Bytea+ 18 -> Just Char+ 19 -> Just Name+ 20 -> Just Int8+ 21 -> Just Int2+ 23 -> Just Int4+ 24 -> Just Regproc+ 25 -> Just Text+ 26 -> Just Oid+ 27 -> Just Tid+ 28 -> Just Xid+ 29 -> Just Cid+ 142 -> Just Xml+ 600 -> Just Point+ 601 -> Just Lseg+ 602 -> Just Path+ 603 -> Just Box+ 604 -> Just Polygon+ 628 -> Just Line+ 650 -> Just Cidr+ 700 -> Just Float4+ 701 -> Just Float8+ 702 -> Just Abstime+ 703 -> Just Reltime+ 704 -> Just Tinterval+ 705 -> Just Unknown+ 718 -> Just Circle+ 790 -> Just Money+ 829 -> Just Macaddr+ 869 -> Just Inet+ 1042 -> Just Bpchar+ 1043 -> Just Varchar+ 1082 -> Just Date+ 1083 -> Just Time+ 1114 -> Just Timestamp+ 1184 -> Just TimestampWithTimeZone+ 1186 -> Just Interval+ 1266 -> Just TimeWithTimeZone+ 1560 -> Just Bit+ 1562 -> Just Varbit+ 1700 -> Just Numeric+ 1790 -> Just Refcursor+ 2249 -> Just Record+ 2278 -> Just Void+ _ -> Nothing++builtin2typname :: BuiltinType -> ByteString+builtin2typname typ = case typ of+ Bool -> bool+ Bytea -> bytea+ Char -> char+ Name -> name+ Int8 -> int8+ Int2 -> int2+ Int4 -> int4+ Regproc -> regproc+ Text -> text+ Oid -> oid+ Tid -> tid+ Xid -> xid+ Cid -> cid+ Xml -> xml+ Point -> point+ Lseg -> lseg+ Path -> path+ Box -> box+ Polygon -> polygon+ Line -> line+ Cidr -> cidr+ Float4 -> float4+ Float8 -> float8+ Abstime -> abstime+ Reltime -> reltime+ Tinterval -> tinterval+ Unknown -> unknown+ Circle -> circle+ Money -> money+ Macaddr -> macaddr+ Inet -> inet+ Bpchar -> bpchar+ Varchar -> varchar+ Date -> date+ Time -> time+ Timestamp -> timestamp+ TimestampWithTimeZone -> timestamptz+ Interval -> interval+ TimeWithTimeZone -> timetz+ Bit -> bit+ Varbit -> varbit+ Numeric -> numeric+ Refcursor -> refcursor+ Record -> record+ Void -> void++oid2typname :: PQ.Oid -> Maybe ByteString+oid2typname (PQ.Oid x) = case x of+ 16 -> Just bool+ 17 -> Just bytea+ 18 -> Just char+ 19 -> Just name+ 20 -> Just int8+ 21 -> Just int2+ 23 -> Just int4+ 24 -> Just regproc+ 25 -> Just text+ 26 -> Just oid+ 27 -> Just tid+ 28 -> Just xid+ 29 -> Just cid+ 142 -> Just xml+ 600 -> Just point+ 601 -> Just lseg+ 602 -> Just path+ 603 -> Just box+ 604 -> Just polygon+ 628 -> Just line+ 650 -> Just cidr+ 700 -> Just float4+ 701 -> Just float8+ 702 -> Just abstime+ 703 -> Just reltime+ 704 -> Just tinterval+ 705 -> Just unknown+ 718 -> Just circle+ 790 -> Just money+ 829 -> Just macaddr+ 869 -> Just inet+ 1042 -> Just bpchar+ 1043 -> Just varchar+ 1082 -> Just date+ 1083 -> Just time+ 1114 -> Just timestamp+ 1184 -> Just timestamptz+ 1186 -> Just interval+ 1266 -> Just timetz+ 1560 -> Just bit+ 1562 -> Just varbit+ 1700 -> Just numeric+ 1790 -> Just refcursor+ 2249 -> Just record+ 2278 -> Just void+ _ -> Nothing++bool :: ByteString+bool = "bool"++bytea :: ByteString+bytea = "bytea"++char :: ByteString+char = "char"++name :: ByteString+name = "name"++int8 :: ByteString+int8 = "int8"++int2 :: ByteString+int2 = "int2"++int4 :: ByteString+int4 = "int4"++regproc :: ByteString+regproc = "regproc"++text :: ByteString+text = "text"++oid :: ByteString+oid = "oid"++tid :: ByteString+tid = "tid"++xid :: ByteString+xid = "xid"++cid :: ByteString+cid = "cid"++xml :: ByteString+xml = "xml"++point :: ByteString+point = "point"++lseg :: ByteString+lseg = "lseg"++path :: ByteString+path = "path"++box :: ByteString+box = "box"++polygon :: ByteString+polygon = "polygon"++line :: ByteString+line = "line"++cidr :: ByteString+cidr = "cidr"++float4 :: ByteString+float4 = "float4"++float8 :: ByteString+float8 = "float8"++abstime :: ByteString+abstime = "abstime"++reltime :: ByteString+reltime = "reltime"++tinterval :: ByteString+tinterval = "tinterval"++unknown :: ByteString+unknown = "unknown"++circle :: ByteString+circle = "circle"++money :: ByteString+money = "money"++macaddr :: ByteString+macaddr = "macaddr"++inet :: ByteString+inet = "inet"++bpchar :: ByteString+bpchar = "bpchar"++varchar :: ByteString+varchar = "varchar"++date :: ByteString+date = "date"++time :: ByteString+time = "time"++timestamp :: ByteString+timestamp = "timestamp"++timestamptz :: ByteString+timestamptz = "timestamptz"++interval :: ByteString+interval = "interval"++timetz :: ByteString+timetz = "timetz"++bit :: ByteString+bit = "bit"++varbit :: ByteString+varbit = "varbit"++numeric :: ByteString+numeric = "numeric"++refcursor :: ByteString+refcursor = "refcursor"++record :: ByteString+record = "record"++void :: ByteString+void = "void"
+ src/Database/PostgreSQL/Simple/Field.hs view
@@ -0,0 +1,15 @@+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/Internal.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE OverloadedStrings, NamedFieldPuns, RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable #-}+module Database.PostgreSQL.Simple.Internal where++import Prelude hiding (catch)++import Control.Applicative+import Control.Exception+import Control.Concurrent.MVar+import Data.ByteString(ByteString)+import qualified Data.IntMap as IntMap+import Data.String+import Data.Typeable+import Data.Word+import Database.PostgreSQL.LibPQ(Oid(..))+import qualified Database.PostgreSQL.LibPQ as PQ+import Database.PostgreSQL.Simple.BuiltinTypes (BuiltinType)+import System.IO.Unsafe (unsafePerformIO)++-- | A Field represents metadata about a particular field+--+-- You don't particularly want to retain these structures for a long+-- period of time, as they will retain the entire query result, not+-- just the field metadata++data Field = Field {+ result :: PQ.Result+ , column :: PQ.Column+ , typename :: ByteString+ }++name :: Field -> Maybe ByteString+name Field{..} = unsafePerformIO (PQ.fname result column)++tableOid :: Field -> PQ.Oid+tableOid Field{..} = unsafePerformIO (PQ.ftable result column)++tableColumn :: Field -> Int+tableColumn Field{..} = fromCol (unsafePerformIO (PQ.ftablecol result column))+ where+ fromCol (PQ.Col x) = fromIntegral x+++format :: Field -> PQ.Format+format Field{..} = unsafePerformIO (PQ.fformat result column)++typeOid :: Field -> PQ.Oid+typeOid Field{..} = unsafePerformIO (PQ.ftype result column)+++data Connection = Connection {+ connectionHandle :: MVar (Maybe PQ.Connection)+ , connectionObjects :: MVar (IntMap.IntMap ByteString)+ }++data SqlType+ = Builtin BuiltinType+ | Other Oid++data SqlError = SqlError {+ sqlState :: ByteString+ , sqlNativeError :: Int+ , sqlErrorMsg :: ByteString+ } deriving (Show, Typeable)++instance Exception SqlError++data ConnectInfo = ConnectInfo {+ connectHost :: String+ , connectPort :: Word16+ , connectUser :: String+ , connectPassword :: String+ , connectDatabase :: String+ } deriving (Eq,Read,Show,Typeable)++defaultConnectInfo :: ConnectInfo+defaultConnectInfo = ConnectInfo {+ connectHost = "127.0.0.1"+ , connectPort = 5432+ , connectUser = "postgres"+ , connectPassword = ""+ , connectDatabase = ""+ }++-- | Connect with the given username to the given database. Will throw+-- an exception if it cannot connect.+connect :: ConnectInfo -> IO Connection+connect = connectPostgreSQL . postgreSQLConnectionString++connectPostgreSQL :: ByteString -> IO Connection+connectPostgreSQL connstr = do+ conn <- PQ.connectdb connstr+ connectionHandle <- newMVar (Just conn)+ connectionObjects <- newMVar (IntMap.empty)+ return Connection{..}++postgreSQLConnectionString :: ConnectInfo -> ByteString+postgreSQLConnectionString connectInfo = fromString connstr+ where+ connstr = str "host=" connectHost+ $ num "port=" connectPort+ $ str "user=" connectUser+ $ str "password=" connectPassword+ $ str "dbname=" connectDatabase+ $ []++ str name field+ | null value = id+ | otherwise = (name ++) . quote value . space+ where value = field connectInfo++ num name field+ | value <= 0 = id+ | otherwise = (name ++) . (show value ++) . space+ where value = field connectInfo++ quote str rest = '\'' : foldr delta ('\'' : rest) str+ where+ delta c cs = case c of+ '\\' -> '\\' : '\\' : cs+ '\'' -> '\\' : '\'' : cs+ _ -> c : cs++ space [] = []+ space xs = ' ':xs++++oid2int :: Oid -> Int+oid2int (Oid x) = fromIntegral x+{-# INLINE oid2int #-}++exec :: Connection+ -> ByteString+ -> IO PQ.Result+exec conn sql =+ withConnection conn $ \h -> do+ mres <- PQ.exec h sql+ case mres of+ Nothing -> do+ msg <- maybe "execute error" id <$> PQ.errorMessage h+ throwIO $ SqlError { sqlNativeError = -1 -- FIXME?+ , sqlErrorMsg = msg+ , sqlState = "" }+ Just res -> do+ return res++disconnectedError = SqlError {+ sqlNativeError = -1,+ sqlErrorMsg = "connection disconnected",+ sqlState = ""+ }+++-- | Atomically perform an action with the database handle, if there is one.+withConnection :: Connection -> (PQ.Connection -> IO a) -> IO a+withConnection Connection{..} m = do+ withMVar connectionHandle $ \h -> do+ case h of+ Just h -> m h+ -- TODO: Use extensible exceptions.+ Nothing -> throwIO disconnectedError++close :: Connection -> IO ()+close Connection{..} = do+ mconn <- takeMVar connectionHandle+ case mconn of+ Just conn -> PQ.finish conn+ Nothing -> return ()+ `finally` putMVar connectionHandle Nothing++data RawResult = RawResult { rawField :: Field, rawData :: Maybe ByteString }
+ src/Database/PostgreSQL/Simple/LargeObjects.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module : Database.PostgreSQL.Simple.LargeObjects+-- Copyright : (c) 2011 Leon P Smith+-- License : BSD3+--+-- Maintainer : leon@melding-monads.com+--+-----------------------------------------------------------------------------++module Database.PostgreSQL.Simple.LargeObjects+ ( loImport+ , loExport+ , Oid(..)+ ) where++import Control.Applicative ((<$>))+import Control.Exception (throwIO)+import Database.PostgreSQL.LibPQ (Oid(..))+import qualified Database.PostgreSQL.LibPQ as PQ+import Database.PostgreSQL.Simple.Internal+import Foreign.C.Types(CInt)++loImport :: Connection -> FilePath -> IO Oid+loImport conn path = withConnection conn $ \c -> do+ res <- PQ.loImport c path+ case res of+ Nothing -> do+ msg <- maybe "loImport error" id <$> PQ.errorMessage c+ throwIO $ SqlError { sqlNativeError = -1 -- FIXME?+ , sqlErrorMsg = msg+ , sqlState = "" }+ Just x -> return x+++loExport :: Connection -> Oid -> FilePath -> IO ()+loExport conn oid path = withConnection conn $ \c -> do+ res <- PQ.loExport c oid path+ case res of+ Nothing -> do+ msg <- maybe "loExport error" id <$> PQ.errorMessage c+ throwIO $ SqlError { sqlNativeError = -1 -- FIXME?+ , sqlErrorMsg = msg+ , sqlState = "" }+ Just x -> return x
+ src/Database/PostgreSQL/Simple/Notification.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}++-----------------------------------------------------------------------------+-- |+-- Module : Database.PostgreSQL.Simple.Notification+-- Copyright : (c) 2011 Leon P Smith+-- License : BSD3+--+-- Maintainer : leon@melding-monads.com+-- Stability : experimental+--+-----------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Notification+ ( Notification(..)+ , getNotification+ ) where++import Control.Concurrent ( threadWaitRead )+import Control.Concurrent.MVar ( takeMVar, putMVar )+import qualified Data.ByteString as B+import Database.PostgreSQL.Simple.Internal+import qualified Database.PostgreSQL.LibPQ as PQ+import System.Posix.Types ( CPid )++data Notification = Notification+ { notificationPid :: CPid+ , notificationChannel :: B.ByteString+ , notificationData :: B.ByteString+ }++errfd = "Database.PostgreSQL.Simple.Notification.getNotification: \+ \failed to fetch file descriptor"+errconn = "Database.PostgreSQL.Simple.Notification.getNotification: \+ \not connected"++lockConn :: Connection -> IO (PQ.Connection)+lockConn Connection{..} = do+ mconn <- takeMVar connectionHandle+ case mconn of+ Nothing -> do+ putMVar connectionHandle mconn+ fail errconn+ Just conn -> return conn++unlockConn :: Connection -> PQ.Connection -> IO ()+unlockConn Connection{..} c = putMVar connectionHandle (Just c)++getNotification :: Connection -> IO Notification+getNotification conn = do+ c <- lockConn conn+ loop conn c+ where+ -- now, I believe the only ways that this code throws an exception is:+ -- 1. lockConn/unlockConn when we are blocked on a GC'd MVar+ -- 2. threadWaitRead when closeFdWith gets called+ -- 3. and if we raise it ourself+ -- If 1 happens, then it doesn't matter if the MVar is locked or not,+ -- and if 2 or 3 happens then the connection should be unlocked.+ --+ -- Note, however, that this function is not safe from asynchronous+ -- exceptions, which probably ought to be fixed.+ loop conn c = do+ mmsg <- PQ.notifies c+ case mmsg of+ Nothing -> do+ mfd <- PQ.socket c+ unlockConn conn c+ case mfd of+ Nothing -> fail errfd+ Just fd -> do+ threadWaitRead fd+ c <- lockConn conn+ _ <- PQ.consumeInput c+ -- FIXME? error handling+ loop conn c+ Just PQ.Notify{..} -> do+ unlockConn conn c+ return Notification { notificationPid = notifyBePid+ , notificationChannel = notifyRelname+ , notificationData = notifyExtra }
+ src/Database/PostgreSQL/Simple/Param.hs view
@@ -0,0 +1,206 @@+{-# 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 = renderNull+ | otherwise = Plain (float v)+ {-# INLINE render #-}++instance Param Double where+ render v | isNaN v || isInfinite v = renderNull+ | 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 view
@@ -0,0 +1,85 @@+-- |+-- 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 view
@@ -0,0 +1,222 @@+{-# 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.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(..))++-- | 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] = (a,b)+-- where !a = 'convert' fa va+-- !b = 'convert' fb vb+-- 'convertResults' fs vs = 'convertError' fs vs 2+-- @+--+-- Notice that this instance evaluates each element to WHNF before+-- constructing the pair. By doing this, we guarantee two important+-- properties:+--+-- * Keep resource usage under control by preventing the construction+-- of potentially long-lived thunks.+--+-- * Ensure that any 'ResultError' that might arise is thrown+-- immediately, rather than some place later in application code+-- that cannot handle it.+--+-- You can also declare Haskell types of your own to be instances of+-- 'QueryResults'.+--+-- @+--data User { firstName :: String, lastName :: String }+--+--instance 'QueryResults' User where+-- 'convertResults' [fa,fb] [va,vb] = User a b+-- where !a = 'convert' fa va+-- !b = 'convert' fb vb+-- 'convertResults' fs vs = 'convertError' fs vs+-- @++class QueryResults a where+ convertResults :: [Field] -> [Maybe ByteString] -> Either SomeException a+ -- ^ Convert values from a row into a Haskell collection.+ --+ -- This function will throw 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++-- | 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 view
@@ -0,0 +1,259 @@+{-# 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(..)+ ) 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(..))+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++left :: Exception a => a -> Either SomeException 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 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 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+ -> Either SomeException (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) 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')+{- | isText f = doConvert f okText $ (Right . ST.decodeUtf8)+ | otherwise = incompatible f (typeOf ST.empty)+ "attempt to mix binary and text" -}+ -- 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 = doConvert f ok $ \bs ->+ case parseTime defaultTimeLocale "%F %T%Q%z" (B8.unpack bs ++ "00") of+ Just t -> Right t+ Nothing -> returnError ConversionFailed f "could not parse"+ where ok = mkCompats [TimestampWithTimeZone]+{--+instance Result Day where+ convert f = flip (atto ok) f $ case fieldType f of+ Year -> year+ _ -> date+ where ok = mkCompats [Year,Date,NewDate]+ year = fromGregorian <$> decimal <*> pure 1 <*> pure 1+ date = fromGregorian <$> (decimal <* char '-')+ <*> (decimal <* char '-')+ <*> decimal++instance Result TimeOfDay where+ convert f = flip (atto ok) f $ do+ hours <- decimal <* char ':'+ mins <- decimal <* char ':'+ secs <- decimal :: Parser Int+ case makeTimeOfDayValid hours mins (fromIntegral secs) of+ Just t -> return t+ _ -> conversionFailed f "TimeOfDay" "could not parse"+ where ok = mkCompats [Time]++isText :: Field -> Bool+isText f = fieldCharSet f /= 63+--}+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 -> Either SomeException a)+ -> Maybe ByteString -> Either SomeException 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 ""+++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+ -> Either SomeException a+atto types p0 f dat = doConvert f types (go p0) dat+ where+ go :: Parser a -> ByteString -> Either SomeException a+ go p s =+ case parseOnly p s of+ Left err -> returnError ConversionFailed f err+ Right v -> Right v++instance Result RawResult where+ convert field rawData = Right (RawResult field rawData)
+ src/Database/PostgreSQL/Simple/SqlQQ.hs view
@@ -0,0 +1,52 @@+------------------------------------------------------------------------------+-- |+-- Module: Database.PostgreSQL.Simple.SqlQQ+-- Copyright: (c) 2011 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+--+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.SqlQQ (sql) where++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Data.Char++-- | 'sql' is a quasiquoter that eases the syntactic burden+-- of writing big sql statements in Haskell source code. It attempts+-- to minimize whitespace. Note that this implementation is incomplete+-- and can mess up your syntax; it only really understands standard+-- sql string literals (default in PostgreSQL 9) and not the extended+-- escape syntax or other situations where white space should be+-- preserved as is.++sql :: QuasiQuoter+sql = QuasiQuoter+ { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\+ \ quasiquoter used in pattern context"+ , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\+ \ quasiquoter used in type context"+ , quoteExp = sqlExp+ , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\+ \ quasiquoter used in declaration context"+ }++sqlExp :: String -> Q Exp+sqlExp = stringE . outstring . dropSpace+ where+ dropSpace = dropWhile isSpace++ outstring ('\'':xs) = '\'' : instring xs+ outstring (x:xs) | isSpace x = case dropSpace xs of+ [] -> []+ ys -> ' ' : outstring ys+ | otherwise = x : outstring xs+ outstring [] = []++ instring ('\'':'\'':xs) = '\'':'\'': instring xs+ instring ('\'':xs) = '\'': outstring xs+ instring (x:xs) = x : instring xs+ instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\+ \ string literal not terminated"
+ src/Database/PostgreSQL/Simple/Types.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}++-- |+-- Module: Database.PostgreSQL.Simple.Types+-- Copyright: (c) 2011 MailRank, Inc.+-- (c) 2011 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+-- Portability: portable+--+-- Basic types.++module Database.PostgreSQL.Simple.Types+ (+ Null(..)+ , Only(..)+ , In(..)+ , Binary(..)+ , Query(..)+ , Oid(..)+ ) where++import Blaze.ByteString.Builder (toByteString)+import Control.Arrow (first)+import Data.ByteString (ByteString)+import Data.Monoid (Monoid(..))+import Data.String (IsString(..))+import Data.Typeable (Typeable)+import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8+import qualified Data.ByteString as B+import Database.PostgreSQL.LibPQ (Oid(..))++-- | A placeholder for the SQL @NULL@ value.+data Null = Null+ deriving (Read, Show, Typeable)++instance Eq Null where+ _ == _ = False+ _ /= _ = False++-- | A query string. This type is intended to make it difficult to+-- construct a SQL query by concatenating string fragments, as that is+-- an extremely common way to accidentally introduce SQL injection+-- vulnerabilities into an application.+--+-- This type is an instance of 'IsString', so the easiest way to+-- construct a query is to enable the @OverloadedStrings@ language+-- extension and then simply write the query in double quotes.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- >+-- > import Database.PostgreSQL.Simple+-- >+-- > q :: Query+-- > q = "select ?"+--+-- The underlying type is a 'ByteString', and literal Haskell strings+-- that contain Unicode characters will be correctly transformed to+-- UTF-8.+newtype Query = Query {+ fromQuery :: ByteString+ } deriving (Eq, Ord, Typeable)++instance Show Query where+ show = show . fromQuery++instance Read Query where+ readsPrec i = fmap (first Query) . readsPrec i++instance IsString Query where+ fromString = Query . toByteString . Utf8.fromString++instance Monoid Query where+ mempty = Query B.empty+ mappend (Query a) (Query b) = Query (B.append a b)+ {-# INLINE mappend #-}++-- | A single-value \"collection\".+--+-- This is useful if you need to supply a single parameter to a SQL+-- query, or extract a single column from a SQL result.+--+-- Parameter example:+--+-- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@+--+-- Result example:+--+-- @xs <- query_ c \"select id from users\"+--forM_ xs $ \\('Only' id) -> {- ... -}@+newtype Only a = Only {+ fromOnly :: a+ } deriving (Eq, Ord, Read, Show, Typeable, Functor)++-- | Wrap a list of values for use in an @IN@ clause. Replaces a+-- single \"@?@\" character with a parenthesized list of rendered+-- values.+--+-- Example:+--+-- > query c "select * from whatever where id in ?" (In [3,4,5])+newtype In a = In a+ deriving (Eq, Ord, Read, Show, Typeable, Functor)++-- | Wrap a mostly-binary string to be escaped in hexadecimal.+newtype Binary a = Binary a+ deriving (Eq, Ord, Read, Show, Typeable, Functor)