diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,22 @@ +For the full changelog, see + + +### Version 0.5.2.1 (2016-06-29) + * Bumped the lower bound for `base` to 4.6. Thanks to Herbert + Valerio Riedel for reporting the issue. + + * Added an `Eq` instance for `SqlError`, thanks to Chris Allen + + * Fixed a bug where a all-caps `"NULL"` text value inside a + postgresql array would get parsed as the SQL null value. Thanks + goes to Edgar Gomes and Silk for finding and fixing this mistake. + + * Modified `withTransaction` and friends to ignore `IOError`s when + attempting to roll back the transaction. This fixes a buggy + interaction between `withTransaction` and async exceptions (e.g. + `System.Timeout`) on unix platforms. Thanks goes to Erik + Hesselink and Silk for providing the test case that exposed this + issue. + + * Added the `testTimeout` regression test for the problem above. + diff --git a/CONTRIBUTORS b/CONTRIBUTORS new file mode 100644 --- /dev/null +++ b/CONTRIBUTORS @@ -0,0 +1,35 @@ +Bryan 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 +Doug Beardsley +Manuel Gómez +Michael Snoyman +Adam Bergmark +Tobias Florek +Francesco Mazzoli +Chris Allen +Simon Hengel +Tom Ellis +Mike Ledger +João Cristóvão +Bardur Arantsson +Travis Staton +Sam Rijs +Janne Hellsten +Timmy Tofu +Alexey Khudyakov +Timo von Holtz +Amit Levy +Ben Gamari +Edgar Gomes Araujo +Erik Hesselink diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,62 @@ +Copyright (c) 2011, Leon P Smith + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Leon P Smith nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +Copyright (c) 2011, MailRank, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/pg.cabal b/pg.cabal new file mode 100644 --- /dev/null +++ b/pg.cabal @@ -0,0 +1,125 @@ +Name: pg +Version: 0.5.2.1 +Synopsis: Mid-level PostgreSQL client library +Description: Mid-level PostgreSQL client library, forked from postgresql-simple. +License: BSD3 +License-file: LICENSE +Author: Bryan O'Sullivan, Leon P Smith +Maintainer: Charmander <~@charmander.me> +Copyright: (c) 2011 MailRank, Inc. + (c) 2011-2015 Leon P Smith +Category: Database +Build-type: Simple + +Cabal-version: >= 1.9.2 + +extra-source-files: + CONTRIBUTORS + CHANGELOG.md + +Library + hs-source-dirs: src + Exposed-modules: + Database.PostgreSQL.Simple + Database.PostgreSQL.Simple.Arrays + 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.Range + 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.Macro + 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.Time.Internal.Parser + Database.PostgreSQL.Simple.Time.Internal.Printer + Database.PostgreSQL.Simple.TypeInfo.Types + + Build-depends: + aeson >= 0.6, + attoparsec >= 0.10.3, + base >= 4.6 && < 5, + bytestring >= 0.9, + bytestring-builder, + case-insensitive, + containers, + hashable, + postgresql-libpq >= 0.9 && < 0.10, + template-haskell, + text >= 0.11.1, + time, + transformers, + uuid-types >= 1.0.0, + scientific, + vector + + if !impl(ghc >= 7.6) + Build-depends: + ghc-prim + + extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns + TypeOperators + + ghc-options: -Wall -fno-warn-name-shadowing + +source-repository head + type: git + location: https://github.com/charmander/haskell-pg + +test-suite test + type: exitcode-stdio-1.0 + + hs-source-dirs: test + main-is: Main.hs + other-modules: + Common + Notify + Serializable + Time + + ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind + + extensions: NamedFieldPuns + , OverloadedStrings + , Rank2Types + , RecordWildCards + , PatternGuards + , ScopedTypeVariables + + build-depends: base + , aeson + , base16-bytestring + , bytestring + , containers + , cryptohash + , filepath + , tasty + , tasty-hunit + , tasty-golden + , HUnit + , pg + , text + , time + , vector + + if !impl(ghc >= 7.6) + build-depends: + ghc-prim diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple.hs @@ -0,0 +1,1001 @@ +{-# 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 return results + -- $returning + + -- * Extracting results + -- $result + + -- ** Handling null values + -- $null + + -- ** Type conversions + -- $types + + -- * Types + Connection + , Query + , ToRow + , FromRow + , In(..) + , Binary(..) + , Only(..) + , (:.)(..) + -- ** Exceptions + , SqlError(..) + , PQ.ExecStatus(..) + , FormatError(..) + , QueryError(..) + , ResultError(..) + -- * Connection management + , Base.connectPostgreSQL + , Base.close + , Base.connect + , Base.ConnectInfo(..) + , Base.defaultConnectInfo + , Base.postgreSQLConnectionString + -- * Queries that return results + , query + , query_ + -- ** Queries taking parser as argument + , queryWith + , queryWith_ + -- * Queries that stream results + , FoldOptions(..) + , FetchQuantity(..) + , defaultFoldOptions + , fold + , foldWithOptions + , fold_ + , foldWithOptions_ + , forEach + , forEach_ + , returning + -- ** Queries that stream results taking a parser as an argument + , foldWith + , foldWithOptionsAndParser + , foldWith_ + , foldWithOptionsAndParser_ + , forEachWith + , forEachWith_ + , returningWith + -- * 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 Data.ByteString.Builder + ( Builder, byteString, char8, intDec ) +import Control.Applicative ((<$>)) +import Control.Exception as E +import Control.Monad (unless) +import Data.ByteString (ByteString) +import Data.Int (Int64) +import Data.List (intersperse) +import Data.Monoid (mconcat) +import Database.PostgreSQL.Simple.Compat ( (<>), toByteString ) +import Database.PostgreSQL.Simple.FromField (ResultError(..)) +import Database.PostgreSQL.Simple.FromRow (FromRow(..)) +import Database.PostgreSQL.Simple.Ok +import Database.PostgreSQL.Simple.ToField (Action(..)) +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 Control.Monad.Trans.Reader +import Control.Monad.Trans.State.Strict + + +-- | 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 $ byteString before : + intersperse (char8 ',') bs ++ + [byteString 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 + + + +buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder +buildQuery conn q template xs = + zipParams (split template) <$> mapM (buildAction conn q xs) xs + where split s = + let (h,t) = B.break (=='?') s + in byteString h + : if B.null t + then [] + else split (B.tail t) + 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, or +-- a 'SqlError' exception if the backend returns an error. +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. If the list of parameters is empty, +-- this function will simply return 0 without issuing the query to the backend. +-- If this is not desired, consider using the 'Values' constructor instead. +-- +-- Throws 'FormatError' if the query could not be formatted correctly, or +-- a 'SqlError' exception if the backend returns an error. +-- +-- For example, here's a command that inserts two rows into a table +-- with two columns: +-- +-- @ +-- executeMany c [sql| +-- INSERT INTO sometable VALUES (?,?) +-- |] [(1, \"hello\"),(2, \"world\")] +-- @ +-- +-- Here's an canonical example of a multi-row update command: +-- +-- @ +-- executeMany c [sql| +-- UPDATE sometable +-- SET sometable.y = upd.y +-- FROM (VALUES (?,?)) as upd(x,y) +-- WHERE sometable.x = upd.x +-- |] [(1, \"hello\"),(2, \"world\")] +-- @ + +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'. +-- +-- If the list of parameters is empty, this function will simply return @[]@ +-- without issuing the query to the backend. If this is not desired, +-- consider using the 'Values' constructor instead. +-- +-- Throws 'FormatError' if the query could not be formatted correctly. +returning :: (ToRow q, FromRow r) => Connection -> Query -> [q] -> IO [r] +returning = returningWith fromRow + +returningWith :: (ToRow q) => RowParser r -> Connection -> Query -> [q] -> IO [r] +returningWith _ _ _ [] = return [] +returningWith parser conn q qs = do + result <- exec conn =<< formatMany conn q qs + finishQueryWith parser 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. +-- +-- * 'SqlError': the postgresql backend returned an error, e.g. +-- a syntax or type error, or an incorrect table or column name. +query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] +query = queryWith fromRow + +-- | A version of 'query' that does not perform query substitution. +query_ :: (FromRow r) => Connection -> Query -> IO [r] +query_ = queryWith_ fromRow + +-- | A version of 'query' taking parser as argument +queryWith :: ToRow q => RowParser r -> Connection -> Query -> q -> IO [r] +queryWith parser conn template qs = do + result <- exec conn =<< formatQuery conn template qs + finishQueryWith parser conn template result + +-- | A version of 'query_' taking parser as argument +queryWith_ :: RowParser r -> Connection -> Query -> IO [r] +queryWith_ parser conn q@(Query que) = do + result <- exec conn que + finishQueryWith parser 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. +-- +-- This is implemented using a database cursor. As such, this requires +-- a transaction. This function will detect whether or not there is a +-- transaction in progress, and will create a 'ReadCommitted' 'ReadOnly' +-- transaction if needed. The cursor is given a unique temporary name, +-- so the consumer may itself call fold. +-- +-- 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. +-- +-- * 'SqlError': the postgresql backend returned an error, e.g. +-- a syntax or type error, or an incorrect table or column name. +fold :: ( FromRow row, ToRow params ) + => Connection + -> Query + -> params + -> a + -> (a -> row -> IO a) + -> IO a +fold = foldWithOptions defaultFoldOptions + +-- | A version of 'fold' taking a parser as an argument +foldWith :: ( ToRow params ) + => RowParser row + -> Connection + -> Query + -> params + -> a + -> (a -> row -> IO a) + -> IO a +foldWith = foldWithOptionsAndParser defaultFoldOptions + +-- | Number of rows to fetch at a time. 'Automatic' currently defaults +-- to 256 rows, although it might be nice to make this more intelligent +-- based on e.g. the average size of the rows. +data FetchQuantity + = Automatic + | Fixed !Int + +data FoldOptions + = FoldOptions { + fetchQuantity :: !FetchQuantity, + transactionMode :: !TransactionMode + } + +-- | defaults to 'Automatic', and 'TransactionMode' 'ReadCommitted' 'ReadOnly' +defaultFoldOptions :: FoldOptions +defaultFoldOptions = FoldOptions { + fetchQuantity = Automatic, + transactionMode = TransactionMode ReadCommitted ReadOnly + } + +-- | The same as 'fold', but this provides a bit more control over +-- lower-level details. Currently, the number of rows fetched per +-- round-trip to the server and the transaction mode may be adjusted +-- accordingly. If the connection is already in a transaction, +-- then the existing transaction is used and thus the 'transactionMode' +-- option is ignored. +foldWithOptions :: ( FromRow row, ToRow params ) + => FoldOptions + -> Connection + -> Query + -> params + -> a + -> (a -> row -> IO a) + -> IO a +foldWithOptions opts = foldWithOptionsAndParser opts fromRow + +-- | A version of 'foldWithOptions' taking a parser as an argument +foldWithOptionsAndParser :: (ToRow params) + => FoldOptions + -> RowParser row + -> Connection + -> Query + -> params + -> a + -> (a -> row -> IO a) + -> IO a +foldWithOptionsAndParser opts parser conn template qs a f = do + q <- formatQuery conn template qs + doFold opts parser 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 + +-- | A version of 'fold_' taking a parser as an argument +foldWith_ :: RowParser r + -> Connection + -> Query + -> a + -> (a -> r -> IO a) + -> IO a +foldWith_ = foldWithOptionsAndParser_ 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 fromRow conn query query a f + +-- | A version of 'foldWithOptions_' taking a parser as an argument +foldWithOptionsAndParser_ :: FoldOptions + -> RowParser r + -> Connection + -> Query -- ^ Query. + -> a -- ^ Initial state for result consumer. + -> (a -> r -> IO a) -- ^ Result consumer. + -> IO a +foldWithOptionsAndParser_ opts parser conn query a f = doFold opts parser conn query query a f + +doFold :: FoldOptions + -> RowParser row + -> Connection + -> Query + -> Query + -> a + -> (a -> row -> IO a) + -> IO a +doFold FoldOptions{..} parser 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 pg 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 + 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. + unless (isFailedTransactionError ex) $ throwIO ex + + go = bracket declare close $ \(Query name) -> + let q = toByteString (byteString "FETCH FORWARD " + <> intDec chunkSize + <> byteString " FROM " + <> byteString name + ) + loop a = do + result <- exec conn q + status <- PQ.resultStatus result + case status of + PQ.TuplesOk -> do + nrows <- PQ.ntuples result + ncols <- PQ.nfields result + if nrows > 0 + then do + let inner a row = do + x <- getRowWith parser row ncols conn result + f a x + foldM' inner a 0 (nrows - 1) >>= loop + else return a + _ -> throwResultError "fold" result status + 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 = forEachWith fromRow +{-# INLINE forEach #-} + +-- | A version of 'forEach' taking a parser as an argument +forEachWith :: ( ToRow q ) + => RowParser r + -> Connection + -> Query + -> q + -> (r -> IO ()) + -> IO () +forEachWith parser conn template qs = foldWith parser conn template qs () . const +{-# INLINE forEachWith #-} + +-- | A version of 'forEach' that does not perform query substitution. +forEach_ :: (FromRow r) => + Connection + -> Query -- ^ Query template. + -> (r -> IO ()) -- ^ Result consumer. + -> IO () +forEach_ = forEachWith_ fromRow +{-# INLINE forEach_ #-} + +forEachWith_ :: RowParser r + -> Connection + -> Query + -> (r -> IO ()) + -> IO () +forEachWith_ parser conn template = foldWith_ parser conn template () . const +{-# INLINE forEachWith_ #-} + +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) +{-# INLINE forM' #-} + +foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a +foldM' f a lo hi = loop a lo + where + loop a !n + | n > hi = return a + | otherwise = do + a' <- f a n + loop a' (n+1) +{-# INLINE foldM' #-} + +finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r] +finishQueryWith parser conn q result = do + status <- PQ.resultStatus result + case status of + PQ.EmptyQuery -> + throwIO $ QueryError "query: Empty query" q + PQ.CommandOk -> + throwIO $ QueryError "query resulted in a command response" q + PQ.TuplesOk -> do + nrows <- PQ.ntuples result + ncols <- PQ.nfields result + forM' 0 (nrows-1) $ \row -> + getRowWith parser row ncols conn result + 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 + +getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r +getRowWith parser row ncols conn result = do + let rw = Row row result + let unCol (PQ.Col x) = fromIntegral x :: Int + okvc <- runConversion (runStateT (runReaderT (unRP parser) 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 + +ellipsis :: ByteString -> ByteString +ellipsis bs + | B.length bs > 15 = B.take 10 bs `B.append` "[...]" + | otherwise = bs + + +-- $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 :: IO Int +-- > hello = do +-- > conn <- connectPostgreSQL "" +-- > [Only i] <- query_ conn "select 2 + 2" +-- > return i +-- +-- 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. +-- +-- Finally, remember that the compiler must be able to infer the type +-- of a query's /results/ as well as its parameters. We might like +-- the following example to work: +-- +-- > print =<< query_ conn "select 2 + 2" +-- +-- Unfortunately, while a quick glance tells us that the result type +-- should be a single row containing a single numeric column, the +-- compiler has no way to infer what the types are. We can easily fix +-- this by providing an explicit type annotation: +-- +-- > xs <- query_ conn "select 2 + 2" +-- > print (xs :: [Only Int]) + +-- $only_param +-- +-- Haskell lacks a single-element tuple type, so if you have just one +-- value you want substituted into a query or a single-column result, +-- 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"] +-- +-- A row of /n/ query results is represented using an /n/-tuple, so +-- you should use 'Only' to represent a single-column result. + +-- $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 ?" $ +-- > Only $ 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. diff --git a/src/Database/PostgreSQL/Simple.hs-boot b/src/Database/PostgreSQL/Simple.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple.hs-boot @@ -0,0 +1,23 @@ +module Database.PostgreSQL.Simple + ( Connection + , Query + , query + , query_ + , execute + , execute_ + , executeMany + ) where + +import Data.Int(Int64) +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.Types +import {-# SOURCE #-} Database.PostgreSQL.Simple.FromRow +import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow + +query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] + +query_ :: FromRow r => Connection -> Query -> IO [r] + +execute :: ToRow q => Connection -> Query -> q -> IO Int64 + +executeMany :: ToRow q => Connection -> Query -> [q] -> IO Int64 diff --git a/src/Database/PostgreSQL/Simple/Arrays.hs b/src/Database/PostgreSQL/Simple/Arrays.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Arrays.hs @@ -0,0 +1,92 @@ +{-# 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.ByteString.Char8 + + +-- | Parse one of three primitive field formats: array, quoted and plain. +arrayFormat :: Char -> Parser ArrayFormat +arrayFormat delim = Array <$> array delim + <|> Plain <$> plain delim + <|> Quoted <$> quoted + +data ArrayFormat = Array [ArrayFormat] + | Plain ByteString + | Quoted ByteString + deriving (Eq, Show, Ord) + +array :: Char -> Parser [ArrayFormat] +array delim = char '{' *> option [] (arrays <|> strings) <* char '}' + where + strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim) + arrays = sepBy1 (Array <$> array delim) (char ',') + -- NB: Arrays seem to always be delimited by commas. + +-- | Recognizes a quoted string. +quoted :: Parser ByteString +quoted = char '"' *> option "" contents <* char '"' + where + esc = char '\\' *> (char '\\' <|> char '"') + unQ = takeWhile1 (notInClass "\"\\") + contents = mconcat <$> many (unQ <|> B.singleton <$> esc) + +-- | Recognizes a plain string literal, not containing quotes or brackets and +-- not containing the delimiter character. +plain :: Char -> Parser ByteString +plain delim = takeWhile1 (notInClass (delim:"\"{}")) + +-- Mutually recursive 'fmt' and 'delimit' separate out value formatting +-- from the subtleties of delimiting. + +-- | Format an array format item, using the delimiter character if the item is +-- itself an array. +fmt :: Char -> ArrayFormat -> ByteString +fmt = fmt' False + +-- | Format a list of array format items, inserting the appropriate delimiter +-- between them. When the items are arrays, they will be delimited with +-- commas; otherwise, they are delimited with the passed-in-delimiter. +delimit :: Char -> [ArrayFormat] -> ByteString +delimit _ [] = "" +delimit c [x] = fmt' True c x +delimit c (x:y:z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y:z) + where + c' | Array _ <- x = ',' + | otherwise = c + +-- | Format an array format item, using the delimiter character if the item is +-- itself an array, optionally applying quoting rules. Creates copies for +-- safety when used in 'FromField' instances. +fmt' :: Bool -> Char -> ArrayFormat -> ByteString +fmt' quoting c x = + case x of + Array items -> '{' `B.cons` (delimit c items `B.snoc` '}') + Plain bytes -> B.copy bytes + Quoted q | quoting -> '"' `B.cons` (esc q `B.snoc` '"') + | otherwise -> B.copy q + -- NB: The 'snoc' and 'cons' functions always copy. + +-- | Escape a string according to Postgres double-quoted string format. +esc :: ByteString -> ByteString +esc = B.concatMap f + where + f '"' = "\\\"" + f '\\' = "\\\\" + f c = B.singleton c + -- TODO: Implement easy performance improvements with unfoldr. diff --git a/src/Database/PostgreSQL/Simple/Compat.hs b/src/Database/PostgreSQL/Simple/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Compat.hs @@ -0,0 +1,94 @@ +{-# 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 + , toByteString + , scientificBuilder + , toPico + , fromPico + ) where + +import qualified Control.Exception as E +import Data.Monoid +import Data.ByteString (ByteString) +#if MIN_VERSION_bytestring(0,10,0) +import Data.ByteString.Lazy (toStrict) +#else +import qualified Data.ByteString as B +import Data.ByteString.Lazy (toChunks) +#endif +import Data.ByteString.Builder (Builder, toLazyByteString) + +#if MIN_VERSION_scientific(0,3,0) +import Data.Text.Lazy.Builder.Scientific (scientificBuilder) +#else +import Data.Scientific (scientificBuilder) +#endif + +#if __GLASGOW_HASKELL__ >= 702 +import System.IO.Unsafe (unsafeDupablePerformIO) +#elif __GLASGOW_HASKELL__ >= 611 +import GHC.IO (unsafeDupablePerformIO) +#else +import GHC.IOBase (unsafeDupablePerformIO) +#endif + +import Data.Fixed (Pico) +#if MIN_VERSION_base(4,7,0) +import Data.Fixed (Fixed(MkFixed)) +#else +import Unsafe.Coerce (unsafeCoerce) +#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 + +toByteString :: Builder -> ByteString +#if MIN_VERSION_bytestring(0,10,0) +toByteString x = toStrict (toLazyByteString x) +#else +toByteString x = B.concat (toChunks (toLazyByteString x)) +#endif + +#if MIN_VERSION_base(4,7,0) + +toPico :: Integer -> Pico +toPico = MkFixed + +fromPico :: Pico -> Integer +fromPico (MkFixed i) = i + +#else + +toPico :: Integer -> Pico +toPico = unsafeCoerce + +fromPico :: Pico -> Integer +fromPico = unsafeCoerce + +#endif diff --git a/src/Database/PostgreSQL/Simple/Copy.hs b/src/Database/PostgreSQL/Simple/Copy.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Copy.hs @@ -0,0 +1,241 @@ +{-# 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 an appropriate +-- query as documented in the link above. Then, in the case of a +-- @COPY TO STDOUT@ query, call 'getCopyData' repeatedly until it +-- returns 'CopyOutDone'. In the case of a @COPY FROM STDIN@ +-- query, 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 @CopyIn@ or @CopyOut@ 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 @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former +-- case, the connection's state will change to @CopyIn@; in the latter, +-- @CopyOut@. The connection must be in the ready state in order +-- to call this function. 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 @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former +-- case, the connection's state will change to @CopyIn@; in the latter, +-- @CopyOut@. The connection must be in the ready state in order +-- to call this function. 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) + + +-- | Retrieve some data from a @COPY TO STDOUT@ query. A connection +-- must be in the @CopyOut@ state in order to call this function. 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 + } + + +-- | Feed some data to a @COPY FROM STDIN@ query. 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@. +-- +-- A connection must be in the @CopyIn@ state in order to call this +-- function, otherwise a 'SqlError' exception will result. The +-- connection remains in the @CopyIn@ state after this function +-- is called. + +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" + + +-- | Completes a @COPY FROM STDIN@ query. Returns the number of rows +-- processed. +-- +-- A connection must be in the @CopyIn@ state in order to call this +-- function, otherwise a 'SqlError' exception will result. The +-- connection's state changes back to ready after this function +-- is called. + +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" + + +-- | Aborts a @COPY FROM STDIN@ query. The string parameter is simply +-- an arbitrary error message that may show up in the PostgreSQL +-- server's log. +-- +-- A connection must be in the @CopyIn@ state in order to call this +-- function, otherwise a 'SqlError' exception will result. The +-- connection's state changes back to ready after this function +-- is called. + +putCopyError :: Connection -> B.ByteString -> IO () +putCopyError conn err = withConnection conn $ \pqconn -> do + doCopyIn funcName (\c -> PQ.putCopyEnd c (Just err)) pqconn + consumeResults 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 + consumeResults pqconn + let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput) + case P.parseOnly rowCount cmdStat of + Left _ -> do mmsg <- PQ.errorMessage pqconn + fail $ errCmdStatusFmt + ++ maybe "" (\msg -> "\nConnection error: "++B.unpack msg) mmsg + Right n -> return $! n + where + errCmdStatus = B.unpack funcName ++ ": failed to fetch command status" + errCmdStatusFmt = B.unpack funcName ++ ": failed to parse command status" + + +consumeResults :: PQ.Connection -> IO () +consumeResults pqconn = do + mres <- PQ.getResult pqconn + case mres of + Nothing -> return () + Just _ -> consumeResults pqconn diff --git a/src/Database/PostgreSQL/Simple/Errors.hs b/src/Database/PostgreSQL/Simple/Errors.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Errors.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.Errors +-- Copyright: (c) 2012-2013 Leonid Onokhov, Joey Adams +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- | Module for parsing errors from postgresql error messages. +-- Currently 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 + , isSerializationError + , isNoActiveTransactionError + , isFailedTransactionError + ) + where + +import Control.Applicative +import Control.Exception as E + +import Data.Attoparsec.ByteString.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 + | ExclusionViolation ByteString + -- ^ Name of the exclusion violation constraint + 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 + "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 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 + +------------------------------------------------------------------------ +-- Error predicates +-- +-- https://www.postgresql.org/docs/9.5/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 diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -0,0 +1,654 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE PatternGuards, ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards, TemplateHaskell #-} + +{- | +Module: Database.PostgreSQL.Simple.FromField +Copyright: (c) 2011 MailRank, Inc. + (c) 2011-2013 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. + +Note that the 'Float' and 'Double' instances use attoparsec's 'double' +conversion routine, which sacrifices some accuracy for speed. If you +need accuracy, consider first converting data to a 'Scientific' or 'Rational' +type, and then converting to a floating-point type. If you are defining +your own 'Database.PostgreSQL.Simple.FromRow.FromRow' instances, this can be +achieved simply by +@'fromRational' '<$>' 'Database.PostgreSQL.Simple.FromRow.field'@, although +this idiom is additionally compatible with PostgreSQL's @int8@ and @numeric@ +types. If this is unacceptable, you may find +'Database.PostgreSQL.Simple.FromRow.fieldWith' useful. + +Also note that while converting to a 'Double' through the 'Scientific' type +is likely somewhat faster than converting through the 'Rational' type, +the 'Scientific' type has no way to represent @NaN@ and @±Infinity@ values. +Thus, if you need precision conversion of regular floating point values +and the possibility of receiving these special values from the backend, +stick with 'Rational'. + +Because 'FromField' is a typeclass, one may provide conversions to +additional Haskell types without modifying pg. This is +particularly useful for supporting PostgreSQL types that pg +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.FromField + ( FromField (fromField) , typeOid, returnError, ResultError (..) ) +import Database.PostgreSQL.Simple.TypeInfo.Static (typoid, uuid) +import qualified Data.ByteString.Char8 as B + +instance FromField UUID where + fromField f mdata = + if typeOid f /= typoid 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 ConversionFailed 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. One could hard-code the type oid, or +obtain it by other means, but in this case we simply pull it out of the +static table provided by pg. + +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(..) + , pgArrayFieldParser + + , optionalField + , fromJSONField + ) where + +#include "MachDeps.h" + +import Control.Applicative ( (<|>), (<$>), pure, (*>), (<*) ) +import Control.Concurrent.MVar (MVar, newMVar) +import Control.Exception (Exception) +import qualified Data.Aeson as JSON +import qualified Data.Aeson.Parser as JSON (value') +import Data.Attoparsec.ByteString.Char8 hiding (Result) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Int (Int16, Int32, Int64) +import Data.IORef (IORef, newIORef) +import Data.Ratio (Ratio) +import Data.Time ( UTCTime, ZonedTime, LocalTime, Day, TimeOfDay ) +import Data.Typeable (Typeable, typeOf) +import Data.Vector (Vector) +import Data.Vector.Mutable (IOVector) +import qualified Data.Vector as V +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.Compat +import Database.PostgreSQL.Simple.Ok +import Database.PostgreSQL.Simple.Types +import Database.PostgreSQL.Simple.TypeInfo as TI +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI +import Database.PostgreSQL.Simple.TypeInfo.Macro as TI +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 +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI +import Data.UUID.Types (UUID) +import qualified Data.UUID.Types as UUID +import Data.Scientific (Scientific) +import GHC.Real (infinity, notANumber) + +-- | 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'. + -- + -- Note that retaining any reference to the 'Field' argument causes + -- the entire @LibPQ.'PQ.Result'@ to be retained. Thus, implementations + -- of 'fromField' should return results that do not refer to this value + -- after the result have been evaluated to WHNF. + -- + -- Note that as of @postgresql-simple-0.4.0.0@, the 'ByteString' value + -- has already been copied out of the @LibPQ.'PQ.Result'@ before it has + -- been passed to 'fromField'. This is because for short strings, it's + -- cheaper to copy the string than to set up a finalizer. + +-- | 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, pg will check +-- the built-in, static table. If the type oid is not there, +-- pg 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 typeOid) + +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) + +-- | void +instance FromField () where + fromField f _bs + | typeOid f /= $(inlineTypoid TI.void) = returnError Incompatible f "" + | otherwise = pure () + +-- | 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 = optionalField fromField + +-- | For dealing with SQL @null@ values outside of the 'FromField' class. +-- Alternatively, one could use 'Control.Applicative.optional', but that +-- also turns type and conversion errors into 'Nothing', whereas this is +-- more specific and turns only @null@ values into 'Nothing'. + +optionalField :: FieldParser a -> FieldParser (Maybe a) +optionalField p f mv = + case mv of + Nothing -> pure Nothing + Just _ -> Just <$> p f mv +{-# INLINE optionalField #-} + +-- | 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 /= $(inlineTypoid TI.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 /= $(inlineTypoid TI.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 (Uses attoparsec's 'double' routine, for +-- better accuracy convert to 'Scientific' or 'Rational' first) +instance FromField Float where + fromField = atto ok (realToFrac <$> pg_double) + where ok = $(mkCompats [TI.float4,TI.int2]) + +-- | int2, int4, float4, float8 (Uses attoparsec's 'double' routine, for +-- better accuracy convert to 'Scientific' or 'Rational' first) +instance FromField Double where + fromField = atto ok pg_double + where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4]) + +-- | int2, int4, int8, float4, float8, numeric +instance FromField (Ratio Integer) where + fromField = atto ok pg_rational + where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric]) + +-- | int2, int4, int8, float4, float8, numeric +instance FromField Scientific where + fromField = atto ok rational + where ok = $(mkCompats [TI.float4,TI.float8,TI.int2,TI.int4,TI.int8,TI.numeric]) + +unBinary :: Binary t -> t +unBinary (Binary x) = x + +pg_double :: Parser Double +pg_double + = (string "NaN" *> pure ( 0 / 0)) + <|> (string "Infinity" *> pure ( 1 / 0)) + <|> (string "-Infinity" *> pure (-1 / 0)) + <|> double + +pg_rational :: Parser Rational +pg_rational + = (string "NaN" *> pure notANumber ) + <|> (string "Infinity" *> pure infinity ) + <|> (string "-Infinity" *> pure (-infinity)) + <|> rational + +-- | bytea, name, text, \"char\", bpchar, varchar, unknown +instance FromField SB.ByteString where + fromField f dat = if typeOid f == $(inlineTypoid TI.bytea) + then unBinary <$> fromField f dat + else doFromField f okText' pure dat + +-- | oid +instance FromField PQ.Oid where + fromField f dat = PQ.Oid <$> atto (== $(inlineTypoid TI.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) 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 + +-- | citext +instance FromField (CI ST.Text) where + fromField f mdat = do + typ <- typename f + if typ /= "citext" + then returnError Incompatible f "" + else case mdat of + Nothing -> returnError UnexpectedNull f "" + Just dat -> either left (pure . CI.mk) + (ST.decodeUtf8' dat) + +-- | citext +instance FromField (CI LT.Text) where + fromField f mdat = do + typ <- typename f + if typ /= "citext" + then returnError Incompatible f "" + else case mdat of + Nothing -> returnError UnexpectedNull f "" + Just dat -> either left (pure . CI.mk . LT.fromStrict) + (ST.decodeUtf8' 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 $(inlineTypoid TI.timestamptz) "UTCTime" parseUTCTime + +-- | timestamptz +instance FromField ZonedTime where + fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTime" parseZonedTime + +-- | timestamp +instance FromField LocalTime where + fromField = ff $(inlineTypoid TI.timestamp) "LocalTime" parseLocalTime + +-- | date +instance FromField Day where + fromField = ff $(inlineTypoid TI.date) "Day" parseDay + +-- | time +instance FromField TimeOfDay where + fromField = ff $(inlineTypoid TI.time) "TimeOfDay" parseTimeOfDay + +-- | timestamptz +instance FromField UTCTimestamp where + fromField = ff $(inlineTypoid TI.timestamptz) "UTCTimestamp" parseUTCTimestamp + +-- | timestamptz +instance FromField ZonedTimestamp where + fromField = ff $(inlineTypoid TI.timestamptz) "ZonedTimestamp" parseZonedTimestamp + +-- | timestamp +instance FromField LocalTimestamp where + fromField = ff $(inlineTypoid TI.timestamp) "LocalTimestamp" parseLocalTimestamp + +-- | date +instance FromField Date where + fromField = ff $(inlineTypoid TI.date) "Date" parseDate + +ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a) + -> Field -> Maybe B8.ByteString -> Conversion a +ff compatOid hsType parse f mstr = + if typeOid f /= compatOid + 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 (PGArray a) where + fromField = pgArrayFieldParser fromField + +pgArrayFieldParser :: Typeable a => FieldParser a -> FieldParser (PGArray a) +pgArrayFieldParser fieldParser f mdat = do + info <- typeInfo f + case info of + TI.Array{} -> + case mdat of + Nothing -> returnError UnexpectedNull f "" + Just dat -> do + case parseOnly (fromArray fieldParser info f) dat of + Left err -> returnError ConversionFailed f err + Right conv -> PGArray <$> conv + _ -> returnError Incompatible f "" + +fromArray :: FieldParser a -> TypeInfo -> Field -> Parser (Conversion [a]) +fromArray fieldParser typeInfo f = sequence . (parseIt <$>) <$> array delim + where + delim = typdelim (typelem typeInfo) + fElem = f{ typeOid = typoid (typelem typeInfo) } + + parseIt item = + fieldParser f' $ if item == Arrays.Plain "NULL" then Nothing else Just item' + where + item' = fmt delim item + f' | Arrays.Array _ <- item = f + | otherwise = fElem + +instance (FromField a, Typeable a) => FromField (Vector a) where + fromField f v = V.fromList . fromPGArray <$> fromField f v + +instance (FromField a, Typeable a) => FromField (IOVector a) where + fromField f v = liftConversion . V.unsafeThaw =<< fromField f v + +-- | uuid +instance FromField UUID where + fromField f mbs = + if typeOid f /= $(inlineTypoid TI.uuid) + then returnError Incompatible f "" + else case mbs of + Nothing -> returnError UnexpectedNull f "" + Just bs -> + case UUID.fromASCIIBytes bs of + Nothing -> returnError ConversionFailed f "Invalid UUID" + Just uuid -> pure uuid + +-- | json +instance FromField JSON.Value where + fromField f mbs = + if typeOid f /= $(inlineTypoid TI.json) && typeOid f /= $(inlineTypoid TI.jsonb) + then returnError Incompatible f "" + else case mbs of + Nothing -> returnError UnexpectedNull f "" + Just bs -> + case parseOnly (JSON.value' <* endOfInput) bs of + Left err -> returnError ConversionFailed f err + Right val -> pure val + +-- | Parse a field to a JSON 'JSON.Value' and convert that into a +-- Haskell value using 'JSON.fromJSON'. +-- +-- This can be used as the default implementation for the 'fromField' +-- method for Haskell types that have a JSON representation in +-- PostgreSQL. +-- +-- The 'Typeable' constraint is required to show more informative +-- error messages when parsing fails. +-- +-- Note that @fromJSONField :: FieldParser ('Maybe' Foo)@ will return +-- @'Nothing'@ on the json @null@ value, and return an exception on SQL @null@ +-- value. Alternatively, one could write @'optionalField' fromJSONField@ +-- that will return @Nothing@ on SQL @null@, and otherwise will call +-- @fromJSONField :: FieldParser Foo@ and then return @'Just'@ the +-- result value, or return its exception. If one would +-- like to return @Nothing@ on both the SQL @null@ and json @null@ values, +-- one way to do it would be to write +-- @\\f mv -> 'Control.Monad.join' '<$>' optionalField fromJSONField f mv@ +fromJSONField :: (JSON.FromJSON a, Typeable a) => FieldParser a +fromJSONField f mbBs = do + value <- fromField f mbBs + case JSON.fromJSON value of + JSON.Error err -> returnError ConversionFailed f $ + "JSON decoding error: " ++ err + JSON.Success x -> pure x + +-- | Compatible with the same set of types as @a@. Note that +-- modifying the 'IORef' does not have any effects outside +-- the local process on the local machine. +instance FromField a => FromField (IORef a) where + fromField f v = liftConversion . newIORef =<< fromField f v + +-- | Compatible with the same set of types as @a@. Note that +-- modifying the 'MVar' does not have any effects outside +-- the local process on the local machine. +instance FromField a => FromField (MVar a) where + fromField f v = liftConversion . newMVar =<< fromField f v + +type Compat = PQ.Oid -> Bool + +okText, okText', okBinary, ok16, ok32, ok64, okInt :: Compat +okText = $( mkCompats [ TI.name, TI.text, TI.char, + TI.bpchar, TI.varchar ] ) +okText' = $( mkCompats [ TI.name, TI.text, TI.char, + TI.bpchar, TI.varchar, TI.unknown ] ) +okBinary = (== $( inlineTypoid TI.bytea )) +ok16 = (== $( inlineTypoid TI.int2 )) +ok32 = $( mkCompats [TI.int2,TI.int4] ) +ok64 = $( mkCompats [TI.int2,TI.int4,TI.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 isCompat cvt (Just bs) + | isCompat (typeOid f) = 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 diff --git a/src/Database/PostgreSQL/Simple/FromField.hs-boot b/src/Database/PostgreSQL/Simple/FromField.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromField.hs-boot @@ -0,0 +1,11 @@ +module 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) diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs b/src/Database/PostgreSQL/Simple/FromRow.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromRow.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards, FlexibleInstances, DefaultSignatures #-} + + +------------------------------------------------------------------------------ +-- | +-- 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. The instances for 'Maybe' types return 'Nothing' if all +-- the columns that would have been otherwise consumed are null, otherwise +-- it attempts a regular conversion. +-- +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.FromRow + ( FromRow(..) + , RowParser + , field + , fieldWith + , numFieldsRemaining + ) where + +import Prelude hiding (null) +import Control.Applicative (Applicative(..), (<$>), (<|>), (*>), liftA2) +import Control.Monad (replicateM, replicateM_) +import Control.Monad.Trans.State.Strict +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Vector (Vector) +import qualified Data.Vector as V +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 ((:.)(..), Null) +import Database.PostgreSQL.Simple.TypeInfo + +import GHC.Generics + + +-- | 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 pg, 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 its result to WHNF, so the caveats listed in +-- mysql-simple and very early versions of pg no longer apply. +-- Instead, look at the caveats associated with user-defined implementations +-- of 'fromField'. + +class FromRow a where + fromRow :: RowParser a + default fromRow :: (Generic a, GFromRow (Rep a)) => RowParser a + fromRow = to <$> gfromRow + +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) + +null :: RowParser Null +null = field + +instance (FromField a) => FromRow (Only a) where + fromRow = Only <$> field + +instance (FromField a) => FromRow (Maybe (Only a)) where + fromRow = (null *> pure Nothing) + <|> (Just <$> fromRow) + +instance (FromField a, FromField b) => FromRow (a,b) where + fromRow = (,) <$> field <*> field + +instance (FromField a, FromField b) => FromRow (Maybe (a,b)) where + fromRow = (null *> null *> pure Nothing) + <|> (Just <$> fromRow) + +instance (FromField a, FromField b, FromField c) => FromRow (a,b,c) where + fromRow = (,,) <$> field <*> field <*> field + +instance (FromField a, FromField b, FromField c) => FromRow (Maybe (a,b,c)) where + fromRow = (null *> null *> null *> pure Nothing) + <|> (Just <$> fromRow) + +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) => + FromRow (Maybe (a,b,c,d)) where + fromRow = (null *> null *> null *> null *> pure Nothing) + <|> (Just <$> fromRow) + +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) => + FromRow (Maybe (a,b,c,d,e)) where + fromRow = (null *> null *> null *> null *> null *> pure Nothing) + <|> (Just <$> fromRow) + +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) => + FromRow (Maybe (a,b,c,d,e,f)) where + fromRow = (null *> null *> null *> null *> null *> + null *> pure Nothing) + <|> (Just <$> fromRow) + +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) => + FromRow (Maybe (a,b,c,d,e,f,g)) where + fromRow = (null *> null *> null *> null *> null *> + null *> null *> pure Nothing) + <|> (Just <$> fromRow) + +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) => + FromRow (Maybe (a,b,c,d,e,f,g,h)) where + fromRow = (null *> null *> null *> null *> null *> + null *> null *> null *> pure Nothing) + <|> (Just <$> fromRow) + +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) => + FromRow (Maybe (a,b,c,d,e,f,g,h,i)) where + fromRow = (null *> null *> null *> null *> null *> + null *> null *> null *> null *> pure Nothing) + <|> (Just <$> fromRow) + +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, FromField b, FromField c, FromField d, FromField e, + FromField f, FromField g, FromField h, FromField i, FromField j) => + FromRow (Maybe (a,b,c,d,e,f,g,h,i,j)) where + fromRow = (null *> null *> null *> null *> null *> + null *> null *> null *> null *> null *> pure Nothing) + <|> (Just <$> fromRow) + +instance FromField a => FromRow [a] where + fromRow = do + n <- numFieldsRemaining + replicateM n field + +instance FromField a => FromRow (Maybe [a]) where + fromRow = do + n <- numFieldsRemaining + (replicateM_ n null *> pure Nothing) <|> (Just <$> replicateM n field) + +instance FromField a => FromRow (Vector a) where + fromRow = do + n <- numFieldsRemaining + V.replicateM n field + +instance FromField a => FromRow (Maybe (Vector a)) where + fromRow = do + n <- numFieldsRemaining + (replicateM_ n null *> pure Nothing) <|> (Just <$> V.replicateM n field) + +instance (FromRow a, FromRow b) => FromRow (a :. b) where + fromRow = (:.) <$> fromRow <*> fromRow + + + +-- Type class for default implementation of FromRow using generics +class GFromRow f where + gfromRow :: RowParser (f p) + +instance GFromRow f => GFromRow (M1 c i f) where + gfromRow = M1 <$> gfromRow + +instance (GFromRow f, GFromRow g) => GFromRow (f :*: g) where + gfromRow = liftA2 (:*:) gfromRow gfromRow + +instance (FromField a) => GFromRow (K1 R a) where + gfromRow = K1 <$> field + +instance GFromRow U1 where + gfromRow = pure U1 diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs-boot b/src/Database/PostgreSQL/Simple/FromRow.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/FromRow.hs-boot @@ -0,0 +1,17 @@ +module 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) diff --git a/src/Database/PostgreSQL/Simple/HStore.hs b/src/Database/PostgreSQL/Simple/HStore.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/HStore.hs @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- | +-- 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 + , parseHStoreList + , ToHStoreText(..) + , HStoreText + ) where + +import Database.PostgreSQL.Simple.HStore.Implementation diff --git a/src/Database/PostgreSQL/Simple/HStore/Implementation.hs b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/HStore/Implementation.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE CPP, 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 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.Builder (Builder, byteString, char8) +import qualified Data.ByteString.Builder as BU +import Data.ByteString.Internal (c2w, w2c) +import qualified Data.ByteString.Lazy as BL +#if !MIN_VERSION_bytestring(0,10,0) +import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks) +#endif +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 -> BU.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 -> char8 ',' `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 + = byteString 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 '\"' = byteString "\\\"" + | otherwise = byteString "\\\\" + +hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder +hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) = + Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\"" + `mappend` val `mappend` char8 '"') + +instance ToField HStoreBuilder where + toField Empty = toField (BS.empty) + toField (Comma x) = toField (BU.toLazyByteString x) + +newtype HStoreList = HStoreList {fromHStoreList :: [(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 {fromHStoreMap :: 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) + +parseHStoreList :: BS.ByteString -> Either String HStoreList +parseHStoreList dat = + case P.parseOnly (parseHStore <* P.endOfInput) dat of + Left err -> Left (show err) + Right (Left err) -> Left (show err) + Right (Right val) -> Right val + +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 '"' diff --git a/src/Database/PostgreSQL/Simple/HStore/Internal.hs b/src/Database/PostgreSQL/Simple/HStore/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/HStore/Internal.hs @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- | +-- 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 diff --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Internal.hs @@ -0,0 +1,586 @@ +{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse, RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.Internal +-- Copyright: (c) 2011-2015 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 pg +-- 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 as B +import qualified Data.ByteString.Char8 as B8 +import Data.ByteString.Builder ( Builder, byteString ) +import Data.Char (ord) +import Data.Int (Int64) +import qualified Data.IntMap as IntMap +import Data.IORef +import Data.Maybe(fromMaybe) +import Data.Monoid +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +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.Compat ( toByteString ) +import Database.PostgreSQL.Simple.Ok +import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes) +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 Control.Monad.Trans.Class +import GHC.IO.Exception +#if !defined(mingw32_HOST_OS) +import Control.Concurrent(threadWaitRead, threadWaitWrite) +#endif + +-- | 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) + } deriving (Typeable) + +instance Eq Connection where + x == y = connectionHandle x == connectionHandle y + +data SqlError = SqlError { + sqlState :: ByteString + , sqlExecStatus :: ExecStatus + , sqlErrorMsg :: ByteString + , sqlErrorDetail :: ByteString + , sqlErrorHint :: ByteString + } deriving (Eq, 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 + +-- | 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 + +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. Also note that environment variables also affect +-- parameters not provided, parameters provided as the empty string, and a +-- few other things; see +-- +-- for details. Here is an example with some of the most commonly used +-- parameters: +-- +-- > host='db.somedomain.com' port=5432 ... +-- +-- This attempts to connect to @db.somedomain.com:5432@. Omitting the port +-- will normally default to 5432. +-- +-- On systems that provide unix domain sockets, omitting the host parameter +-- will cause libpq to attempt to connect via unix domain sockets. +-- The default filesystem path to the socket is constructed from the +-- port number and the @DEFAULT_PGSOCKET_DIR@ constant defined in the +-- @pg_config_manual.h@ header file. Connecting via unix sockets tends +-- to use the @peer@ authentication method, which is very secure and +-- does not require a password. +-- +-- On Windows and other systems without unix domain sockets, omitting +-- the host will default to @localhost@. +-- +-- > ... dbname='postgres' user='postgres' password='secret \' \\ pw' +-- +-- This attempts to connect to a database named @postgres@ with +-- user @postgres@ and password @secret \' \\ pw@. Backslash +-- characters will have to be double-quoted in literal Haskell strings, +-- of course. Omitting @dbname@ and @user@ will both default to the +-- system username that the client process is running as. +-- +-- Omitting @password@ will default to an appropriate password found +-- in the @pgpass@ file, or no password at all if a matching line is +-- not found. See +-- for +-- more information regarding this file. +-- +-- As all parameters are optional and the defaults are sensible, the +-- empty connection string can be useful for development and +-- exploratory use, assuming your system is set up appropriately. +-- +-- On Unix, such a setup would typically consist of a local +-- postgresql server listening on port 5432, as well as a system user, +-- database user, and database sharing a common name, with permissions +-- granted to the user on the database. +-- +-- On Windows, in addition you will either need @pg_hba.conf@ +-- to specify the use of the @trust@ authentication method for +-- the connection, which may not be appropriate for multiuser +-- or production machines, or you will need to use a @pgpass@ file +-- with the @password@ or @md5@ authentication methods. +-- +-- See +-- for more information regarding the authentication process. +-- +-- SSL/TLS will typically "just work" if your postgresql server supports or +-- requires it. However, note that libpq is trivially vulnerable to a MITM +-- attack without setting additional SSL connection parameters. In +-- particular, @sslmode@ needs to be set to @require@, @verify-ca@, or +-- @verify-full@ in order to perform certificate validation. When @sslmode@ +-- is @require@, then you will also need to specify a @sslrootcert@ file, +-- otherwise no validation of the server's identity will be performed. +-- Client authentication via certificates is also possible via the +-- @sslcert@ and @sslkey@ parameters. See +-- +-- for detailed information regarding libpq and SSL. + +connectPostgreSQL :: ByteString -> IO Connection +connectPostgreSQL connstr = do + conn <- 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;SET client_encoding TO UTF8" + | otherwise = "SET datestyle TO ISO;SET client_encoding TO UTF8;SET standard_conforming_strings TO on" + _ <- execute_ wconn settings + return wconn + _ -> do + msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn + throwIO $ fatalError msg + +connectdb :: ByteString -> IO PQ.Connection +#if defined(mingw32_HOST_OS) +connectdb = PQ.connectdb +#else +connectdb conninfo = do + conn <- PQ.connectStart conninfo + loop conn + where + funcName = "Database.PostgreSQL.Simple.connectPostgreSQL" + loop conn = do + status <- PQ.connectPoll conn + case status of + PQ.PollingFailed -> throwLibPQError conn "connection failed" + PQ.PollingReading -> do + mfd <- PQ.socket conn + case mfd of + Nothing -> throwIO $! fdError funcName + Just fd -> do + threadWaitRead fd + loop conn + PQ.PollingWriting -> do + mfd <- PQ.socket conn + case mfd of + Nothing -> throwIO $! fdError funcName + Just fd -> do + threadWaitWrite fd + loop conn + PQ.PollingOk -> return conn + +#endif + +-- | 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 +#if defined(mingw32_HOST_OS) +exec conn sql = + withConnection conn $ \h -> do + mres <- PQ.exec h sql + case mres of + Nothing -> throwLibPQError h "PQexec returned no results" + Just res -> return res +#else +exec conn sql = + withConnection conn $ \h -> do + success <- PQ.sendQuery h sql + if success + then awaitResult h Nothing + else throwLibPQError h "PQsendQuery failed" + where + awaitResult h mres = do + mfd <- PQ.socket h + case mfd of + Nothing -> throwIO $! fdError "Database.PostgreSQL.Simple.Internal.exec" + Just fd -> do + threadWaitRead fd + _ <- PQ.consumeInput h -- FIXME? + getResult h mres + + getResult h mres = do + isBusy <- PQ.isBusy h + if isBusy + then awaitResult h mres + else do + mres' <- PQ.getResult h + case mres' of + Nothing -> case mres of + Nothing -> throwLibPQError h "PQgetResult returned no results" + Just res -> return res + Just res -> do + status <- PQ.resultStatus res + case status of + PQ.EmptyQuery -> getResult h mres' + PQ.CommandOk -> getResult h mres' + PQ.TuplesOk -> getResult h mres' + PQ.CopyOut -> return res + PQ.CopyIn -> return res + PQ.BadResponse -> getResult h mres' + PQ.NonfatalError -> getResult h mres' + PQ.FatalError -> getResult h mres' +#endif + +-- | 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 ) + +liftRowParser :: IO a -> RowParser a +liftRowParser = RP . lift . lift . liftConversion + +newtype Conversion a = Conversion { runConversion :: Connection -> IO (Ok a) } + +liftConversion :: IO a -> Conversion a +liftConversion m = Conversion (\_ -> Ok <$> m) + +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 +#if !(MIN_VERSION_base(4,8,0)) + return = pure +#endif + 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 [toException 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 + } + + +libPQError :: ByteString -> IOError +libPQError desc = IOError { + ioe_handle = Nothing, + ioe_type = OtherError, + ioe_location = "libpq", + ioe_description = B8.unpack desc, + ioe_errno = Nothing, + ioe_filename = Nothing + } + +throwLibPQError :: PQ.Connection -> ByteString -> IO a +throwLibPQError conn default_desc = do + msg <- maybe default_desc id <$> PQ.errorMessage conn + throwIO $! libPQError msg + + +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 (EscapeIdentifier s) = s + twiddle (Many ys) = B.concat (map twiddle ys) + +fmtErrorBs :: Query -> [Action] -> ByteString -> a +fmtErrorBs q xs msg = fmtError (T.unpack $ TE.decodeUtf8 msg) q xs + +-- | Quote bytestring or throw 'FormatError' +quote :: Query -> [Action] -> Either ByteString ByteString -> Builder +quote q xs = either (fmtErrorBs q xs) (inQuotes . byteString) + +buildAction :: Connection -- ^ Connection for string escaping + -> Query -- ^ Query for message error + -> [Action] -- ^ List of parameters for message error + -> Action -- ^ Action to build + -> IO Builder +buildAction _ _ _ (Plain b) = pure b +buildAction conn q xs (Escape s) = quote q xs <$> escapeStringConn conn s +buildAction conn q xs (EscapeByteA s) = quote q xs <$> escapeByteaConn conn s +buildAction conn q xs (EscapeIdentifier s) = + either (fmtErrorBs q xs) byteString <$> escapeIdentifier conn s +buildAction conn q xs (Many ys) = + mconcat <$> mapM (buildAction conn q xs) ys + +checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a) +checkError _ (Just x) = return $ Right x +checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c + +escapeWrap :: (PQ.Connection -> ByteString -> IO (Maybe ByteString)) + -> Connection + -> ByteString + -> IO (Either ByteString ByteString) +escapeWrap f conn s = + withConnection conn $ \c -> + f c s >>= checkError c + +escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString) +escapeStringConn = escapeWrap PQ.escapeStringConn + +escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString) +escapeIdentifier = escapeWrap PQ.escapeIdentifier + +escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString) +escapeByteaConn = escapeWrap PQ.escapeByteaConn diff --git a/src/Database/PostgreSQL/Simple/LargeObjects.hs b/src/Database/PostgreSQL/Simple/LargeObjects.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/LargeObjects.hs @@ -0,0 +1,97 @@ +----------------------------------------------------------------------------- +-- | +-- 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', 'loCreate', and 'loUnlink', you will need to run the entire +-- sequence of functions in a transaction. As 'loImport' and 'loExport' +-- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and +-- 'loWrite', and do not perform any transaction handling themselves, +-- they also need to be wrapped in an explicit 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) diff --git a/src/Database/PostgreSQL/Simple/Notification.hs b/src/Database/PostgreSQL/Simple/Notification.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Notification.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Database.PostgreSQL.Simple.Notification +-- Copyright : (c) 2011-2015 Leon P Smith +-- (c) 2012 Joey Adams +-- 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 + , getBackendPID + ) where + +import Control.Monad ( join, void ) +import Control.Exception ( throwIO, catch ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import Database.PostgreSQL.Simple.Internal +import qualified Database.PostgreSQL.LibPQ as PQ +import System.Posix.Types ( CPid ) +import GHC.IO.Exception ( ioe_location ) + +#if defined(mingw32_HOST_OS) +import Control.Concurrent ( threadDelay ) +#elif !MIN_VERSION_base(4,7,0) +import Control.Concurrent ( threadWaitRead ) +#else +import GHC.Conc ( atomically ) +import Control.Concurrent ( threadWaitReadSTM ) +#endif + +data Notification = Notification + { notificationPid :: {-# UNPACK #-} !CPid + , notificationChannel :: {-# UNPACK #-} !B.ByteString + , notificationData :: {-# UNPACK #-} !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. +-- +-- It is safe to call 'getNotification' on a connection that is concurrently +-- being used for other purposes, note however that PostgreSQL does not +-- deliver notifications while a connection is inside a transaction. + +getNotification :: Connection -> IO Notification +getNotification conn = join $ withConnection conn fetch + where + funcName = "Database.PostgreSQL.Simple.Notification.getNotification" + + fetch c = do + mmsg <- PQ.notifies c + case mmsg of + Just msg -> return (return $! convertNotice msg) + Nothing -> do + mfd <- PQ.socket c + case mfd of + Nothing -> return (throwIO $! fdError funcName) +#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. + Just _fd -> do + return (threadDelay 1000000 >> loop) +#elif !MIN_VERSION_base(4,7,0) + -- Technically there's a race condition that is usually benign. + -- If the connection is closed or reset after we drop the + -- lock, and then the fd index is reallocated to a new + -- descriptor before we call threadWaitRead, then + -- we could end up waiting on the wrong descriptor. + -- + -- Now, if the descriptor becomes readable promptly, then + -- it's no big deal as we'll wake up and notice the change + -- on the next iteration of the loop. But if are very + -- unlucky, then we could end up waiting a long time. + Just fd -> do + return $ do + threadWaitRead fd `catch` (throwIO . setIOErrorLocation) + loop +#else + -- This case fixes the race condition above. By registering + -- our interest in the descriptor before we drop the lock, + -- there is no opportunity for the descriptor index to be + -- reallocated on us. + -- + -- (That is, assuming there isn't concurrently executing + -- code that manipulates the descriptor without holding + -- the lock... but such a major bug is likely to exhibit + -- itself in an at least somewhat more dramatic fashion.) + Just fd -> do + (waitRead, _) <- threadWaitReadSTM fd + return $ do + atomically waitRead `catch` (throwIO . setIOErrorLocation) + loop +#endif + + loop = join $ withConnection conn $ \c -> do + void $ PQ.consumeInput c + fetch c + + setIOErrorLocation :: IOError -> IOError + setIOErrorLocation err = err { ioe_location = B8.unpack funcName } + + +-- | 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 + +-- | Returns the process 'CPid' of the backend server process +-- handling this connection. +-- +-- The backend PID is useful for debugging purposes and for comparison +-- to NOTIFY messages (which include the PID of the notifying backend +-- process). Note that the PID belongs to a process executing on the +-- database server host, not the local host! + +getBackendPID :: Connection -> IO CPid +getBackendPID conn = withConnection conn PQ.backendPID diff --git a/src/Database/PostgreSQL/Simple/Ok.hs b/src/Database/PostgreSQL/Simple/Ok.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Ok.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE CPP #-} + +------------------------------------------------------------------------------ +-- | +-- Module : Database.PostgreSQL.Simple.Ok +-- Copyright : (c) 2012-2015 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 pg. +-- +-- 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: '<|>' concatenates +-- 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 +#if !(MIN_VERSION_base(4,8,0)) + return = pure +#endif + + 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 diff --git a/src/Database/PostgreSQL/Simple/Range.hs b/src/Database/PostgreSQL/Simple/Range.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Range.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.Range +-- Copyright: (c) 2014-2015 Leonid Onokhov +-- (c) 2014-2015 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.Range + ( RangeBound(..) + , PGRange(..) + , empty + , isEmpty, isEmptyBy + , contains, containsBy + ) where + +import Control.Applicative hiding (empty) +import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly) +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.ByteString as B +import Data.ByteString.Builder + ( Builder, byteString, lazyByteString, char8 + , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec + , wordDec, word8Dec, word16Dec, word32Dec, word64Dec + , doubleDec, floatDec ) +import Data.Int (Int16, Int32, Int64, + Int8) +import Data.Function (on) +import Data.Monoid (mempty) +import Data.Scientific (Scientific) +import qualified Data.Text.Lazy.Builder as LT +import qualified Data.Text.Lazy.Encoding as LT +import Data.Time (Day, LocalTime, + NominalDiffTime, + TimeOfDay, UTCTime, + ZonedTime, + zonedTimeToUTC) +import Data.Typeable (Typeable) +import Data.Word (Word, Word16, Word32, + Word64, Word8) + +import Database.PostgreSQL.Simple.Compat (scientificBuilder, (<>), toByteString) +import Database.PostgreSQL.Simple.FromField +import Database.PostgreSQL.Simple.Time + hiding (PosInfinity, NegInfinity) +-- import qualified Database.PostgreSQL.Simple.Time as Time +import Database.PostgreSQL.Simple.ToField + +-- | Represents boundary of a range +data RangeBound a = NegInfinity + | Inclusive !a + | Exclusive !a + | PosInfinity + deriving (Show, Typeable, Eq, Functor) + +-- | Generic range type +data PGRange a = PGRange !(RangeBound a) !(RangeBound a) + deriving (Show, Typeable, Functor) + +empty :: PGRange a +empty = PGRange PosInfinity NegInfinity + +instance Ord a => Eq (PGRange a) where + x == y = eq x y || (isEmpty x && isEmpty y) + where eq (PGRange a m) (PGRange b n) = a == b && m == n + +isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool +isEmptyBy cmp v = + case v of + (PGRange PosInfinity _) -> True + (PGRange _ NegInfinity) -> True + (PGRange NegInfinity _) -> False + (PGRange _ PosInfinity) -> False + (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT + (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT + (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT + (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT + +-- | Is a range empty? If this returns 'True', then the 'contains' +-- predicate will always return 'False'. However, if this returns +-- 'False', it is not necessarily true that there exists a point for +-- which 'contains' returns 'True'. +-- Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@, +-- for example. +isEmpty :: Ord a => PGRange a -> Bool +isEmpty = isEmptyBy compare + + +-- | Does a range contain a given point? Note that in some cases, this may +-- not correspond exactly with a server-side computation. Consider @UTCTime@ +-- for example, which has a resolution of a picosecond, whereas postgresql's +-- @timestamptz@ types have a resolution of a microsecond. Putting such +-- Haskell values into the database will result in them being rounded, which +-- can change the value of the containment predicate. + +contains :: Ord a => PGRange a -> (a -> Bool) +contains = containsBy compare + +containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool) +containsBy cmp rng x = + case rng of + PGRange _lb NegInfinity -> False + PGRange lb ub -> checkLB lb x && checkUB ub x + where + checkLB lb x = + case lb of + NegInfinity -> True + PosInfinity -> False + Inclusive a -> cmp a x /= GT + Exclusive a -> cmp a x == LT + + checkUB ub x = + case ub of + NegInfinity -> False + PosInfinity -> True + Inclusive z -> cmp x z /= GT + Exclusive z -> cmp x z == LT + +lowerBound :: Parser (a -> RangeBound a) +lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive) +{-# INLINE lowerBound #-} + +upperBound :: Parser (a -> RangeBound a) +upperBound = (A.char ')' *> pure Exclusive) <|> (A.char ']' *> pure Inclusive) +{-# INLINE upperBound #-} + +-- | Generic range parser +pgrange :: Parser (RangeBound B.ByteString, RangeBound B.ByteString) +pgrange = do + lb <- lowerBound + v1 <- (A.char ',' *> "") <|> (rangeElem (==',') <* A.char ',') + v2 <- rangeElem $ \c -> c == ')' || c == ']' + ub <- upperBound + A.endOfInput + let low = if B.null v1 then NegInfinity else lb v1 + up = if B.null v2 then PosInfinity else ub v2 + return (low, up) + +rangeElem :: (Char -> Bool) -> Parser B.ByteString +rangeElem end = (A.char '"' *> doubleQuoted) + <|> A.takeTill end +{-# INLINE rangeElem #-} + +-- | Simple double quoted value parser +doubleQuoted :: Parser B.ByteString +doubleQuoted = toByteString <$> go mempty + where + go acc = do + h <- byteString <$> A.takeTill (\c -> c == '\\' || c == '"') + let rest = do + start <- A.anyChar + case start of + '\\' -> do + c <- A.anyChar + go (acc <> h <> char8 c) + '"' -> (A.char '"' *> go (acc <> h <> char8 '"')) + <|> pure (acc <> h) + _ -> error "impossible in doubleQuoted" + rest + +rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder +rangeToBuilder = rangeToBuilderBy compare + +-- | Generic range to builder for plain values +rangeToBuilderBy :: (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder +rangeToBuilderBy cmp f x = + if isEmptyBy cmp x + then byteString "'empty'" + else let (PGRange a b) = x + in buildLB a <> buildUB b + where + buildLB NegInfinity = byteString "'[," + buildLB (Inclusive v) = byteString "'[\"" <> f v <> byteString "\"," + buildLB (Exclusive v) = byteString "'(\"" <> f v <> byteString "\"," + buildLB PosInfinity = error "impossible in rangeToBuilder" + + buildUB NegInfinity = error "impossible in rangeToBuilder" + buildUB (Inclusive v) = char8 '"' <> f v <> byteString "\"]'" + buildUB (Exclusive v) = char8 '"' <> f v <> byteString "\")'" + buildUB PosInfinity = byteString "]'" +{-# INLINE rangeToBuilder #-} + + +instance (FromField a, Typeable a) => FromField (PGRange a) where + fromField f mdat = do + info <- typeInfo f + case info of + Range{} -> + let f' = f { typeOid = typoid (rngsubtype info) } + in case mdat of + Nothing -> returnError UnexpectedNull f "" + Just "empty" -> pure $ empty + Just bs -> + let parseIt NegInfinity = pure NegInfinity + parseIt (Inclusive v) = Inclusive <$> fromField f' (Just v) + parseIt (Exclusive v) = Exclusive <$> fromField f' (Just v) + parseIt PosInfinity = pure PosInfinity + in case parseOnly pgrange bs of + Left e -> returnError ConversionFailed f e + Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub + _ -> returnError Incompatible f "" + + +instance ToField (PGRange Int8) where + toField = Plain . rangeToBuilder int8Dec + {-# INLINE toField #-} + +instance ToField (PGRange Int16) where + toField = Plain . rangeToBuilder int16Dec + {-# INLINE toField #-} + +instance ToField (PGRange Int32) where + toField = Plain . rangeToBuilder int32Dec + {-# INLINE toField #-} + +instance ToField (PGRange Int) where + toField = Plain . rangeToBuilder intDec + {-# INLINE toField #-} + +instance ToField (PGRange Int64) where + toField = Plain . rangeToBuilder int64Dec + {-# INLINE toField #-} + +instance ToField (PGRange Integer) where + toField = Plain . rangeToBuilder integerDec + {-# INLINE toField #-} + +instance ToField (PGRange Word8) where + toField = Plain . rangeToBuilder word8Dec + {-# INLINE toField #-} + +instance ToField (PGRange Word16) where + toField = Plain . rangeToBuilder word16Dec + {-# INLINE toField #-} + +instance ToField (PGRange Word32) where + toField = Plain . rangeToBuilder word32Dec + {-# INLINE toField #-} + +instance ToField (PGRange Word) where + toField = Plain . rangeToBuilder wordDec + {-# INLINE toField #-} + +instance ToField (PGRange Word64) where + toField = Plain . rangeToBuilder word64Dec + {-# INLINE toField #-} + +instance ToField (PGRange Float) where + toField = Plain . rangeToBuilder floatDec + {-# INLINE toField #-} + +instance ToField (PGRange Double) where + toField = Plain . rangeToBuilder doubleDec + {-# INLINE toField #-} + +instance ToField (PGRange Scientific) where + toField = Plain . rangeToBuilder f + where + f = lazyByteString . LT.encodeUtf8 . LT.toLazyText . scientificBuilder + {-# INLINE toField #-} + +instance ToField (PGRange UTCTime) where + toField = Plain . rangeToBuilder utcTimeToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange ZonedTime) where + toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder + {-# INLINE toField #-} + +cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering +cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize + +instance ToField (PGRange LocalTime) where + toField = Plain . rangeToBuilder localTimeToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange Day) where + toField = Plain . rangeToBuilder dayToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange TimeOfDay) where + toField = Plain . rangeToBuilder timeOfDayToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange UTCTimestamp) where + toField = Plain . rangeToBuilder utcTimestampToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange ZonedTimestamp) where + toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder + {-# INLINE toField #-} + +cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering +cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>) + +instance ToField (PGRange LocalTimestamp) where + toField = Plain . rangeToBuilder localTimestampToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange Date) where + toField = Plain . rangeToBuilder dateToBuilder + {-# INLINE toField #-} + +instance ToField (PGRange NominalDiffTime) where + toField = Plain . rangeToBuilder nominalDiffTimeToBuilder + {-# INLINE toField #-} diff --git a/src/Database/PostgreSQL/Simple/SqlQQ.hs b/src/Database/PostgreSQL/Simple/SqlQQ.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/SqlQQ.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE TemplateHaskell #-} +------------------------------------------------------------------------------ +-- | +-- 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 Database.PostgreSQL.Simple.Types (Query) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Data.Char +import Data.String + +-- | '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 returns a literal string expression of type 'Query', +-- and 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 = appE [| fromString :: String -> Query |] . 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" diff --git a/src/Database/PostgreSQL/Simple/Time.hs b/src/Database/PostgreSQL/Simple/Time.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time.hs @@ -0,0 +1,244 @@ +{- | +Module: Database.PostgreSQL.Simple.Time +Copyright: (c) 2012-2015 Leon P Smith +License: BSD3 +Maintainer: Leon P Smith +Stability: experimental + +This module provides time types that supports positive and negative +infinity, as well as some functions for converting to and from strings. + +Also, this module also contains commentary regarding postgresql's timestamp +types, civil timekeeping in general, and how it relates to +pg. You can read more about PostgreSQL's date and time types +at , +and the IANA time zone database at . + +Stack Overflow also has some excellent commentary on time, if it is a +wiki page or a highly upvoted question and answer. If the answer regarding +time has not received about a hundred upvotes at least, then the answer is +almost invariably completely and painfully wrong, even if it's the chosen +answer or the most highly upvoted answer to a question. + +PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be +converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types, +because values of these types represent a self-contained, unambiguous point +in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@) +can be converted to Haskell's 'Data.Time.LocalTime', because values of these +types are ambiguous by themselves, and require context to disambiguate. + +While this behavior may be superficially counterintuitive because the +names might suggest otherwise, this behavior is correct. In fact, +the \"timezone\" language in both the postgresql and haskell types would +be better read as \"offset (from UTC)\", thus we have postgresql's +\"timestamp with offset\" corresponding to Haskell's \"time with the +offset \'zero\'\" and Haskell's \"time with an offset (that might be +nonzero)\". Similarly, postgresql's \"timestamp without an offset\" +corresponds to Haskell's \"local time (without an offset)\". + +It's important to distinguish between an offset, a standard time, and +a time zone. An offset is simply a difference of a local time from UTC, +such as @+00@, @-05@, or @+05:30@. A standard time specifies an offset +(which may vary throughout the year, due to daylight savings) that a +region follows, such as Universal Coordinated Time (UTC), Eastern Standard +Time\/Eastern Daylight Time (EST\/EDT), or India Standard Time (IST). +And a time zone, much like a standard time, is a function from +timestamps to offsets. + +A time zone is different from a standard time because different regions +inside a standard time can be governed by different civil authorities with +different laws and thus have different histories of civil time. An IANA +time zone is any region of the world that has had the same history of +civil time since @1970-01-01 00:00+00@. + +For example, as of today, both @America\/New_York@ and +@America\/Indiana\/Indianapolis@ are on the EST\/EDT time standard, but +Indiana used to be on Central Standard Time until 1942, and did not observe +daylight savings time (EST only) until 2006. Thus, the choice between +these two time zones still matters if you are dealing with timestamps +prior to 2006, and could become relevant again if (most of) Indiana +moves back to Central Time. (Of course, if the Central to Eastern switch +was the only difference, then these two time zones would be the same in +IANA's eyes, due to their cutoff date of 1970-01-01.) + +Getting back to practicalities, PostgreSQL's @timestamptz@ type does not +actually store an offset; rather, it uses the offset provided to calculate +UTC, and stores the timestamp as UTC. If an offset is not provided, the +given timestamp is assumed to be a local time for whatever the @timezone@ +variable is set to, and the IANA TZ database is consulted to calculate an +offset from UTC for the time in question. + +Note that while most (local timestamp, time zone) pairs correspond to exactly +one UTC timestamp, some correspond to two UTC timestamps, while others +correspond to none at all. The ambiguous case occurs when the civil time +is rolled back, making a calendar day longer than 24 hours. In this case, +PostgreSQL silently chooses the second, later possibility. The inconsistent +case occurs when the civil time is moved forward, making a calendar day less +than 24 hours. In this case, PostgreSQL silently assumes the local time +was read off a clock that had not been moved forward at the prescribed time, +and moves the clock forward for you. Thus, converting from local time +to UTC need not be monotonic, if these inconsistent cases are allowed. + +When retrieving a @timestamptz@, the backend looks at the @time zone@ +connection variable and then consults the IANA TZ database to calculate +an offset for the timestamp in the given time zone. + +Note that while some of the information contained in the IANA TZ database +is a bit of a standardized fiction, the conversion from UTC time to a +(local time, offset) pair in a particular time zone is always unambiguous, +and the result can always be unambiguously converted back to UTC. Thus, +pg can interpret such a result as a 'Data.Time.ZonedTime', +or use the offset to convert back to 'Data.Time.UTCTime'. + +By contrast, the @timestamp@ type ignores any offsets provided to it, +and never sends back an offset. Thus, pg equates this +with 'Data.Time.LocalTime', which has no concept of an offset. One can +convert between @timestamptz@ and @timestamp@ using the @AT TIME ZONE@ +operator, whose semantics also demonstrates that @timestamptz@ is +'Data.Time.UTCTime' whereas @timestamp@ is 'Data.Time.LocalTime'. + +PostgreSQL's @timezone@ is a per-connection variable that by default is +initialized to @\'localtime\'@, which normally corresponds to the server's +time zone. However, this default can be modified on the server side for an +entire cluster, or on a per-user or per-database basis. Moreover, a client +can modify their instance of the variable at any time, and can apply that +change to the remaining duration of the connection, the current transaction, +or the execution context of a server-side function. In addition, upon +connection initialization, the libpq client checks for the existence of +the @PGTZ@ environment variable, and if it exists, modifies @timezone@ +accordingly. + +With a few caveats, pg is designed so that you can both send +and receive timestamps with the server and get a correct result, no matter +what the @timezone@ setting is. But it is important to understand the caveats: + +1. The correctness of server-side computations can depend on the @timezone@ + setting. Examples include adding an @interval@ to a @timestamptz@, or + type casting between @timestamp@ and @timestamptz@, or applying + the @DATE@ function to a @timestamptz@. + +2. The (localtime, offset) pair contained in a 'Data.Time.ZonedTime' result + will depend on the @timezone@ setting, although the result will always + represent the same instant in time regardless of the time zone. + +3. Sending a 'Data.Time.LocalTime' and interpreting it as a @timestamptz@ + can be useful, as it will be converted to UTC via the tz database, + but correctness will depend on the @timezone@ setting. You may prefer + to use an explicit @AT TIME ZONE@ conversion instead, which would avoid + this contextual dependence. + +Furthermore, although these following points don't involve the @timezone@ +setting, they are related to the last point above: + +1. Sending a 'Data.Time.UTCTime' and interpreting it as a @timestamp@ can + be useful. In practice, the most common context used to disambiguate + @timestamp@ is that it represents UTC, and this coding technique will + work as expected in this situation. + +2. Sending a 'Data.Time.ZonedTime' and interpreting it as a @timestamp@ is + almost always the wrong thing to do, as the offset will be ignored and + discarded. This is likely to lead to inconsistencies in the database, + and may lead to partial data loss. + +When dealing with local timestamps that refer to the future, it is often +useful to store it as a local time in a @timestamp@ column and store the +time zone in a second column. One reason to do this is so that you can +convert to UTC on the fly as needed, and be protected against future changes +to the TZ database due to changes in local time standards. In any case, +'Data.Time.ZonedTime' is not suitable for this application, because despite +its name, it represents an offset and not a time zone. Time zones can change; +offsets do not. In reality, we can't convert a local timestamp that occurs +sufficiently far in the future to UTC, because we don't know how to do it yet. + +There are a few limitations and caveats that one might need to be aware +of with the current implementation when dealing with older timestamps: + +For sufficiently old timestamps in almost all time zones, the IANA TZ +database specifies offsets from UTC that is not an integral number of +minutes. This corresponds to local mean time; that is, astronomical +time in the city that defines the time zone. Different time zones moved +away from local mean time to a standard time at different points in +history, so \"sufficiently old\" depends on the time zone in question. + +Thus, when retrieving a @timestamptz@ postgresql will in some cases +provide seconds in the offset. For example: + +@ +$ psql +psql (9.4.5) +Type \"help\" for help. + +lpsmith=> SET timezone TO \'America/New_York\'; +SET +lpsmith=> VALUES (\'1883-11-18 16:59:59+00\'::timestamptz), + (\'1883-11-18 17:00:00+00\'::timestamptz); + column1 +------------------------------ + 1883-11-18 12:03:57-04:56:02 + 1883-11-18 12:00:00-05 +(2 rows) +@ + +Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type, +however 'Data.Time.ZonedTime' will fail on the former timestamp. +Because 'Data.Time.ZonedTime' assumes that offsets are an integer number +of minutes, there isn't an particularly good solution here. + +PostgreSQL, like most software, uses the proleptic Gregorian calendar +for its date calculations, extending the Gregorian calendar backwards +in time before its introduction and pretending that the Julian calendar +does not exist. For most purposes, the adoption of the Gregorian calendar +ranges from @1582-10-15@ to @1923-03-01@, depending on location and +sometimes even political allegiances within a single location. + +Timestamps BCE are not supported. For example, PostgreSQL +will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of +the year the Roman Empire adopted the Julian Calendar, but +pg does not (yet?) have the ability to either parse or +generate this syntax. Unfortunately this syntax isn't convenient to +print or especially parse. + +Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@, +which is the Julian date on the proleptic Gregorian Calendar. Although +postgresql's timestamp types are perfectly capable of representing timestamps +nearly 300,000 years in the past, using this would require pg +and other client programs to support binary parameters and results. + +Dealing with years BCE is also complicated slightly by the fact that +Haskell's time library has a year \"0000\", which is a convention often +used by astronomers, while postgresql adopts the more historically +accurate convention that there is no year zero, but rather \"1 BCE\" +was immediately followed by \"1 CE\". + +-} + +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 + , nominalDiffTimeToBuilder + ) where + +import Database.PostgreSQL.Simple.Time.Implementation diff --git a/src/Database/PostgreSQL/Simple/Time/Implementation.hs b/src/Database/PostgreSQL/Simple/Time/Implementation.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Implementation.hs @@ -0,0 +1,166 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.Time.Implementation +-- Copyright: (c) 2012-2015 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +------------------------------------------------------------------------------ + +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} + +module Database.PostgreSQL.Simple.Time.Implementation where + +import Prelude hiding (take) +import Data.ByteString.Builder(Builder, byteString) +import Data.ByteString.Builder.Prim(primBounded) +import Control.Arrow((***)) +import Control.Applicative +import qualified Data.ByteString as B +import Data.Time hiding (getTimeZone, getZonedTime) +import Data.Typeable +import Data.Maybe (fromMaybe) +import qualified Data.Attoparsec.ByteString.Char8 as A +import Database.PostgreSQL.Simple.Compat ((<>)) +import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP +import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP + +data Unbounded a + = NegInfinity + | Finite !a + | PosInfinity + deriving (Eq, Ord, Typeable, Functor) + +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 = TP.day + +getDate :: A.Parser Date +getDate = getUnbounded getDay + +getTimeOfDay :: A.Parser TimeOfDay +getTimeOfDay = TP.timeOfDay + +getLocalTime :: A.Parser LocalTime +getLocalTime = TP.localTime + +getLocalTimestamp :: A.Parser LocalTimestamp +getLocalTimestamp = getUnbounded getLocalTime + +getTimeZone :: A.Parser TimeZone +getTimeZone = fromMaybe utc <$> TP.timeZone + +type TimeZoneHMS = (Int,Int,Int) + +getTimeZoneHMS :: A.Parser TimeZoneHMS +getTimeZoneHMS = munge <$> TP.timeZoneHMS + where + munge Nothing = (0,0,0) + munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s) + +localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay) +localToUTCTimeOfDayHMS (dh, dm, ds) tod = + TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod + +getZonedTime :: A.Parser ZonedTime +getZonedTime = TP.zonedTime + +getZonedTimestamp :: A.Parser ZonedTimestamp +getZonedTimestamp = getUnbounded getZonedTime + +getUTCTime :: A.Parser UTCTime +getUTCTime = TP.utcTime + +getUTCTimestamp :: A.Parser UTCTimestamp +getUTCTimestamp = getUnbounded getUTCTime + +dayToBuilder :: Day -> Builder +dayToBuilder = primBounded TPP.day + +timeOfDayToBuilder :: TimeOfDay -> Builder +timeOfDayToBuilder = primBounded TPP.timeOfDay + +timeZoneToBuilder :: TimeZone -> Builder +timeZoneToBuilder = primBounded TPP.timeZone + +utcTimeToBuilder :: UTCTime -> Builder +utcTimeToBuilder = primBounded TPP.utcTime + +zonedTimeToBuilder :: ZonedTime -> Builder +zonedTimeToBuilder = primBounded TPP.zonedTime + +localTimeToBuilder :: LocalTime -> Builder +localTimeToBuilder = primBounded TPP.localTime + +unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder) +unboundedToBuilder finiteToBuilder unbounded + = case unbounded of + NegInfinity -> byteString "-infinity" + Finite a -> finiteToBuilder a + PosInfinity -> byteString "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 + +nominalDiffTimeToBuilder :: NominalDiffTime -> Builder +nominalDiffTimeToBuilder = TPP.nominalDiffTime diff --git a/src/Database/PostgreSQL/Simple/Time/Internal.hs b/src/Database/PostgreSQL/Simple/Time/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Internal.hs @@ -0,0 +1,27 @@ +------------------------------------------------------------------------------ +-- | +-- 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 + , TimeZoneHMS + , getTimeZoneHMS + , localToUTCTimeOfDayHMS + ) where + +import Database.PostgreSQL.Simple.Time.Implementation diff --git a/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs b/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE BangPatterns, ScopedTypeVariables #-} + +-- | +-- Module: Database.PostgreSQL.Simple.Time.Internal.Parser +-- Copyright: (c) 2012-2015 Leon P Smith +-- (c) 2015 Bryan O'Sullivan +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- Parsers for parsing dates and times. + +module Database.PostgreSQL.Simple.Time.Internal.Parser + ( + day + , localTime + , timeOfDay + , timeZone + , UTCOffsetHMS(..) + , timeZoneHMS + , localToUTCTimeOfDayHMS + , utcTime + , zonedTime + ) where + +import Control.Applicative ((<$>), (<*>), (<*), (*>)) +import Database.PostgreSQL.Simple.Compat (toPico) +import Data.Attoparsec.ByteString.Char8 as A +import Data.Bits ((.&.)) +import Data.Char (ord) +import Data.Fixed (Pico) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Time.Calendar (Day, fromGregorianValid, addDays) +import Data.Time.Clock (UTCTime(..)) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.Time.LocalTime as Local + +-- | Parse a date of the form @YYYY-MM-DD@. +day :: Parser Day +day = do + y <- decimal <* char '-' + m <- twoDigits <* char '-' + d <- twoDigits + maybe (fail "invalid date") return (fromGregorianValid y m d) + +-- | Parse a two-digit integer (e.g. day of month, hour). +twoDigits :: Parser Int +twoDigits = do + a <- digit + b <- digit + let c2d c = ord c .&. 15 + return $! c2d a * 10 + c2d b + +-- | Parse a time of the form @HH:MM[:SS[.SSS]]@. +timeOfDay :: Parser Local.TimeOfDay +timeOfDay = do + h <- twoDigits <* char ':' + m <- twoDigits + mc <- peekChar + s <- case mc of + Just ':' -> anyChar *> seconds + _ -> return 0 + if h < 24 && m < 60 && s <= 60 + then return (Local.TimeOfDay h m s) + else fail "invalid time" + +-- | Parse a count of seconds, with the integer part being two digits +-- long. +seconds :: Parser Pico +seconds = do + real <- twoDigits + mc <- peekChar + case mc of + Just '.' -> do + t <- anyChar *> takeWhile1 isDigit + return $! parsePicos (fromIntegral real) t + _ -> return $! fromIntegral real + where + parsePicos :: Int64 -> B8.ByteString -> Pico + parsePicos a0 t = toPico (fromIntegral (t' * 10^n)) + where n = max 0 (12 - B8.length t) + t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0 + (B8.take 12 t) + +-- | Parse a time zone, and return 'Nothing' if the offset from UTC is +-- zero. (This makes some speedups possible.) +timeZone :: Parser (Maybe Local.TimeZone) +timeZone = do + ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' + if ch == 'Z' + then return Nothing + else do + h <- twoDigits + mm <- peekChar + m <- case mm of + Just ':' -> anyChar *> twoDigits + _ -> return 0 + let off | ch == '-' = negate off0 + | otherwise = off0 + off0 = h * 60 + m + case undefined of + _ | off == 0 -> + return Nothing + | h > 23 || m > 59 -> + fail "invalid time zone offset" + | otherwise -> + let !tz = Local.minutesToTimeZone off + in return (Just tz) + +data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int + +-- | Parse a time zone, and return 'Nothing' if the offset from UTC is +-- zero. (This makes some speedups possible.) +timeZoneHMS :: Parser (Maybe UTCOffsetHMS) +timeZoneHMS = do + ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' + if ch == 'Z' + then return Nothing + else do + h <- twoDigits + m <- maybeTwoDigits + s <- maybeTwoDigits + case undefined of + _ | h == 0 && m == 0 && s == 0 -> + return Nothing + | h > 23 || m >= 60 || s >= 60 -> + fail "invalid time zone offset" + | otherwise -> + if ch == '+' + then let !tz = UTCOffsetHMS h m s + in return (Just tz) + else let !tz = UTCOffsetHMS (-h) (-m) (-s) + in return (Just tz) + where + maybeTwoDigits = do + ch <- peekChar + case ch of + Just ':' -> anyChar *> twoDigits + _ -> return 0 + +localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay) +localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) = + (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'') + where + s' = s - fromIntegral ds + (!s'', m') + | s' < 0 = (s' + 60, m - dm - 1) + | s' >= 60 = (s' - 60, m - dm + 1) + | otherwise = (s' , m - dm ) + (!m'', h') + | m' < 0 = (m' + 60, h - dh - 1) + | m' >= 60 = (m' - 60, h - dh + 1) + | otherwise = (m' , h - dh ) + (!h'', dday) + | h' < 0 = (h' + 24, -1) + | h' >= 24 = (h' - 24, 1) + | otherwise = (h' , 0) + + +-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@. +-- The space may be replaced with a @T@. The number of seconds may be +-- followed by a fractional component. +localTime :: Parser Local.LocalTime +localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay + where daySep = satisfy (\c -> c == ' ' || c == 'T') + +-- | Behaves as 'zonedTime', but converts any time zone offset into a +-- UTC time. +utcTime :: Parser UTCTime +utcTime = do + (Local.LocalTime d t) <- localTime + mtz <- timeZoneHMS + case mtz of + Nothing -> let !tt = Local.timeOfDayToTime t + in return (UTCTime d tt) + Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t + !d' = addDays dd d + !tt = Local.timeOfDayToTime t' + in return (UTCTime d' tt) + +-- | Parse a date with time zone info. Acceptable formats: +-- +-- @YYYY-MM-DD HH:MM:SS Z@ +-- +-- The first space may instead be a @T@, and the second space is +-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a +-- time zone offset of the form @+0000@ or @-08:00@, where the first +-- two digits are hours, the @:@ is optional and the second two digits +-- (also optional) are minutes. +zonedTime :: Parser Local.ZonedTime +zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone) + +utc :: Local.TimeZone +utc = Local.TimeZone 0 False "" diff --git a/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs b/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE BangPatterns, ViewPatterns #-} + +------------------------------------------------------------------------------ +-- Module: Database.PostgreSQL.Simple.Time.Internal.Printer +-- Copyright: (c) 2012-2015 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.Time.Internal.Printer + ( + day + , timeOfDay + , timeZone + , utcTime + , localTime + , zonedTime + , nominalDiffTime + ) where + +import Control.Arrow ((>>>)) +import Data.ByteString.Builder (Builder, integerDec) +import Data.ByteString.Builder.Prim + ( liftFixedToBounded, (>$<), (>*<) + , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec) +import Data.Char ( chr ) +import Data.Int ( Int32, Int64 ) +import Data.Time + ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime + , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay + , TimeZone, timeZoneMinutes ) +import Database.PostgreSQL.Simple.Compat ((<>), fromPico) +import Unsafe.Coerce (unsafeCoerce) + +liftB :: FixedPrim a -> BoundedPrim a +liftB = liftFixedToBounded + +digit :: FixedPrim Int +digit = (\x -> chr (x + 48)) >$< char8 + +digits2 :: FixedPrim Int +digits2 = (`quotRem` 10) >$< (digit >*< digit) + +digits3 :: FixedPrim Int +digits3 = (`quotRem` 10) >$< (digits2 >*< digit) + +digits4 :: FixedPrim Int +digits4 = (`quotRem` 10) >$< (digits3 >*< digit) + +frac :: BoundedPrim Int64 +frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12)) + where + trunc12 :: BoundedPrim Int64 + trunc12 = (`quotRem` 1000000) >$< + condB (\(_,y) -> y == 0) + (fst >$< trunc6) + (liftB digits6 >*< trunc6) + + digitB = liftB digit + + digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit) + digits5 = (`quotRem` 10) >$< (digits4 >*< digit) + + trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5) + trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4)) + trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3)) + trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2)) + trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1)) + trunc1 = condB (== 0) emptyB digitB + + +year :: BoundedPrim Int32 +year = condB (> 10000) int32Dec (checkBCE >$< liftB digits4) + where + checkBCE :: Int32 -> Int + checkBCE y + | y > 0 = fromIntegral y + | otherwise = error msg + + msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported" + +day :: BoundedPrim Day +day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2)) + where + toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d)))) + +timeOfDay :: BoundedPrim TimeOfDay +timeOfDay = f >$< (hh_mm_ >*< ss) + where + f (TimeOfDay h m s) = ((h,(':',(m,':'))),s) + + hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8) + + ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$< + (liftB (fromIntegral >$< digits2) >*< frac) + +timeZone :: BoundedPrim TimeZone +timeZone = timeZoneMinutes >$< tz + where + tz = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh) + + tzh = liftB char8 >*< ((`quotRem` 60) >$< (liftB digits2 >*< tzm)) + + tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2)) + +utcTime :: BoundedPrim UTCTime +utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8) + where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z'))) + +localTime :: BoundedPrim LocalTime +localTime = f >$< (day >*< liftB char8 >*< timeOfDay) + where f (LocalTime d tod) = (d, (' ', tod)) + +zonedTime :: BoundedPrim ZonedTime +zonedTime = f >$< (localTime >*< timeZone) + where f (ZonedTime lt tz) = (lt, tz) + + +nominalDiffTime :: NominalDiffTime -> Builder +nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y)) + where + (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000 diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -0,0 +1,371 @@ +{-# LANGUAGE CPP, 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(..) + , toJSONField + , inQuotes + ) where + +import qualified Data.Aeson as JSON +import Data.ByteString (ByteString) +import Data.ByteString.Builder + ( Builder, byteString, char8, stringUtf8 + , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec + , wordDec, word8Dec, word16Dec, word32Dec, word64Dec + , floatDec, doubleDec + ) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.List (intersperse) +import Data.Monoid (mappend) +import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime) +import Data.Typeable (Typeable) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow +import Database.PostgreSQL.Simple.Types +import Database.PostgreSQL.Simple.Compat (toByteString) + +import qualified Data.ByteString as SB +import qualified Data.ByteString.Lazy as LB +import qualified Data.Text as ST +import qualified Data.Text.Encoding as ST +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.Builder as LT +import Data.UUID.Types (UUID) +import qualified Data.UUID.Types as UUID +import Data.Vector (Vector) +import qualified Data.Vector as V +import qualified Database.PostgreSQL.LibPQ as PQ +import Database.PostgreSQL.Simple.Time +import Data.Scientific (Scientific) +#if MIN_VERSION_scientific(0,3,0) +import Data.Text.Lazy.Builder.Scientific (scientificBuilder) +#else +import Data.Scientific (scientificBuilder) +#endif +import Foreign.C.Types (CUInt(..)) + +-- | 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. + | EscapeIdentifier ByteString + -- ^ Escape before substituting. Use for all sql identifiers like + -- table, column names, etc. This is used by the 'Identifier' 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 (EscapeIdentifier b) = "EscapeIdentifier " ++ 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 $ byteString "(null)" + toField (In xs) = Many $ + Plain (char8 '(') : + (intersperse (Plain (char8 ',')) . map toField $ xs) ++ + [Plain (char8 ')')] + +renderNull :: Action +renderNull = Plain (byteString "null") + +instance ToField Null where + toField _ = renderNull + {-# INLINE toField #-} + +instance ToField Default where + toField _ = Plain (byteString "default") + {-# INLINE toField #-} + +instance ToField Bool where + toField True = Plain (byteString "true") + toField False = Plain (byteString "false") + {-# INLINE toField #-} + +instance ToField Int8 where + toField = Plain . int8Dec + {-# INLINE toField #-} + +instance ToField Int16 where + toField = Plain . int16Dec + {-# INLINE toField #-} + +instance ToField Int32 where + toField = Plain . int32Dec + {-# INLINE toField #-} + +instance ToField Int where + toField = Plain . intDec + {-# INLINE toField #-} + +instance ToField Int64 where + toField = Plain . int64Dec + {-# INLINE toField #-} + +instance ToField Integer where + toField = Plain . integerDec + {-# INLINE toField #-} + +instance ToField Word8 where + toField = Plain . word8Dec + {-# INLINE toField #-} + +instance ToField Word16 where + toField = Plain . word16Dec + {-# INLINE toField #-} + +instance ToField Word32 where + toField = Plain . word32Dec + {-# INLINE toField #-} + +instance ToField Word where + toField = Plain . wordDec + {-# INLINE toField #-} + +instance ToField Word64 where + toField = Plain . word64Dec + {-# INLINE toField #-} + +instance ToField PQ.Oid where + toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x + {-# INLINE toField #-} + +instance ToField Float where + toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v)) + | otherwise = Plain (floatDec v) + {-# INLINE toField #-} + +instance ToField Double where + toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v)) + | otherwise = Plain (doubleDec v) + {-# INLINE toField #-} + +instance ToField Scientific where + toField x = toField (LT.toLazyText (scientificBuilder x)) + {-# 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 Identifier where + toField (Identifier bs) = EscapeIdentifier (ST.encodeUtf8 bs) + {-# INLINE toField #-} + +instance ToField QualifiedIdentifier where + toField (QualifiedIdentifier (Just s) t) = + Many [ EscapeIdentifier (ST.encodeUtf8 s) + , Plain (char8 '.') + , EscapeIdentifier (ST.encodeUtf8 t) + ] + toField (QualifiedIdentifier Nothing t) = + EscapeIdentifier (ST.encodeUtf8 t) + {-# 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 . stringUtf8 + {-# 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 NominalDiffTime where + toField = Plain . inQuotes . nominalDiffTimeToBuilder + {-# INLINE toField #-} + +instance (ToField a) => ToField (PGArray a) where + toField pgArray = + case fromPGArray pgArray of + [] -> Plain (byteString "'{}'") + xs -> Many $ + Plain (byteString "ARRAY[") : + (intersperse (Plain (char8 ',')) . map toField $ xs) ++ + [Plain (char8 ']')] + -- Because the ARRAY[...] input syntax is being used, it is possible + -- that the use of type-specific separator characters is unnecessary. + +instance (ToField a) => ToField (Vector a) where + toField = toField . PGArray . V.toList + +instance ToField UUID where + toField = Plain . inQuotes . byteString . UUID.toASCIIBytes + +instance ToField JSON.Value where + toField = toField . JSON.encode + +-- | Convert a Haskell value to a JSON 'JSON.Value' using +-- 'JSON.toJSON' and convert that to a field using 'toField'. +-- +-- This can be used as the default implementation for the 'toField' +-- method for Haskell types that have a JSON representation in +-- PostgreSQL. +toJSONField :: JSON.ToJSON a => a -> Action +toJSONField = toField . JSON.toJSON + +-- | 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 = char8 '\'' + +interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b] +interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as +{-# INLINE interleaveFoldr #-} + +instance ToRow a => ToField (Values a) where + toField (Values types rows) = + case rows of + [] -> case types of + [] -> error norows + (_:_) -> values $ typedRow (repeat (lit "null")) + types + [lit " LIMIT 0)"] + (_:_) -> case types of + [] -> values $ untypedRows rows [litC ')'] + (_:_) -> values $ typedRows rows types [litC ')'] + where + funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action" + norows = funcname ++ " either values or types must be non-empty" + emptyrow = funcname ++ " each row must contain at least one column" + lit = Plain . byteString + litC = Plain . char8 + values x = Many (lit "(VALUES ": x) + + typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action] + typedField (val,typ) rest = val : lit "::" : toField typ : rest + + typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action] + typedRow (val:vals) (typ:typs) rest = + litC '(' : + typedField (val,typ) ( interleaveFoldr + typedField + (litC ',') + (litC ')' : rest) + (zip vals typs) ) + typedRow _ _ _ = error emptyrow + + untypedRow :: [Action] -> [Action] -> [Action] + untypedRow (val:vals) rest = + litC '(' : val : + interleaveFoldr + (:) + (litC ',') + (litC ')' : rest) + vals + untypedRow _ _ = error emptyrow + + typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action] + typedRows [] _ _ = error funcname + typedRows (val:vals) types rest = + typedRow (toRow val) types (multiRows vals rest) + + untypedRows :: ToRow a => [a] -> [Action] -> [Action] + untypedRows [] _ = error funcname + untypedRows (val:vals) rest = + untypedRow (toRow val) (multiRows vals rest) + + multiRows :: ToRow a => [a] -> [Action] -> [Action] + multiRows vals rest = interleaveFoldr + (untypedRow . toRow) + (litC ',') + rest + vals diff --git a/src/Database/PostgreSQL/Simple/ToField.hs-boot b/src/Database/PostgreSQL/Simple/ToField.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/ToField.hs-boot @@ -0,0 +1,30 @@ +module Database.PostgreSQL.Simple.ToField where + +import Database.PostgreSQL.Simple.Types +import Data.ByteString.Builder(Builder) +import Data.ByteString(ByteString) + +-- | 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. + | EscapeIdentifier ByteString + -- ^ Escape before substituting. Use for all sql identifiers like + -- table, column names, etc. This is used by the 'Identifier' newtype + -- wrapper. + | Many [Action] + -- ^ Concatenate a series of rendering actions. + +class ToField a + +instance ToField Oid diff --git a/src/Database/PostgreSQL/Simple/ToRow.hs b/src/Database/PostgreSQL/Simple/ToRow.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/ToRow.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} +------------------------------------------------------------------------------ +-- | +-- 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(..), (:.)(..)) +import GHC.Generics + +-- | A collection type that can be turned into a list of rendering +-- 'Action's. +-- +-- Instances should use the 'toField' method of the 'ToField' class +-- to perform conversion of each element of the collection. +class ToRow a where + toRow :: a -> [Action] + default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action] + toRow = gtoRow . from + -- ^ 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 + + +-- Type class for default implementation of ToRow using generics +class GToRow f where + gtoRow :: f p -> [Action] + +instance GToRow f => GToRow (M1 c i f) where + gtoRow (M1 x) = gtoRow x + +instance (GToRow f, GToRow g) => GToRow (f :*: g) where + gtoRow (f :*: g) = gtoRow f ++ gtoRow g + +instance (ToField a) => GToRow (K1 R a) where + gtoRow (K1 a) = [toField a] + +instance GToRow U1 where + gtoRow _ = [] diff --git a/src/Database/PostgreSQL/Simple/ToRow.hs-boot b/src/Database/PostgreSQL/Simple/ToRow.hs-boot new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/ToRow.hs-boot @@ -0,0 +1,18 @@ +{-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} +module Database.PostgreSQL.Simple.ToRow ( + ToRow(..) + ) where + +import Database.PostgreSQL.Simple.Types +import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField +import GHC.Generics + +class ToRow a where + toRow :: a -> [Action] + default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action] + toRow = gtoRow . from + +class GToRow f where + gtoRow :: f p -> [Action] + +instance ToField a => ToRow (Only a) diff --git a/src/Database/PostgreSQL/Simple/Transaction.hs b/src/Database/PostgreSQL/Simple/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Transaction.hs @@ -0,0 +1,260 @@ +{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.Transaction +-- Copyright: (c) 2011-2013 Leon P Smith +-- (c) 2013 Joey Adams +-- License: BSD3 +-- Maintainer: Leon P Smith +-- +------------------------------------------------------------------------------ + +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 qualified Data.ByteString as B +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.Types +import Database.PostgreSQL.Simple.Errors +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 () + +-- | Rollback a transaction, ignoring any @IOErrors@ +rollback_ :: Connection -> IO () +rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> 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 diff --git a/src/Database/PostgreSQL/Simple/TypeInfo.hs b/src/Database/PostgreSQL/Simple/TypeInfo.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/TypeInfo.hs @@ -0,0 +1,121 @@ +{-# 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 pg'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) diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE TemplateHaskell #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.TypeInfo.Macro +-- Copyright: (c) 2013 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- A Template Haskell macro for efficiently checking membership in +-- a set of type oids. +-- +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.TypeInfo.Macro + ( mkCompats + , inlineTypoid + ) where + +import Database.PostgreSQL.Simple.TypeInfo.Static +import Database.PostgreSQL.Simple.Types (Oid(..)) +import Language.Haskell.TH + + +-- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the +-- oid is equal to any one of the 'typoid's of the given 'TypeInfo's. +mkCompats :: [TypeInfo] -> ExpQ +mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |] + where + alt :: TypeInfo -> MatchQ + alt ty = match (inlineTypoidP ty) (normalB [| True |]) [] + + catchAll :: MatchQ + catchAll = match wildP (normalB [| False |]) [] + +-- | Literally substitute the 'typoid' of a 'TypeInfo' expression. +-- Returns an expression of type 'Oid'. Useful because GHC tends +-- not to fold constants. +inlineTypoid :: TypeInfo -> ExpQ +inlineTypoid ty = [| Oid $(litE (getTypoid ty)) |] + +inlineTypoidP :: TypeInfo -> PatQ +inlineTypoidP ty = litP (getTypoid ty) + +getTypoid :: TypeInfo -> Lit +getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x) diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Static.hs @@ -0,0 +1,1232 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.TypeInfo +-- Copyright: (c) 2011-2012 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +-- This module contains portions of the @pg_type@ table that are relevant +-- to pg and are believed to not change between PostgreSQL +-- versions. +-- +------------------------------------------------------------------------------ + +-- 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 + , unknown + , circle + , money + , macaddr + , inet + , bpchar + , varchar + , date + , time + , timestamp + , timestamptz + , interval + , timetz + , bit + , varbit + , numeric + , refcursor + , record + , void + , array_record + , regprocedure + , regoper + , regoperator + , regclass + , regtype + , uuid + , json + , jsonb + , int2vector + , oidvector + , array_xml + , array_json + , array_line + , array_cidr + , array_circle + , array_money + , array_bool + , array_bytea + , array_char + , array_name + , array_int2 + , array_int2vector + , array_int4 + , array_regproc + , array_text + , array_tid + , array_xid + , array_cid + , array_oidvector + , array_bpchar + , array_varchar + , array_int8 + , array_point + , array_lseg + , array_path + , array_box + , array_float4 + , array_float8 + , array_polygon + , array_oid + , array_macaddr + , array_inet + , array_timestamp + , array_date + , array_time + , array_timestamptz + , array_interval + , array_numeric + , array_timetz + , array_bit + , array_varbit + , array_refcursor + , array_regprocedure + , array_regoper + , array_regoperator + , array_regclass + , array_regtype + , array_uuid + , array_jsonb + , int4range + , _int4range + , numrange + , _numrange + , tsrange + , _tsrange + , tstzrange + , _tstzrange + , daterange + , _daterange + , int8range + , _int8range + ) 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 + 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 + 2287 -> Just array_record + 2202 -> Just regprocedure + 2203 -> Just regoper + 2204 -> Just regoperator + 2205 -> Just regclass + 2206 -> Just regtype + 2950 -> Just uuid + 114 -> Just json + 3802 -> Just jsonb + 22 -> Just int2vector + 30 -> Just oidvector + 143 -> Just array_xml + 199 -> Just array_json + 629 -> Just array_line + 651 -> Just array_cidr + 719 -> Just array_circle + 791 -> Just array_money + 1000 -> Just array_bool + 1001 -> Just array_bytea + 1002 -> Just array_char + 1003 -> Just array_name + 1005 -> Just array_int2 + 1006 -> Just array_int2vector + 1007 -> Just array_int4 + 1008 -> Just array_regproc + 1009 -> Just array_text + 1010 -> Just array_tid + 1011 -> Just array_xid + 1012 -> Just array_cid + 1013 -> Just array_oidvector + 1014 -> Just array_bpchar + 1015 -> Just array_varchar + 1016 -> Just array_int8 + 1017 -> Just array_point + 1018 -> Just array_lseg + 1019 -> Just array_path + 1020 -> Just array_box + 1021 -> Just array_float4 + 1022 -> Just array_float8 + 1027 -> Just array_polygon + 1028 -> Just array_oid + 1040 -> Just array_macaddr + 1041 -> Just array_inet + 1115 -> Just array_timestamp + 1182 -> Just array_date + 1183 -> Just array_time + 1185 -> Just array_timestamptz + 1187 -> Just array_interval + 1231 -> Just array_numeric + 1270 -> Just array_timetz + 1561 -> Just array_bit + 1563 -> Just array_varbit + 2201 -> Just array_refcursor + 2207 -> Just array_regprocedure + 2208 -> Just array_regoper + 2209 -> Just array_regoperator + 2210 -> Just array_regclass + 2211 -> Just array_regtype + 2951 -> Just array_uuid + 3807 -> Just array_jsonb + 3904 -> Just int4range + 3905 -> Just _int4range + 3906 -> Just numrange + 3907 -> Just _numrange + 3908 -> Just tsrange + 3909 -> Just _tsrange + 3910 -> Just tstzrange + 3911 -> Just _tstzrange + 3912 -> Just daterange + 3913 -> Just _daterange + 3926 -> Just int8range + 3927 -> Just _int8range + _ -> 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" + } + +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" + } + +array_record :: TypeInfo +array_record = Array { + typoid = Oid 2287, + typcategory = 'P', + typdelim = ',', + typname = "_record", + typelem = record + } + +regprocedure :: TypeInfo +regprocedure = Basic { + typoid = Oid 2202, + typcategory = 'N', + typdelim = ',', + typname = "regprocedure" + } + +regoper :: TypeInfo +regoper = Basic { + typoid = Oid 2203, + typcategory = 'N', + typdelim = ',', + typname = "regoper" + } + +regoperator :: TypeInfo +regoperator = Basic { + typoid = Oid 2204, + typcategory = 'N', + typdelim = ',', + typname = "regoperator" + } + +regclass :: TypeInfo +regclass = Basic { + typoid = Oid 2205, + typcategory = 'N', + typdelim = ',', + typname = "regclass" + } + +regtype :: TypeInfo +regtype = Basic { + typoid = Oid 2206, + typcategory = 'N', + typdelim = ',', + typname = "regtype" + } + +uuid :: TypeInfo +uuid = Basic { + typoid = Oid 2950, + typcategory = 'U', + typdelim = ',', + typname = "uuid" + } + +json :: TypeInfo +json = Basic { + typoid = Oid 114, + typcategory = 'U', + typdelim = ',', + typname = "json" + } + +jsonb :: TypeInfo +jsonb = Basic { + typoid = Oid 3802, + typcategory = 'U', + typdelim = ',', + typname = "jsonb" + } + +int2vector :: TypeInfo +int2vector = Array { + typoid = Oid 22, + typcategory = 'A', + typdelim = ',', + typname = "int2vector", + typelem = int2 + } + +oidvector :: TypeInfo +oidvector = Array { + typoid = Oid 30, + typcategory = 'A', + typdelim = ',', + typname = "oidvector", + typelem = oid + } + +array_xml :: TypeInfo +array_xml = Array { + typoid = Oid 143, + typcategory = 'A', + typdelim = ',', + typname = "_xml", + typelem = xml + } + +array_json :: TypeInfo +array_json = Array { + typoid = Oid 199, + typcategory = 'A', + typdelim = ',', + typname = "_json", + typelem = json + } + +array_line :: TypeInfo +array_line = Array { + typoid = Oid 629, + typcategory = 'A', + typdelim = ',', + typname = "_line", + typelem = line + } + +array_cidr :: TypeInfo +array_cidr = Array { + typoid = Oid 651, + typcategory = 'A', + typdelim = ',', + typname = "_cidr", + typelem = cidr + } + +array_circle :: TypeInfo +array_circle = Array { + typoid = Oid 719, + typcategory = 'A', + typdelim = ',', + typname = "_circle", + typelem = circle + } + +array_money :: TypeInfo +array_money = Array { + typoid = Oid 791, + typcategory = 'A', + typdelim = ',', + typname = "_money", + typelem = money + } + +array_bool :: TypeInfo +array_bool = Array { + typoid = Oid 1000, + typcategory = 'A', + typdelim = ',', + typname = "_bool", + typelem = bool + } + +array_bytea :: TypeInfo +array_bytea = Array { + typoid = Oid 1001, + typcategory = 'A', + typdelim = ',', + typname = "_bytea", + typelem = bytea + } + +array_char :: TypeInfo +array_char = Array { + typoid = Oid 1002, + typcategory = 'A', + typdelim = ',', + typname = "_char", + typelem = char + } + +array_name :: TypeInfo +array_name = Array { + typoid = Oid 1003, + typcategory = 'A', + typdelim = ',', + typname = "_name", + typelem = name + } + +array_int2 :: TypeInfo +array_int2 = Array { + typoid = Oid 1005, + typcategory = 'A', + typdelim = ',', + typname = "_int2", + typelem = int2 + } + +array_int2vector :: TypeInfo +array_int2vector = Array { + typoid = Oid 1006, + typcategory = 'A', + typdelim = ',', + typname = "_int2vector", + typelem = int2vector + } + +array_int4 :: TypeInfo +array_int4 = Array { + typoid = Oid 1007, + typcategory = 'A', + typdelim = ',', + typname = "_int4", + typelem = int4 + } + +array_regproc :: TypeInfo +array_regproc = Array { + typoid = Oid 1008, + typcategory = 'A', + typdelim = ',', + typname = "_regproc", + typelem = regproc + } + +array_text :: TypeInfo +array_text = Array { + typoid = Oid 1009, + typcategory = 'A', + typdelim = ',', + typname = "_text", + typelem = text + } + +array_tid :: TypeInfo +array_tid = Array { + typoid = Oid 1010, + typcategory = 'A', + typdelim = ',', + typname = "_tid", + typelem = tid + } + +array_xid :: TypeInfo +array_xid = Array { + typoid = Oid 1011, + typcategory = 'A', + typdelim = ',', + typname = "_xid", + typelem = xid + } + +array_cid :: TypeInfo +array_cid = Array { + typoid = Oid 1012, + typcategory = 'A', + typdelim = ',', + typname = "_cid", + typelem = cid + } + +array_oidvector :: TypeInfo +array_oidvector = Array { + typoid = Oid 1013, + typcategory = 'A', + typdelim = ',', + typname = "_oidvector", + typelem = oidvector + } + +array_bpchar :: TypeInfo +array_bpchar = Array { + typoid = Oid 1014, + typcategory = 'A', + typdelim = ',', + typname = "_bpchar", + typelem = bpchar + } + +array_varchar :: TypeInfo +array_varchar = Array { + typoid = Oid 1015, + typcategory = 'A', + typdelim = ',', + typname = "_varchar", + typelem = varchar + } + +array_int8 :: TypeInfo +array_int8 = Array { + typoid = Oid 1016, + typcategory = 'A', + typdelim = ',', + typname = "_int8", + typelem = int8 + } + +array_point :: TypeInfo +array_point = Array { + typoid = Oid 1017, + typcategory = 'A', + typdelim = ',', + typname = "_point", + typelem = point + } + +array_lseg :: TypeInfo +array_lseg = Array { + typoid = Oid 1018, + typcategory = 'A', + typdelim = ',', + typname = "_lseg", + typelem = lseg + } + +array_path :: TypeInfo +array_path = Array { + typoid = Oid 1019, + typcategory = 'A', + typdelim = ',', + typname = "_path", + typelem = path + } + +array_box :: TypeInfo +array_box = Array { + typoid = Oid 1020, + typcategory = 'A', + typdelim = ';', + typname = "_box", + typelem = box + } + +array_float4 :: TypeInfo +array_float4 = Array { + typoid = Oid 1021, + typcategory = 'A', + typdelim = ',', + typname = "_float4", + typelem = float4 + } + +array_float8 :: TypeInfo +array_float8 = Array { + typoid = Oid 1022, + typcategory = 'A', + typdelim = ',', + typname = "_float8", + typelem = float8 + } + +array_polygon :: TypeInfo +array_polygon = Array { + typoid = Oid 1027, + typcategory = 'A', + typdelim = ',', + typname = "_polygon", + typelem = polygon + } + +array_oid :: TypeInfo +array_oid = Array { + typoid = Oid 1028, + typcategory = 'A', + typdelim = ',', + typname = "_oid", + typelem = oid + } + +array_macaddr :: TypeInfo +array_macaddr = Array { + typoid = Oid 1040, + typcategory = 'A', + typdelim = ',', + typname = "_macaddr", + typelem = macaddr + } + +array_inet :: TypeInfo +array_inet = Array { + typoid = Oid 1041, + typcategory = 'A', + typdelim = ',', + typname = "_inet", + typelem = inet + } + +array_timestamp :: TypeInfo +array_timestamp = Array { + typoid = Oid 1115, + typcategory = 'A', + typdelim = ',', + typname = "_timestamp", + typelem = timestamp + } + +array_date :: TypeInfo +array_date = Array { + typoid = Oid 1182, + typcategory = 'A', + typdelim = ',', + typname = "_date", + typelem = date + } + +array_time :: TypeInfo +array_time = Array { + typoid = Oid 1183, + typcategory = 'A', + typdelim = ',', + typname = "_time", + typelem = time + } + +array_timestamptz :: TypeInfo +array_timestamptz = Array { + typoid = Oid 1185, + typcategory = 'A', + typdelim = ',', + typname = "_timestamptz", + typelem = timestamptz + } + +array_interval :: TypeInfo +array_interval = Array { + typoid = Oid 1187, + typcategory = 'A', + typdelim = ',', + typname = "_interval", + typelem = interval + } + +array_numeric :: TypeInfo +array_numeric = Array { + typoid = Oid 1231, + typcategory = 'A', + typdelim = ',', + typname = "_numeric", + typelem = numeric + } + +array_timetz :: TypeInfo +array_timetz = Array { + typoid = Oid 1270, + typcategory = 'A', + typdelim = ',', + typname = "_timetz", + typelem = timetz + } + +array_bit :: TypeInfo +array_bit = Array { + typoid = Oid 1561, + typcategory = 'A', + typdelim = ',', + typname = "_bit", + typelem = bit + } + +array_varbit :: TypeInfo +array_varbit = Array { + typoid = Oid 1563, + typcategory = 'A', + typdelim = ',', + typname = "_varbit", + typelem = varbit + } + +array_refcursor :: TypeInfo +array_refcursor = Array { + typoid = Oid 2201, + typcategory = 'A', + typdelim = ',', + typname = "_refcursor", + typelem = refcursor + } + +array_regprocedure :: TypeInfo +array_regprocedure = Array { + typoid = Oid 2207, + typcategory = 'A', + typdelim = ',', + typname = "_regprocedure", + typelem = regprocedure + } + +array_regoper :: TypeInfo +array_regoper = Array { + typoid = Oid 2208, + typcategory = 'A', + typdelim = ',', + typname = "_regoper", + typelem = regoper + } + +array_regoperator :: TypeInfo +array_regoperator = Array { + typoid = Oid 2209, + typcategory = 'A', + typdelim = ',', + typname = "_regoperator", + typelem = regoperator + } + +array_regclass :: TypeInfo +array_regclass = Array { + typoid = Oid 2210, + typcategory = 'A', + typdelim = ',', + typname = "_regclass", + typelem = regclass + } + +array_regtype :: TypeInfo +array_regtype = Array { + typoid = Oid 2211, + typcategory = 'A', + typdelim = ',', + typname = "_regtype", + typelem = regtype + } + +array_uuid :: TypeInfo +array_uuid = Array { + typoid = Oid 2951, + typcategory = 'A', + typdelim = ',', + typname = "_uuid", + typelem = uuid + } + +array_jsonb :: TypeInfo +array_jsonb = Array { + typoid = Oid 3807, + typcategory = 'A', + typdelim = ',', + typname = "_jsonb", + typelem = jsonb + } + +int4range :: TypeInfo +int4range = Range { + typoid = Oid 3904, + typcategory = 'R', + typdelim = ',', + typname = "int4range", + rngsubtype = int4 + } + +_int4range :: TypeInfo +_int4range = Array { + typoid = Oid 3905, + typcategory = 'A', + typdelim = ',', + typname = "_int4range", + typelem = int4range + } + +numrange :: TypeInfo +numrange = Range { + typoid = Oid 3906, + typcategory = 'R', + typdelim = ',', + typname = "numrange", + rngsubtype = numeric + } + +_numrange :: TypeInfo +_numrange = Array { + typoid = Oid 3907, + typcategory = 'A', + typdelim = ',', + typname = "_numrange", + typelem = numrange + } + +tsrange :: TypeInfo +tsrange = Range { + typoid = Oid 3908, + typcategory = 'R', + typdelim = ',', + typname = "tsrange", + rngsubtype = timestamp + } + +_tsrange :: TypeInfo +_tsrange = Array { + typoid = Oid 3909, + typcategory = 'A', + typdelim = ',', + typname = "_tsrange", + typelem = tsrange + } + +tstzrange :: TypeInfo +tstzrange = Range { + typoid = Oid 3910, + typcategory = 'R', + typdelim = ',', + typname = "tstzrange", + rngsubtype = timestamptz + } + +_tstzrange :: TypeInfo +_tstzrange = Array { + typoid = Oid 3911, + typcategory = 'A', + typdelim = ',', + typname = "_tstzrange", + typelem = tstzrange + } + +daterange :: TypeInfo +daterange = Range { + typoid = Oid 3912, + typcategory = 'R', + typdelim = ',', + typname = "daterange", + rngsubtype = date + } + +_daterange :: TypeInfo +_daterange = Array { + typoid = Oid 3913, + typcategory = 'A', + typdelim = ',', + typname = "_daterange", + typelem = daterange + } + +int8range :: TypeInfo +int8range = Range { + typoid = Oid 3926, + typcategory = 'R', + typdelim = ',', + typname = "int8range", + rngsubtype = int8 + } + +_int8range :: TypeInfo +_int8range = Array { + typoid = Oid 3927, + typcategory = 'A', + typdelim = ',', + typname = "_int8range", + typelem = int8range + } diff --git a/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs b/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/TypeInfo/Types.hs @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- | +-- 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) diff --git a/src/Database/PostgreSQL/Simple/Types.hs b/src/Database/PostgreSQL/Simple/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Types.hs @@ -0,0 +1,274 @@ +{-# 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(..) + , Default(..) + , Only(..) + , In(..) + , Binary(..) + , Identifier(..) + , QualifiedIdentifier(..) + , Query(..) + , Oid(..) + , (:.)(..) + , Savepoint(..) + , PGArray(..) + , Values(..) + ) where + +import Control.Arrow (first) +import Data.ByteString (ByteString) +import Data.Hashable (Hashable(hashWithSalt)) +import Data.Monoid (Monoid(..)) +import Data.String (IsString(..)) +import Data.Typeable (Typeable) +import Data.ByteString.Builder ( stringUtf8 ) +import qualified Data.ByteString as B +import Data.Text (Text) +import qualified Data.Text as T +import Database.PostgreSQL.LibPQ (Oid(..)) +import Database.PostgreSQL.Simple.Compat (toByteString) + +-- | A placeholder for the SQL @NULL@ value. +data Null = Null + deriving (Read, Show, Typeable) + +instance Eq Null where + _ == _ = False + _ /= _ = False + +-- | A placeholder for the PostgreSQL @DEFAULT@ value. +data Default = Default + deriving (Read, Show, Typeable) + +-- | 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 . stringUtf8 + +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])) +-- +-- Note that @In []@ expands to @(null)@, which works as expected in +-- the query above, but evaluates to the logical null value on every +-- row instead of @TRUE@. This means that changing the query above +-- to @... id NOT in ?@ and supplying the empty list as the parameter +-- returns zero rows, instead of all of them as one would expect. +-- +-- Since postgresql doesn't seem to provide a syntax for actually specifying +-- an empty list, which could solve this completely, there are two +-- workarounds particularly worth mentioning, namely: +-- +-- 1. Use postgresql-simple's 'Values' type instead, which can handle the +-- empty case correctly. Note however that while specifying the +-- postgresql type @"int4"@ is mandatory in the empty case, specifying +-- the haskell type @Values (Only Int)@ would not normally be needed in +-- realistic use cases. +-- +-- > query c "select * from whatever where id not in ?" +-- > (Only (Values ["int4"] [] :: Values (Only Int))) +-- +-- +-- 2. Use sql's @COALESCE@ operator to turn a logical @null@ into the correct +-- boolean. Note however that the correct boolean depends on the use +-- case: +-- +-- > query c "select * from whatever where coalesce(id NOT in ?, TRUE)" +-- > (Only (In [] :: In [Int])) +-- +-- > query c "select * from whatever where coalesce(id IN ?, FALSE)" +-- > (Only (In [] :: In [Int])) +-- +-- Note that at as of PostgreSQL 9.4, the query planner cannot see inside +-- the @COALESCE@ operator, so if you have an index on @id@ then you +-- probably don't want to write the last example with @COALESCE@, which +-- would result in a table scan. There are further caveats if @id@ can +-- be null or you want null treated sensibly as a component of @IN@ or +-- @NOT IN@. + +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 {fromBinary :: a} + deriving (Eq, Ord, Read, Show, Typeable, Functor) + +-- | Wrap text for use as sql identifier, i.e. a table or column name. +newtype Identifier = Identifier {fromIdentifier :: Text} + deriving (Eq, Ord, Read, Show, Typeable, IsString) + +instance Hashable Identifier where + hashWithSalt i (Identifier t) = hashWithSalt i t + +-- | Wrap text for use as (maybe) qualified identifier, i.e. a table +-- with schema, or column with table. +data QualifiedIdentifier = QualifiedIdentifier (Maybe Text) Text + deriving (Eq, Ord, Read, Show, Typeable) + +instance Hashable QualifiedIdentifier where + hashWithSalt i (QualifiedIdentifier q t) = hashWithSalt i (q, t) + +-- | @\"foo.bar\"@ will get turned into +-- @QualifiedIdentifier (Just \"foo\") \"bar\"@, while @\"foo\"@ will get +-- turned into @QualifiedIdentifier Nothing \"foo\"@. Note this instance +-- is for convenience, and does not match postgres syntax. It +-- only examines the first period character, and thus cannot be used if the +-- qualifying identifier contains a period for example. + +instance IsString QualifiedIdentifier where + fromString str = let (x,y) = T.break (== '.') (fromString str) + in if T.null y + then QualifiedIdentifier Nothing x + else QualifiedIdentifier (Just x) (T.tail y) + +-- | Wrap a list for use as a PostgreSQL array. +newtype PGArray a = PGArray {fromPGArray :: [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) + +-- | Represents a @VALUES@ table literal, usable as an alternative to +-- 'Database.PostgreSQL.Simple.executeMany' and +-- 'Database.PostgreSQL.Simple.returning'. The main advantage is that +-- you can parametrize more than just a single @VALUES@ expression. +-- For example, here's a query to insert a thing into one table +-- and some attributes of that thing into another, returning the +-- new id generated by the database: +-- +-- +-- > query c [sql| +-- > WITH new_thing AS ( +-- > INSERT INTO thing (name) VALUES (?) RETURNING id +-- > ), new_attributes AS ( +-- > INSERT INTO thing_attributes +-- > SELECT new_thing.id, attrs.* +-- > FROM new_thing JOIN ? attrs ON TRUE +-- > ) SELECT * FROM new_thing +-- > |] ("foo", Values [ "int4", "text" ] +-- > [ ( 1 , "hello" ) +-- > , ( 2 , "world" ) ]) +-- +-- (Note this example uses writable common table expressions, +-- which were added in PostgreSQL 9.1) +-- +-- The second parameter gets expanded into the following SQL syntax: +-- +-- > (VALUES (1::"int4",'hello'::"text"),(2,'world')) +-- +-- When the list of attributes is empty, the second parameter expands to: +-- +-- > (VALUES (null::"int4",null::"text") LIMIT 0) +-- +-- By contrast, @executeMany@ and @returning@ don't issue the query +-- in the empty case, and simply return @0@ and @[]@ respectively. +-- This behavior is usually correct given their intended use cases, +-- but would certainly be wrong in the example above. +-- +-- The first argument is a list of postgresql type names. Because this +-- is turned into a properly quoted identifier, the type name is case +-- sensitive and must be as it appears in the @pg_type@ table. Thus, +-- you must write @timestamptz@ instead of @timestamp with time zone@, +-- @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@, +-- etcetera. +-- +-- You may omit the type names, however, if you do so the list +-- of values must be non-empty, and postgresql must be able to infer +-- the types of the columns from the surrounding context. If the first +-- condition is not met, pg will throw an exception +-- without issuing the query. In the second case, the postgres server +-- will return an error which will be turned into a @SqlError@ exception. +-- +-- See for +-- more information. +data Values a = Values [QualifiedIdentifier] [a] + deriving (Eq, Ord, Show, Read, Typeable) diff --git a/test/Common.hs b/test/Common.hs new file mode 100644 --- /dev/null +++ b/test/Common.hs @@ -0,0 +1,32 @@ +module Common ( + module Database.PostgreSQL.Simple, + module Test.Tasty.HUnit, + TestEnv(..), + md5, +) where + +import Data.ByteString (ByteString) +import Data.Text (Text) +import Database.PostgreSQL.Simple +import Test.Tasty.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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DoAndIfThenElse #-} +{-# LANGUAGE ScopedTypeVariables #-} +import Common +import Database.PostgreSQL.Simple.FromField (FromField) +import Database.PostgreSQL.Simple.Types(Query(..),Values(..)) +import Database.PostgreSQL.Simple.HStore +import Database.PostgreSQL.Simple.Copy +import qualified Database.PostgreSQL.Simple.Transaction as ST + +import Control.Applicative +import Control.Exception as E +import Control.Monad +import Data.Char +import Data.List (sort) +import Data.IORef +import Data.Typeable +import GHC.Generics (Generic) + +import Data.Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy.Char8 as BL +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Text(Text) +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V +import System.FilePath +import System.Timeout(timeout) +import Data.Time(getCurrentTime, diffUTCTime) + +import Test.Tasty +import Test.Tasty.Golden +import Notify +import Serializable +import Time + +tests :: TestEnv -> TestTree +tests env = testGroup "tests" + $ map ($ env) + [ testBytea + , testCase "ExecuteMany" . testExecuteMany + , testCase "Fold" . testFold + , testCase "Notify" . testNotify + , testCase "Serializable" . testSerializable + , testCase "Time" . testTime + , testCase "Array" . testArray + , testCase "Array of nullables" . testNullableArray + , testCase "HStore" . testHStore + , testCase "JSON" . testJSON + , testCase "Savepoint" . testSavepoint + , testCase "Unicode" . testUnicode + , testCase "Values" . testValues + , testCase "Copy" . testCopy + , testCopyFailures + , testCase "Double" . testDouble + , testCase "1-ary generic" . testGeneric1 + , testCase "2-ary generic" . testGeneric2 + , testCase "3-ary generic" . testGeneric3 + , testCase "Timeout" . testTimeout + ] + +testBytea :: TestEnv -> TestTree +testBytea TestEnv{..} = testGroup "Bytea" + [ 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 = testCase label $ 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 -> Assertion +testExecuteMany TestEnv{..} = 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 -> Assertion +testFold TestEnv{..} = 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 -> Assertion +testArray TestEnv{..} = 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) + +testNullableArray :: TestEnv -> Assertion +testNullableArray TestEnv{..} = do + xs <- query_ conn "SELECT '{sometext, \"NULL\"}'::_text" + xs @?= [Only (V.fromList ["sometext", "NULL" :: Text])] + xs <- query_ conn "SELECT '{sometext, NULL}'::_text" + xs @?= [Only (V.fromList [Just "sometext", Nothing :: Maybe Text])] + queryFailure conn "SELECT '{sometext, NULL}'::_text" (undefined :: V.Vector Text) + +testHStore :: TestEnv -> Assertion +testHStore TestEnv{..} = do + execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore" + 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' + +testJSON :: TestEnv -> Assertion +testJSON TestEnv{..} = do + roundTrip (Map.fromList [] :: Map Text Text) + roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text) + roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text) + roundTrip (V.fromList [1,2,3,4,5::Int]) + roundTrip ("foo" :: Text) + roundTrip (42 :: Int) + where + roundTrip :: ToJSON a => a -> Assertion + roundTrip a = do + let js = Only (toJSON a) + js' <- query conn "SELECT ?::json" js + [js] @?= js' + +testSavepoint :: TestEnv -> Assertion +testSavepoint TestEnv{..} = 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 () + +testUnicode :: TestEnv -> Assertion +testUnicode TestEnv{..} = do + let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure + -- the table gets created correctly. + let messages = map Only ["привет","мир"] :: [Only Text] + execute_ conn (q "CREATE TEMPORARY TABLE ру́сский (сообщение TEXT)") + executeMany conn "INSERT INTO ру́сский (сообщение) VALUES (?)" messages + messages' <- query_ conn "SELECT сообщение FROM ру́сский" + sort messages @?= sort messages' + +testValues :: TestEnv -> Assertion +testValues TestEnv{..} = do + execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)" + test (Values ["int4","text"] []) + test (Values ["int4","text"] [(1,"hello")]) + test (Values ["int4","text"] [(1,"hello"),(2,"world")]) + test (Values ["int4","text"] [(1,"hello"),(2,"world"),(3,"goodbye")]) + test (Values [] [(1,"hello")]) + test (Values [] [(1,"hello"),(2,"world")]) + test (Values [] [(1,"hello"),(2,"world"),(3,"goodbye")]) + where + test :: Values (Int, Text) -> Assertion + test table@(Values _ vals) = do + execute conn "INSERT INTO values_test ?" (Only table) + vals' <- query_ conn "DELETE FROM values_test RETURNING *" + sort vals @?= sort vals' + + +testCopy :: TestEnv -> Assertion +testCopy TestEnv{..} = do + execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)" + copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)" + mapM_ (putCopyData conn) copyRows + putCopyEnd conn + copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)" + mapM_ (putCopyData conn) abortRows + putCopyError conn "aborted" + -- Hmm, does postgres always produce \n as an end-of-line here, or + -- are there cases where it will use a \r\n as well? + copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)" + rows <- loop [] + sort rows @?= sort copyRows + -- Now, let's just verify that the connection state is back to ready, + -- so that we can issue more queries: + [Only (x::Int)] <- query_ conn "SELECT 2 + 2" + x @?= 4 + where + copyRows = ["1,foo\n" + ,"2,bar\n"] + abortRows = ["3,baz\n"] + loop rows = do + mrow <- getCopyData conn + case mrow of + CopyOutDone _ -> return rows + CopyOutRow row -> loop (row:rows) + +testCopyFailures :: TestEnv -> TestTree +testCopyFailures env = testGroup "Copy failures" + $ map ($ env) + [ testCopyUniqueConstraintError + , testCopyMalformedError + ] + +goldenTest :: TestName -> IO BL.ByteString -> TestTree +goldenTest testName = + goldenVsString testName (resultsDir fileName<.>"expected") + where + resultsDir = "test" "results" + fileName = map normalize testName + normalize c | not (isAlpha c) = '-' + | otherwise = c + +-- | Test that we provide a sensible error message on failure +testCopyUniqueConstraintError :: TestEnv -> TestTree +testCopyUniqueConstraintError TestEnv{..} = + goldenTest "unique constraint violation" + $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do + execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)" + copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)" + mapM_ (putCopyData conn) copyRows + _n <- putCopyEnd conn + return BL.empty + where + copyRows = ["1,foo\n" + ,"2,bar\n" + ,"1,baz\n"] + +testCopyMalformedError :: TestEnv -> TestTree +testCopyMalformedError TestEnv{..} = + goldenTest "malformed input" + $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do + execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)" + copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)" + mapM_ (putCopyData conn) copyRows + _n <- putCopyEnd conn + return BL.empty + where + copyRows = ["1,foo\n" + ,"2,bar\n" + ,"z,baz\n"] + +testTimeout :: TestEnv -> Assertion +testTimeout TestEnv{..} = + withConn $ \c -> do + start_t <- getCurrentTime + res <- timeout 200000 $ do + withTransaction c $ do + query_ c "SELECT pg_sleep(1)" :: IO [Only ()] + end_t <- getCurrentTime + assertBool "Timeout did not occur" (res == Nothing) +#if !defined(mingw32_HOST_OS) +-- At the moment, you cannot timely abandon queries with async exceptions on +-- Windows. + let d = end_t `diffUTCTime` start_t + assertBool "Timeout didn't work in a timely fashion" (0.1 < d && d < 0.6) +#endif + +testDouble :: TestEnv -> Assertion +testDouble TestEnv{..} = do + [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8" + assertBool "expected NaN" (isNaN x) + [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8" + x @?= (1 / 0) + [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8" + x @?= (-1 / 0) + + +testGeneric1 :: TestEnv -> Assertion +testGeneric1 TestEnv{..} = do + roundTrip conn (Gen1 123) + where + roundTrip conn x0 = do + r <- query conn "SELECT ?::int" (x0 :: Gen1) + r @?= [x0] + +testGeneric2 :: TestEnv -> Assertion +testGeneric2 TestEnv{..} = do + roundTrip conn (Gen2 123 "asdf") + where + roundTrip conn x0 = do + r <- query conn "SELECT ?::int, ?::text" x0 + r @?= [x0] + +testGeneric3 :: TestEnv -> Assertion +testGeneric3 TestEnv{..} = do + roundTrip conn (Gen3 123 "asdf" True) + where + roundTrip conn x0 = do + r <- query conn "SELECT ?::int, ?::text, ?::bool" x0 + r @?= [x0] + +data Gen1 = Gen1 Int + deriving (Show,Eq,Generic) +instance FromRow Gen1 +instance ToRow Gen1 + +data Gen2 = Gen2 Int Text + deriving (Show,Eq,Generic) +instance FromRow Gen2 +instance ToRow Gen2 + +data Gen3 = Gen3 Int Text Bool + deriving (Show,Eq,Generic) +instance FromRow Gen3 +instance ToRow Gen3 + +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 = withTestEnv $ defaultMain . tests diff --git a/test/Notify.hs b/test/Notify.hs new file mode 100644 --- /dev/null +++ b/test/Notify.hs @@ -0,0 +1,41 @@ +module 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 -> Assertion +testNotify TestEnv{..} = + 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] diff --git a/test/Serializable.hs b/test/Serializable.hs new file mode 100644 --- /dev/null +++ b/test/Serializable.hs @@ -0,0 +1,68 @@ +module Serializable (testSerializable) where + +import Common +import Control.Concurrent +import Control.Exception as E +import Data.IORef +import Database.PostgreSQL.Simple.Transaction + +initCounter :: Connection -> IO () +initCounter conn = do + 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 -> Assertion +testSerializable TestEnv{..} = + 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 () diff --git a/test/Time.hs b/test/Time.hs new file mode 100644 --- /dev/null +++ b/test/Time.hs @@ -0,0 +1,119 @@ +{-# 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. + + +Right now, we are checking that 1400+ timestamps in the range of 1860 to +2060 round trip from postgresql to haskell and back in 5 different timezones. +In addition to UTC, the four timezones were selected so that 2 have a positive +offset, and 2 have a negative offset, and that 2 have an offset of a +whole number of hours, while the other two do not. + +It may be worth adding a few more timezones to ensure better test coverage. + +We are checking a handful of selected timestamps to ensure we hit +various corner-cases in the code, in addition to 1400 timestamps randomly +generated with granularity of seconds down to microseconds in powers of ten. + +-} + +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 -> Assertion +testTime env@TestEnv{..} = do + initializeTable env + execute_ conn "SET timezone TO 'UTC'" + checkRoundTrips env "1860-01-01 00:00:00+00" + execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00 + checkRoundTrips env "1883-11-18 12:00:00-06" + execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00 + checkRoundTrips env "1888-01-01 00:00:00+09" + execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45 + checkRoundTrips env "1919-12-31 23:48:44+05:30" + execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30 + checkRoundTrips env "1935-03-30 00:00:52-03:30" + +initializeTable :: TestEnv -> IO () +initializeTable TestEnv{..} = withTransaction conn $ do + execute_ conn + [sql| CREATE TEMPORARY TABLE testtime + ( x serial, y timestamptz, PRIMARY KEY(x) ) |] + + let test :: ByteString -> IO () = \x -> do + execute conn [sql| + INSERT INTO testtime (y) VALUES (?) + |] (Only x) + return () + -- America/Chicago + test "1883-11-18 11:59:59-05:50:36" + test "1883-11-18 12:09:23-05:50:36" + test "1883-11-18 12:00:00-06" + -- Asia/Tokyo + test "1887-12-31 23:59:59+09:18:59" + test "1888-01-01 00:18:58+09:18:59" + test "1888-01-01 00:00:00+09" + -- Asia/Kathmandu + test "1919-12-31 23:59:59+05:41:16" + test "1919-12-31 23:48:44+05:30" + test "1985-12-31 23:59:59+05:30" + test "1986-01-01 00:15:00+05:45" + -- America/St_Johns + test "1935-03-29 23:59:59-03:30:52" + test "1935-03-30 00:00:52-03:30" + + -- While the above special cases are probably a decent start, there + -- are probably more that are well worth adding to ensure better + -- coverage. + + let pop :: ByteString -> Double -> IO () = \x y -> + replicateM_ numTests $ execute conn + [sql| INSERT INTO testtime (y) VALUES + ('1860-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 -> ByteString -> IO () +checkRoundTrips TestEnv{..} limit = 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] + + yxs :: [(ZonedTime, Int)] <- query conn [sql| + SELECT y, x FROM testtime WHERE y > ? + |] (Only limit) + forM_ yxs $ \yx -> do + res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx + assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $ + res == [Only True]