postgresql-simple-0.3.4.0/0000755000000000000000000000000012173400557013540 5ustar0000000000000000postgresql-simple-0.3.4.0/LICENSE0000644000000000000000000000565312173400557014556 0ustar0000000000000000Copyright (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. postgresql-simple-0.3.4.0/CONTRIBUTORS0000644000000000000000000000072012173400557015417 0ustar0000000000000000Bryan O'Sullivan Leon P Smith Felipe Lessa Ozgun Ataman Joey Adams Rekado Leonid Onokhov Bas van Dijk Jason Dusek Jeff Chu Oliver Charles Simon Meier Alexey Uimanov postgresql-simple-0.3.4.0/postgresql-simple.cabal0000644000000000000000000000600312173400557020215 0ustar0000000000000000Name: postgresql-simple Version: 0.3.4.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 Copyright: (c) 2011 MailRank, Inc. (c) 2011-2013 Leon P Smith Category: Database Build-type: Simple Cabal-version: >= 1.9.2 extra-source-files: CONTRIBUTORS Library hs-source-dirs: src Exposed-modules: Database.PostgreSQL.Simple Database.PostgreSQL.Simple.Arrays Database.PostgreSQL.Simple.BuiltinTypes Database.PostgreSQL.Simple.Copy Database.PostgreSQL.Simple.FromField Database.PostgreSQL.Simple.FromRow Database.PostgreSQL.Simple.LargeObjects Database.PostgreSQL.Simple.HStore Database.PostgreSQL.Simple.HStore.Internal Database.PostgreSQL.Simple.Notification Database.PostgreSQL.Simple.Ok Database.PostgreSQL.Simple.SqlQQ Database.PostgreSQL.Simple.Time Database.PostgreSQL.Simple.Time.Internal Database.PostgreSQL.Simple.ToField Database.PostgreSQL.Simple.ToRow Database.PostgreSQL.Simple.Transaction Database.PostgreSQL.Simple.TypeInfo Database.PostgreSQL.Simple.TypeInfo.Static Database.PostgreSQL.Simple.Types Database.PostgreSQL.Simple.Errors -- Other-modules: Database.PostgreSQL.Simple.Internal Other-modules: Database.PostgreSQL.Simple.Compat Database.PostgreSQL.Simple.HStore.Implementation Database.PostgreSQL.Simple.Time.Implementation Database.PostgreSQL.Simple.TypeInfo.Types Build-depends: attoparsec >= 0.10.3, base < 5, blaze-builder, blaze-textual, bytestring >= 0.9, containers, postgresql-libpq >= 0.6.2, template-haskell, text >= 0.11.1, 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 source-repository this type: git location: http://github.com/lpsmith/postgresql-simple tag: v0.3.4.0 test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Main.hs other-modules: Common Notify Serializable Time Build-depends: vector ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind extensions: NamedFieldPuns , OverloadedStrings , Rank2Types , RecordWildCards , PatternGuards , ScopedTypeVariables build-depends: base , base16-bytestring , bytestring , containers , cryptohash , HUnit , postgresql-simple , text , time postgresql-simple-0.3.4.0/Setup.hs0000644000000000000000000000005612173400557015175 0ustar0000000000000000import Distribution.Simple main = defaultMain postgresql-simple-0.3.4.0/src/0000755000000000000000000000000012173400557014327 5ustar0000000000000000postgresql-simple-0.3.4.0/src/Database/0000755000000000000000000000000012173400557016033 5ustar0000000000000000postgresql-simple-0.3.4.0/src/Database/PostgreSQL/0000755000000000000000000000000012173400557020036 5ustar0000000000000000postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple.hs-boot0000644000000000000000000000115712173400557022570 0ustar0000000000000000module Database.PostgreSQL.Simple ( Connection , Query , query , query_ , execute , execute_ , executeMany ) where import Data.Int(Int64) import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import {-# SOURCE #-} Database.PostgreSQL.Simple.FromRow import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] query_ :: FromRow r => Connection -> Query -> IO [r] execute :: ToRow q => Connection -> Query -> q -> IO Int64 executeMany :: ToRow q => Connection -> Query -> [q] -> IO Int64 postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple.hs0000644000000000000000000007633212173400557021636 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- 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 -- ** @RETURNING@: modifications that returns results -- $returning -- * Extracting results -- $result -- ** Handling null values -- $null -- ** Type conversions -- $types -- * Types Base.ConnectInfo(..) , Connection , Query , ToRow , FromRow , In(..) , Binary(..) , Only(..) , (:.)(..) -- ** Exceptions , SqlError(..) , PQ.ExecStatus(..) , 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 , FoldOptions(..) , FetchQuantity(..) , defaultFoldOptions , fold , foldWithOptions , fold_ , foldWithOptions_ , forEach , forEach_ , returning -- * Statements that do not return results , execute , execute_ , executeMany -- , Base.insertID -- * Transaction handling , withTransaction , withSavepoint -- , Base.autocommit , begin , commit , rollback -- * Helper functions , formatMany , formatQuery ) where import Blaze.ByteString.Builder ( Builder, fromByteString, toByteString ) import Blaze.ByteString.Builder.Char8 (fromChar) import Blaze.Text ( integral ) import Control.Applicative ((<$>), pure) import Control.Exception as E import Control.Monad (foldM) import Data.ByteString (ByteString) import Data.Int (Int64) import Data.List (intersperse) import Data.Monoid (mconcat) import Data.Typeable (Typeable) import Database.PostgreSQL.Simple.Compat ( (<>) ) 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 Database.PostgreSQL.Simple.Transaction import Database.PostgreSQL.Simple.TypeInfo import qualified Database.PostgreSQL.LibPQ as PQ import qualified Data.ByteString.Char8 as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE import 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 -- 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 -- | 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 :: 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 = toRow 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 :: (ToRow q) => Connection -> Query -> [q] -> IO ByteString formatMany _ q [] = fmtError "no rows supplied" q [] formatMany conn q@(Query template) qs = do case parseTemplate template of Just (before, qbits, after) -> do bs <- mapM (buildQuery conn q qbits . toRow) qs return . toByteString . mconcat $ fromByteString before : intersperse (fromChar ',') bs ++ [fromByteString after] Nothing -> fmtError "syntax error in multi-row template" q [] -- Split the input string into three pieces, @before@, @qbits@, and @after@, -- following this grammar: -- -- start: ^ before qbits after $ -- before: ([^?]* [^?\w])? 'VALUES' \s* -- qbits: '(' \s* '?' \s* (',' \s* '?' \s*)* ')' -- after: [^?]* -- -- \s: [ \t\n\r\f] -- \w: [A-Z] | [a-z] | [\x80-\xFF] | '_' | '$' | [0-9] -- -- This would be much more concise with some sort of regex engine. -- 'formatMany' used to use pcre-light instead of this hand-written parser, -- but pcre is a hassle to install on Windows. parseTemplate :: ByteString -> Maybe (ByteString, ByteString, ByteString) parseTemplate template = -- Convert input string to uppercase, to facilitate searching. search $ B.map toUpper_ascii template where -- Search for the next occurrence of "VALUES" search bs = case B.breakSubstring "VALUES" bs of (x, y) -- If "VALUES" is not present in the string, or any '?' characters -- were encountered prior to it, fail. | B.null y || ('?' `B.elem` x) -> Nothing -- If "VALUES" is preceded by an identifier character (a.k.a. \w), -- try the next occurrence. | not (B.null x) && isIdent (B.last x) -> search $ B.drop 6 y -- Otherwise, we have a legitimate "VALUES" token. | otherwise -> parseQueryBits $ skipSpace $ B.drop 6 y -- Parse '(' \s* '?' \s* . If this doesn't match -- (and we don't consume a '?'), look for another "VALUES". -- -- qb points to the open paren (if present), meaning it points to the -- beginning of the "qbits" production described above. This is why we -- pass it down to finishQueryBits. parseQueryBits qb | Just ('(', skipSpace -> bs1) <- B.uncons qb , Just ('?', skipSpace -> bs2) <- B.uncons bs1 = finishQueryBits qb bs2 | otherwise = search qb -- Parse (',' \s* '?' \s*)* ')' [^?]* . -- -- Since we've already consumed at least one '?', there's no turning back. -- The parse has to succeed here, or the whole thing fails -- (because we don't allow '?' to appear outside of the VALUES list). finishQueryBits qb bs0 | Just (')', bs1) <- B.uncons bs0 = if '?' `B.elem` bs1 then Nothing else Just $ slice3 template qb bs1 | Just (',', skipSpace -> bs1) <- B.uncons bs0 , Just ('?', skipSpace -> bs2) <- B.uncons bs1 = finishQueryBits qb bs2 | otherwise = Nothing -- Slice a string into three pieces, given the start offset of the second -- and third pieces. Each "offset" is actually a tail of the uppercase -- version of the template string. Its length is used to infer the offset. -- -- It is important to note that we only slice the original template. -- We don't want our all-caps trick messing up the actual query string. slice3 source p1 p2 = (s1, s2, source'') where (s1, source') = B.splitAt (B.length source - B.length p1) source (s2, source'') = B.splitAt (B.length p1 - B.length p2) source' toUpper_ascii c | c >= 'a' && c <= 'z' = toEnum (fromEnum c - 32) | otherwise = c -- Based on the definition of {ident_cont} in src/backend/parser/scan.l -- in the PostgreSQL source. No need to check [a-z], since we converted -- the whole string to uppercase. isIdent c = (c >= '0' && c <= '9') || (c >= 'A' && c <= 'Z') || (c >= '\x80' && c <= '\xFF') || c == '_' || c == '$' -- Based on {space} in scan.l isSpace_ascii c = (c == ' ') || (c >= '\t' && c <= '\r') skipSpace = B.dropWhile isSpace_ascii escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString) escapeStringConn conn s = withConnection conn $ \c -> PQ.escapeStringConn c s >>= checkError c escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString) escapeByteaConn conn s = withConnection conn $ \c -> PQ.escapeByteaConn c s >>= checkError c checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a) checkError _ (Just x) = return $ Right x checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs where quote = either (\msg -> fmtError (utf8ToString msg) q xs) (inQuotes . fromByteString) utf8ToString = T.unpack . TE.decodeUtf8 sub (Plain b) = pure b sub (Escape s) = quote <$> escapeStringConn conn s sub (EscapeByteA s) = quote <$> escapeByteaConn 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 <> p <> 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 :: (ToRow q) => Connection -> Query -> q -> IO Int64 execute conn template qs = do result <- exec conn =<< formatQuery conn template qs finishExecute conn template 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 :: (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 -- | Execute @INSERT ... RETURNING@, @UPDATE ... RETURNING@, or other SQL -- query that accepts multi-row input and is expected to return results. -- Note that it is possible to write -- @'query' conn "INSERT ... RETURNING ..." ...@ -- in cases where you are only inserting a single row, and do not need -- functionality analogous to 'executeMany'. -- -- Throws 'FormatError' if the query could not be formatted correctly. returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r] returning _ _ [] = return [] returning conn q qs = do result <- exec conn =<< formatMany conn q qs finishQuery conn q result -- | 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 :: (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_ :: (FromRow 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. -- -- 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 :: ( FromRow row, ToRow params ) => Connection -> Query -> params -> a -> (a -> row -> IO a) -> IO a fold = foldWithOptions defaultFoldOptions data FetchQuantity = Automatic | Fixed !Int data FoldOptions = FoldOptions { fetchQuantity :: !FetchQuantity, transactionMode :: !TransactionMode } defaultFoldOptions :: FoldOptions defaultFoldOptions = FoldOptions { fetchQuantity = Automatic, transactionMode = TransactionMode ReadCommitted ReadOnly } foldWithOptions :: ( FromRow row, ToRow params ) => FoldOptions -> Connection -> Query -> params -> a -> (a -> row -> IO a) -> IO a foldWithOptions opts conn template qs a f = do q <- formatQuery conn template qs doFold opts conn template (Query q) a f -- | A version of 'fold' that does not perform query substitution. fold_ :: (FromRow r) => Connection -> Query -- ^ Query. -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a fold_ = foldWithOptions_ defaultFoldOptions foldWithOptions_ :: (FromRow r) => FoldOptions -> Connection -> Query -- ^ Query. -> a -- ^ Initial state for result consumer. -> (a -> r -> IO a) -- ^ Result consumer. -> IO a foldWithOptions_ opts conn query a f = doFold opts conn query query a f doFold :: ( FromRow row ) => FoldOptions -> Connection -> Query -> Query -> a -> (a -> row -> IO a) -> IO a doFold FoldOptions{..} conn _template q a0 f = do stat <- withConnection conn PQ.transactionStatus case stat of PQ.TransIdle -> withTransactionMode transactionMode conn go PQ.TransInTrans -> go PQ.TransActive -> fail "foldWithOpts FIXME: PQ.TransActive" -- This _shouldn't_ occur in the current incarnation of -- the library, as we aren't using libpq asynchronously. -- However, it could occur in future incarnations of -- this library or if client code uses the Internal module -- to use raw libpq commands on postgresql-simple connections. PQ.TransInError -> fail "foldWithOpts FIXME: PQ.TransInError" -- This should be turned into a better error message. -- It is probably a bad idea to automatically roll -- back the transaction and start another. PQ.TransUnknown -> fail "foldWithOpts FIXME: PQ.TransUnknown" -- Not sure what this means. where declare = do name <- newTempName conn _ <- execute_ conn $ mconcat [ "DECLARE ", name, " NO SCROLL CURSOR FOR ", q ] return name fetch (Query name) = query_ conn $ Query (toByteString (fromByteString "FETCH FORWARD " <> integral chunkSize <> fromByteString " FROM " <> fromByteString name )) close name = (execute_ conn ("CLOSE " <> name) >> return ()) `E.catch` \ex -> -- Don't throw exception if CLOSE failed because the transaction is -- aborted. Otherwise, it will throw away the original error. if isFailedTransactionError ex then return () else throwIO ex go = bracket declare close $ \name -> let loop a = do rs <- fetch name if null rs then return a else foldM f a rs >>= loop in loop a0 -- FIXME: choose the Automatic chunkSize more intelligently -- One possibility is to use the type of the results, although this -- still isn't a perfect solution, given that common types (e.g. text) -- are of highly variable size. -- A refinement of this technique is to pick this number adaptively -- as results are read in from the database. chunkSize = case fetchQuantity of Automatic -> 256 Fixed n -> n -- | A version of 'fold' that does not transform a state value. forEach :: (ToRow q, FromRow 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_ :: (FromRow 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 :: (FromRow r) => Connection -> Query -> PQ.Result -> IO [r] finishQuery conn q result = do status <- PQ.resultStatus result case status of PQ.EmptyQuery -> throwIO $ QueryError "query: Empty query" q PQ.CommandOk -> do throwIO $ QueryError "query resulted in a command response" q PQ.TuplesOk -> do let unCol (PQ.Col x) = fromIntegral x :: Int nrows <- PQ.ntuples result ncols <- PQ.nfields result forM' 0 (nrows-1) $ \row -> do let rw = Row row result okvc <- runConversion (runStateT (runReaderT (unRP fromRow) rw) 0) conn case okvc of Ok (val,col) | col == ncols -> return val | otherwise -> do vals <- forM' 0 (ncols-1) $ \c -> do tinfo <- getTypeInfo conn =<< PQ.ftype result c v <- PQ.getvalue result row c return ( tinfo , fmap ellipsis v ) throw (ConversionFailed (show (unCol ncols) ++ " values: " ++ show vals) Nothing "" (show (unCol col) ++ " slots in target type") "mismatch between number of columns to \ \convert and number in target type") Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error" Errors [x] -> throwIO x Errors xs -> throwIO $ ManyErrors xs PQ.CopyOut -> throwIO $ QueryError "query: COPY TO is not supported" q PQ.CopyIn -> throwIO $ QueryError "query: COPY FROM is not supported" q PQ.BadResponse -> throwResultError "query" result status PQ.NonfatalError -> throwResultError "query" result status PQ.FatalError -> throwResultError "query" result status ellipsis :: ByteString -> ByteString ellipsis bs | B.length bs > 15 = B.take 10 bs `B.append` "[...]" | otherwise = bs 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 (EscapeByteA 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 case 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 (ToField a) => ToRow 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 be 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') -- $returning -- -- PostgreSQL supports returning values from data manipulation statements -- such as @INSERT@ and @UPDATE@. You can use these statements by -- using 'query' instead of 'execute'. For multi-tuple inserts, -- use 'returning' instead of 'executeMany'. -- -- For example, were there an auto-incrementing @id@ column and -- timestamp column @t@ that defaulted to the present time for the -- @sales@ table, then the following query would insert two new -- sales records and also return their new @id@s and timestamps. -- -- > let q = "insert into sales (amount, label) values (?,?) returning id, t" -- > xs :: [(Int, UTCTime)] <- query conn q (15,"Sawdust") -- > ys :: [(Int, UTCTime)] <- returning conn q [(20,"Chips"),(300,"Wood")] -- $result -- -- The 'query' and 'query_' functions return a list of values in the -- '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: -- -- > 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 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. postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/0000755000000000000000000000000012173400557021267 5ustar0000000000000000postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/FromRow.hs0000644000000000000000000001463512173400557023227 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.FromRow -- Copyright: (c) 2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- 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 , fieldWith , numFieldsRemaining ) where import Control.Applicative (Applicative(..), (<$>)) import Control.Monad (replicateM) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Database.PostgreSQL.Simple.Types (Only(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Compat import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.Types ((:.)(..)) import Database.PostgreSQL.Simple.TypeInfo import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import Control.Monad.Trans.Class -- | 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 be 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 getvalue :: PQ.Result -> PQ.Row -> PQ.Column -> Maybe ByteString getvalue result row col = unsafeDupablePerformIO (PQ.getvalue result row col) nfields :: PQ.Result -> PQ.Column nfields result = unsafeDupablePerformIO (PQ.nfields result) getTypeInfoByCol :: Row -> PQ.Column -> Conversion TypeInfo getTypeInfoByCol Row{..} col = Conversion $ \conn -> do oid <- PQ.ftype rowresult col Ok <$> getTypeInfo conn oid getTypenameByCol :: Row -> PQ.Column -> Conversion ByteString getTypenameByCol row col = typname <$> getTypeInfoByCol row col fieldWith :: FieldParser a -> RowParser a fieldWith fieldP = RP $ do let unCol (PQ.Col x) = fromIntegral x :: Int r@Row{..} <- ask column <- lift get lift (put (column + 1)) let ncols = nfields rowresult if (column >= ncols) then lift $ lift $ do vals <- mapM (getTypenameByCol r) [0..ncols-1] let err = ConversionFailed (show (unCol ncols) ++ " values: " ++ show (map ellipsis vals)) Nothing "" ("at least " ++ show (unCol column + 1) ++ " slots in target type") "mismatch between number of columns to \ \convert and number in target type" conversionError err else do let !result = rowresult !typeOid = unsafeDupablePerformIO (PQ.ftype result column) !field = Field{..} lift (lift (fieldP field (getvalue result row column))) field :: FromField a => RowParser a field = fieldWith fromField 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 postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/LargeObjects.hs0000644000000000000000000000637412173400557024201 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Database.PostgreSQL.Simple.LargeObjects -- Copyright : (c) 2011-2012 Leon P Smith -- License : BSD3 -- -- Maintainer : leon@melding-monads.com -- -- Support for PostgreSQL's Large Objects; see -- for more -- information. -- -- Note that Large Object File Descriptors are only valid within a single -- database transaction, so if you are interested in using anything beyond -- 'loCreat', 'loImport', 'loExport', and 'loUnlink', you will need to run -- the entire sequence of functions in a transaction. -- ----------------------------------------------------------------------------- module Database.PostgreSQL.Simple.LargeObjects ( loCreat , loCreate , loImport , loImportWithOid , loExport , loOpen , loWrite , loRead , loSeek , loTell , loTruncate , loClose , loUnlink , Oid(..) , LoFd , IOMode(..) , SeekMode(..) ) where import Control.Applicative ((<$>)) import Control.Exception (throwIO) import qualified Data.ByteString as B import Database.PostgreSQL.LibPQ (Oid(..),LoFd(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Internal import System.IO (IOMode(..),SeekMode(..)) liftPQ :: B.ByteString -> Connection -> (PQ.Connection -> IO (Maybe a)) -> IO a liftPQ str conn m = withConnection conn $ \c -> do res <- m c case res of Nothing -> do msg <- maybe str id <$> PQ.errorMessage c throwIO $ fatalError msg Just x -> return x loCreat :: Connection -> IO Oid loCreat conn = liftPQ "loCreat" conn (\c -> PQ.loCreat c) loCreate :: Connection -> Oid -> IO Oid loCreate conn oid = liftPQ "loCreate" conn (\c -> PQ.loCreate c oid) loImport :: Connection -> FilePath -> IO Oid loImport conn path = liftPQ "loImport" conn (\c -> PQ.loImport c path) loImportWithOid :: Connection -> FilePath -> Oid -> IO Oid loImportWithOid conn path oid = liftPQ "loImportWithOid" conn (\c -> PQ.loImportWithOid c path oid) loExport :: Connection -> Oid -> FilePath -> IO () loExport conn oid path = liftPQ "loExport" conn (\c -> PQ.loExport c oid path) loOpen :: Connection -> Oid -> IOMode -> IO LoFd loOpen conn oid mode = liftPQ "loOpen" conn (\c -> PQ.loOpen c oid mode ) loWrite :: Connection -> LoFd -> B.ByteString -> IO Int loWrite conn fd dat = liftPQ "loWrite" conn (\c -> PQ.loWrite c fd dat) loRead :: Connection -> LoFd -> Int -> IO B.ByteString loRead conn fd maxlen = liftPQ "loRead" conn (\c -> PQ.loRead c fd maxlen) loSeek :: Connection -> LoFd -> SeekMode -> Int -> IO Int loSeek conn fd seekmode offset = liftPQ "loSeek" conn (\c -> PQ.loSeek c fd seekmode offset) loTell :: Connection -> LoFd -> IO Int loTell conn fd = liftPQ "loTell" conn (\c -> PQ.loTell c fd) loTruncate :: Connection -> LoFd -> Int -> IO () loTruncate conn fd len = liftPQ "loTruncate" conn (\c -> PQ.loTruncate c fd len) loClose :: Connection -> LoFd -> IO () loClose conn fd = liftPQ "loClose" conn (\c -> PQ.loClose c fd) loUnlink :: Connection -> Oid -> IO () loUnlink conn oid = liftPQ "loUnlink" conn (\c -> PQ.loUnlink c oid) postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/BuiltinTypes.hs0000644000000000000000000001655712173400557024274 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.BuiltinTypes -- Copyright: (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- 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 | TimestampTZ | Interval | TimeTZ | Bit | VarBit | Numeric | RefCursor | Record | Void | UUID 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 TimestampTZ -> 1184 Interval -> 1186 TimeTZ -> 1266 Bit -> 1560 VarBit -> 1562 Numeric -> 1700 RefCursor -> 1790 Record -> 2249 Void -> 2278 UUID -> 2950 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 TimestampTZ 1186 -> Just Interval 1266 -> Just TimeTZ 1560 -> Just Bit 1562 -> Just VarBit 1700 -> Just Numeric 1790 -> Just RefCursor 2249 -> Just Record 2278 -> Just Void 2950 -> Just UUID _ -> Nothing 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 TimestampTZ -> timestamptz Interval -> interval TimeTZ -> timetz Bit -> bit VarBit -> varbit Numeric -> numeric RefCursor -> refcursor Record -> record Void -> void UUID -> uuid 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 2950 -> Just uuid _ -> 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" uuid :: ByteString uuid = "uuid" postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/ToRow.hs-boot0000644000000000000000000000030512173400557023634 0ustar0000000000000000module Database.PostgreSQL.Simple.ToRow where import Database.PostgreSQL.Simple.Types import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField class ToRow a instance ToField a => ToRow (Only a) postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/HStore.hs0000644000000000000000000000225612173400557023034 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.HStore -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Parsers and printers for hstore, a extended type bundled with -- PostgreSQL providing finite maps from text strings to text strings. -- See for more -- information. -- -- Note that in order to use this type, a database superuser must -- install it by running a sql script in the share directory. This -- can be done on PostgreSQL 9.1 and later with the command -- @CREATE EXTENSION hstore@. See -- for more -- information. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.HStore ( HStoreList(..) , HStoreMap(..) , ToHStore(..) , HStoreBuilder , toBuilder , toLazyByteString , hstore , ToHStoreText(..) , HStoreText ) where import Database.PostgreSQL.Simple.HStore.Implementation postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Notification.hs0000644000000000000000000001007012173400557024247 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : Database.PostgreSQL.Simple.Notification -- Copyright : (c) 2011-2012 Leon P Smith -- License : BSD3 -- -- Maintainer : leon@melding-monads.com -- Stability : experimental -- -- Support for receiving asynchronous notifications via PostgreSQL's -- Listen/Notify mechanism. See -- for more -- information. -- -- Note that on Windows, @getNotification@ currently uses a polling loop -- of 1 second to check for more notifications, due to some inadequacies -- in GHC's IO implementation and interface on that platform. See GHC -- issue #7353 for more information. While this workaround is less than -- ideal, notifications are still better than polling the database directly. -- Notifications do not create any extra work for the backend, and are -- likely cheaper on the client side as well. -- -- -- ----------------------------------------------------------------------------- module Database.PostgreSQL.Simple.Notification ( Notification(..) , getNotification , getNotificationNonBlocking ) where import Control.Concurrent import Control.Monad ( when ) import Control.Exception ( throwIO ) 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 } convertNotice :: PQ.Notify -> Notification convertNotice PQ.Notify{..} = Notification { notificationPid = notifyBePid , notificationChannel = notifyRelname , notificationData = notifyExtra } -- | Returns a single notification. If no notifications are available, -- 'getNotification' blocks until one arrives. getNotification :: Connection -> IO Notification getNotification conn = loop False where funcName = "Database.PostgreSQL.Simple.Notification.getNotification" loop doConsume = do res <- withConnection conn $ \c -> do when doConsume (PQ.consumeInput c >> return ()) mmsg <- PQ.notifies c case mmsg of Nothing -> do mfd <- PQ.socket c case mfd of Nothing -> throwIO $ fdError funcName Just fd -> return (Left fd) Just msg -> return (Right msg) -- FIXME? what happens if the connection is closed/reset right here? case res of #if defined(mingw32_HOST_OS) -- threadWaitRead doesn't work for sockets on Windows, so just poll -- for input every second (PQconsumeInput is non-blocking). -- -- We could call select(), but FFI calls can't be interrupted with -- async exceptions, whereas threadDelay can. Left _fd -> threadDelay 1000000 >> loop True #else Left fd -> threadWaitRead fd >> loop True #endif Right msg -> return $! convertNotice msg -- | Non-blocking variant of 'getNotification'. Returns a single notification, -- if available. If no notifications are available, returns 'Nothing'. getNotificationNonBlocking :: Connection -> IO (Maybe Notification) getNotificationNonBlocking conn = withConnection conn $ \c -> do mmsg <- PQ.notifies c case mmsg of Just msg -> return $! Just $! convertNotice msg Nothing -> do _ <- PQ.consumeInput c mmsg' <- PQ.notifies c case mmsg' of Just msg -> return $! Just $! convertNotice msg Nothing -> return Nothing postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/FromRow.hs-boot0000644000000000000000000000114012173400557024153 0ustar0000000000000000module Database.PostgreSQL.Simple.FromRow where import {-# SOURCE #-} Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.Types class FromRow a instance (FromField a) => FromRow (Only a) instance (FromField a, FromField b) => FromRow (a,b) instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a,b,c,d) instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a,b,c,d,e) instance (FromField a, FromField b, FromField c, FromField d, FromField e ,FromField f) => FromRow (a,b,c,d,e,f) postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Compat.hs0000644000000000000000000000241712173400557023052 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | This is a module of its own, partly because it uses the CPP extension, -- which doesn't play well with backslash-broken string literals. module Database.PostgreSQL.Simple.Compat ( mask , (<>) , unsafeDupablePerformIO ) where import qualified Control.Exception as E import Data.Monoid #if __GLASGOW_HASKELL__ >= 702 import System.IO.Unsafe (unsafeDupablePerformIO) #elif __GLASGOW_HASKELL__ >= 611 import GHC.IO (unsafeDupablePerformIO) #else import GHC.IOBase (unsafeDupablePerformIO) #endif -- | Like 'E.mask', but backported to base before version 4.3.0. -- -- Note that the restore callback is monomorphic, unlike in 'E.mask'. This -- 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 #-} #if !MIN_VERSION_base(4,5,0) infixr 6 <> (<>) :: Monoid m => m -> m -> m (<>) = mappend {-# INLINE (<>) #-} #endif postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/TypeInfo.hs0000644000000000000000000001251612173400557023365 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.TypeInfo -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- This module provides convenient and efficient access to parts of the -- @pg_type@ metatable. At the moment, this requires PostgreSQL 8.4 if -- you need to work with types that do not appear in -- 'Database.PostgreSQL.Simple.TypeInfo.Static'. -- -- The current scheme could be more efficient, especially for some use -- cases. In particular, connection pools that use many user-added -- types and connect to a set of servers with identical (or at least -- compatible) @pg_type@ and associated tables could share a common -- typeinfo cache, thus saving memory and communication between the -- client and server. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.TypeInfo ( getTypeInfo , TypeInfo(..) , Attribute(..) ) where import qualified Data.ByteString as B import qualified Data.IntMap as IntMap import qualified Data.Vector as V import qualified Data.Vector.Mutable as MV import Control.Concurrent.MVar import Control.Exception (throw) import qualified Database.PostgreSQL.LibPQ as PQ import {-# SOURCE #-} Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.TypeInfo.Types import Database.PostgreSQL.Simple.TypeInfo.Static -- | Returns the metadata of the type with a particular oid. To find -- this data, 'getTypeInfo' first consults postgresql-simple's -- built-in 'staticTypeInfo' table, then checks the connection's -- typeinfo cache. Finally, the database's 'pg_type' table will -- be queried only if necessary, and the result will be stored -- in the connections's cache. getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo getTypeInfo conn@Connection{..} oid = case staticTypeInfo oid of Just name -> return name Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache -> IO (TypeInfoCache, TypeInfo) getTypeInfo' conn oid oidmap = case IntMap.lookup (oid2int oid) oidmap of Just typeinfo -> return (oidmap, typeinfo) Nothing -> do names <- query conn "SELECT oid, typcategory, typdelim, typname,\ \ typelem, typrelid\ \ FROM pg_type WHERE oid = ?" (Only oid) (oidmap', typeInfo) <- case names of [] -> return $ throw (fatalError "invalid type oid") [(typoid, typcategory, typdelim, typname, typelem_, typrelid)] -> do case typcategory of 'A' -> do (oidmap', typelem) <- getTypeInfo' conn typelem_ oidmap let !typeInfo = Array{..} return $! (oidmap', typeInfo) 'R' -> do rngsubtypeOids <- query conn "SELECT rngsubtype\ \ FROM pg_range\ \ WHERE rngtypid = ?" (Only oid) case rngsubtypeOids of [Only rngsubtype_] -> do (oidmap', rngsubtype) <- getTypeInfo' conn rngsubtype_ oidmap let !typeInfo = Range{..} return $! (oidmap', typeInfo) _ -> fail "range subtype query failed to return exactly one result" 'C' -> do cols <- query conn "SELECT attname, atttypid\ \ FROM pg_attribute\ \ WHERE attrelid = ?\ \ AND attnum > 0\ \ AND NOT attisdropped\ \ ORDER BY attnum" (Only typrelid) vec <- MV.new $! length cols (oidmap', attributes) <- getAttInfos conn cols oidmap vec 0 let !typeInfo = Composite{..} return $! (oidmap', typeInfo) _ -> do let !typeInfo = Basic{..} return $! (oidmap, typeInfo) _ -> fail "typename query returned more than one result" -- oid is a primary key, so the query should -- never return more than one result let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap' return $! (oidmap'', typeInfo) getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache -> MV.IOVector Attribute -> Int -> IO (TypeInfoCache, V.Vector Attribute) getAttInfos conn cols oidmap vec n = case cols of [] -> do !attributes <- V.unsafeFreeze vec return $! (oidmap, attributes) ((attname, attTypeOid):xs) -> do (oidmap', atttype) <- getTypeInfo' conn attTypeOid oidmap MV.write vec n $! Attribute{..} getAttInfos conn xs oidmap' vec (n+1) postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Errors.hs0000644000000000000000000000732312173400557023104 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -- | Module for parsing errors from posgresql error messages. -- Currently in only parses integrity violation errors (class 23). -- -- /Note: Success of parsing may depend on language settings./ ---------------------------------------------------------- module Database.PostgreSQL.Simple.Errors ( ConstraintViolation(..) , constraintViolation , constraintViolationE , catchViolation ) where import Control.Applicative import Control.Exception as E import Data.Attoparsec.Char8 import Data.ByteString (ByteString) import Data.Typeable import Database.PostgreSQL.Simple.Internal -- Examples of parsed error messages -- -- `ERROR: new row for relation "users" violates check -- constraint "user_kind_check"` -- -- `ERROR: insert or update on table "user_group_map" violates foreign key -- constraint "user_id"` -- -- `ERROR: null value in column "login" violates not-null constraint` -- -- `ERROR: duplicate key value violates unique constraint "users_login_key"` data ConstraintViolation = NotNullViolation ByteString -- ^ The field is a column name | ForeignKeyViolation ByteString ByteString -- ^ Table name and name of violated constraint | UniqueViolation ByteString -- ^ Name of violated constraint | CheckViolation ByteString ByteString -- ^ Relation name (usually table), constraint name deriving (Show, Eq, Ord, Typeable) -- Default instance should be enough instance Exception ConstraintViolation -- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and -- succeedes only if able to parse sqlErrorMsg. -- -- > createUser = catchJust constraintViolation catcher $ execute conn ... -- > where -- > catcher UniqueViolation "user_login_key" = ... -- > catcher _ = ... constraintViolation :: SqlError -> Maybe ConstraintViolation constraintViolation e = case sqlState e of "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg _ -> Nothing where msg = sqlErrorMsg e -- | Like constraintViolation, but also packs original SqlError. -- -- > createUser = catchJust constraintViolationE catcher $ execute conn ... -- > where -- > catcher (_, UniqueViolation "user_login_key") = ... -- > catcher (e, _) = throwIO e -- constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation) constraintViolationE e = fmap ((,) e) $ constraintViolation e -- | Catches SqlError, tries to convert to ConstraintViolation, re-throws -- on fail. Provides alternative interface to catchJust -- -- > createUser = catchViolation catcher $ execute conn ... -- > where -- > catcher _ (UniqueViolation "user_login_key") = ... -- > catcher e _ = throwIO e catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a catchViolation f m = E.catch m (\e -> maybe (throwIO e) (f e) $ constraintViolation e) -- Parsers just try to extract quoted strings from error messages, number -- of quoted strings depend on error type. scanTillQuote :: Parser ByteString scanTillQuote = scan False go where go True _ = Just False -- escaped character go False '"' = Nothing -- end parse go False '\\' = Just True -- next one is escaped go _ _ = Just False parseQ1 :: Parser ByteString parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"' parseQ2 :: Parser (ByteString, ByteString) parseQ2 = (,) <$> parseQ1 <*> parseQ1 parseMaybe :: Parser a -> ByteString -> Maybe a parseMaybe p b = either (const Nothing) Just $ parseOnly p b postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/FromField.hs-boot0000644000000000000000000000041312173400557024431 0ustar0000000000000000module Database.PostgreSQL.Simple.FromField where import Data.ByteString(ByteString) import Database.PostgreSQL.Simple.Types class FromField a instance FromField Oid instance FromField Char instance FromField ByteString instance FromField a => FromField (Maybe a) postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Internal.hs0000644000000000000000000003042112173400557023377 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Internal -- Copyright: (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- 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 -- disappear from this module. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Internal where import Control.Applicative import Control.Exception import Control.Concurrent.MVar import Control.Monad(MonadPlus(..)) import Data.ByteString(ByteString) import qualified Data.ByteString.Char8 as B8 import Data.Char (ord) import Data.Int (Int64) import qualified Data.IntMap as IntMap import Data.IORef import Data.Maybe(fromMaybe) import Data.String import Data.Typeable import Data.Word import Database.PostgreSQL.LibPQ(Oid(..)) import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.LibPQ(ExecStatus(..)) import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.Types (Query(..)) import Database.PostgreSQL.Simple.TypeInfo.Types(TypeInfo) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import GHC.IO.Exception -- | 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 :: {-# UNPACK #-} !PQ.Column , typeOid :: {-# UNPACK #-} !PQ.Oid -- ^ This returns the type oid associated with the column. Analogous -- to libpq's @PQftype@. } type TypeInfoCache = IntMap.IntMap TypeInfo data Connection = Connection { connectionHandle :: {-# UNPACK #-} !(MVar PQ.Connection) , connectionObjects :: {-# UNPACK #-} !(MVar TypeInfoCache) , connectionTempNameCounter :: {-# UNPACK #-} !(IORef Int64) } data SqlError = SqlError { sqlState :: ByteString , sqlExecStatus :: ExecStatus , sqlErrorMsg :: ByteString , sqlErrorDetail :: ByteString , sqlErrorHint :: ByteString } deriving (Show, Typeable) fatalError :: ByteString -> SqlError fatalError msg = SqlError "" FatalError msg "" "" instance Exception SqlError -- | Exception thrown if 'query' is used to perform an @INSERT@-like -- 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 data ConnectInfo = ConnectInfo { connectHost :: String , connectPort :: Word16 , connectUser :: String , connectPassword :: String , connectDatabase :: String } deriving (Eq,Read,Show,Typeable) -- | Default information for setting up a connection. -- -- Defaults are as follows: -- -- * Server on @localhost@ -- -- * Port on @5432@ -- -- * User @postgres@ -- -- * No password -- -- * Database @postgres@ -- -- Use as in the following example: -- -- > connect defaultConnectInfo { connectHost = "db.example.com" } 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 -- | Attempt to make a connection based on a libpq connection string. -- See -- for more information. connectPostgreSQL :: ByteString -> IO Connection connectPostgreSQL connstr = do conn <- PQ.connectdb connstr stat <- PQ.status conn case stat of PQ.ConnectionOk -> do connectionHandle <- newMVar conn connectionObjects <- newMVar (IntMap.empty) connectionTempNameCounter <- newIORef 0 let wconn = Connection{..} version <- PQ.serverVersion conn let settings | version < 80200 = "SET datestyle TO ISO" | otherwise = "SET standard_conforming_strings TO on;\ \SET datestyle TO ISO" _ <- execute_ wconn settings return wconn _ -> do msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn throwIO $ fatalError msg -- | Turns a 'ConnectInfo' data structure into a libpq connection string. 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 = showString name . quote value . space where value = field connectInfo num name field | value <= 0 = id | otherwise = showString name . shows 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 $ fatalError msg Just res -> do return res -- | 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 finishExecute :: Connection -> Query -> PQ.Result -> IO Int64 finishExecute _conn q result = do status <- PQ.resultStatus result case status of PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q 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.CopyOut -> throwIO $ QueryError "execute: COPY TO is not supported" q PQ.CopyIn -> throwIO $ QueryError "execute: COPY FROM is not supported" q PQ.BadResponse -> throwResultError "execute" result status PQ.NonfatalError -> throwResultError "execute" result status PQ.FatalError -> throwResultError "execute" result status where toInteger str = B8.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: " ++ B8.unpack str) throwResultError :: ByteString -> PQ.Result -> PQ.ExecStatus -> IO a throwResultError _ result status = do errormsg <- fromMaybe "" <$> PQ.resultErrorField result PQ.DiagMessagePrimary detail <- fromMaybe "" <$> PQ.resultErrorField result PQ.DiagMessageDetail hint <- fromMaybe "" <$> PQ.resultErrorField result PQ.DiagMessageHint state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate throwIO $ SqlError { sqlState = state , sqlExecStatus = status , sqlErrorMsg = errormsg , sqlErrorDetail = detail , sqlErrorHint = hint } disconnectedError :: SqlError disconnectedError = fatalError "connection disconnected" -- | 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 $ \conn -> do if PQ.isNullConnection conn then throwIO disconnectedError else m conn close :: Connection -> IO () close Connection{..} = mask $ \restore -> (do conn <- takeMVar connectionHandle restore (PQ.finish conn) `finally` do putMVar connectionHandle =<< PQ.newNullConnection ) newNullConnection :: IO Connection newNullConnection = do connectionHandle <- newMVar =<< PQ.newNullConnection connectionObjects <- newMVar IntMap.empty connectionTempNameCounter <- newIORef 0 return Connection{..} data Row = Row { row :: {-# UNPACK #-} !PQ.Row , rowresult :: !PQ.Result } newtype RowParser a = RP { unRP :: ReaderT Row (StateT PQ.Column Conversion) a } deriving ( Functor, Applicative, Alternative, Monad ) newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) } instance Functor Conversion where fmap f m = Conversion $ \conn -> (fmap . fmap) f (runConversion m conn) instance Applicative Conversion where pure a = Conversion $ \_conn -> pure (pure a) mf <*> ma = Conversion $ \conn -> do okf <- runConversion mf conn case okf of Ok f -> (fmap . fmap) f (runConversion ma conn) Errors errs -> return (Errors errs) instance Alternative Conversion where empty = Conversion $ \_conn -> pure empty ma <|> mb = Conversion $ \conn -> do oka <- runConversion ma conn case oka of Ok _ -> return oka Errors _ -> (oka <|>) <$> runConversion mb conn instance Monad Conversion where return a = Conversion $ \_conn -> return (return a) m >>= f = Conversion $ \conn -> do oka <- runConversion m conn case oka of Ok a -> runConversion (f a) conn Errors err -> return (Errors err) instance MonadPlus Conversion where mzero = empty mplus = (<|>) conversionMap :: (Ok a -> Ok b) -> Conversion a -> Conversion b conversionMap f m = Conversion $ \conn -> f <$> runConversion m conn conversionError :: Exception err => err -> Conversion a conversionError err = Conversion $ \_ -> return (Errors [SomeException err]) newTempName :: Connection -> IO Query newTempName Connection{..} = do !n <- atomicModifyIORef connectionTempNameCounter (\n -> let !n' = n+1 in (n', n')) return $! Query $ B8.pack $ "temp" ++ show n -- FIXME? What error should getNotification and getCopyData throw? fdError :: ByteString -> IOError fdError funcName = IOError { ioe_handle = Nothing, ioe_type = ResourceVanished, ioe_location = B8.unpack funcName, ioe_description = "failed to fetch file descriptor", ioe_errno = Nothing, ioe_filename = Nothing } postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/ToField.hs-boot0000644000000000000000000000020012173400557024102 0ustar0000000000000000module Database.PostgreSQL.Simple.ToField where import Database.PostgreSQL.Simple.Types class ToField a instance ToField Oid postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/SqlQQ.hs0000644000000000000000000000647012173400557022633 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.SqlQQ -- Copyright: (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- 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. For example: -- -- > {-# LANGUAGE QuasiQuotes #-} -- > -- > query conn [sql| SELECT column_a, column_b -- > FROM table1 NATURAL JOIN table2 -- > WHERE ? <= time AND time < ? -- > AND name LIKE ? -- > ORDER BY size DESC -- > LIMIT 100 |] -- > (beginTime,endTime,string) -- -- This quasiquoter attempts to mimimize whitespace; otherwise the -- above query would consist of approximately half whitespace when sent -- to the database backend. It also recognizes and strips out standard -- sql comments "--". -- -- The implementation of the whitespace reducer is currently incomplete. -- Thus it can mess up your syntax in cases where whitespace should be -- preserved as-is. It does preserve whitespace inside standard SQL string -- literals. But it can get confused by the non-standard PostgreSQL string -- literal syntax (which is the default setting in PostgreSQL 8 and below), -- the extended escape string syntax, quoted identifiers, and other similar -- constructs. -- -- Of course, this caveat only applies to text written inside the SQL -- quasiquoter; whitespace reduction is a compile-time computation and -- thus will not touch the @string@ parameter above, which is a run-time -- value. -- -- Also note that this will not work if the substring @|]@ is contained -- in the query. 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 . minimizeSpace minimizeSpace :: String -> String minimizeSpace = drop 1 . reduceSpace where needsReduced [] = False needsReduced ('-':'-':_) = True needsReduced (x:_) = isSpace x reduceSpace xs = case dropWhile isSpace xs of [] -> [] ('-':'-':ys) -> reduceSpace (dropWhile (/= '\n') ys) ys -> ' ' : insql ys insql ('\'':xs) = '\'' : instring xs insql xs | needsReduced xs = reduceSpace xs insql (x:xs) = x : insql xs insql [] = [] instring ('\'':'\'':xs) = '\'':'\'': instring xs instring ('\'':xs) = '\'': insql xs instring (x:xs) = x : instring xs instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ \ string literal not terminated" postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/FromField.hs0000644000000000000000000004410612173400557023477 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE PatternGuards, ScopedTypeVariables #-} {-# LANGUAGE RecordWildCards #-} {- | Module: Database.PostgreSQL.Simple.FromField Copyright: (c) 2011 MailRank, Inc. (c) 2011-2012 Leon P Smith License: BSD3 Maintainer: Leon P Smith Stability: experimental The 'FromField' typeclass, for converting a single value in a row returned by a SQL query into a more useful Haskell representation. Note that each instance of 'FromField' is documented by a list of compatible postgresql types. 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 PostgreSQL's 64-bit @bigint@, the two are /not/ considered compatible. Because 'FromField' is a typeclass, one may provide conversions to additional Haskell types without modifying postgresql-simple. This is particularly useful for supporting PostgreSQL types that postgresql-simple does not support out-of-box. Here's an example of what such an instance might look like for a UUID type that implements the @Read@ class: @ import Data.UUID ( UUID ) import Database.PostgreSQL.Simple.BuiltinTypes ( BuiltinType(UUID), builtin2oid ) import qualified Data.ByteString as B instance FromField UUID where fromField f mdata = if typeOid f /= builtin2oid UUID then returnError Incompatible f \"\" else case B.unpack \`fmap\` mdata of Nothing -> returnError UnexpectedNull f \"\" Just dat -> case [ x | (x,t) <- reads dat, (\"\",\"\") <- lex t ] of [x] -> return x _ -> returnError ConversionError f dat @ Note that because PostgreSQL's @uuid@ type is built into postgres and is not provided by an extension, the 'typeOid' of @uuid@ does not change and thus we can examine it directly. Here, we simply pull the type oid out of the static table provided by postgresql-simple. On the other hand if the type is provided by an extension, such as @PostGIS@ or @hstore@, then the 'typeOid' is not stable and can vary from database to database. In this case it is recommended that FromField instances use 'typename' instead. -} module Database.PostgreSQL.Simple.FromField ( FromField(..) , FieldParser , Conversion() , runConversion , conversionMap , conversionError , ResultError(..) , returnError , Field , typename , TypeInfo(..) , Attribute(..) , typeInfo , typeInfoByOid , name , tableOid , tableColumn , format , typeOid , PQ.Oid(..) , PQ.Format(..) ) where #include "MachDeps.h" import Control.Applicative ( Applicative, (<|>), (<$>), pure ) import Control.Exception (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 ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay ) import Data.Typeable (Typeable, typeOf) import Data.Vector (Vector) import qualified Data.Vector as V import Data.Word (Word64) import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.BuiltinTypes import Database.PostgreSQL.Simple.Compat import Database.PostgreSQL.Simple.Ok import Database.PostgreSQL.Simple.Types (Binary(..), Null(..)) import Database.PostgreSQL.Simple.TypeInfo as TypeInfo import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TypeInfo import Database.PostgreSQL.Simple.Time import Database.PostgreSQL.Simple.Arrays as Arrays import qualified Database.PostgreSQL.LibPQ as PQ import 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 , errSQLTableOid :: Maybe PQ.Oid , errSQLField :: String , errHaskellType :: String , errMessage :: String } -- ^ The SQL and Haskell types are not compatible. | UnexpectedNull { errSQLType :: String , errSQLTableOid :: Maybe PQ.Oid , errSQLField :: String , errHaskellType :: String , errMessage :: String } -- ^ A SQL @NULL@ was encountered when the Haskell -- type did not permit it. | ConversionFailed { errSQLType :: String , errSQLTableOid :: Maybe PQ.Oid , errSQLField :: String , errHaskellType :: String , errMessage :: String } -- ^ The SQL value could not be parsed, or could not -- 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 -> Conversion b left = conversionError type FieldParser a = Field -> Maybe ByteString -> Conversion a -- | A type that may be converted from a SQL type. class FromField a where fromField :: FieldParser 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. -- | Returns the data type name. This is the preferred way of identifying -- types that do not have a stable type oid, such as types provided by -- extensions to PostgreSQL. -- -- More concretely, it returns the @typname@ column associated with the -- type oid in the @pg_type@ table. First, postgresql-simple will check -- built-in, static table. If the type oid is not there, postgresql-simple -- will check a per-connection cache, and then finally query the database's -- meta-schema. typename :: Field -> Conversion ByteString typename field = typname <$> typeInfo field typeInfo :: Field -> Conversion TypeInfo typeInfo Field{..} = Conversion $ \conn -> do Ok <$> (getTypeInfo conn =<< PQ.ftype result column) typeInfoByOid :: PQ.Oid -> Conversion TypeInfo typeInfoByOid oid = Conversion $ \conn -> do Ok <$> (getTypeInfo conn oid) -- | Returns the name of the column. This is often determined by a table -- definition, but it can be set using an @as@ clause. name :: Field -> Maybe ByteString name Field{..} = unsafeDupablePerformIO (PQ.fname result column) -- | Returns the name of the object id of the @table@ associated with the -- column, if any. Returns 'Nothing' when there is no such table; -- for example a computed column does not have a table associated with it. -- Analogous to libpq's @PQftable@. tableOid :: Field -> Maybe PQ.Oid tableOid Field{..} = toMaybeOid (unsafeDupablePerformIO (PQ.ftable result column)) where toMaybeOid x = if x == PQ.invalidOid then Nothing else Just x -- | If the column has a table associated with it, this returns the number -- off the associated table column. Numbering starts from 0. Analogous -- to libpq's @PQftablecol@. tableColumn :: Field -> Int tableColumn Field{..} = fromCol (unsafeDupablePerformIO (PQ.ftablecol result column)) where fromCol (PQ.Col x) = fromIntegral x -- | This returns whether the data was returned in a binary or textual format. -- Analogous to libpq's @PQfformat@. format :: Field -> PQ.Format format Field{..} = unsafeDupablePerformIO (PQ.fformat result column) -- | For dealing with null values. Compatible with any postgresql type -- compatible with type @a@. Note that the type is not checked if -- the value is null, although it is inadvisable to rely on this -- behavior. instance (FromField a) => FromField (Maybe a) where fromField _ Nothing = pure Nothing fromField f bs = Just <$> fromField f bs -- | compatible with any data type, but the value must be null instance FromField Null where fromField _ Nothing = pure Null fromField f (Just _) = returnError ConversionFailed f "data is not null" -- | bool instance FromField Bool where fromField f bs | typeOid f /= typoid (TypeInfo.bool) = returnError Incompatible f "" | bs == Nothing = returnError UnexpectedNull f "" | bs == Just "t" = pure True | bs == Just "f" = pure False | otherwise = returnError ConversionFailed f "" -- | \"char\" instance FromField Char where fromField f bs = if typeOid f /= typoid (TypeInfo.char) then returnError Incompatible f "" else case bs of Nothing -> returnError UnexpectedNull f "" Just bs -> if B.length bs /= 1 then returnError ConversionFailed f "length not 1" else return $! (B.head bs) -- | int2 instance FromField Int16 where fromField = atto ok16 $ signed decimal -- | int2, int4 instance FromField Int32 where fromField = atto ok32 $ signed decimal #if WORD_SIZE_IN_BITS < 64 -- | int2, int4, and if compiled as 64-bit code, int8 as well. -- This library was compiled as 32-bit code. #else -- | int2, int4, and if compiled as 64-bit code, int8 as well. -- This library was compiled as 64-bit code. #endif instance FromField Int where fromField = atto okInt $ signed decimal -- | int2, int4, int8 instance FromField Int64 where fromField = atto ok64 $ signed decimal -- | int2, int4, int8 instance FromField Integer where fromField = atto ok64 $ signed decimal -- | int2, float4 instance FromField Float where fromField = atto ok (realToFrac <$> double) where ok = mkCompats [Float4,Int2] -- | int2, int4, float4, float8 instance FromField Double where fromField = atto ok double where ok = mkCompats [Float4,Float8,Int2,Int4] -- | int2, int4, float4, float8, numeric 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 -- | bytea, name, text, \"char\", bpchar, varchar, unknown instance FromField SB.ByteString where fromField f dat = if typeOid f == typoid TypeInfo.bytea then unBinary <$> fromField f dat else doFromField f okText' (pure . B.copy) dat -- | oid instance FromField PQ.Oid where fromField f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat -- | bytea, name, text, \"char\", bpchar, varchar, unknown instance FromField LB.ByteString where fromField f dat = LB.fromChunks . (:[]) <$> fromField f dat unescapeBytea :: Field -> SB.ByteString -> Conversion (Binary SB.ByteString) unescapeBytea f str = case unsafeDupablePerformIO (PQ.unescapeBytea str) of Nothing -> returnError ConversionFailed f "unescapeBytea failed" Just str -> pure (Binary str) -- | bytea 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 -- | bytea instance FromField (Binary LB.ByteString) where fromField f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> fromField f dat -- | name, text, \"char\", bpchar, varchar instance FromField ST.Text where fromField f = doFromField f okText $ (either left pure . ST.decodeUtf8') -- FIXME: check character encoding -- | name, text, \"char\", bpchar, varchar instance FromField LT.Text where fromField f dat = LT.fromStrict <$> fromField f dat -- | name, text, \"char\", bpchar, varchar instance FromField [Char] where fromField f dat = ST.unpack <$> fromField f dat -- | timestamptz instance FromField UTCTime where fromField = ff TypeInfo.timestamptz "UTCTime" parseUTCTime -- | timestamptz instance FromField ZonedTime where fromField = ff TypeInfo.timestamptz "ZonedTime" parseZonedTime -- | timestamp instance FromField LocalTime where fromField = ff TypeInfo.timestamp "LocalTime" parseLocalTime -- | date instance FromField Day where fromField = ff TypeInfo.date "Day" parseDay -- | time instance FromField TimeOfDay where fromField = ff TypeInfo.time "TimeOfDay" parseTimeOfDay -- | timestamptz instance FromField UTCTimestamp where fromField = ff TypeInfo.timestamptz "UTCTimestamp" parseUTCTimestamp -- | timestamptz instance FromField ZonedTimestamp where fromField = ff TypeInfo.timestamptz "ZonedTimestamp" parseZonedTimestamp -- | timestamp instance FromField LocalTimestamp where fromField = ff TypeInfo.timestamp "LocalTimestamp" parseLocalTimestamp -- | date instance FromField Date where fromField = ff TypeInfo.date "Date" parseDate ff :: TypeInfo -> String -> (B8.ByteString -> Either String a) -> Field -> Maybe B8.ByteString -> Conversion a ff pgType hsType parse f mstr = if typeOid f /= typoid pgType then err Incompatible "" else case mstr of Nothing -> err UnexpectedNull "" Just str -> case parse str of Left msg -> err ConversionFailed msg Right val -> return val where err errC msg = do typnam <- typename f left $ errC (B8.unpack typnam) (tableOid f) (maybe "" B8.unpack (name f)) hsType msg {-# INLINE ff #-} -- | Compatible with both types. Conversions to type @b@ are -- preferred, the conversion to type @a@ will be tried after -- the 'Right' conversion fails. instance (FromField a, FromField b) => FromField (Either a b) where fromField f dat = (Right <$> fromField f dat) <|> (Left <$> fromField f dat) -- | any postgresql array whose elements are compatible with type @a@ instance (FromField a, Typeable a) => FromField (Vector a) where fromField f mdat = do info <- typeInfo f case info of TypeInfo.Array{} -> case mdat of Nothing -> returnError UnexpectedNull f "" Just dat -> do case parseOnly (fromArray info f) dat of Left err -> returnError ConversionFailed f err Right conv -> V.fromList <$> conv _ -> returnError Incompatible f "" fromArray :: (FromField a) => TypeInfo -> Field -> Parser (Conversion [a]) fromArray typeInfo f = sequence . (parseIt <$>) <$> array delim where delim = typdelim (typelem typeInfo) fElem = f{ typeOid = typoid (typelem typeInfo) } parseIt item = (fromField f' . Just . fmt delim) item where f' | Arrays.Array _ <- item = f | otherwise = fElem newtype Compat = Compat Word64 mkCompats :: [BuiltinType] -> Compat 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 -> Conversion a) -> Maybe ByteString -> Conversion 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 -> Maybe PQ.Oid -> String -> String -> String -> err) -> Field -> String -> Conversion a returnError mkErr f msg = do typnam <- typename f left $ mkErr (B.unpack typnam) (tableOid f) (maybe "" B.unpack (name f)) (show (typeOf (undefined :: a))) msg atto :: forall a. (Typeable a) => Compat -> Parser a -> Field -> Maybe ByteString -> Conversion a atto types p0 f dat = doFromField f types (go p0) dat where go :: Parser a -> ByteString -> Conversion a go p s = case parseOnly p s of Left err -> returnError ConversionFailed f err Right v -> pure v postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Arrays.hs0000644000000000000000000000663512173400557023076 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Arrays -- Copyright: (c) 2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- A Postgres array parser and pretty-printer. ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Arrays where import Control.Applicative (Applicative(..), Alternative(..), (<$>)) import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as B import Data.Monoid import Data.Attoparsec.Char8 -- | Parse one of three primitive field formats: array, quoted and plain. arrayFormat :: Char -> Parser ArrayFormat arrayFormat delim = Array <$> array delim <|> Plain <$> plain delim <|> Quoted <$> quoted data ArrayFormat = Array [ArrayFormat] | Plain ByteString | Quoted ByteString deriving (Eq, Show, Ord) array :: Char -> Parser [ArrayFormat] array delim = char '{' *> option [] (arrays <|> strings) <* char '}' where strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim) arrays = sepBy1 (Array <$> array delim) (char ',') -- NB: Arrays seem to always be delimited by commas. -- | Recognizes a quoted string. quoted :: Parser ByteString quoted = char '"' *> option "" contents <* char '"' where esc = char '\\' *> (char '\\' <|> char '"') unQ = takeWhile1 (notInClass "\"\\") contents = mconcat <$> many (unQ <|> B.singleton <$> esc) -- | Recognizes a plain string literal, not containing quotes or brackets and -- not containing the delimiter character. plain :: Char -> Parser ByteString plain delim = takeWhile1 (notInClass (delim:"\"{}")) -- Mutually recursive 'fmt' and 'delimit' separate out value formatting -- from the subtleties of delimiting. -- | Format an array format item, using the delimiter character if the item is -- itself an array. fmt :: Char -> ArrayFormat -> ByteString fmt = fmt' False -- | Format a list of array format items, inserting the appropriate delimiter -- between them. When the items are arrays, they will be delimited with -- commas; otherwise, they are delimited with the passed-in-delimiter. delimit :: Char -> [ArrayFormat] -> ByteString delimit _ [] = "" delimit c [x] = fmt' True c x delimit c (x:y:z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y:z) where c' | Array _ <- x = ',' | otherwise = c -- | Format an array format item, using the delimiter character if the item is -- itself an array, optionally applying quoting rules. Creates copies for -- safety when used in 'FromField' instances. fmt' :: Bool -> Char -> ArrayFormat -> ByteString fmt' quoting c x = case x of Array items -> '{' `B.cons` (delimit c items `B.snoc` '}') Plain bytes -> B.copy bytes Quoted q | quoting -> '"' `B.cons` (esc q `B.snoc` '"') | otherwise -> B.copy q -- NB: The 'snoc' and 'cons' functions always copy. -- | Escape a string according to Postgres double-quoted string format. esc :: ByteString -> ByteString esc = B.concatMap f where f '"' = "\\\"" f '\\' = "\\\\" f c = B.singleton c -- TODO: Implement easy performance improvements with unfoldr. postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Types.hs0000644000000000000000000000741112173400557022732 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Types -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Basic types. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Types ( Null(..) , Only(..) , In(..) , Binary(..) , Query(..) , Oid(..) , (:.)(..) , Savepoint(..) ) 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 #-} mconcat xs = Query (B.concat (map fromQuery xs)) -- | 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 ?" (Only (In [3,4,5])) newtype In a = In a deriving (Eq, Ord, Read, Show, Typeable, Functor) -- | Wrap binary data for use as a @bytea@ value. 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 :. newtype Savepoint = Savepoint Query deriving (Eq, Ord, Show, Read, Typeable) postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Time.hs0000644000000000000000000000616312173400557022527 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Time -- Copyright: (c) 2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Time types that supports positive and negative infinity. Also includes -- new time parsers and printers with better performance than GHC's time -- package. -- -- The parsers only understand the specific variant of ISO 8601 that -- PostgreSQL emits, and the printers attempt to duplicate this syntax. -- Thus the @datestyle@ parameter for the connection must be set to @ISO@. -- -- These parsers and printers likely have problems and shortcomings. Some -- that I know of: -- -- 1 @TimestampTZ@s before a timezone-dependent point in time cannot be -- parsed, because the parsers can only handle timezone offsets of a -- integer number of minutes. However, PostgreSQL will include seconds -- in the offset, depending on the historical time standards for the city -- identifying the time zone. -- -- This boundary point often marks an event of some interest. In the US -- for example, @timestamptz@s before @1883-Nov-18 12:00:00@ local time -- cannot be parsed. This is the moment Standard Railway Time went live. -- Concretely, PostgreSQL will emit @1883-11-18 12:03:57-04:56:02@ -- instead of @1883-11-18 11:59:59-05@ when the @timezone@ parameter -- for the connection is set to @America/New_York@. -- -- 2. Dates and times surrounding @1582-Feb-24@, the date the Gregorian -- Calendar was introduced, should be investigated for conversion errors. -- -- 3. Points in time Before Christ are not also not supported. For example, -- PostgreSQL will emit @0045-01-01 BC@ for a value of a @date@ type. -- This is the year that the Julian Calendar was adopted. -- -- However, it should be noted that the old parsers also had issues 1 and 3. -- Also, the new parsers now correctly handle time zones that include minutes -- in their offset. Most notably, this includes all of India and parts of -- Canada and Australia. -- -- PostgreSQL uses the zoneinfo database for its time zone information. -- You can read more about PostgreSQL's date and time types at -- , -- and zoneinfo at . -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Time ( Unbounded(..) , Date , UTCTimestamp , ZonedTimestamp , LocalTimestamp , parseDay , parseUTCTime , parseZonedTime , parseLocalTime , parseTimeOfDay , parseDate , parseUTCTimestamp , parseZonedTimestamp , parseLocalTimestamp , dayToBuilder , utcTimeToBuilder , zonedTimeToBuilder , localTimeToBuilder , timeOfDayToBuilder , timeZoneToBuilder , dateToBuilder , utcTimestampToBuilder , zonedTimestampToBuilder , localTimestampToBuilder , unboundedToBuilder ) where import Database.PostgreSQL.Simple.Time.Implementation postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/ToField.hs0000644000000000000000000001646312173400557023163 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.ToField -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- 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, toByteString) import Blaze.ByteString.Builder.Char8 (fromChar) import Blaze.Text (integral, double, float) import Data.ByteString (ByteString) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intersperse) import Data.Monoid (mappend) import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime) import Data.Typeable (Typeable) import Data.Word (Word, Word8, Word16, Word32, Word64) import Database.PostgreSQL.Simple.Types (Binary(..), In(..), Null) 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 Data.Vector (Vector) import qualified Data.Vector as V import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Time -- | 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. | EscapeByteA ByteString -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding -- quotes. This is used by the 'Binary' newtype wrapper. | 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 (EscapeByteA b) = "EscapeByteA " ++ 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 ')')] 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 (Binary SB.ByteString) where toField (Binary bs) = EscapeByteA bs {-# INLINE toField #-} instance ToField (Binary LB.ByteString) where toField (Binary bs) = (EscapeByteA . SB.concat . LB.toChunks) bs {-# 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 . inQuotes . utcTimeToBuilder {-# INLINE toField #-} instance ToField ZonedTime where toField = Plain . inQuotes . zonedTimeToBuilder {-# INLINE toField #-} instance ToField LocalTime where toField = Plain . inQuotes . localTimeToBuilder {-# INLINE toField #-} instance ToField Day where toField = Plain . inQuotes . dayToBuilder {-# INLINE toField #-} instance ToField TimeOfDay where toField = Plain . inQuotes . timeOfDayToBuilder {-# INLINE toField #-} instance ToField UTCTimestamp where toField = Plain . inQuotes . utcTimestampToBuilder {-# INLINE toField #-} instance ToField ZonedTimestamp where toField = Plain . inQuotes . zonedTimestampToBuilder {-# INLINE toField #-} instance ToField LocalTimestamp where toField = Plain . inQuotes . localTimestampToBuilder {-# INLINE toField #-} instance ToField Date where toField = Plain . inQuotes . dateToBuilder {-# INLINE toField #-} instance (ToField a) => ToField (Vector a) where toField xs = Many $ Plain (fromByteString "ARRAY[") : (intersperse (Plain (fromChar ',')) . map toField $ V.toList xs) ++ [Plain (fromChar ']')] -- Because the ARRAY[...] input syntax is being used, it is possible -- that the use of type-specific separator characters is unnecessary. -- | Surround a string with single-quote characters: \"@'@\" -- -- This function /does not/ perform any other escaping. inQuotes :: Builder -> Builder inQuotes b = quote `mappend` b `mappend` quote where quote = Utf8.fromChar '\'' postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Transaction.hs0000644000000000000000000002303312173400557024111 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Database.PostgreSQL.Simple.Transaction ( -- * Transaction handling withTransaction , withTransactionLevel , withTransactionMode , withTransactionModeRetry , withTransactionSerializable , TransactionMode(..) , IsolationLevel(..) , ReadWriteMode(..) , defaultTransactionMode , defaultIsolationLevel , defaultReadWriteMode -- , Base.autocommit , begin , beginLevel , beginMode , commit , rollback -- * Savepoint , withSavepoint , Savepoint , newSavepoint , releaseSavepoint , rollbackToSavepoint , rollbackToAndReleaseSavepoint -- * Error predicates , isSerializationError , isNoActiveTransactionError , isFailedTransactionError ) where import qualified Control.Exception as E import Data.ByteString (ByteString) import qualified Data.ByteString as B import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.Compat (mask, (<>)) -- | Of the four isolation levels defined by the SQL standard, -- these are the three levels distinguished by PostgreSQL as of version 9.0. -- See -- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead' -- was equivalent to 'Serializable'. data IsolationLevel = DefaultIsolationLevel -- ^ the isolation level will be taken from -- PostgreSQL's per-connection -- @default_transaction_isolation@ variable, -- which is initialized according to the -- server's config. The default configuration -- is 'ReadCommitted'. | ReadCommitted | RepeatableRead | Serializable deriving (Show, Eq, Ord, Enum, Bounded) data ReadWriteMode = DefaultReadWriteMode -- ^ the read-write mode will be taken from -- PostgreSQL's per-connection -- @default_transaction_read_only@ variable, -- which is initialized according to the -- server's config. The default configuration -- is 'ReadWrite'. | ReadWrite | ReadOnly deriving (Show, Eq, Ord, Enum, Bounded) data TransactionMode = TransactionMode { isolationLevel :: !IsolationLevel, readWriteMode :: !ReadWriteMode } deriving (Show, Eq) defaultTransactionMode :: TransactionMode defaultTransactionMode = TransactionMode defaultIsolationLevel defaultReadWriteMode defaultIsolationLevel :: IsolationLevel defaultIsolationLevel = DefaultIsolationLevel defaultReadWriteMode :: ReadWriteMode defaultReadWriteMode = DefaultReadWriteMode -- | Execute an action inside a SQL transaction. -- -- This function initiates a transaction with a \"@begin -- transaction@\" statement, then executes the supplied action. If -- the action succeeds, the transaction will be completed with -- 'Base.commit' before this function returns. -- -- If the action throws /any/ kind of exception (not just a -- PostgreSQL-related exception), the transaction will be rolled back using -- 'rollback', then the exception will be rethrown. -- -- For nesting transactions, see 'withSavepoint'. withTransaction :: Connection -> IO a -> IO a withTransaction = withTransactionMode defaultTransactionMode -- | Execute an action inside of a 'Serializable' transaction. If a -- serialization failure occurs, roll back the transaction and try again. -- Be warned that this may execute the IO action multiple times. -- -- A 'Serializable' transaction creates the illusion that your program has -- exclusive access to the database. This means that, even in a concurrent -- setting, you can perform queries in sequence without having to worry about -- what might happen between one statement and the next. -- -- Think of it as STM, but without @retry@. withTransactionSerializable :: Connection -> IO a -> IO a withTransactionSerializable = withTransactionModeRetry TransactionMode { isolationLevel = Serializable , readWriteMode = ReadWrite } isSerializationError -- | Execute an action inside a SQL transaction with a given isolation level. withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a withTransactionLevel lvl = withTransactionMode defaultTransactionMode { isolationLevel = lvl } -- | Execute an action inside a SQL transaction with a given transaction mode. withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a withTransactionMode mode conn act = mask $ \restore -> do beginMode mode conn r <- restore act `E.onException` rollback conn commit conn return r -- | Like 'withTransactionMode', but also takes a custom callback to -- determine if a transaction should be retried if an 'SqlError' occurs. -- If the callback returns True, then the transaction will be retried. -- If the callback returns False, or an exception other than an 'SqlError' -- occurs then the transaction will be rolled back and the exception rethrown. -- -- This is used to implement 'withTransactionSerializable'. withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a withTransactionModeRetry mode shouldRetry conn act = mask $ \restore -> retryLoop $ E.try $ do a <- restore act commit conn return a where retryLoop :: IO (Either E.SomeException a) -> IO a retryLoop act' = do beginMode mode conn r <- act' case r of Left e -> do rollback conn case fmap shouldRetry (E.fromException e) of Just True -> retryLoop act' _ -> E.throwIO e Right a -> return a -- | Rollback a transaction. rollback :: Connection -> IO () rollback conn = execute_ conn "ABORT" >> return () -- | Commit a transaction. commit :: Connection -> IO () commit conn = execute_ conn "COMMIT" >> return () -- | Begin a transaction. begin :: Connection -> IO () begin = beginMode defaultTransactionMode -- | Begin a transaction with a given isolation level beginLevel :: IsolationLevel -> Connection -> IO () beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl } -- | Begin a transaction with a given transaction mode beginMode :: TransactionMode -> Connection -> IO () beginMode mode conn = do _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode]) return () where isolevel = case isolationLevel mode of DefaultIsolationLevel -> "" ReadCommitted -> " ISOLATION LEVEL READ COMMITTED" RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ" Serializable -> " ISOLATION LEVEL SERIALIZABLE" readmode = case readWriteMode mode of DefaultReadWriteMode -> "" ReadWrite -> " READ WRITE" ReadOnly -> " READ ONLY" ------------------------------------------------------------------------ -- Savepoint -- | Create a savepoint, and roll back to it if an error occurs. This may only -- be used inside of a transaction, and provides a sort of -- \"nested transaction\". -- -- See withSavepoint :: Connection -> IO a -> IO a withSavepoint conn body = mask $ \restore -> do sp <- newSavepoint conn r <- restore body `E.onException` rollbackToAndReleaseSavepoint conn sp releaseSavepoint conn sp `E.catch` \err -> if isFailedTransactionError err then rollbackToAndReleaseSavepoint conn sp else E.throwIO err return r -- | Create a new savepoint. This may only be used inside of a transaction. newSavepoint :: Connection -> IO Savepoint newSavepoint conn = do name <- newTempName conn _ <- execute_ conn ("SAVEPOINT " <> name) return (Savepoint name) -- | Destroy a savepoint, but retain its effects. -- -- Warning: this will throw a 'SqlError' matching 'isFailedTransactionError' if -- the transaction is aborted due to an error. 'commit' would merely warn and -- roll back. releaseSavepoint :: Connection -> Savepoint -> IO () releaseSavepoint conn (Savepoint name) = execute_ conn ("RELEASE SAVEPOINT " <> name) >> return () -- | Roll back to a savepoint. This will not release the savepoint. rollbackToSavepoint :: Connection -> Savepoint -> IO () rollbackToSavepoint conn (Savepoint name) = execute_ conn ("ROLLBACK TO SAVEPOINT " <> name) >> return () -- | Roll back to a savepoint and release it. This is like calling -- 'rollbackToSavepoint' followed by 'releaseSavepoint', but avoids a -- round trip to the database server. rollbackToAndReleaseSavepoint :: Connection -> Savepoint -> IO () rollbackToAndReleaseSavepoint conn (Savepoint name) = execute_ conn sql >> return () where sql = "ROLLBACK TO SAVEPOINT " <> name <> "; RELEASE SAVEPOINT " <> name ------------------------------------------------------------------------ -- Error predicates -- -- http://www.postgresql.org/docs/current/static/errcodes-appendix.html isSerializationError :: SqlError -> Bool isSerializationError = isSqlState "40001" isNoActiveTransactionError :: SqlError -> Bool isNoActiveTransactionError = isSqlState "25P01" isFailedTransactionError :: SqlError -> Bool isFailedTransactionError = isSqlState "25P02" isSqlState :: ByteString -> SqlError -> Bool isSqlState s SqlError{..} = sqlState == s postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Copy.hs0000644000000000000000000002041012173400557022532 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Copy -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- mid-level support for COPY IN and COPY OUT. See -- for -- more information. -- -- To use this binding, first call 'copy' with a @COPY FROM STDIN@ -- or @COPY TO STDOUT@ query as documented in the link above. Then -- call @getCopyData@ repeatedly until it returns 'CopyOutDone' in -- the former case, or in the latter, call @putCopyData@ repeatedly -- and then finish by calling either @putCopyEnd@ to proceed or -- @putCopyError@ to abort. -- -- You cannot issue another query on the same connection while a copy -- is ongoing; this will result in an exception. It is harmless to -- concurrently call @getNotification@ on a connection while it is in -- a copy in or copy out state, however be aware that current versions -- of the PostgreSQL backend will not deliver notifications to a client -- while a transaction is ongoing. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Copy ( copy , copy_ , CopyOutResult(..) , getCopyData , putCopyData , putCopyEnd , putCopyError ) where import Control.Applicative import Control.Concurrent import Control.Exception ( throwIO ) import qualified Data.Attoparsec.ByteString.Char8 as P import Data.Typeable(Typeable) import Data.Int(Int64) import qualified Data.ByteString.Char8 as B import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple import Database.PostgreSQL.Simple.Types import Database.PostgreSQL.Simple.Internal -- | Issue a query that changes a connection's state to @CopyIn@ -- (via a @COPY FROM STDIN@ query) or @CopyOut@ (via @COPY TO STDOUT@) -- query. Performs parameter subsitution. copy :: ( ToRow params ) => Connection -> Query -> params -> IO () copy conn template qs = do q <- formatQuery conn template qs doCopy "Database.PostgreSQL.Simple.Copy.copy" conn template q -- | Issue a query that changes a connection's state to @CopyIn@ -- (via a @COPY FROM STDIN@ query) or @CopyOut@ (via @COPY TO STDOUT@) -- query. Does not perform parameter subsitution. copy_ :: Connection -> Query -> IO () copy_ conn (Query q) = do doCopy "Database.PostgreSQL.Simple.Copy.copy_" conn (Query q) q doCopy :: B.ByteString -> Connection -> Query -> B.ByteString -> IO () doCopy funcName conn template q = do result <- exec conn q status <- PQ.resultStatus result let err = throwIO $ QueryError (B.unpack funcName ++ " " ++ show status) template case status of PQ.EmptyQuery -> err PQ.CommandOk -> err PQ.TuplesOk -> err PQ.CopyOut -> return () PQ.CopyIn -> return () PQ.BadResponse -> throwResultError funcName result status PQ.NonfatalError -> throwResultError funcName result status PQ.FatalError -> throwResultError funcName result status data CopyOutResult = CopyOutRow !B.ByteString -- ^ Data representing either exactly -- one row of the result, or header -- or footer data depending on format. | CopyOutDone {-# UNPACK #-} !Int64 -- ^ No more rows, and a count of the -- number of rows returned. deriving (Eq, Typeable, Show) -- | A connection must be in the @CopyOut@ state in order to call this -- function, via a @COPY TO STDOUT@ query. If this returns a 'CopyOutRow', -- the connection remains in the @CopyOut@ state, if it returns 'CopyOutDone', -- then the connection has reverted to the ready state. getCopyData :: Connection -> IO CopyOutResult getCopyData conn = withConnection conn loop where funcName = "Database.PostgreSQL.Simple.Copy.getCopyData" loop pqconn = do #if defined(mingw32_HOST_OS) row <- PQ.getCopyData pqconn False #else row <- PQ.getCopyData pqconn True #endif case row of PQ.CopyOutRow rowdata -> return $! CopyOutRow rowdata PQ.CopyOutDone -> CopyOutDone <$> getCopyCommandTag funcName pqconn #if defined(mingw32_HOST_OS) PQ.CopyOutWouldBlock -> do fail (B.unpack funcName ++ ": the impossible happened") #else PQ.CopyOutWouldBlock -> do mfd <- PQ.socket pqconn case mfd of Nothing -> throwIO (fdError funcName) Just fd -> do threadWaitRead fd _ <- PQ.consumeInput pqconn loop pqconn #endif PQ.CopyOutError -> do mmsg <- PQ.errorMessage pqconn throwIO SqlError { sqlState = "", sqlExecStatus = FatalError, sqlErrorMsg = maybe "" id mmsg, sqlErrorDetail = "", sqlErrorHint = funcName } -- | A connection must be in the @CopyIn@ state in order to call this -- function, via a @COPY FROM STDIN@ query. The connection remains -- in a @CopyIn@ state after this function is called. Note that -- the data does not need to represent a single row, or even an -- integral number of rows. The net result of -- @putCopyData conn a >> putCopyData conn b@ -- is the same as @putCopyData conn c@ whenever @c == BS.append a b@. putCopyData :: Connection -> B.ByteString -> IO () putCopyData conn dat = withConnection conn $ \pqconn -> do doCopyIn funcName (\c -> PQ.putCopyData c dat) pqconn where funcName = "Database.PostgreSQL.Simple.Copy.putCopyData" -- | A connection must be in the @CopyIn@ state in order to call this -- function, via a @COPY FROM STDIN@ query. Completes the COPY IN -- operation, changing the connection's state back to normal. -- Returns the number of rows processed. putCopyEnd :: Connection -> IO Int64 putCopyEnd conn = withConnection conn $ \pqconn -> do doCopyIn funcName (\c -> PQ.putCopyEnd c Nothing) pqconn getCopyCommandTag funcName pqconn where funcName = "Database.PostgreSQL.Simple.Copy.putCopyEnd" -- | A connection must be in the @CopyIn@ state in order to call this -- function, via a @COPY FROM STDIN@ query. Aborts the COPY IN -- operation, changing the connection's state back to normal. putCopyError :: Connection -> B.ByteString -> IO () putCopyError conn err = withConnection conn $ \pqconn -> do doCopyIn funcName (\c -> PQ.putCopyEnd c (Just err)) pqconn where funcName = "Database.PostgreSQL.Simple.Copy.putCopyError" doCopyIn :: B.ByteString -> (PQ.Connection -> IO PQ.CopyInResult) -> PQ.Connection -> IO () doCopyIn funcName action = loop where loop pqconn = do stat <- action pqconn case stat of PQ.CopyInOk -> return () PQ.CopyInError -> do mmsg <- PQ.errorMessage pqconn throwIO SqlError { sqlState = "", sqlExecStatus = FatalError, sqlErrorMsg = maybe "" id mmsg, sqlErrorDetail = "", sqlErrorHint = funcName } PQ.CopyInWouldBlock -> do mfd <- PQ.socket pqconn case mfd of Nothing -> throwIO (fdError funcName) Just fd -> do threadWaitWrite fd loop pqconn {-# INLINE doCopyIn #-} getCopyCommandTag :: B.ByteString -> PQ.Connection -> IO Int64 getCopyCommandTag funcName pqconn = do result <- maybe (fail errCmdStatus) return =<< PQ.getResult pqconn cmdStat <- maybe (fail errCmdStatus) return =<< PQ.cmdStatus result let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput) case P.parseOnly rowCount cmdStat of Left _ -> fail errCmdStatusFmt Right n -> return $! n where errCmdStatus = B.unpack funcName ++ ": failed to fetch command status" errCmdStatusFmt = B.unpack funcName ++ ": failed to parse command status" postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Ok.hs0000644000000000000000000000525312173400557022201 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} ------------------------------------------------------------------------------ -- | -- Module : Database.PostgreSQL.Simple.Ok -- Copyright : (c) 2012 Leon P Smith -- License : BSD3 -- -- Maintainer : leon@melding-monads.com -- Stability : experimental -- -- The 'Ok' type is a simple error handler, basically equivalent to -- @Either [SomeException]@. This type (without the list) was used to -- handle conversion errors in early versions of postgresql-simple. -- -- One of the primary reasons why this type was introduced is that -- @Either SomeException@ had not been provided an instance for 'Alternative', -- and it would have been a bad idea to provide an orphaned instance for a -- commonly-used type and typeclass included in @base@. -- -- Extending the failure case to a list of 'SomeException's enables a -- more sensible 'Alternative' instance definitions: '<|>' concatinates -- the list of exceptions when both cases fail, and 'empty' is defined as -- 'Errors []'. Though '<|>' one could pick one of two exceptions, and -- throw away the other, and have 'empty' provide a generic exception, -- this avoids cases where 'empty' overrides a more informative exception -- and allows you to see all the different ways your computation has failed. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Ok where import Control.Applicative import Control.Exception import Control.Monad(MonadPlus(..)) import Data.Typeable -- FIXME: [SomeException] should probably be something else, maybe -- a difference list (or a tree?) data Ok a = Errors [SomeException] | Ok !a deriving(Show, Typeable, Functor) -- | Two 'Errors' cases are considered equal, regardless of what the -- list of exceptions looks like. 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 fail str = Errors [SomeException (ErrorCall str)] -- | a way to reify a list of exceptions into a single exception newtype ManyErrors = ManyErrors [SomeException] deriving (Show, Typeable) instance Exception ManyErrors postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/ToRow.hs0000644000000000000000000000634212173400557022702 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.ToRow -- Copyright: (c) 2011 MailRank, Inc. -- (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- The 'ToRow' 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 instance (ToRow a, ToRow b) => ToRow (a :. b) where toRow (a :. b) = toRow a ++ toRow b postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/HStore/0000755000000000000000000000000012173400557022473 5ustar0000000000000000postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/HStore/Internal.hs0000644000000000000000000000117112173400557024603 0ustar0000000000000000{-# OPTIONS_HADDOCK hide #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.HStore.Internal -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.HStore.Internal ( HStoreBuilder(..) , HStoreText(..) , parseHStore , parseHStoreKeyVal , parseHStoreText ) where import Database.PostgreSQL.Simple.HStore.Implementation postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/HStore/Implementation.hs0000644000000000000000000001542512173400557026023 0ustar0000000000000000{-# LANGUAGE ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.HStore.Implementation -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- This code has yet to be profiled and optimized. -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.HStore.Implementation where import Control.Applicative import Blaze.ByteString.Builder as Blaze ( Builder, toLazyByteString, copyByteString ) import Blaze.ByteString.Builder.Char8 (fromChar) import qualified Data.Attoparsec.ByteString as P import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8) import qualified Data.ByteString as BS import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Internal as BL import Data.Map(Map) import qualified Data.Map as Map import Data.Text(Text) import qualified Data.Text as TS import qualified Data.Text.Encoding as TS import Data.Text.Encoding.Error(UnicodeException) import qualified Data.Text.Lazy as TL import Data.Typeable import Data.Monoid(Monoid(..)) import Database.PostgreSQL.Simple.FromField import Database.PostgreSQL.Simple.ToField class ToHStore a where toHStore :: a -> HStoreBuilder -- | Represents valid hstore syntax. data HStoreBuilder = Empty | Comma !Builder deriving (Typeable) instance ToHStore HStoreBuilder where toHStore = id toBuilder :: HStoreBuilder -> Builder toBuilder x = case x of Empty -> mempty Comma x -> x toLazyByteString :: HStoreBuilder -> BL.ByteString toLazyByteString x = case x of Empty -> BL.empty Comma x -> Blaze.toLazyByteString x instance Monoid HStoreBuilder where mempty = Empty mappend Empty x = x mappend (Comma a) x = Comma (a `mappend` case x of Empty -> mempty Comma b -> fromChar ',' `mappend` b) class ToHStoreText a where toHStoreText :: a -> HStoreText -- | Represents escape text, ready to be the key or value to a hstore value newtype HStoreText = HStoreText Builder deriving (Typeable, Monoid) instance ToHStoreText HStoreText where toHStoreText = id -- | Assumed to be UTF-8 encoded instance ToHStoreText BS.ByteString where toHStoreText str = HStoreText (escapeAppend str mempty) -- | Assumed to be UTF-8 encoded instance ToHStoreText BL.ByteString where toHStoreText = HStoreText . BL.foldrChunks escapeAppend mempty instance ToHStoreText TS.Text where toHStoreText str = HStoreText (escapeAppend (TS.encodeUtf8 str) mempty) instance ToHStoreText TL.Text where toHStoreText = HStoreText . TL.foldrChunks (escapeAppend . TS.encodeUtf8) mempty escapeAppend :: BS.ByteString -> Builder -> Builder escapeAppend = loop where loop (BS.break quoteNeeded -> (a,b)) rest = copyByteString a `mappend` case BS.uncons b of Nothing -> rest Just (c,d) -> quoteChar c `mappend` loop d rest quoteNeeded c = c == c2w '\"' || c == c2w '\\' quoteChar c | c == c2w '\"' = copyByteString "\\\"" | otherwise = copyByteString "\\\\" hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) = Comma (fromChar '"' `mappend` key `mappend` copyByteString "\"=>\"" `mappend` val `mappend` fromChar '"') instance ToField HStoreBuilder where toField Empty = toField (BS.empty) toField (Comma x) = toField (Blaze.toLazyByteString x) newtype HStoreList = HStoreList [(Text,Text)] deriving (Typeable, Show) -- | hstore instance ToHStore HStoreList where toHStore (HStoreList xs) = mconcat (map (uncurry hstore) xs) instance ToField HStoreList where toField xs = toField (toHStore xs) -- | hstore instance FromField HStoreList where fromField f mdat = do typ <- typename f if typ /= "hstore" then returnError Incompatible f "" else case mdat of Nothing -> returnError UnexpectedNull f "" Just dat -> case P.parseOnly (parseHStore <* P.endOfInput) dat of Left err -> returnError ConversionFailed f err Right (Left err) -> returnError ConversionFailed f "unicode exception" <|> conversionError err Right (Right val) -> return val newtype HStoreMap = HStoreMap (Map Text Text) deriving (Eq, Ord, Typeable, Show) instance ToHStore HStoreMap where toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs where f k v xs = hstore k v `mappend` xs instance ToField HStoreMap where toField xs = toField (toHStore xs) instance FromField HStoreMap where fromField f mdat = convert <$> fromField f mdat where convert (HStoreList xs) = HStoreMap (Map.fromList xs) parseHStore :: P.Parser (Either UnicodeException HStoreList) parseHStore = do kvs <- P.sepBy' (skipWhiteSpace *> parseHStoreKeyVal) (skipWhiteSpace *> P.word8 (c2w ',')) return $ HStoreList <$> sequence kvs parseHStoreKeyVal :: P.Parser (Either UnicodeException (Text,Text)) parseHStoreKeyVal = do mkey <- parseHStoreText case mkey of Left err -> return (Left err) Right key -> do skipWhiteSpace _ <- P.string "=>" skipWhiteSpace mval <- parseHStoreText case mval of Left err -> return (Left err) Right val -> return (Right (key,val)) skipWhiteSpace :: P.Parser () skipWhiteSpace = P.skipWhile P.isSpace_w8 parseHStoreText :: P.Parser (Either UnicodeException Text) parseHStoreText = do _ <- P.word8 (c2w '"') mtexts <- parseHStoreTexts id case mtexts of Left err -> return (Left err) Right texts -> do _ <- P.word8 (c2w '"') return (Right (TS.concat texts)) parseHStoreTexts :: ([Text] -> [Text]) -> P.Parser (Either UnicodeException [Text]) parseHStoreTexts acc = do mchunk <- TS.decodeUtf8' <$> P.takeWhile (not . isSpecialChar) case mchunk of Left err -> return (Left err) Right chunk -> (do _ <- P.word8 (c2w '\\') c <- TS.singleton . w2c <$> P.satisfy isSpecialChar parseHStoreTexts (acc . (chunk:) . (c:)) ) <|> return (Right (acc [chunk])) where isSpecialChar c = c == c2w '\\' || c == c2w '"' postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/TypeInfo/0000755000000000000000000000000012173400557023024 5ustar0000000000000000postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs0000644000000000000000000000340212173400557024463 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.TypeInfo.Types -- Copyright: (c) 2013 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.TypeInfo.Types where import Data.ByteString(ByteString) import Database.PostgreSQL.LibPQ(Oid) import Data.Vector(Vector) -- | A structure representing some of the metadata regarding a PostgreSQL -- type, mostly taken from the @pg_type@ table. data TypeInfo = Basic { typoid :: {-# UNPACK #-} !Oid , typcategory :: {-# UNPACK #-} !Char , typdelim :: {-# UNPACK #-} !Char , typname :: !ByteString } | Array { typoid :: {-# UNPACK #-} !Oid , typcategory :: {-# UNPACK #-} !Char , typdelim :: {-# UNPACK #-} !Char , typname :: !ByteString , typelem :: !TypeInfo } | Range { typoid :: {-# UNPACK #-} !Oid , typcategory :: {-# UNPACK #-} !Char , typdelim :: {-# UNPACK #-} !Char , typname :: !ByteString , rngsubtype :: !TypeInfo } | Composite { typoid :: {-# UNPACK #-} !Oid , typcategory :: {-# UNPACK #-} !Char , typdelim :: {-# UNPACK #-} !Char , typname :: !ByteString , typrelid :: {-# UNPACK #-} !Oid , attributes :: !(Vector Attribute) } deriving (Show) data Attribute = Attribute { attname :: !ByteString , atttype :: !TypeInfo } deriving (Show) postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs0000644000000000000000000002145312173400557024614 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.TypeInfo -- Copyright: (c) 2011-2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- -- Note that this module is semi-internal, and you probably want to use -- Database.PostgreSQL.Simple.TypeInfo instead. -- ------------------------------------------------------------------------------ -- Note that this file is generated by tools/GenTypeInfo.hs, and should -- not be edited directly module Database.PostgreSQL.Simple.TypeInfo.Static ( TypeInfo(..) , staticTypeInfo , bool , bytea , char , name , int8 , int2 , int4 , regproc , text , oid , tid , xid , cid , xml , point , lseg , path , box , polygon , line , cidr , float4 , float8 , abstime , reltime , tinterval , unknown , circle , money , macaddr , inet , bpchar , varchar , date , time , timestamp , timestamptz , interval , timetz , bit , varbit , numeric , refcursor , record , void , uuid ) where import Database.PostgreSQL.LibPQ (Oid(..)) import Database.PostgreSQL.Simple.TypeInfo.Types staticTypeInfo :: Oid -> Maybe TypeInfo staticTypeInfo (Oid x) = case x of 16 -> Just bool 17 -> Just bytea 18 -> Just char 19 -> Just name 20 -> Just int8 21 -> Just int2 23 -> Just int4 24 -> Just regproc 25 -> Just text 26 -> Just oid 27 -> Just tid 28 -> Just xid 29 -> Just cid 142 -> Just xml 600 -> Just point 601 -> Just lseg 602 -> Just path 603 -> Just box 604 -> Just polygon 628 -> Just line 650 -> Just cidr 700 -> Just float4 701 -> Just float8 702 -> Just abstime 703 -> Just reltime 704 -> Just tinterval 705 -> Just unknown 718 -> Just circle 790 -> Just money 829 -> Just macaddr 869 -> Just inet 1042 -> Just bpchar 1043 -> Just varchar 1082 -> Just date 1083 -> Just time 1114 -> Just timestamp 1184 -> Just timestamptz 1186 -> Just interval 1266 -> Just timetz 1560 -> Just bit 1562 -> Just varbit 1700 -> Just numeric 1790 -> Just refcursor 2249 -> Just record 2278 -> Just void 2950 -> Just uuid _ -> Nothing bool :: TypeInfo bool = Basic { typoid = Oid 16, typcategory = 'B', typdelim = ',', typname = "bool" } bytea :: TypeInfo bytea = Basic { typoid = Oid 17, typcategory = 'U', typdelim = ',', typname = "bytea" } char :: TypeInfo char = Basic { typoid = Oid 18, typcategory = 'S', typdelim = ',', typname = "char" } name :: TypeInfo name = Basic { typoid = Oid 19, typcategory = 'S', typdelim = ',', typname = "name" } int8 :: TypeInfo int8 = Basic { typoid = Oid 20, typcategory = 'N', typdelim = ',', typname = "int8" } int2 :: TypeInfo int2 = Basic { typoid = Oid 21, typcategory = 'N', typdelim = ',', typname = "int2" } int4 :: TypeInfo int4 = Basic { typoid = Oid 23, typcategory = 'N', typdelim = ',', typname = "int4" } regproc :: TypeInfo regproc = Basic { typoid = Oid 24, typcategory = 'N', typdelim = ',', typname = "regproc" } text :: TypeInfo text = Basic { typoid = Oid 25, typcategory = 'S', typdelim = ',', typname = "text" } oid :: TypeInfo oid = Basic { typoid = Oid 26, typcategory = 'N', typdelim = ',', typname = "oid" } tid :: TypeInfo tid = Basic { typoid = Oid 27, typcategory = 'U', typdelim = ',', typname = "tid" } xid :: TypeInfo xid = Basic { typoid = Oid 28, typcategory = 'U', typdelim = ',', typname = "xid" } cid :: TypeInfo cid = Basic { typoid = Oid 29, typcategory = 'U', typdelim = ',', typname = "cid" } xml :: TypeInfo xml = Basic { typoid = Oid 142, typcategory = 'U', typdelim = ',', typname = "xml" } point :: TypeInfo point = Basic { typoid = Oid 600, typcategory = 'G', typdelim = ',', typname = "point" } lseg :: TypeInfo lseg = Basic { typoid = Oid 601, typcategory = 'G', typdelim = ',', typname = "lseg" } path :: TypeInfo path = Basic { typoid = Oid 602, typcategory = 'G', typdelim = ',', typname = "path" } box :: TypeInfo box = Basic { typoid = Oid 603, typcategory = 'G', typdelim = ';', typname = "box" } polygon :: TypeInfo polygon = Basic { typoid = Oid 604, typcategory = 'G', typdelim = ',', typname = "polygon" } line :: TypeInfo line = Basic { typoid = Oid 628, typcategory = 'G', typdelim = ',', typname = "line" } cidr :: TypeInfo cidr = Basic { typoid = Oid 650, typcategory = 'I', typdelim = ',', typname = "cidr" } float4 :: TypeInfo float4 = Basic { typoid = Oid 700, typcategory = 'N', typdelim = ',', typname = "float4" } float8 :: TypeInfo float8 = Basic { typoid = Oid 701, typcategory = 'N', typdelim = ',', typname = "float8" } abstime :: TypeInfo abstime = Basic { typoid = Oid 702, typcategory = 'D', typdelim = ',', typname = "abstime" } reltime :: TypeInfo reltime = Basic { typoid = Oid 703, typcategory = 'T', typdelim = ',', typname = "reltime" } tinterval :: TypeInfo tinterval = Basic { typoid = Oid 704, typcategory = 'T', typdelim = ',', typname = "tinterval" } unknown :: TypeInfo unknown = Basic { typoid = Oid 705, typcategory = 'X', typdelim = ',', typname = "unknown" } circle :: TypeInfo circle = Basic { typoid = Oid 718, typcategory = 'G', typdelim = ',', typname = "circle" } money :: TypeInfo money = Basic { typoid = Oid 790, typcategory = 'N', typdelim = ',', typname = "money" } macaddr :: TypeInfo macaddr = Basic { typoid = Oid 829, typcategory = 'U', typdelim = ',', typname = "macaddr" } inet :: TypeInfo inet = Basic { typoid = Oid 869, typcategory = 'I', typdelim = ',', typname = "inet" } bpchar :: TypeInfo bpchar = Basic { typoid = Oid 1042, typcategory = 'S', typdelim = ',', typname = "bpchar" } varchar :: TypeInfo varchar = Basic { typoid = Oid 1043, typcategory = 'S', typdelim = ',', typname = "varchar" } date :: TypeInfo date = Basic { typoid = Oid 1082, typcategory = 'D', typdelim = ',', typname = "date" } time :: TypeInfo time = Basic { typoid = Oid 1083, typcategory = 'D', typdelim = ',', typname = "time" } timestamp :: TypeInfo timestamp = Basic { typoid = Oid 1114, typcategory = 'D', typdelim = ',', typname = "timestamp" } timestamptz :: TypeInfo timestamptz = Basic { typoid = Oid 1184, typcategory = 'D', typdelim = ',', typname = "timestamptz" } interval :: TypeInfo interval = Basic { typoid = Oid 1186, typcategory = 'T', typdelim = ',', typname = "interval" } timetz :: TypeInfo timetz = Basic { typoid = Oid 1266, typcategory = 'D', typdelim = ',', typname = "timetz" } bit :: TypeInfo bit = Basic { typoid = Oid 1560, typcategory = 'V', typdelim = ',', typname = "bit" } varbit :: TypeInfo varbit = Basic { typoid = Oid 1562, typcategory = 'V', typdelim = ',', typname = "varbit" } numeric :: TypeInfo numeric = Basic { typoid = Oid 1700, typcategory = 'N', typdelim = ',', typname = "numeric" } refcursor :: TypeInfo refcursor = Basic { typoid = Oid 1790, typcategory = 'U', typdelim = ',', typname = "refcursor" } record :: TypeInfo record = Basic { typoid = Oid 2249, typcategory = 'P', typdelim = ',', typname = "record" } void :: TypeInfo void = Basic { typoid = Oid 2278, typcategory = 'P', typdelim = ',', typname = "void" } uuid :: TypeInfo uuid = Basic { typoid = Oid 2950, typcategory = 'U', typdelim = ',', typname = "uuid" } postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Time/0000755000000000000000000000000012173400557022165 5ustar0000000000000000postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Time/Internal.hs0000644000000000000000000000125212173400557024275 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Time.Internal -- Copyright: (c) 2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ module Database.PostgreSQL.Simple.Time.Internal ( getDay , getDate , getTimeOfDay , getLocalTime , getLocalTimestamp , getTimeZone , getZonedTime , getZonedTimestamp , getUTCTime , getUTCTimestamp ) where import Database.PostgreSQL.Simple.Time.Implementation postgresql-simple-0.3.4.0/src/Database/PostgreSQL/Simple/Time/Implementation.hs0000644000000000000000000002202512173400557025507 0ustar0000000000000000------------------------------------------------------------------------------ -- | -- Module: Database.PostgreSQL.Simple.Time.Implementation -- Copyright: (c) 2012 Leon P Smith -- License: BSD3 -- Maintainer: Leon P Smith -- Stability: experimental -- ------------------------------------------------------------------------------ {-# LANGUAGE DeriveDataTypeable #-} module Database.PostgreSQL.Simple.Time.Implementation where import Prelude hiding (take, (++)) import Blaze.ByteString.Builder(Builder, fromByteString) import Blaze.ByteString.Builder.Char8(fromChar) import Blaze.Text.Int(integral) import Control.Arrow((***)) import Control.Applicative import Control.Monad(when) import Data.Bits((.&.)) import qualified Data.ByteString as B import Data.ByteString.Internal (c2w, w2c) import Data.Time hiding (getTimeZone, getZonedTime) import Data.Typeable import Data.Word(Word8) import qualified Data.Attoparsec.Char8 as A import Data.Monoid(Monoid(..)) import Data.Fixed (Pico) import Unsafe.Coerce (++) :: Monoid a => a -> a -> a (++) = mappend infixr 5 ++ data Unbounded a = NegInfinity | Finite !a | PosInfinity deriving (Eq, Ord, Typeable) instance Show a => Show (Unbounded a) where showsPrec prec x rest = case x of NegInfinity -> "-infinity" ++ rest Finite time -> showsPrec prec time rest PosInfinity -> "infinity" ++ rest instance Read a => Read (Unbounded a) where readsPrec prec = readParen False $ \str -> case str of ('-':'i':'n':'f':'i':'n':'i':'t':'y':xs) -> [(NegInfinity,xs)] ( 'i':'n':'f':'i':'n':'i':'t':'y':xs) -> [(PosInfinity,xs)] xs -> map (Finite *** id) (readsPrec prec xs) type LocalTimestamp = Unbounded LocalTime type UTCTimestamp = Unbounded UTCTime type ZonedTimestamp = Unbounded ZonedTime type Date = Unbounded Day parseUTCTime :: B.ByteString -> Either String UTCTime parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput) parseZonedTime :: B.ByteString -> Either String ZonedTime parseZonedTime = A.parseOnly (getZonedTime <* A.endOfInput) parseLocalTime :: B.ByteString -> Either String LocalTime parseLocalTime = A.parseOnly (getLocalTime <* A.endOfInput) parseDay :: B.ByteString -> Either String Day parseDay = A.parseOnly (getDay <* A.endOfInput) parseTimeOfDay :: B.ByteString -> Either String TimeOfDay parseTimeOfDay = A.parseOnly (getTimeOfDay <* A.endOfInput) parseUTCTimestamp :: B.ByteString -> Either String UTCTimestamp parseUTCTimestamp = A.parseOnly (getUTCTimestamp <* A.endOfInput) parseZonedTimestamp :: B.ByteString -> Either String ZonedTimestamp parseZonedTimestamp = A.parseOnly (getZonedTimestamp <* A.endOfInput) parseLocalTimestamp :: B.ByteString -> Either String LocalTimestamp parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput) parseDate :: B.ByteString -> Either String Date parseDate = A.parseOnly (getDate <* A.endOfInput) getUnbounded :: A.Parser a -> A.Parser (Unbounded a) getUnbounded getFinite = (pure NegInfinity <* A.string "-infinity") <|> (pure PosInfinity <* A.string "infinity") <|> (Finite <$> getFinite) getDay :: A.Parser Day getDay = do yearStr <- A.takeWhile A.isDigit when (B.length yearStr < 4) (fail "year must consist of at least 4 digits") let !year = toNum yearStr _ <- A.char '-' month <- digits "month" _ <- A.char '-' day <- digits "day" case fromGregorianValid year month day of Nothing -> fail "invalid date" Just x -> return $! x getDate :: A.Parser Date getDate = getUnbounded getDay decimal :: Fractional a => B.ByteString -> a decimal str = toNum str / 10^(B.length str) {-# INLINE decimal #-} getTimeOfDay :: A.Parser TimeOfDay getTimeOfDay = do hour <- digits "hours" _ <- A.char ':' minute <- digits "minutes" _ <- A.char ':' second <- digits "seconds" subsec <- (A.char '.' *> (decimal <$> A.takeWhile1 A.isDigit)) <|> return 0 let !picos' = second + subsec case makeTimeOfDayValid hour minute picos' of Nothing -> fail "invalid time of day" Just x -> return $! x getLocalTime :: A.Parser LocalTime getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay) getLocalTimestamp :: A.Parser LocalTimestamp getLocalTimestamp = getUnbounded getLocalTime getTimeZone :: A.Parser TimeZone getTimeZone = do sign <- A.satisfy (\c -> c == '+' || c == '-') hours <- digits "timezone" mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0 let !absset = 60 * hours + mins !offset = if sign == '+' then absset else -absset return $! minutesToTimeZone offset getZonedTime :: A.Parser ZonedTime getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone getZonedTimestamp :: A.Parser ZonedTimestamp getZonedTimestamp = getUnbounded getZonedTime getUTCTime :: A.Parser UTCTime getUTCTime = do day <- getDay _ <- A.char ' ' time <- getTimeOfDay zone <- getTimeZone let (!dayDelta,!time') = localToUTCTimeOfDay zone time let !day' = addDays dayDelta day let !time'' = timeOfDayToTime time' return (UTCTime day' time'') getUTCTimestamp :: A.Parser UTCTimestamp getUTCTimestamp = getUnbounded getUTCTime toNum :: Num n => B.ByteString -> n toNum = B.foldl' (\a c -> 10*a + digit c) 0 {-# INLINE toNum #-} digit :: Num n => Word8 -> n digit c = fromIntegral (c .&. 0x0f) {-# INLINE digit #-} digits :: Num n => String -> A.Parser n digits msg = do x <- A.anyChar y <- A.anyChar if A.isDigit x && A.isDigit y then return $! (10 * digit (c2w x) + digit (c2w y)) else fail (msg ++ " is not 2 digits") {-# INLINE digits #-} dayToBuilder :: Day -> Builder dayToBuilder (toGregorian -> (y,m,d)) = do pad4 y ++ fromChar '-' ++ pad2 m ++ fromChar '-' ++ pad2 d timeOfDayToBuilder :: TimeOfDay -> Builder timeOfDayToBuilder (TimeOfDay h m s) = do pad2 h ++ fromChar ':' ++ pad2 m ++ fromChar ':' ++ showSeconds s timeZoneToBuilder :: TimeZone -> Builder timeZoneToBuilder tz | m == 0 = sign h ++ pad2 (abs h) | otherwise = sign h ++ pad2 (abs h) ++ fromChar ':' ++ pad2 (abs m) where (h,m) = timeZoneMinutes tz `quotRem` 60 sign h | h >= 0 = fromChar '+' | otherwise = fromChar '-' utcTimeToBuilder :: UTCTime -> Builder utcTimeToBuilder (UTCTime day time) = dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder (timeToTimeOfDay time) ++ fromByteString "+00" zonedTimeToBuilder :: ZonedTime -> Builder zonedTimeToBuilder (ZonedTime localTime tz) = localTimeToBuilder localTime ++ timeZoneToBuilder tz localTimeToBuilder :: LocalTime -> Builder localTimeToBuilder (LocalTime day tod) = dayToBuilder day ++ fromChar ' ' ++ timeOfDayToBuilder tod unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder) unboundedToBuilder finiteToBuilder unbounded = case unbounded of NegInfinity -> fromByteString "-infinity" Finite a -> finiteToBuilder a PosInfinity -> fromByteString "infinity" utcTimestampToBuilder :: UTCTimestamp -> Builder utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder zonedTimestampToBuilder :: ZonedTimestamp -> Builder zonedTimestampToBuilder = unboundedToBuilder zonedTimeToBuilder localTimestampToBuilder :: LocalTimestamp -> Builder localTimestampToBuilder = unboundedToBuilder localTimeToBuilder dateToBuilder :: Date -> Builder dateToBuilder = unboundedToBuilder dayToBuilder showSeconds :: Pico -> Builder showSeconds xyz | yz == 0 = pad2 x | z == 0 = pad2 x ++ fromChar '.' ++ showD6 y | otherwise = pad2 x ++ fromChar '.' ++ pad6 y ++ showD6 z where -- A kludge to work around the fact that Data.Fixed isn't very fast and -- doesn't give me access to the MkFixed constructor. (x_,yz) = (unsafeCoerce xyz :: Integer) `quotRem` 1000000000000 x = fromIntegral x_ :: Int (fromIntegral -> y, fromIntegral -> z) = yz `quotRem` 1000000 pad6 :: Int -> Builder pad6 xy = let (x,y) = xy `quotRem` 1000 in pad3 x ++ pad3 y showD6 :: Int -> Builder showD6 xy = case xy `quotRem` 1000 of (x,0) -> showD3 x (x,y) -> pad3 x ++ showD3 y pad3 :: Int -> Builder pad3 abc = let (ab,c) = abc `quotRem` 10 (a,b) = ab `quotRem` 10 in p a ++ p b ++ p c showD3 :: Int -> Builder showD3 abc = case abc `quotRem` 100 of (a, 0) -> p a (a,bc) -> case bc `quotRem` 10 of (b,0) -> p a ++ p b (b,c) -> p a ++ p b ++ p c -- | p assumes its input is in the range [0..9] p :: Integral n => n -> Builder p n = fromChar (w2c (fromIntegral (n + 48))) {-# INLINE p #-} -- | pad2 assumes its input is in the range [0..99] pad2 :: Integral n => n -> Builder pad2 n = let (a,b) = n `quotRem` 10 in p a ++ p b {-# INLINE pad2 #-} -- | pad4 assumes its input is positive pad4 :: (Integral n, Show n) => n -> Builder pad4 abcd | abcd >= 10000 = integral abcd | otherwise = p a ++ p b ++ p c ++ p d where (ab,cd) = abcd `quotRem` 100 (a,b) = ab `quotRem` 10 (c,d) = cd `quotRem` 10 {-# INLINE pad4 #-} postgresql-simple-0.3.4.0/test/0000755000000000000000000000000012173400557014517 5ustar0000000000000000postgresql-simple-0.3.4.0/test/Main.hs0000644000000000000000000002263112173400557015743 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ScopedTypeVariables #-} import Common import Database.PostgreSQL.Simple.FromField (FromField) import Database.PostgreSQL.Simple.HStore import qualified Database.PostgreSQL.Simple.Transaction as ST import Control.Applicative import Control.Exception as E import Control.Monad import Data.ByteString (ByteString) import Data.IORef import Data.Typeable import qualified Data.ByteString as B import qualified Data.Map as Map import Data.Text(Text) import System.Exit (exitFailure) import System.IO import qualified Data.Vector as V import Notify import Serializable import Time tests :: [TestEnv -> Test] tests = [ TestLabel "Bytea" . testBytea , TestLabel "ExecuteMany" . testExecuteMany , TestLabel "Fold" . testFold , TestLabel "Notify" . testNotify , TestLabel "Serializable" . testSerializable , TestLabel "Time" . testTime , TestLabel "Array" . testArray , TestLabel "HStore" . testHStore , TestLabel "Savepoint" . testSavepoint ] testBytea :: TestEnv -> Test testBytea TestEnv{..} = TestList [ testStr "empty" [] , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String) , testStr "ascending" [0..255] , testStr "descending" [255,254..0] , testStr "ascending, doubled up" $ doubleUp [0..255] , testStr "descending, doubled up" $ doubleUp [255,254..0] ] where testStr label bytes = TestLabel label $ TestCase $ do let bs = B.pack bytes [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs] assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs] assertBool "SQL -> Haskell conversion altered the string" $ bs == r doubleUp = concatMap (\x -> [x, x]) testExecuteMany :: TestEnv -> Test testExecuteMany TestEnv{..} = TestCase $ do execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)" let rows :: [(Int, String, Binary ByteString)] rows = [ (1, "hello", Binary "bye") , (2, "world", Binary "\0\r\t\n") , (3, "?", Binary "") ] count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows count @?= fromIntegral (length rows) rows' <- query_ conn "SELECT * FROM tmp_executeMany" rows' @?= rows return () testFold :: TestEnv -> Test testFold TestEnv{..} = TestCase $ do xs <- fold_ conn "SELECT generate_series(1,10000)" [] $ \xs (Only x) -> return (x:xs) reverse xs @?= ([1..10000] :: [Int]) ref <- newIORef [] forEach conn "SELECT * FROM generate_series(1,?) a, generate_series(1,?) b" (100 :: Int, 50 :: Int) $ \(a :: Int, b :: Int) -> do xs <- readIORef ref writeIORef ref $! (a,b):xs xs <- readIORef ref reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]] -- Make sure fold propagates our exception. ref <- newIORef [] True <- expectError (== TestException) $ forEach_ conn "SELECT generate_series(1,10)" $ \(Only a) -> if a == 5 then do -- Cause a SQL error to trip up CLOSE. True <- expectError isSyntaxError $ execute_ conn "asdf" True <- expectError ST.isFailedTransactionError $ (query_ conn "SELECT 1" :: IO [(Only Int)]) throwIO TestException else do xs <- readIORef ref writeIORef ref $! (a :: Int) : xs xs <- readIORef ref reverse xs @?= [1..4] withTransaction conn $ replicateM_ 2 $ do xs <- fold_ conn "VALUES (1), (2), (3), (4), (5)" [] $ \xs (Only x) -> return (x:xs) reverse xs @?= ([1..5] :: [Int]) ref <- newIORef [] forEach_ conn "SELECT generate_series(1,101)" $ \(Only a) -> forEach_ conn "SELECT generate_series(1,55)" $ \(Only b) -> do xs <- readIORef ref writeIORef ref $! (a :: Int, b :: Int) : xs xs <- readIORef ref reverse xs @?= [(a,b) | a <- [1..101], b <- [1..55]] xs <- fold_ conn "SELECT 1 WHERE FALSE" [] $ \xs (Only x) -> return (x:xs) xs @?= ([] :: [Int]) -- TODO: add more complete tests, e.g.: -- -- * Fold in a transaction -- -- * Fold in a transaction after a previous fold has been performed -- -- * Nested fold return () queryFailure :: forall a. (FromField a, Typeable a, Show a) => Connection -> Query -> a -> Assertion queryFailure conn q resultType = do x :: Either SomeException [Only a] <- E.try $ query_ conn q case x of Left _ -> return () Right val -> assertFailure ("Did not fail as expected: " ++ show q ++ " :: " ++ show (typeOf resultType) ++ " -> " ++ show val) testArray :: TestEnv -> Test testArray TestEnv{..} = TestCase $ do xs <- query_ conn "SELECT '{1,2,3,4}'::_int4" xs @?= [Only (V.fromList [1,2,3,4 :: Int])] xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4" xs @?= [Only (V.fromList [V.fromList [1,2], V.fromList [3,4 :: Int]])] queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool) queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int) testHStore :: TestEnv -> Test testHStore TestEnv{..} = TestCase $ do roundTrip [] roundTrip [("foo","bar"),("bar","baz"),("baz","hello")] roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] where roundTrip :: [(Text,Text)] -> Assertion roundTrip xs = do let m = Only (HStoreMap (Map.fromList xs)) m' <- query conn "SELECT ?::hstore" m [m] @?= m' testSavepoint :: TestEnv -> Test testSavepoint TestEnv{..} = TestCase $ do True <- expectError ST.isNoActiveTransactionError $ withSavepoint conn $ return () let getRows :: IO [Int] getRows = map fromOnly <$> query_ conn "SELECT a FROM tmp_savepoint ORDER BY a" withTransaction conn $ do execute_ conn "CREATE TEMPORARY TABLE tmp_savepoint (a INT UNIQUE)" execute_ conn "INSERT INTO tmp_savepoint VALUES (1)" [1] <- getRows withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (2)" [1,2] <- getRows return () [1,2] <- getRows withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" [1,2,3] <- getRows True <- expectError isUniqueViolation $ execute_ conn "INSERT INTO tmp_savepoint VALUES (2)" True <- expectError ST.isFailedTransactionError getRows -- Body returning successfully after handling error, -- but 'withSavepoint' will roll back without complaining. return () -- Rolling back clears the error condition. [1,2] <- getRows -- 'withSavepoint' will roll back after an exception, even if the -- exception wasn't SQL-related. True <- expectError (== TestException) $ withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" [1,2,3] <- getRows throwIO TestException [1,2] <- getRows -- Nested savepoint can be rolled back while the -- outer effects are retained. withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" True <- expectError isUniqueViolation $ withSavepoint conn $ do execute_ conn "INSERT INTO tmp_savepoint VALUES (4)" [1,2,3,4] <- getRows execute_ conn "INSERT INTO tmp_savepoint VALUES (4)" [1,2,3] <- getRows return () [1,2,3] <- getRows return () -- Transaction committed successfully, even though there were errors -- (but we rolled them back). [1,2,3] <- getRows return () data TestException = TestException deriving (Eq, Show, Typeable) instance Exception TestException expectError :: Exception e => (e -> Bool) -> IO a -> IO Bool expectError p io = (io >> return False) `E.catch` \ex -> if p ex then return True else throwIO ex isUniqueViolation :: SqlError -> Bool isUniqueViolation SqlError{..} = sqlState == "23505" isSyntaxError :: SqlError -> Bool isSyntaxError SqlError{..} = sqlState == "42601" ------------------------------------------------------------------------ -- | Action for connecting to the database that will be used for testing. -- -- Note that some tests, such as Notify, use multiple connections, and assume -- that 'testConnect' connects to the same database every time it is called. testConnect :: IO Connection testConnect = connectPostgreSQL "" withTestEnv :: (TestEnv -> IO a) -> IO a withTestEnv cb = withConn $ \conn -> cb TestEnv { conn = conn , withConn = withConn } where withConn = bracket testConnect close main :: IO () main = do mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr] Counts{cases, tried, errors, failures} <- withTestEnv $ \env -> runTestTT $ TestList $ map ($ env) tests when (cases /= tried || errors /= 0 || failures /= 0) $ exitFailure postgresql-simple-0.3.4.0/test/Common.hs0000644000000000000000000000160512173400557016305 0ustar0000000000000000module Common ( module Database.PostgreSQL.Simple, module Test.HUnit, TestEnv(..), md5, ) where import Data.ByteString (ByteString) import Data.Text (Text) import Database.PostgreSQL.Simple import Test.HUnit import qualified Crypto.Hash.MD5 as MD5 import qualified Data.ByteString.Base16 as Base16 import qualified Data.Text.Encoding as TE data TestEnv = TestEnv { conn :: Connection -- ^ Connection shared by all the tests , withConn :: forall a. (Connection -> IO a) -> IO a -- ^ Bracket for spawning additional connections } -- | Return the MD5 hash of a 'ByteString', in lowercase hex format. -- -- Example: -- -- >[Only hash] <- query_ conn "SELECT md5('hi')" -- >assertEqual "md5('hi')" (md5 "hi") hash md5 :: ByteString -> Text md5 = TE.decodeUtf8 . Base16.encode . MD5.hash postgresql-simple-0.3.4.0/test/Notify.hs0000644000000000000000000000222512173400557016324 0ustar0000000000000000module Notify (testNotify) where import Common import Control.Applicative import Control.Concurrent import Control.Monad import Data.Function import Data.List import Database.PostgreSQL.Simple.Notification import qualified Data.ByteString as B -- TODO: Test with payload, but only for PostgreSQL >= 9.0 -- (when that feature was introduced). testNotify :: TestEnv -> Test testNotify TestEnv{..} = TestCase $ withConn $ \conn2 -> do execute_ conn "LISTEN foo" execute_ conn "LISTEN bar" results_mv <- newEmptyMVar forkIO $ replicateM 2 (getNotification conn) >>= putMVar results_mv threadDelay 100000 execute_ conn2 "NOTIFY foo" execute_ conn2 "NOTIFY bar" [n1, n2] <- sortBy (compare `on` notificationChannel) <$> takeMVar results_mv assertEqual "n1" "bar" (notificationChannel n1) assertEqual "n2" "foo" (notificationChannel n2) -- Other sanity checks assertEqual "Server PIDs match" (notificationPid n1) (notificationPid n2) assertBool "notificationData is empty" $ all (B.null . notificationData) [n1, n2] postgresql-simple-0.3.4.0/test/Time.hs0000644000000000000000000000433712173400557015760 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} {- Testing strategies: fromString . toString == id ** Todo? toString . fromString == almost id ** Todo? postgresql -> haskell -> postgresql * Done haskell -> postgresql -> haskell ** Todo? But still, what we really want to establish is that the two values correspond; for example, a conversion that consistently added hour when printed to a string and subtracted an hour when parsed from string would still pass these tests. -} module Time (testTime) where import Common import Control.Monad(forM_, replicateM_) import Data.Time import Data.ByteString(ByteString) import Database.PostgreSQL.Simple.SqlQQ numTests :: Int numTests = 200 testTime :: TestEnv -> Test testTime env@TestEnv{..} = TestCase $ do initializeTable env execute_ conn "SET timezone TO 'UTC'" checkRoundTrips env execute_ conn "SET timezone TO 'America/Chicago'" checkRoundTrips env execute_ conn "SET timezone TO 'Asia/Tokyo'" checkRoundTrips env execute_ conn "SET timezone TO 'Asia/Kathmandu'" checkRoundTrips env execute_ conn "SET timezone TO 'America/St_Johns'" checkRoundTrips env initializeTable :: TestEnv -> IO () initializeTable TestEnv{..} = withTransaction conn $ do execute_ conn [sql| CREATE TEMPORARY TABLE testtime ( x serial, y timestamptz, PRIMARY KEY(x) ) |] let pop :: ByteString -> Double -> IO () = \x y -> replicateM_ numTests $ execute conn [sql| INSERT INTO testtime (y) VALUES ('1936-01-01 00:00:00+00'::timestamptz + ?::interval * ROUND(RANDOM() * ?)) |] (x,y) pop "1 microsecond" 6.3113904e15 pop "10 microseconds" 6.3113904e14 pop "100 microseconds" 6.3113904e13 pop "1 millisecond" 6.3113904e12 pop "10 milliseconds" 6.3113904e11 pop "100 milliseconds" 6.3113904e10 pop "1 second" 6.3113904e9 checkRoundTrips :: TestEnv -> IO () checkRoundTrips TestEnv{..} = do yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |] forM_ yxs $ \yx -> do res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx assertBool "UTCTime did not round-trip from SQL to Haskell and back" $ res == [Only True] postgresql-simple-0.3.4.0/test/Serializable.hs0000644000000000000000000000445312173400557017467 0ustar0000000000000000module Serializable (testSerializable) where import Common import Control.Concurrent import Control.Exception as E import Data.IORef import Database.PostgreSQL.Simple.Transaction initCounter :: Connection -> IO () initCounter conn = do 0 <- execute_ conn "DROP TABLE IF EXISTS testSerializableCounter;\ \ CREATE TABLE testSerializableCounter (n INT)" 1 <- execute_ conn "INSERT INTO testSerializableCounter VALUES (0)" return () getCounter :: Connection -> IO Int getCounter conn = do [Only n] <- query_ conn "SELECT n FROM testSerializableCounter" return n putCounter :: Connection -> Int -> IO () putCounter conn n = do 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n) return () testSerializable :: TestEnv -> Test testSerializable TestEnv{..} = TestCase $ withConn $ \conn2 -> do initCounter conn attemptCounter <- newIORef (0 :: Int) readyToBother <- newEmptyMVar bothered <- newEmptyMVar finished <- newEmptyMVar _ <- forkIO $ do withTransactionSerializable conn2 $ do modifyIORef attemptCounter (+1) n <- getCounter conn2 True <- tryPutMVar readyToBother () readMVar bothered putCounter conn2 (n+1) putMVar finished () takeMVar readyToBother withTransactionSerializable conn $ do n <- getCounter conn putCounter conn (n+1) True <- tryPutMVar bothered () takeMVar finished ac <- readIORef attemptCounter assertEqual "attemptCounter" 2 ac ok <- E.catch (do withTransactionSerializable conn (fail "Whoops") return False) (\(_ :: IOException) -> return True) assertBool "Exceptions (besides serialization failure) should be\ \ propagated through withTransactionSerializable" ok -- Make sure transaction isn't dangling 1 <- execute_ conn "UPDATE testSerializableCounter SET n=12345" 0 <- execute_ conn "ROLLBACK" -- This prints "NOTICE: there is no transaction in progress" [Only (12345 :: Int)] <- query_ conn "SELECT n FROM testSerializableCounter" return ()