├── cabal.project ├── Setup.hs ├── .gitignore ├── test ├── results │ ├── malformed-input.expected │ └── unique-constraint-violation.expected ├── Common.hs ├── Notify.hs ├── WRITING-TESTS ├── Serializable.hs ├── Time.hs └── Main.hs ├── src └── Database │ └── PostgreSQL │ ├── Simple │ ├── FromField.hs-boot │ ├── ToRow.hs-boot │ ├── FromRow.hs-boot │ ├── HStore │ │ ├── Internal.hs │ │ └── Implementation.hs │ ├── Time │ │ ├── Internal.hs │ │ ├── Internal │ │ │ ├── Printer.hs │ │ │ └── Parser.hs │ │ └── Implementation.hs │ ├── ToField.hs-boot │ ├── HStore.hs │ ├── TypeInfo │ │ ├── Macro.hs │ │ └── Types.hs │ ├── Compat.hs │ ├── Ok.hs │ ├── Arrays.hs │ ├── SqlQQ.hs │ ├── LargeObjects.hs │ ├── Cursor.hs │ ├── Internal │ │ └── PQResultUtils.hs │ ├── Errors.hs │ ├── TypeInfo.hs │ ├── Notification.hs │ ├── ToRow.hs │ ├── Copy.hs │ ├── Transaction.hs │ ├── Types.hs │ ├── Range.hs │ ├── Time.hs │ └── ToField.hs │ └── Simple.hs-boot ├── README.md ├── .ghci ├── sdist.sh ├── CONTRIBUTORS ├── tools ├── StringsQQ.hs └── GenTypeInfo.hs ├── .travis.yml ├── LICENSE └── postgresql-simple.cabal /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .hg/ 2 | _darcs/ 3 | *~ 4 | dist/ 5 | *.prof 6 | *.hi 7 | *.o 8 | \#*\# 9 | .#* 10 | /CHANGELOG.md 11 | .cabal-sandbox/ 12 | .stack-work/ 13 | cabal.sandbox.config 14 | /dist-newstyle -------------------------------------------------------------------------------- /test/results/malformed-input.expected: -------------------------------------------------------------------------------- 1 | user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status 2 | Connection error: ERROR: invalid input syntax for integer: "z" 3 | CONTEXT: COPY copy_unique_constraint_error_test, line 3, column x: "z" 4 | ) -------------------------------------------------------------------------------- /test/results/unique-constraint-violation.expected: -------------------------------------------------------------------------------- 1 | user error (Database.PostgreSQL.Simple.Copy.putCopyEnd: failed to parse command status 2 | Connection error: ERROR: duplicate key value violates unique constraint "copy_unique_constraint_error_test_pkey" 3 | DETAIL: Key (x)=(1) already exists. 4 | CONTEXT: COPY copy_unique_constraint_error_test, line 3 5 | ) -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/FromField.hs-boot: -------------------------------------------------------------------------------- 1 | module Database.PostgreSQL.Simple.FromField where 2 | 3 | import Data.ByteString(ByteString) 4 | import Database.PostgreSQL.Simple.Types 5 | 6 | class FromField a 7 | 8 | instance FromField Oid 9 | instance FromField Char 10 | instance FromField ByteString 11 | instance FromField a => FromField (Maybe a) 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Continuous Integration status][status-png]][status] 2 | [![Hackage page (downloads and API reference)][hackage-png]][hackage] 3 | 4 | [status-png]: https://api.travis-ci.org/lpsmith/postgresql-simple.svg 5 | [status]: http://travis-ci.org/lpsmith/postgresql-simple?branch=master 6 | [hackage-png]: http://img.shields.io/hackage/v/postgresql-simple.svg 7 | [hackage]: http://hackage.haskell.org/package/postgresql-simple 8 | -------------------------------------------------------------------------------- /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc -itest -optP-includedist/build/autogen/cabal_macros.h 2 | :set -Wall -fno-warn-name-shadowing 3 | 4 | :set -XDoAndIfThenElse 5 | :set -XOverloadedStrings 6 | :set -XBangPatterns 7 | :set -XViewPatterns 8 | :set -XTypeOperators 9 | 10 | -- for tests 11 | :set -XNamedFieldPuns 12 | :set -XRank2Types 13 | :set -XRecordWildCards 14 | :set -XPatternGuards 15 | :set -XScopedTypeVariables 16 | :set -fno-warn-unused-do-bind 17 | -------------------------------------------------------------------------------- /sdist.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | echo "Generating CHANGELOG.md" 4 | echo 5 | 6 | cat <
CHANGELOG.md 7 | For the full changelog, see 8 | 9 | 10 | HEADER 11 | 12 | perl -ne '$n++ if /^###/; exit if $n==2; print' CHANGES.md >> CHANGELOG.md 13 | 14 | cat CHANGELOG.md 15 | rm -f ./dist/*.tar 16 | rm -f ./dist/*.tar.gz 17 | cabal sdist 18 | cd dist 19 | wc *.tar.gz 20 | gunzip *.gz 21 | wc *.tar 22 | zopfli *.tar 23 | wc *.tar.gz 24 | cd .. 25 | rm -f ./dist/*.tar 26 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/ToRow.hs-boot: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} 2 | module Database.PostgreSQL.Simple.ToRow ( 3 | ToRow(..) 4 | ) where 5 | 6 | import Database.PostgreSQL.Simple.Types 7 | import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField 8 | import GHC.Generics 9 | 10 | class ToRow a where 11 | toRow :: a -> [Action] 12 | default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action] 13 | toRow = gtoRow . from 14 | 15 | class GToRow f where 16 | gtoRow :: f p -> [Action] 17 | 18 | instance ToField a => ToRow (Only a) 19 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/FromRow.hs-boot: -------------------------------------------------------------------------------- 1 | module Database.PostgreSQL.Simple.FromRow where 2 | 3 | import {-# SOURCE #-} Database.PostgreSQL.Simple.FromField 4 | import Database.PostgreSQL.Simple.Types 5 | 6 | class FromRow a 7 | 8 | instance (FromField a) => FromRow (Only a) 9 | instance (FromField a, FromField b) 10 | => FromRow (a,b) 11 | instance (FromField a, FromField b, FromField c, FromField d) 12 | => FromRow (a,b,c,d) 13 | instance (FromField a, FromField b, FromField c, FromField d, FromField e) 14 | => FromRow (a,b,c,d,e) 15 | instance (FromField a, FromField b, FromField c, FromField d, FromField e 16 | ,FromField f) 17 | => FromRow (a,b,c,d,e,f) 18 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/HStore/Internal.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- | 3 | -- Module: Database.PostgreSQL.Simple.HStore.Internal 4 | -- Copyright: (c) 2013 Leon P Smith 5 | -- License: BSD3 6 | -- Maintainer: Leon P Smith 7 | -- Stability: experimental 8 | -- 9 | ------------------------------------------------------------------------------ 10 | 11 | module Database.PostgreSQL.Simple.HStore.Internal 12 | ( HStoreBuilder(..) 13 | , HStoreText(..) 14 | , parseHStore 15 | , parseHStoreKeyVal 16 | , parseHStoreText 17 | ) where 18 | 19 | import Database.PostgreSQL.Simple.HStore.Implementation 20 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple.hs-boot: -------------------------------------------------------------------------------- 1 | module Database.PostgreSQL.Simple 2 | ( Connection 3 | , Query 4 | , query 5 | , query_ 6 | , execute 7 | , execute_ 8 | , executeMany 9 | ) where 10 | 11 | import Data.Int(Int64) 12 | import Database.PostgreSQL.Simple.Internal 13 | import Database.PostgreSQL.Simple.Types 14 | import {-# SOURCE #-} Database.PostgreSQL.Simple.FromRow 15 | import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow 16 | 17 | query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r] 18 | 19 | query_ :: FromRow r => Connection -> Query -> IO [r] 20 | 21 | execute :: ToRow q => Connection -> Query -> q -> IO Int64 22 | 23 | executeMany :: ToRow q => Connection -> Query -> [q] -> IO Int64 24 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Time/Internal.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- | 3 | -- Module: Database.PostgreSQL.Simple.Time.Internal 4 | -- Copyright: (c) 2012 Leon P Smith 5 | -- License: BSD3 6 | -- Maintainer: Leon P Smith 7 | -- Stability: experimental 8 | -- 9 | ------------------------------------------------------------------------------ 10 | 11 | module Database.PostgreSQL.Simple.Time.Internal 12 | ( getDay 13 | , getDate 14 | , getTimeOfDay 15 | , getLocalTime 16 | , getLocalTimestamp 17 | , getTimeZone 18 | , getZonedTime 19 | , getZonedTimestamp 20 | , getUTCTime 21 | , getUTCTimestamp 22 | , TimeZoneHMS 23 | , getTimeZoneHMS 24 | , localToUTCTimeOfDayHMS 25 | ) where 26 | 27 | import Database.PostgreSQL.Simple.Time.Implementation 28 | -------------------------------------------------------------------------------- /test/Common.hs: -------------------------------------------------------------------------------- 1 | module Common ( 2 | module Database.PostgreSQL.Simple, 3 | module Test.Tasty.HUnit, 4 | TestEnv(..), 5 | md5, 6 | ) where 7 | 8 | import Data.ByteString (ByteString) 9 | import Data.Text (Text) 10 | import Database.PostgreSQL.Simple 11 | import Test.Tasty.HUnit 12 | 13 | import qualified Crypto.Hash.MD5 as MD5 14 | import qualified Data.ByteString.Base16 as Base16 15 | import qualified Data.Text.Encoding as TE 16 | 17 | data TestEnv 18 | = TestEnv 19 | { conn :: Connection 20 | -- ^ Connection shared by all the tests 21 | , withConn :: forall a. (Connection -> IO a) -> IO a 22 | -- ^ Bracket for spawning additional connections 23 | } 24 | 25 | -- | Return the MD5 hash of a 'ByteString', in lowercase hex format. 26 | -- 27 | -- Example: 28 | -- 29 | -- >[Only hash] <- query_ conn "SELECT md5('hi')" 30 | -- >assertEqual "md5('hi')" (md5 "hi") hash 31 | md5 :: ByteString -> Text 32 | md5 = TE.decodeUtf8 . Base16.encode . MD5.hash 33 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/ToField.hs-boot: -------------------------------------------------------------------------------- 1 | module Database.PostgreSQL.Simple.ToField where 2 | 3 | import Database.PostgreSQL.Simple.Types 4 | import Data.ByteString.Builder(Builder) 5 | import Data.ByteString(ByteString) 6 | 7 | -- | How to render an element when substituting it into a query. 8 | data Action = 9 | Plain Builder 10 | -- ^ Render without escaping or quoting. Use for non-text types 11 | -- such as numbers, when you are /certain/ that they will not 12 | -- introduce formatting vulnerabilities via use of characters such 13 | -- as spaces or \"@'@\". 14 | | Escape ByteString 15 | -- ^ Escape and enclose in quotes before substituting. Use for all 16 | -- text-like types, and anything else that may contain unsafe 17 | -- characters when rendered. 18 | | EscapeByteA ByteString 19 | -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding 20 | -- quotes. This is used by the 'Binary' newtype wrapper. 21 | | EscapeIdentifier ByteString 22 | -- ^ Escape before substituting. Use for all sql identifiers like 23 | -- table, column names, etc. This is used by the 'Identifier' newtype 24 | -- wrapper. 25 | | Many [Action] 26 | -- ^ Concatenate a series of rendering actions. 27 | 28 | class ToField a 29 | 30 | instance ToField Oid 31 | -------------------------------------------------------------------------------- /test/Notify.hs: -------------------------------------------------------------------------------- 1 | module Notify (testNotify) where 2 | 3 | import Common 4 | 5 | import Control.Applicative 6 | import Control.Concurrent 7 | import Control.Monad 8 | import Data.Function 9 | import Data.List 10 | import Database.PostgreSQL.Simple.Notification 11 | 12 | import qualified Data.ByteString as B 13 | 14 | -- TODO: Test with payload, but only for PostgreSQL >= 9.0 15 | -- (when that feature was introduced). 16 | 17 | testNotify :: TestEnv -> Assertion 18 | testNotify TestEnv{..} = 19 | withConn $ \conn2 -> do 20 | execute_ conn "LISTEN foo" 21 | execute_ conn "LISTEN bar" 22 | 23 | results_mv <- newEmptyMVar 24 | forkIO $ replicateM 2 (getNotification conn) 25 | >>= putMVar results_mv 26 | 27 | threadDelay 100000 28 | 29 | execute_ conn2 "NOTIFY foo" 30 | execute_ conn2 "NOTIFY bar" 31 | 32 | [n1, n2] <- sortBy (compare `on` notificationChannel) 33 | <$> takeMVar results_mv 34 | 35 | assertEqual "n1" "bar" (notificationChannel n1) 36 | assertEqual "n2" "foo" (notificationChannel n2) 37 | 38 | -- Other sanity checks 39 | assertEqual "Server PIDs match" (notificationPid n1) (notificationPid n2) 40 | assertBool "notificationData is empty" $ 41 | all (B.null . notificationData) [n1, n2] 42 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/HStore.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- | 3 | -- Module: Database.PostgreSQL.Simple.HStore 4 | -- Copyright: (c) 2013 Leon P Smith 5 | -- License: BSD3 6 | -- Maintainer: Leon P Smith 7 | -- Stability: experimental 8 | -- 9 | -- Parsers and printers for hstore, a extended type bundled with 10 | -- PostgreSQL providing finite maps from text strings to text strings. 11 | -- See for more 12 | -- information. 13 | -- 14 | -- Note that in order to use this type, a database superuser must 15 | -- install it by running a sql script in the share directory. This 16 | -- can be done on PostgreSQL 9.1 and later with the command 17 | -- @CREATE EXTENSION hstore@. See 18 | -- for more 19 | -- information. 20 | -- 21 | ------------------------------------------------------------------------------ 22 | 23 | module Database.PostgreSQL.Simple.HStore 24 | ( HStoreList(..) 25 | , HStoreMap(..) 26 | , ToHStore(..) 27 | , HStoreBuilder 28 | , toBuilder 29 | , toLazyByteString 30 | , hstore 31 | , parseHStoreList 32 | , ToHStoreText(..) 33 | , HStoreText 34 | ) where 35 | 36 | import Database.PostgreSQL.Simple.HStore.Implementation 37 | -------------------------------------------------------------------------------- /CONTRIBUTORS: -------------------------------------------------------------------------------- 1 | Bryan O'Sullivan 2 | Leon P Smith 3 | Felipe Lessa 4 | Ozgun Ataman 5 | Joey Adams 6 | Rekado 7 | Leonid Onokhov 8 | Bas van Dijk 9 | Jason Dusek 10 | Jeff Chu 11 | Oliver Charles 12 | Simon Meier 13 | Alexey Uimanov 14 | Doug Beardsley 15 | Manuel Gómez 16 | Michael Snoyman 17 | Adam Bergmark 18 | Tobias Florek 19 | Francesco Mazzoli 20 | Chris Allen 21 | Simon Hengel 22 | Tom Ellis 23 | Mike Ledger 24 | João Cristóvão 25 | Bardur Arantsson 26 | Travis Staton 27 | Sam Rijs 28 | Janne Hellsten 29 | Timmy Tofu 30 | Alexey Khudyakov 31 | Timo von Holtz 32 | Amit Levy 33 | Ben Gamari 34 | Edgar Gomes Araujo 35 | Erik Hesselink 36 | Matvey Aksenov 37 | -------------------------------------------------------------------------------- /test/WRITING-TESTS: -------------------------------------------------------------------------------- 1 | Do what is EASIEST. Having a test at all is more important than, 2 | say, pretty failure output. 3 | 4 | To add a test, open Main.hs, and add an entry to tests, e.g.: 5 | 6 | tests :: [TestEnv -> Test] 7 | tests = 8 | [ ... 9 | , TestLabel "Foo" . testFoo 10 | ] 11 | 12 | testFoo :: TestEnv -> Test 13 | testFoo TestEnv{..} = TestCase $ do 14 | meaningOfLife @?= 42 15 | 2013 <- getCurrentYear 16 | return () 17 | 18 | Mnemonic for HUnit @=? and @?= operators: 19 | 20 | * `?` is the value whose correctness is in question 21 | 22 | * `=` is the expected value 23 | 24 | If you move a test to a separate module, don't forget to add it to 25 | "other-modules" in postgresql-simple.cabal . Otherwise, the module will be 26 | left out of the tarball generated by `cabal sdist`, and tests will fail to 27 | build when installing from Hackage. 28 | 29 | 'TestEnv' (defined in Common.hs) contains information for accessing the 30 | database. `TestEnv{..}` is a record wildcard which brings the following 31 | definitions into scope: 32 | 33 | conn :: Connection 34 | withConn :: (Connection -> IO a) -> IO a 35 | 36 | 'conn' is a database connection shared by all the tests. 37 | 'withConn' can be used to open additional connections (to the same database). 38 | 39 | 'Test' is basically a tree of 'Assertion's, where 'Assertion' is just a type 40 | alias for IO (). See the [HUnit documentation][1] for more information. 41 | 42 | [1]: http://hackage.haskell.org/packages/archive/HUnit/latest/doc/html/Test-HUnit-Base.html 43 | -------------------------------------------------------------------------------- /tools/StringsQQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module StringsQQ (strings, longstring, typenames) where 4 | 5 | import Language.Haskell.TH 6 | import Language.Haskell.TH.Quote 7 | 8 | import Data.Char (toUpper) 9 | 10 | strings = QuasiQuoter { quotePat = undefined, 11 | quoteType = undefined, 12 | quoteExp = stringsExp, 13 | quoteDec = undefined } 14 | 15 | -- stringE = return . LitE . StringL 16 | 17 | stringsExp :: String -> Q Exp 18 | stringsExp = foldr (\x xs -> [e| $(x) : $(xs) |]) [e| [] |] 19 | . map delta . filter (not . null) . map words . lines 20 | where delta [(x:xs)] = [e| ( $(stringE $ x:xs ) 21 | , $(stringE $ toUpper x : xs ) ) |] 22 | delta [xs,ys] = [e| ( $(stringE xs) , $(stringE ys) ) |] 23 | 24 | longstring = QuasiQuoter { quotePat = undefined, 25 | quoteType = undefined, 26 | quoteExp = longstringExp, 27 | quoteDec = undefined } 28 | 29 | longstringExp ('\n':xs) = stringE xs 30 | longstringExp xs = stringE xs 31 | 32 | typenames = QuasiQuoter { quotePat = undefined, 33 | quoteType = undefined, 34 | quoteExp = typenamesExp, 35 | quoteDec = undefined } 36 | 37 | typenamesExp :: String -> Q Exp 38 | typenamesExp = foldr (\x xs -> [e| $(x) : $(xs) |]) [e| [] |] 39 | . map delta . filter (not . null) . map words . lines 40 | where delta [xs] = delta [xs,xs] 41 | delta [xs,ys] = [e| ( $(stringE xs) , $(stringE ys) ) |] 42 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/TypeInfo/Macro.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.PostgreSQL.Simple.TypeInfo.Macro 6 | -- Copyright: (c) 2013 Leon P Smith 7 | -- License: BSD3 8 | -- Maintainer: Leon P Smith 9 | -- Stability: experimental 10 | -- 11 | -- A Template Haskell macro for efficiently checking membership in 12 | -- a set of type oids. 13 | -- 14 | ------------------------------------------------------------------------------ 15 | 16 | module Database.PostgreSQL.Simple.TypeInfo.Macro 17 | ( mkCompats 18 | , inlineTypoid 19 | ) where 20 | 21 | import Database.PostgreSQL.Simple.TypeInfo.Static 22 | import Database.PostgreSQL.Simple.Types (Oid(..)) 23 | import Language.Haskell.TH 24 | 25 | 26 | -- | Returns an expression that has type @'Oid' -> 'Bool'@, true if the 27 | -- oid is equal to any one of the 'typoid's of the given 'TypeInfo's. 28 | mkCompats :: [TypeInfo] -> ExpQ 29 | mkCompats tys = [| \(Oid x) -> $(caseE [| x |] (map alt tys ++ [catchAll])) |] 30 | where 31 | alt :: TypeInfo -> MatchQ 32 | alt ty = match (inlineTypoidP ty) (normalB [| True |]) [] 33 | 34 | catchAll :: MatchQ 35 | catchAll = match wildP (normalB [| False |]) [] 36 | 37 | -- | Literally substitute the 'typoid' of a 'TypeInfo' expression. 38 | -- Returns an expression of type 'Oid'. Useful because GHC tends 39 | -- not to fold constants. 40 | inlineTypoid :: TypeInfo -> ExpQ 41 | inlineTypoid ty = [| Oid $(litE (getTypoid ty)) |] 42 | 43 | inlineTypoidP :: TypeInfo -> PatQ 44 | inlineTypoidP ty = litP (getTypoid ty) 45 | 46 | getTypoid :: TypeInfo -> Lit 47 | getTypoid ty = let (Oid x) = typoid ty in integerL (fromIntegral x) 48 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/TypeInfo/Types.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- | 3 | -- Module: Database.PostgreSQL.Simple.TypeInfo.Types 4 | -- Copyright: (c) 2013 Leon P Smith 5 | -- License: BSD3 6 | -- Maintainer: Leon P Smith 7 | -- Stability: experimental 8 | -- 9 | ------------------------------------------------------------------------------ 10 | 11 | module Database.PostgreSQL.Simple.TypeInfo.Types where 12 | 13 | import Data.ByteString(ByteString) 14 | import Database.PostgreSQL.LibPQ(Oid) 15 | import Data.Vector(Vector) 16 | 17 | -- | A structure representing some of the metadata regarding a PostgreSQL 18 | -- type, mostly taken from the @pg_type@ table. 19 | 20 | data TypeInfo 21 | 22 | = Basic { typoid :: {-# UNPACK #-} !Oid 23 | , typcategory :: {-# UNPACK #-} !Char 24 | , typdelim :: {-# UNPACK #-} !Char 25 | , typname :: !ByteString 26 | } 27 | 28 | | Array { typoid :: {-# UNPACK #-} !Oid 29 | , typcategory :: {-# UNPACK #-} !Char 30 | , typdelim :: {-# UNPACK #-} !Char 31 | , typname :: !ByteString 32 | , typelem :: !TypeInfo 33 | } 34 | 35 | | Range { typoid :: {-# UNPACK #-} !Oid 36 | , typcategory :: {-# UNPACK #-} !Char 37 | , typdelim :: {-# UNPACK #-} !Char 38 | , typname :: !ByteString 39 | , rngsubtype :: !TypeInfo 40 | } 41 | 42 | | Composite { typoid :: {-# UNPACK #-} !Oid 43 | , typcategory :: {-# UNPACK #-} !Char 44 | , typdelim :: {-# UNPACK #-} !Char 45 | , typname :: !ByteString 46 | , typrelid :: {-# UNPACK #-} !Oid 47 | , attributes :: !(Vector Attribute) 48 | } 49 | 50 | deriving (Show) 51 | 52 | data Attribute 53 | = Attribute { attname :: !ByteString 54 | , atttype :: !TypeInfo 55 | } 56 | deriving (Show) 57 | -------------------------------------------------------------------------------- /test/Serializable.hs: -------------------------------------------------------------------------------- 1 | module Serializable (testSerializable) where 2 | 3 | import Common 4 | import Control.Concurrent 5 | import Control.Exception as E 6 | import Data.IORef 7 | import Database.PostgreSQL.Simple.Transaction 8 | 9 | initCounter :: Connection -> IO () 10 | initCounter conn = do 11 | 0 <- execute_ conn "DROP TABLE IF EXISTS testSerializableCounter;\ 12 | \ CREATE TABLE testSerializableCounter (n INT)" 13 | 1 <- execute_ conn "INSERT INTO testSerializableCounter VALUES (0)" 14 | return () 15 | 16 | getCounter :: Connection -> IO Int 17 | getCounter conn = do 18 | [Only n] <- query_ conn "SELECT n FROM testSerializableCounter" 19 | return n 20 | 21 | putCounter :: Connection -> Int -> IO () 22 | putCounter conn n = do 23 | 1 <- execute conn "UPDATE testSerializableCounter SET n=?" (Only n) 24 | return () 25 | 26 | testSerializable :: TestEnv -> Assertion 27 | testSerializable TestEnv{..} = 28 | withConn $ \conn2 -> do 29 | initCounter conn 30 | 31 | attemptCounter <- newIORef (0 :: Int) 32 | readyToBother <- newEmptyMVar 33 | bothered <- newEmptyMVar 34 | finished <- newEmptyMVar 35 | 36 | _ <- forkIO $ do 37 | withTransactionSerializable conn2 $ do 38 | modifyIORef attemptCounter (+1) 39 | n <- getCounter conn2 40 | True <- tryPutMVar readyToBother () 41 | readMVar bothered 42 | putCounter conn2 (n+1) 43 | putMVar finished () 44 | 45 | takeMVar readyToBother 46 | withTransactionSerializable conn $ do 47 | n <- getCounter conn 48 | putCounter conn (n+1) 49 | True <- tryPutMVar bothered () 50 | 51 | takeMVar finished 52 | 53 | ac <- readIORef attemptCounter 54 | assertEqual "attemptCounter" 2 ac 55 | 56 | ok <- E.catch (do withTransactionSerializable conn (fail "Whoops") 57 | return False) 58 | (\(_ :: IOException) -> return True) 59 | assertBool "Exceptions (besides serialization failure) should be\ 60 | \ propagated through withTransactionSerializable" 61 | ok 62 | 63 | -- Make sure transaction isn't dangling 64 | 1 <- execute_ conn "UPDATE testSerializableCounter SET n=12345" 65 | 0 <- execute_ conn "ROLLBACK" 66 | -- This prints "NOTICE: there is no transaction in progress" 67 | [Only (12345 :: Int)] <- query_ conn "SELECT n FROM testSerializableCounter" 68 | return () 69 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Compat.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | -- | This is a module of its own, partly because it uses the CPP extension, 3 | -- which doesn't play well with backslash-broken string literals. 4 | module Database.PostgreSQL.Simple.Compat 5 | ( mask 6 | , (<>) 7 | , unsafeDupablePerformIO 8 | , toByteString 9 | , scientificBuilder 10 | , toPico 11 | , fromPico 12 | ) where 13 | 14 | import qualified Control.Exception as E 15 | import Data.Monoid 16 | import Data.ByteString (ByteString) 17 | #if MIN_VERSION_bytestring(0,10,0) 18 | import Data.ByteString.Lazy (toStrict) 19 | #else 20 | import qualified Data.ByteString as B 21 | import Data.ByteString.Lazy (toChunks) 22 | #endif 23 | import Data.ByteString.Builder (Builder, toLazyByteString) 24 | 25 | #if MIN_VERSION_scientific(0,3,0) 26 | import Data.Text.Lazy.Builder.Scientific (scientificBuilder) 27 | #else 28 | import Data.Scientific (scientificBuilder) 29 | #endif 30 | 31 | #if __GLASGOW_HASKELL__ >= 702 32 | import System.IO.Unsafe (unsafeDupablePerformIO) 33 | #elif __GLASGOW_HASKELL__ >= 611 34 | import GHC.IO (unsafeDupablePerformIO) 35 | #else 36 | import GHC.IOBase (unsafeDupablePerformIO) 37 | #endif 38 | 39 | import Data.Fixed (Pico) 40 | #if MIN_VERSION_base(4,7,0) 41 | import Data.Fixed (Fixed(MkFixed)) 42 | #else 43 | import Unsafe.Coerce (unsafeCoerce) 44 | #endif 45 | 46 | -- | Like 'E.mask', but backported to base before version 4.3.0. 47 | -- 48 | -- Note that the restore callback is monomorphic, unlike in 'E.mask'. This 49 | -- could be fixed by changing the type signature, but it would require us to 50 | -- enable the RankNTypes extension (since 'E.mask' has a rank-3 type). The 51 | -- 'withTransactionMode' function calls the restore callback only once, so we 52 | -- don't need that polymorphism. 53 | mask :: ((IO a -> IO a) -> IO b) -> IO b 54 | #if MIN_VERSION_base(4,3,0) 55 | mask io = E.mask $ \restore -> io restore 56 | #else 57 | mask io = do 58 | b <- E.blocked 59 | E.block $ io $ \m -> if b then m else E.unblock m 60 | #endif 61 | {-# INLINE mask #-} 62 | 63 | #if !MIN_VERSION_base(4,5,0) 64 | infixr 6 <> 65 | 66 | (<>) :: Monoid m => m -> m -> m 67 | (<>) = mappend 68 | {-# INLINE (<>) #-} 69 | #endif 70 | 71 | toByteString :: Builder -> ByteString 72 | #if MIN_VERSION_bytestring(0,10,0) 73 | toByteString x = toStrict (toLazyByteString x) 74 | #else 75 | toByteString x = B.concat (toChunks (toLazyByteString x)) 76 | #endif 77 | 78 | #if MIN_VERSION_base(4,7,0) 79 | 80 | toPico :: Integer -> Pico 81 | toPico = MkFixed 82 | 83 | fromPico :: Pico -> Integer 84 | fromPico (MkFixed i) = i 85 | 86 | #else 87 | 88 | toPico :: Integer -> Pico 89 | toPico = unsafeCoerce 90 | 91 | fromPico :: Pico -> Integer 92 | fromPico = unsafeCoerce 93 | 94 | #endif 95 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This file has been generated -- see https://github.com/hvr/multi-ghc-travis 2 | language: c 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.cabsnap 8 | - $HOME/.cabal/packages 9 | 10 | before_cache: 11 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 12 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar 13 | 14 | matrix: 15 | include: 16 | - env: CABALVER=1.18 GHCVER=7.8.4 17 | compiler: ": #GHC 7.8.4" 18 | addons: { apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}, postgresql: "9.3"} 19 | - env: CABALVER=1.22 GHCVER=7.10.2 20 | compiler: ": #GHC 7.10.2" 21 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}, postgresql: "9.3"} 22 | - env: CABALVER=1.24 GHCVER=8.0.1 23 | compiler: ": #GHC 8.0.1" 24 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}, postgresql: "9.3"} 25 | 26 | before_install: 27 | - unset CC 28 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 29 | - createdb `whoami` || true 30 | 31 | install: 32 | - cabal --version 33 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 34 | - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ]; 35 | then 36 | zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz > 37 | $HOME/.cabal/packages/hackage.haskell.org/00-index.tar; 38 | fi 39 | - travis_retry cabal update -v 40 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 41 | - cabal install --only-dependencies --enable-tests --enable-benchmarks --dry -v > installplan.txt 42 | - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt 43 | 44 | # check whether current requested install-plan matches cached package-db snapshot 45 | - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt; 46 | then 47 | echo "cabal build-cache HIT"; 48 | rm -rfv .ghc; 49 | cp -a $HOME/.cabsnap/ghc $HOME/.ghc; 50 | cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/; 51 | else 52 | echo "cabal build-cache MISS"; 53 | rm -rf $HOME/.cabsnap; 54 | mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin; 55 | cabal install --only-dependencies --enable-tests --enable-benchmarks; 56 | fi 57 | 58 | # snapshot package-db on cache miss 59 | - if [ ! -d $HOME/.cabsnap ]; 60 | then 61 | echo "snapshotting package-db to build-cache"; 62 | mkdir $HOME/.cabsnap; 63 | cp -a $HOME/.ghc $HOME/.cabsnap/ghc; 64 | cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/; 65 | fi 66 | 67 | # Here starts the actual work to be performed for the package under test; 68 | # any command which exits with a non-zero exit code causes the build to fail. 69 | script: 70 | - if [ -f configure.ac ]; then autoreconf -i; fi 71 | - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging 72 | - cabal build # this builds all libraries and executables (including tests/benchmarks) 73 | - cabal test 74 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Ok.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE CPP #-} 4 | 5 | ------------------------------------------------------------------------------ 6 | -- | 7 | -- Module : Database.PostgreSQL.Simple.Ok 8 | -- Copyright : (c) 2012-2015 Leon P Smith 9 | -- License : BSD3 10 | -- 11 | -- Maintainer : leon@melding-monads.com 12 | -- Stability : experimental 13 | -- 14 | -- The 'Ok' type is a simple error handler, basically equivalent to 15 | -- @Either [SomeException]@. This type (without the list) was used to 16 | -- handle conversion errors in early versions of postgresql-simple. 17 | -- 18 | -- One of the primary reasons why this type was introduced is that 19 | -- @Either SomeException@ had not been provided an instance for 'Alternative', 20 | -- and it would have been a bad idea to provide an orphaned instance for a 21 | -- commonly-used type and typeclass included in @base@. 22 | -- 23 | -- Extending the failure case to a list of 'SomeException's enables a 24 | -- more sensible 'Alternative' instance definitions: '<|>' concatenates 25 | -- the list of exceptions when both cases fail, and 'empty' is defined as 26 | -- 'Errors []'. Though '<|>' one could pick one of two exceptions, and 27 | -- throw away the other, and have 'empty' provide a generic exception, 28 | -- this avoids cases where 'empty' overrides a more informative exception 29 | -- and allows you to see all the different ways your computation has failed. 30 | -- 31 | ------------------------------------------------------------------------------ 32 | 33 | module Database.PostgreSQL.Simple.Ok where 34 | 35 | import Control.Applicative 36 | import Control.Exception 37 | import Control.Monad(MonadPlus(..)) 38 | import Data.Typeable 39 | 40 | -- FIXME: [SomeException] should probably be something else, maybe 41 | -- a difference list (or a tree?) 42 | 43 | data Ok a = Errors [SomeException] | Ok !a 44 | deriving(Show, Typeable, Functor) 45 | 46 | -- | Two 'Errors' cases are considered equal, regardless of what the 47 | -- list of exceptions looks like. 48 | 49 | instance Eq a => Eq (Ok a) where 50 | Errors _ == Errors _ = True 51 | Ok a == Ok b = a == b 52 | _ == _ = False 53 | 54 | instance Applicative Ok where 55 | pure = Ok 56 | 57 | Errors es <*> _ = Errors es 58 | _ <*> Errors es = Errors es 59 | Ok f <*> Ok a = Ok (f a) 60 | 61 | instance Alternative Ok where 62 | empty = Errors [] 63 | 64 | a@(Ok _) <|> _ = a 65 | Errors _ <|> b@(Ok _) = b 66 | Errors as <|> Errors bs = Errors (as ++ bs) 67 | 68 | instance MonadPlus Ok where 69 | mzero = empty 70 | mplus = (<|>) 71 | 72 | instance Monad Ok where 73 | #if !(MIN_VERSION_base(4,8,0)) 74 | return = pure 75 | #endif 76 | 77 | Errors es >>= _ = Errors es 78 | Ok a >>= f = f a 79 | 80 | fail str = Errors [SomeException (ErrorCall str)] 81 | 82 | -- | a way to reify a list of exceptions into a single exception 83 | 84 | newtype ManyErrors = ManyErrors [SomeException] 85 | deriving (Show, Typeable) 86 | 87 | instance Exception ManyErrors 88 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2011, Leon P Smith 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Leon P Smith nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | 33 | Copyright (c) 2011, MailRank, Inc. 34 | 35 | All rights reserved. 36 | 37 | Redistribution and use in source and binary forms, with or without 38 | modification, are permitted provided that the following conditions 39 | are met: 40 | 41 | 1. Redistributions of source code must retain the above copyright 42 | notice, this list of conditions and the following disclaimer. 43 | 44 | 2. Redistributions in binary form must reproduce the above copyright 45 | notice, this list of conditions and the following disclaimer in the 46 | documentation and/or other materials provided with the distribution. 47 | 48 | 3. Neither the name of the author nor the names of his contributors 49 | may be used to endorse or promote products derived from this software 50 | without specific prior written permission. 51 | 52 | THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS 53 | OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 54 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 55 | DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR 56 | ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 57 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS 58 | OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) 59 | HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, 60 | STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN 61 | ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE 62 | POSSIBILITY OF SUCH DAMAGE. 63 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Arrays.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternGuards #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.PostgreSQL.Simple.Arrays 6 | -- Copyright: (c) 2012 Leon P Smith 7 | -- License: BSD3 8 | -- Maintainer: Leon P Smith 9 | -- Stability: experimental 10 | -- 11 | -- A Postgres array parser and pretty-printer. 12 | ------------------------------------------------------------------------------ 13 | 14 | module Database.PostgreSQL.Simple.Arrays where 15 | 16 | import Control.Applicative (Applicative(..), Alternative(..), (<$>)) 17 | import Data.ByteString.Char8 (ByteString) 18 | import qualified Data.ByteString.Char8 as B 19 | import Data.Monoid 20 | import Data.Attoparsec.ByteString.Char8 21 | 22 | 23 | -- | Parse one of three primitive field formats: array, quoted and plain. 24 | arrayFormat :: Char -> Parser ArrayFormat 25 | arrayFormat delim = Array <$> array delim 26 | <|> Plain <$> plain delim 27 | <|> Quoted <$> quoted 28 | 29 | data ArrayFormat = Array [ArrayFormat] 30 | | Plain ByteString 31 | | Quoted ByteString 32 | deriving (Eq, Show, Ord) 33 | 34 | array :: Char -> Parser [ArrayFormat] 35 | array delim = char '{' *> option [] (arrays <|> strings) <* char '}' 36 | where 37 | strings = sepBy1 (Quoted <$> quoted <|> Plain <$> plain delim) (char delim) 38 | arrays = sepBy1 (Array <$> array delim) (char ',') 39 | -- NB: Arrays seem to always be delimited by commas. 40 | 41 | -- | Recognizes a quoted string. 42 | quoted :: Parser ByteString 43 | quoted = char '"' *> option "" contents <* char '"' 44 | where 45 | esc = char '\\' *> (char '\\' <|> char '"') 46 | unQ = takeWhile1 (notInClass "\"\\") 47 | contents = mconcat <$> many (unQ <|> B.singleton <$> esc) 48 | 49 | -- | Recognizes a plain string literal, not containing quotes or brackets and 50 | -- not containing the delimiter character. 51 | plain :: Char -> Parser ByteString 52 | plain delim = takeWhile1 (notInClass (delim:"\"{}")) 53 | 54 | -- Mutually recursive 'fmt' and 'delimit' separate out value formatting 55 | -- from the subtleties of delimiting. 56 | 57 | -- | Format an array format item, using the delimiter character if the item is 58 | -- itself an array. 59 | fmt :: Char -> ArrayFormat -> ByteString 60 | fmt = fmt' False 61 | 62 | -- | Format a list of array format items, inserting the appropriate delimiter 63 | -- between them. When the items are arrays, they will be delimited with 64 | -- commas; otherwise, they are delimited with the passed-in-delimiter. 65 | delimit :: Char -> [ArrayFormat] -> ByteString 66 | delimit _ [] = "" 67 | delimit c [x] = fmt' True c x 68 | delimit c (x:y:z) = (fmt' True c x `B.snoc` c') `mappend` delimit c (y:z) 69 | where 70 | c' | Array _ <- x = ',' 71 | | otherwise = c 72 | 73 | -- | Format an array format item, using the delimiter character if the item is 74 | -- itself an array, optionally applying quoting rules. Creates copies for 75 | -- safety when used in 'FromField' instances. 76 | fmt' :: Bool -> Char -> ArrayFormat -> ByteString 77 | fmt' quoting c x = 78 | case x of 79 | Array items -> '{' `B.cons` (delimit c items `B.snoc` '}') 80 | Plain bytes -> B.copy bytes 81 | Quoted q | quoting -> '"' `B.cons` (esc q `B.snoc` '"') 82 | | otherwise -> B.copy q 83 | -- NB: The 'snoc' and 'cons' functions always copy. 84 | 85 | -- | Escape a string according to Postgres double-quoted string format. 86 | esc :: ByteString -> ByteString 87 | esc = B.concatMap f 88 | where 89 | f '"' = "\\\"" 90 | f '\\' = "\\\\" 91 | f c = B.singleton c 92 | -- TODO: Implement easy performance improvements with unfoldr. 93 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/SqlQQ.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | ------------------------------------------------------------------------------ 3 | -- | 4 | -- Module: Database.PostgreSQL.Simple.SqlQQ 5 | -- Copyright: (c) 2011-2012 Leon P Smith 6 | -- License: BSD3 7 | -- Maintainer: Leon P Smith 8 | -- Stability: experimental 9 | -- 10 | ------------------------------------------------------------------------------ 11 | 12 | module Database.PostgreSQL.Simple.SqlQQ (sql) where 13 | import Database.PostgreSQL.Simple.Types (Query) 14 | import Language.Haskell.TH 15 | import Language.Haskell.TH.Quote 16 | import Data.Char 17 | import Data.String 18 | 19 | -- | 'sql' is a quasiquoter that eases the syntactic burden 20 | -- of writing big sql statements in Haskell source code. For example: 21 | -- 22 | -- > {-# LANGUAGE QuasiQuotes #-} 23 | -- > 24 | -- > query conn [sql| SELECT column_a, column_b 25 | -- > FROM table1 NATURAL JOIN table2 26 | -- > WHERE ? <= time AND time < ? 27 | -- > AND name LIKE ? 28 | -- > ORDER BY size DESC 29 | -- > LIMIT 100 |] 30 | -- > (beginTime,endTime,string) 31 | -- 32 | -- This quasiquoter returns a literal string expression of type 'Query', 33 | -- and attempts to mimimize whitespace; otherwise the above query would 34 | -- consist of approximately half whitespace when sent to the database 35 | -- backend. It also recognizes and strips out standard sql comments "--". 36 | -- 37 | -- The implementation of the whitespace reducer is currently incomplete. 38 | -- Thus it can mess up your syntax in cases where whitespace should be 39 | -- preserved as-is. It does preserve whitespace inside standard SQL string 40 | -- literals. But it can get confused by the non-standard PostgreSQL string 41 | -- literal syntax (which is the default setting in PostgreSQL 8 and below), 42 | -- the extended escape string syntax, quoted identifiers, and other similar 43 | -- constructs. 44 | -- 45 | -- Of course, this caveat only applies to text written inside the SQL 46 | -- quasiquoter; whitespace reduction is a compile-time computation and 47 | -- thus will not touch the @string@ parameter above, which is a run-time 48 | -- value. 49 | -- 50 | -- Also note that this will not work if the substring @|]@ is contained 51 | -- in the query. 52 | 53 | sql :: QuasiQuoter 54 | sql = QuasiQuoter 55 | { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ 56 | \ quasiquoter used in pattern context" 57 | , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ 58 | \ quasiquoter used in type context" 59 | , quoteExp = sqlExp 60 | , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ 61 | \ quasiquoter used in declaration context" 62 | } 63 | 64 | sqlExp :: String -> Q Exp 65 | sqlExp = appE [| fromString :: String -> Query |] . stringE . minimizeSpace 66 | 67 | minimizeSpace :: String -> String 68 | minimizeSpace = drop 1 . reduceSpace 69 | where 70 | needsReduced [] = False 71 | needsReduced ('-':'-':_) = True 72 | needsReduced (x:_) = isSpace x 73 | 74 | reduceSpace xs = 75 | case dropWhile isSpace xs of 76 | [] -> [] 77 | ('-':'-':ys) -> reduceSpace (dropWhile (/= '\n') ys) 78 | ys -> ' ' : insql ys 79 | 80 | insql ('\'':xs) = '\'' : instring xs 81 | insql xs | needsReduced xs = reduceSpace xs 82 | insql (x:xs) = x : insql xs 83 | insql [] = [] 84 | 85 | instring ('\'':'\'':xs) = '\'':'\'': instring xs 86 | instring ('\'':xs) = '\'': insql xs 87 | instring (x:xs) = x : instring xs 88 | instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ 89 | \ string literal not terminated" 90 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/LargeObjects.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Database.PostgreSQL.Simple.LargeObjects 4 | -- Copyright : (c) 2011-2012 Leon P Smith 5 | -- License : BSD3 6 | -- 7 | -- Maintainer : leon@melding-monads.com 8 | -- 9 | -- Support for PostgreSQL's Large Objects; see 10 | -- for more 11 | -- information. 12 | -- 13 | -- Note that Large Object File Descriptors are only valid within a single 14 | -- database transaction, so if you are interested in using anything beyond 15 | -- 'loCreat', 'loCreate', and 'loUnlink', you will need to run the entire 16 | -- sequence of functions in a transaction. As 'loImport' and 'loExport' 17 | -- are simply C functions that call 'loCreat', 'loOpen', 'loRead', and 18 | -- 'loWrite', and do not perform any transaction handling themselves, 19 | -- they also need to be wrapped in an explicit transaction. 20 | -- 21 | ----------------------------------------------------------------------------- 22 | 23 | module Database.PostgreSQL.Simple.LargeObjects 24 | ( loCreat 25 | , loCreate 26 | , loImport 27 | , loImportWithOid 28 | , loExport 29 | , loOpen 30 | , loWrite 31 | , loRead 32 | , loSeek 33 | , loTell 34 | , loTruncate 35 | , loClose 36 | , loUnlink 37 | , Oid(..) 38 | , LoFd 39 | , IOMode(..) 40 | , SeekMode(..) 41 | ) where 42 | 43 | import Control.Applicative ((<$>)) 44 | import Control.Exception (throwIO) 45 | import qualified Data.ByteString as B 46 | import Database.PostgreSQL.LibPQ (Oid(..),LoFd(..)) 47 | import qualified Database.PostgreSQL.LibPQ as PQ 48 | import Database.PostgreSQL.Simple.Internal 49 | import System.IO (IOMode(..),SeekMode(..)) 50 | 51 | liftPQ :: B.ByteString -> Connection -> (PQ.Connection -> IO (Maybe a)) -> IO a 52 | liftPQ str conn m = withConnection conn $ \c -> do 53 | res <- m c 54 | case res of 55 | Nothing -> do 56 | msg <- maybe str id <$> PQ.errorMessage c 57 | throwIO $ fatalError msg 58 | Just x -> return x 59 | 60 | loCreat :: Connection -> IO Oid 61 | loCreat conn = liftPQ "loCreat" conn (\c -> PQ.loCreat c) 62 | 63 | loCreate :: Connection -> Oid -> IO Oid 64 | loCreate conn oid = liftPQ "loCreate" conn (\c -> PQ.loCreate c oid) 65 | 66 | loImport :: Connection -> FilePath -> IO Oid 67 | loImport conn path = liftPQ "loImport" conn (\c -> PQ.loImport c path) 68 | 69 | loImportWithOid :: Connection -> FilePath -> Oid -> IO Oid 70 | loImportWithOid conn path oid = liftPQ "loImportWithOid" conn (\c -> PQ.loImportWithOid c path oid) 71 | 72 | loExport :: Connection -> Oid -> FilePath -> IO () 73 | loExport conn oid path = liftPQ "loExport" conn (\c -> PQ.loExport c oid path) 74 | 75 | loOpen :: Connection -> Oid -> IOMode -> IO LoFd 76 | loOpen conn oid mode = liftPQ "loOpen" conn (\c -> PQ.loOpen c oid mode ) 77 | 78 | loWrite :: Connection -> LoFd -> B.ByteString -> IO Int 79 | loWrite conn fd dat = liftPQ "loWrite" conn (\c -> PQ.loWrite c fd dat) 80 | 81 | loRead :: Connection -> LoFd -> Int -> IO B.ByteString 82 | loRead conn fd maxlen = liftPQ "loRead" conn (\c -> PQ.loRead c fd maxlen) 83 | 84 | loSeek :: Connection -> LoFd -> SeekMode -> Int -> IO Int 85 | loSeek conn fd seekmode offset = liftPQ "loSeek" conn (\c -> PQ.loSeek c fd seekmode offset) 86 | 87 | loTell :: Connection -> LoFd -> IO Int 88 | loTell conn fd = liftPQ "loTell" conn (\c -> PQ.loTell c fd) 89 | 90 | loTruncate :: Connection -> LoFd -> Int -> IO () 91 | loTruncate conn fd len = liftPQ "loTruncate" conn (\c -> PQ.loTruncate c fd len) 92 | 93 | loClose :: Connection -> LoFd -> IO () 94 | loClose conn fd = liftPQ "loClose" conn (\c -> PQ.loClose c fd) 95 | 96 | loUnlink :: Connection -> Oid -> IO () 97 | loUnlink conn oid = liftPQ "loUnlink" conn (\c -> PQ.loUnlink c oid) 98 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Cursor.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.PostgreSQL.Simple.Cursor 6 | -- Copyright: (c) 2011-2012 Leon P Smith 7 | -- (c) 2017 Bardur Arantsson 8 | -- License: BSD3 9 | -- Maintainer: Leon P Smith 10 | -- 11 | ------------------------------------------------------------------------------ 12 | 13 | module Database.PostgreSQL.Simple.Cursor 14 | ( 15 | -- * Types 16 | Cursor 17 | -- * Cursor management 18 | , declareCursor 19 | , closeCursor 20 | -- * Folding over rows from a cursor 21 | , foldForward 22 | , foldForwardWithParser 23 | ) where 24 | 25 | import Data.ByteString.Builder (intDec) 26 | import Control.Applicative ((<$>)) 27 | import Control.Exception as E 28 | import Control.Monad (unless, void) 29 | import Data.Monoid (mconcat) 30 | import Database.PostgreSQL.Simple.Compat ((<>), toByteString) 31 | import Database.PostgreSQL.Simple.FromRow (FromRow(..)) 32 | import Database.PostgreSQL.Simple.Types (Query(..)) 33 | import Database.PostgreSQL.Simple.Internal as Base 34 | import Database.PostgreSQL.Simple.Internal.PQResultUtils 35 | import Database.PostgreSQL.Simple.Transaction 36 | import qualified Database.PostgreSQL.LibPQ as PQ 37 | 38 | -- | Cursor within a transaction. 39 | data Cursor = Cursor !Query !Connection 40 | 41 | -- | Declare a temporary cursor. The cursor is given a 42 | -- unique name for the given connection. 43 | declareCursor :: Connection -> Query -> IO Cursor 44 | declareCursor conn q = do 45 | name <- newTempName conn 46 | void $ execute_ conn $ mconcat ["DECLARE ", name, " NO SCROLL CURSOR FOR ", q] 47 | return $ Cursor name conn 48 | 49 | -- | Close the given cursor. 50 | closeCursor :: Cursor -> IO () 51 | closeCursor (Cursor name conn) = 52 | (void $ execute_ conn ("CLOSE " <> name)) `E.catch` \ex -> 53 | -- Don't throw exception if CLOSE failed because the transaction is 54 | -- aborted. Otherwise, it will throw away the original error. 55 | unless (isFailedTransactionError ex) $ throwIO ex 56 | 57 | -- | Fold over a chunk of rows from the given cursor, calling the 58 | -- supplied fold-like function on each row as it is received. In case 59 | -- the cursor is exhausted, a 'Left' value is returned, otherwise a 60 | -- 'Right' value is returned. 61 | foldForwardWithParser :: Cursor -> RowParser r -> Int -> (a -> r -> IO a) -> a -> IO (Either a a) 62 | foldForwardWithParser (Cursor name conn) parser chunkSize f a0 = do 63 | let q = "FETCH FORWARD " 64 | <> (toByteString $ intDec chunkSize) 65 | <> " FROM " 66 | <> fromQuery name 67 | result <- exec conn q 68 | status <- PQ.resultStatus result 69 | case status of 70 | PQ.TuplesOk -> do 71 | nrows <- PQ.ntuples result 72 | ncols <- PQ.nfields result 73 | if nrows > 0 74 | then do 75 | let inner a row = do 76 | x <- getRowWith parser row ncols conn result 77 | f a x 78 | Right <$> foldM' inner a0 0 (nrows - 1) 79 | else 80 | return $ Left a0 81 | _ -> throwResultError "foldForwardWithParser" result status 82 | 83 | -- | Fold over a chunk of rows, calling the supplied fold-like function 84 | -- on each row as it is received. In case the cursor is exhausted, 85 | -- a 'Left' value is returned, otherwise a 'Right' value is returned. 86 | foldForward :: FromRow r => Cursor -> Int -> (a -> r -> IO a) -> a -> IO (Either a a) 87 | foldForward cursor = foldForwardWithParser cursor fromRow 88 | 89 | 90 | foldM' :: (Ord n, Num n) => (a -> n -> IO a) -> a -> n -> n -> IO a 91 | foldM' f a lo hi = loop a lo 92 | where 93 | loop a !n 94 | | n > hi = return a 95 | | otherwise = do 96 | a' <- f a n 97 | loop a' (n+1) 98 | {-# INLINE foldM' #-} 99 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Internal/PQResultUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.PostgreSQL.Simple.Internal.PQResultUtils 6 | -- Copyright: (c) 2011 MailRank, Inc. 7 | -- (c) 2011-2012 Leon P Smith 8 | -- License: BSD3 9 | -- Maintainer: Leon P Smith 10 | -- Stability: experimental 11 | -- 12 | ------------------------------------------------------------------------------ 13 | 14 | 15 | module Database.PostgreSQL.Simple.Internal.PQResultUtils 16 | ( finishQueryWith 17 | , getRowWith 18 | ) where 19 | 20 | import Control.Exception as E 21 | import Data.ByteString (ByteString) 22 | import Database.PostgreSQL.Simple.FromField (ResultError(..)) 23 | import Database.PostgreSQL.Simple.Ok 24 | import Database.PostgreSQL.Simple.Types (Query(..)) 25 | import Database.PostgreSQL.Simple.Internal as Base 26 | import Database.PostgreSQL.Simple.TypeInfo 27 | import qualified Database.PostgreSQL.LibPQ as PQ 28 | import qualified Data.ByteString.Char8 as B 29 | import Control.Monad.Trans.Reader 30 | import Control.Monad.Trans.State.Strict 31 | 32 | finishQueryWith :: RowParser r -> Connection -> Query -> PQ.Result -> IO [r] 33 | finishQueryWith parser conn q result = do 34 | status <- PQ.resultStatus result 35 | case status of 36 | PQ.TuplesOk -> do 37 | nrows <- PQ.ntuples result 38 | ncols <- PQ.nfields result 39 | forM' 0 (nrows-1) $ \row -> 40 | getRowWith parser row ncols conn result 41 | PQ.EmptyQuery -> queryErr "query: Empty query" 42 | PQ.CommandOk -> queryErr "query resulted in a command response" 43 | PQ.CopyOut -> queryErr "query: COPY TO is not supported" 44 | PQ.CopyIn -> queryErr "query: COPY FROM is not supported" 45 | #if MIN_VERSION_postgresql_libpq(0,9,3) 46 | PQ.CopyBoth -> queryErr "query: COPY BOTH is not supported" 47 | #endif 48 | #if MIN_VERSION_postgresql_libpq(0,9,2) 49 | PQ.SingleTuple -> queryErr "query: single-row mode is not supported" 50 | #endif 51 | PQ.BadResponse -> throwResultError "query" result status 52 | PQ.NonfatalError -> throwResultError "query" result status 53 | PQ.FatalError -> throwResultError "query" result status 54 | where 55 | queryErr msg = throwIO $ QueryError msg q 56 | 57 | getRowWith :: RowParser r -> PQ.Row -> PQ.Column -> Connection -> PQ.Result -> IO r 58 | getRowWith parser row ncols conn result = do 59 | let rw = Row row result 60 | let unCol (PQ.Col x) = fromIntegral x :: Int 61 | okvc <- runConversion (runStateT (runReaderT (unRP parser) rw) 0) conn 62 | case okvc of 63 | Ok (val,col) | col == ncols -> return val 64 | | otherwise -> do 65 | vals <- forM' 0 (ncols-1) $ \c -> do 66 | tinfo <- getTypeInfo conn =<< PQ.ftype result c 67 | v <- PQ.getvalue result row c 68 | return ( tinfo 69 | , fmap ellipsis v ) 70 | throw (ConversionFailed 71 | (show (unCol ncols) ++ " values: " ++ show vals) 72 | Nothing 73 | "" 74 | (show (unCol col) ++ " slots in target type") 75 | "mismatch between number of columns to convert and number in target type") 76 | Errors [] -> throwIO $ ConversionFailed "" Nothing "" "" "unknown error" 77 | Errors [x] -> throwIO x 78 | Errors xs -> throwIO $ ManyErrors xs 79 | 80 | ellipsis :: ByteString -> ByteString 81 | ellipsis bs 82 | | B.length bs > 15 = B.take 10 bs `B.append` "[...]" 83 | | otherwise = bs 84 | 85 | forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a] 86 | forM' lo hi m = loop hi [] 87 | where 88 | loop !n !as 89 | | n < lo = return as 90 | | otherwise = do 91 | a <- m n 92 | loop (n-1) (a:as) 93 | {-# INLINE forM' #-} 94 | -------------------------------------------------------------------------------- /postgresql-simple.cabal: -------------------------------------------------------------------------------- 1 | Name: postgresql-simple 2 | Version: 0.5.3.0 3 | Synopsis: Mid-Level PostgreSQL client library 4 | Description: 5 | Mid-Level PostgreSQL client library, forked from mysql-simple. 6 | License: BSD3 7 | License-file: LICENSE 8 | Author: Bryan O'Sullivan, Leon P Smith 9 | Maintainer: Leon P Smith 10 | Copyright: (c) 2011 MailRank, Inc. 11 | (c) 2011-2015 Leon P Smith 12 | Category: Database 13 | Build-type: Simple 14 | 15 | Cabal-version: >= 1.9.2 16 | 17 | extra-source-files: 18 | CONTRIBUTORS 19 | CHANGELOG.md 20 | 21 | Library 22 | hs-source-dirs: src 23 | Exposed-modules: 24 | Database.PostgreSQL.Simple 25 | Database.PostgreSQL.Simple.Arrays 26 | Database.PostgreSQL.Simple.Copy 27 | Database.PostgreSQL.Simple.Cursor 28 | Database.PostgreSQL.Simple.FromField 29 | Database.PostgreSQL.Simple.FromRow 30 | Database.PostgreSQL.Simple.LargeObjects 31 | Database.PostgreSQL.Simple.HStore 32 | Database.PostgreSQL.Simple.HStore.Internal 33 | Database.PostgreSQL.Simple.Notification 34 | Database.PostgreSQL.Simple.Ok 35 | Database.PostgreSQL.Simple.Range 36 | Database.PostgreSQL.Simple.SqlQQ 37 | Database.PostgreSQL.Simple.Time 38 | Database.PostgreSQL.Simple.Time.Internal 39 | Database.PostgreSQL.Simple.ToField 40 | Database.PostgreSQL.Simple.ToRow 41 | Database.PostgreSQL.Simple.Transaction 42 | Database.PostgreSQL.Simple.TypeInfo 43 | Database.PostgreSQL.Simple.TypeInfo.Macro 44 | Database.PostgreSQL.Simple.TypeInfo.Static 45 | Database.PostgreSQL.Simple.Types 46 | Database.PostgreSQL.Simple.Errors 47 | -- Other-modules: 48 | Database.PostgreSQL.Simple.Internal 49 | 50 | Other-modules: 51 | Database.PostgreSQL.Simple.Compat 52 | Database.PostgreSQL.Simple.HStore.Implementation 53 | Database.PostgreSQL.Simple.Internal.PQResultUtils 54 | Database.PostgreSQL.Simple.Time.Implementation 55 | Database.PostgreSQL.Simple.Time.Internal.Parser 56 | Database.PostgreSQL.Simple.Time.Internal.Printer 57 | Database.PostgreSQL.Simple.TypeInfo.Types 58 | 59 | Build-depends: 60 | aeson >= 0.6, 61 | attoparsec >= 0.10.3, 62 | base >= 4.6 && < 5, 63 | bytestring >= 0.9, 64 | bytestring-builder, 65 | case-insensitive, 66 | containers, 67 | hashable, 68 | Only, 69 | postgresql-libpq >= 0.9 && < 0.10, 70 | template-haskell, 71 | text >= 0.11.1, 72 | time, 73 | transformers, 74 | uuid-types >= 1.0.0, 75 | scientific, 76 | semigroups, 77 | vector 78 | 79 | if !impl(ghc >= 7.6) 80 | Build-depends: 81 | ghc-prim 82 | 83 | extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns 84 | TypeOperators 85 | 86 | ghc-options: -Wall -fno-warn-name-shadowing 87 | 88 | source-repository head 89 | type: git 90 | location: http://github.com/lpsmith/postgresql-simple 91 | 92 | source-repository this 93 | type: git 94 | location: http://github.com/lpsmith/postgresql-simple 95 | tag: v0.5.3.0 96 | 97 | test-suite test 98 | type: exitcode-stdio-1.0 99 | 100 | hs-source-dirs: test 101 | main-is: Main.hs 102 | other-modules: 103 | Common 104 | Notify 105 | Serializable 106 | Time 107 | 108 | ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind 109 | 110 | extensions: NamedFieldPuns 111 | , OverloadedStrings 112 | , Rank2Types 113 | , RecordWildCards 114 | , PatternGuards 115 | , ScopedTypeVariables 116 | 117 | build-depends: base 118 | , aeson 119 | , base16-bytestring 120 | , bytestring 121 | , containers 122 | , cryptohash 123 | , filepath 124 | , tasty 125 | , tasty-hunit 126 | , tasty-golden 127 | , HUnit 128 | , postgresql-simple 129 | , text 130 | , time 131 | , vector 132 | , case-insensitive 133 | 134 | if !impl(ghc >= 7.6) 135 | build-depends: 136 | ghc-prim 137 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, ViewPatterns #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- Module: Database.PostgreSQL.Simple.Time.Internal.Printer 5 | -- Copyright: (c) 2012-2015 Leon P Smith 6 | -- License: BSD3 7 | -- Maintainer: Leon P Smith 8 | -- Stability: experimental 9 | ------------------------------------------------------------------------------ 10 | 11 | module Database.PostgreSQL.Simple.Time.Internal.Printer 12 | ( 13 | day 14 | , timeOfDay 15 | , timeZone 16 | , utcTime 17 | , localTime 18 | , zonedTime 19 | , nominalDiffTime 20 | ) where 21 | 22 | import Control.Arrow ((>>>)) 23 | import Data.ByteString.Builder (Builder, integerDec) 24 | import Data.ByteString.Builder.Prim 25 | ( liftFixedToBounded, (>$<), (>*<) 26 | , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec) 27 | import Data.Char ( chr ) 28 | import Data.Int ( Int32, Int64 ) 29 | import Data.Time 30 | ( UTCTime(..), ZonedTime(..), LocalTime(..), NominalDiffTime 31 | , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay 32 | , TimeZone, timeZoneMinutes ) 33 | import Database.PostgreSQL.Simple.Compat ((<>), fromPico) 34 | import Unsafe.Coerce (unsafeCoerce) 35 | 36 | liftB :: FixedPrim a -> BoundedPrim a 37 | liftB = liftFixedToBounded 38 | 39 | digit :: FixedPrim Int 40 | digit = (\x -> chr (x + 48)) >$< char8 41 | 42 | digits2 :: FixedPrim Int 43 | digits2 = (`quotRem` 10) >$< (digit >*< digit) 44 | 45 | digits3 :: FixedPrim Int 46 | digits3 = (`quotRem` 10) >$< (digits2 >*< digit) 47 | 48 | digits4 :: FixedPrim Int 49 | digits4 = (`quotRem` 10) >$< (digits3 >*< digit) 50 | 51 | frac :: BoundedPrim Int64 52 | frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12)) 53 | where 54 | trunc12 :: BoundedPrim Int64 55 | trunc12 = (`quotRem` 1000000) >$< 56 | condB (\(_,y) -> y == 0) 57 | (fst >$< trunc6) 58 | (liftB digits6 >*< trunc6) 59 | 60 | digitB = liftB digit 61 | 62 | digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit) 63 | digits5 = (`quotRem` 10) >$< (digits4 >*< digit) 64 | 65 | trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5) 66 | trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4)) 67 | trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3)) 68 | trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2)) 69 | trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1)) 70 | trunc1 = condB (== 0) emptyB digitB 71 | 72 | 73 | year :: BoundedPrim Int32 74 | year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4) 75 | where 76 | checkBCE :: Int32 -> Int 77 | checkBCE y 78 | | y > 0 = fromIntegral y 79 | | otherwise = error msg 80 | 81 | msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported" 82 | 83 | day :: BoundedPrim Day 84 | day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2)) 85 | where 86 | toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d)))) 87 | 88 | timeOfDay :: BoundedPrim TimeOfDay 89 | timeOfDay = f >$< (hh_mm_ >*< ss) 90 | where 91 | f (TimeOfDay h m s) = ((h,(':',(m,':'))),s) 92 | 93 | hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8) 94 | 95 | ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$< 96 | (liftB (fromIntegral >$< digits2) >*< frac) 97 | 98 | timeZone :: BoundedPrim TimeZone 99 | timeZone = timeZoneMinutes >$< tz 100 | where 101 | tz = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh) 102 | 103 | tzh = liftB char8 >*< ((`quotRem` 60) >$< (liftB digits2 >*< tzm)) 104 | 105 | tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2)) 106 | 107 | utcTime :: BoundedPrim UTCTime 108 | utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8) 109 | where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z'))) 110 | 111 | localTime :: BoundedPrim LocalTime 112 | localTime = f >$< (day >*< liftB char8 >*< timeOfDay) 113 | where f (LocalTime d tod) = (d, (' ', tod)) 114 | 115 | zonedTime :: BoundedPrim ZonedTime 116 | zonedTime = f >$< (localTime >*< timeZone) 117 | where f (ZonedTime lt tz) = (lt, tz) 118 | 119 | 120 | nominalDiffTime :: NominalDiffTime -> Builder 121 | nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y)) 122 | where 123 | (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000 124 | -------------------------------------------------------------------------------- /test/Time.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | {- 4 | 5 | Testing strategies: 6 | 7 | fromString . toString == id ** Todo? 8 | 9 | toString . fromString == almost id ** Todo? 10 | 11 | postgresql -> haskell -> postgresql * Done 12 | 13 | haskell -> postgresql -> haskell ** Todo? 14 | 15 | But still, what we really want to establish is that the two values 16 | correspond; for example, a conversion that consistently added hour 17 | when printed to a string and subtracted an hour when parsed from string 18 | would still pass these tests. 19 | 20 | 21 | Right now, we are checking that 1400+ timestamps in the range of 1860 to 22 | 2060 round trip from postgresql to haskell and back in 5 different timezones. 23 | In addition to UTC, the four timezones were selected so that 2 have a positive 24 | offset, and 2 have a negative offset, and that 2 have an offset of a 25 | whole number of hours, while the other two do not. 26 | 27 | It may be worth adding a few more timezones to ensure better test coverage. 28 | 29 | We are checking a handful of selected timestamps to ensure we hit 30 | various corner-cases in the code, in addition to 1400 timestamps randomly 31 | generated with granularity of seconds down to microseconds in powers of ten. 32 | 33 | -} 34 | 35 | module Time (testTime) where 36 | 37 | import Common 38 | import Control.Monad(forM_, replicateM_) 39 | import Data.Time 40 | import Data.ByteString(ByteString) 41 | import Database.PostgreSQL.Simple.SqlQQ 42 | 43 | numTests :: Int 44 | numTests = 200 45 | 46 | testTime :: TestEnv -> Assertion 47 | testTime env@TestEnv{..} = do 48 | initializeTable env 49 | execute_ conn "SET timezone TO 'UTC'" 50 | checkRoundTrips env "1860-01-01 00:00:00+00" 51 | execute_ conn "SET timezone TO 'America/Chicago'" -- -5:00 52 | checkRoundTrips env "1883-11-18 12:00:00-06" 53 | execute_ conn "SET timezone TO 'Asia/Tokyo'" -- +9:00 54 | checkRoundTrips env "1888-01-01 00:00:00+09" 55 | execute_ conn "SET timezone TO 'Asia/Kathmandu'" -- +5:45 56 | checkRoundTrips env "1919-12-31 23:48:44+05:30" 57 | execute_ conn "SET timezone TO 'America/St_Johns'" -- -3:30 58 | checkRoundTrips env "1935-03-30 00:00:52-03:30" 59 | 60 | initializeTable :: TestEnv -> IO () 61 | initializeTable TestEnv{..} = withTransaction conn $ do 62 | execute_ conn 63 | [sql| CREATE TEMPORARY TABLE testtime 64 | ( x serial, y timestamptz, PRIMARY KEY(x) ) |] 65 | 66 | let test :: ByteString -> IO () = \x -> do 67 | execute conn [sql| 68 | INSERT INTO testtime (y) VALUES (?) 69 | |] (Only x) 70 | return () 71 | -- America/Chicago 72 | test "1883-11-18 11:59:59-05:50:36" 73 | test "1883-11-18 12:09:23-05:50:36" 74 | test "1883-11-18 12:00:00-06" 75 | -- Asia/Tokyo 76 | test "1887-12-31 23:59:59+09:18:59" 77 | test "1888-01-01 00:18:58+09:18:59" 78 | test "1888-01-01 00:00:00+09" 79 | -- Asia/Kathmandu 80 | test "1919-12-31 23:59:59+05:41:16" 81 | test "1919-12-31 23:48:44+05:30" 82 | test "1985-12-31 23:59:59+05:30" 83 | test "1986-01-01 00:15:00+05:45" 84 | -- America/St_Johns 85 | test "1935-03-29 23:59:59-03:30:52" 86 | test "1935-03-30 00:00:52-03:30" 87 | 88 | -- While the above special cases are probably a decent start, there 89 | -- are probably more that are well worth adding to ensure better 90 | -- coverage. 91 | 92 | let pop :: ByteString -> Double -> IO () = \x y -> 93 | replicateM_ numTests $ execute conn 94 | [sql| INSERT INTO testtime (y) VALUES 95 | ('1860-01-01 00:00:00+00'::timestamptz 96 | + ?::interval * ROUND(RANDOM() * ?)) |] (x,y) 97 | pop "1 microsecond" 6.3113904e15 98 | pop "10 microseconds" 6.3113904e14 99 | pop "100 microseconds" 6.3113904e13 100 | pop "1 millisecond" 6.3113904e12 101 | pop "10 milliseconds" 6.3113904e11 102 | pop "100 milliseconds" 6.3113904e10 103 | pop "1 second" 6.3113904e9 104 | 105 | checkRoundTrips :: TestEnv -> ByteString -> IO () 106 | checkRoundTrips TestEnv{..} limit = do 107 | yxs :: [(UTCTime, Int)] <- query_ conn [sql| SELECT y, x FROM testtime |] 108 | forM_ yxs $ \yx -> do 109 | res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx 110 | assertBool "UTCTime did not round-trip from SQL to Haskell and back" $ 111 | res == [Only True] 112 | 113 | yxs :: [(ZonedTime, Int)] <- query conn [sql| 114 | SELECT y, x FROM testtime WHERE y > ? 115 | |] (Only limit) 116 | forM_ yxs $ \yx -> do 117 | res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx 118 | assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $ 119 | res == [Only True] 120 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Errors.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | ------------------------------------------------------------------------------ 5 | -- | 6 | -- Module: Database.PostgreSQL.Simple.Errors 7 | -- Copyright: (c) 2012-2013 Leonid Onokhov, Joey Adams 8 | -- License: BSD3 9 | -- Maintainer: Leon P Smith 10 | -- Stability: experimental 11 | -- 12 | -- | Module for parsing errors from postgresql error messages. 13 | -- Currently only parses integrity violation errors (class 23). 14 | -- 15 | -- /Note: Success of parsing may depend on language settings./ 16 | ---------------------------------------------------------- 17 | module Database.PostgreSQL.Simple.Errors 18 | ( ConstraintViolation(..) 19 | , constraintViolation 20 | , constraintViolationE 21 | , catchViolation 22 | , isSerializationError 23 | , isNoActiveTransactionError 24 | , isFailedTransactionError 25 | ) 26 | where 27 | 28 | import Control.Applicative 29 | import Control.Exception as E 30 | 31 | import Data.Attoparsec.ByteString.Char8 32 | import Data.ByteString (ByteString) 33 | import Data.Typeable 34 | 35 | import Database.PostgreSQL.Simple.Internal 36 | 37 | -- Examples of parsed error messages 38 | -- 39 | -- `ERROR: new row for relation "users" violates check 40 | -- constraint "user_kind_check"` 41 | -- 42 | -- `ERROR: insert or update on table "user_group_map" violates foreign key 43 | -- constraint "user_id"` 44 | -- 45 | -- `ERROR: null value in column "login" violates not-null constraint` 46 | -- 47 | -- `ERROR: duplicate key value violates unique constraint "users_login_key"` 48 | 49 | data ConstraintViolation 50 | = NotNullViolation ByteString 51 | -- ^ The field is a column name 52 | | ForeignKeyViolation ByteString ByteString 53 | -- ^ Table name and name of violated constraint 54 | | UniqueViolation ByteString 55 | -- ^ Name of violated constraint 56 | | CheckViolation ByteString ByteString 57 | -- ^ Relation name (usually table), constraint name 58 | | ExclusionViolation ByteString 59 | -- ^ Name of the exclusion violation constraint 60 | deriving (Show, Eq, Ord, Typeable) 61 | 62 | -- Default instance should be enough 63 | instance Exception ConstraintViolation 64 | 65 | 66 | -- | Tries to convert 'SqlError' to 'ConstrainViolation', checks sqlState and 67 | -- succeedes only if able to parse sqlErrorMsg. 68 | -- 69 | -- > createUser = handleJust constraintViolation handler $ execute conn ... 70 | -- > where 71 | -- > handler (UniqueViolation "user_login_key") = ... 72 | -- > handler _ = ... 73 | constraintViolation :: SqlError -> Maybe ConstraintViolation 74 | constraintViolation e = 75 | case sqlState e of 76 | "23502" -> NotNullViolation <$> parseMaybe parseQ1 msg 77 | "23503" -> uncurry ForeignKeyViolation <$> parseMaybe parseQ2 msg 78 | "23505" -> UniqueViolation <$> parseMaybe parseQ1 msg 79 | "23514" -> uncurry CheckViolation <$> parseMaybe parseQ2 msg 80 | "23P01" -> ExclusionViolation <$> parseMaybe parseQ1 msg 81 | _ -> Nothing 82 | where msg = sqlErrorMsg e 83 | 84 | 85 | -- | Like constraintViolation, but also packs original SqlError. 86 | -- 87 | -- > createUser = handleJust constraintViolationE handler $ execute conn ... 88 | -- > where 89 | -- > handler (_, UniqueViolation "user_login_key") = ... 90 | -- > handler (e, _) = throwIO e 91 | -- 92 | constraintViolationE :: SqlError -> Maybe (SqlError, ConstraintViolation) 93 | constraintViolationE e = fmap ((,) e) $ constraintViolation e 94 | 95 | -- | Catches SqlError, tries to convert to ConstraintViolation, re-throws 96 | -- on fail. Provides alternative interface to 'E.handleJust' 97 | -- 98 | -- > createUser = catchViolation catcher $ execute conn ... 99 | -- > where 100 | -- > catcher _ (UniqueViolation "user_login_key") = ... 101 | -- > catcher e _ = throwIO e 102 | catchViolation :: (SqlError -> ConstraintViolation -> IO a) -> IO a -> IO a 103 | catchViolation f m = E.catch m 104 | (\e -> maybe (throwIO e) (f e) $ constraintViolation e) 105 | 106 | -- Parsers just try to extract quoted strings from error messages, number 107 | -- of quoted strings depend on error type. 108 | scanTillQuote :: Parser ByteString 109 | scanTillQuote = scan False go 110 | where go True _ = Just False -- escaped character 111 | go False '"' = Nothing -- end parse 112 | go False '\\' = Just True -- next one is escaped 113 | go _ _ = Just False 114 | 115 | parseQ1 :: Parser ByteString 116 | parseQ1 = scanTillQuote *> char '"' *> scanTillQuote <* char '"' 117 | 118 | parseQ2 :: Parser (ByteString, ByteString) 119 | parseQ2 = (,) <$> parseQ1 <*> parseQ1 120 | 121 | parseMaybe :: Parser a -> ByteString -> Maybe a 122 | parseMaybe p b = either (const Nothing) Just $ parseOnly p b 123 | 124 | ------------------------------------------------------------------------ 125 | -- Error predicates 126 | -- 127 | -- https://www.postgresql.org/docs/9.5/static/errcodes-appendix.html 128 | 129 | isSerializationError :: SqlError -> Bool 130 | isSerializationError = isSqlState "40001" 131 | 132 | isNoActiveTransactionError :: SqlError -> Bool 133 | isNoActiveTransactionError = isSqlState "25P01" 134 | 135 | isFailedTransactionError :: SqlError -> Bool 136 | isFailedTransactionError = isSqlState "25P02" 137 | 138 | isSqlState :: ByteString -> SqlError -> Bool 139 | isSqlState s SqlError{..} = sqlState == s 140 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/TypeInfo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.PostgreSQL.Simple.TypeInfo 6 | -- Copyright: (c) 2013 Leon P Smith 7 | -- License: BSD3 8 | -- Maintainer: Leon P Smith 9 | -- Stability: experimental 10 | -- 11 | -- This module provides convenient and efficient access to parts of the 12 | -- @pg_type@ metatable. At the moment, this requires PostgreSQL 8.4 if 13 | -- you need to work with types that do not appear in 14 | -- 'Database.PostgreSQL.Simple.TypeInfo.Static'. 15 | -- 16 | -- The current scheme could be more efficient, especially for some use 17 | -- cases. In particular, connection pools that use many user-added 18 | -- types and connect to a set of servers with identical (or at least 19 | -- compatible) @pg_type@ and associated tables could share a common 20 | -- typeinfo cache, thus saving memory and communication between the 21 | -- client and server. 22 | -- 23 | ------------------------------------------------------------------------------ 24 | 25 | module Database.PostgreSQL.Simple.TypeInfo 26 | ( getTypeInfo 27 | , TypeInfo(..) 28 | , Attribute(..) 29 | ) where 30 | 31 | import qualified Data.ByteString as B 32 | import qualified Data.IntMap as IntMap 33 | import qualified Data.Vector as V 34 | import qualified Data.Vector.Mutable as MV 35 | import Control.Concurrent.MVar 36 | import Control.Exception (throw) 37 | 38 | import qualified Database.PostgreSQL.LibPQ as PQ 39 | import {-# SOURCE #-} Database.PostgreSQL.Simple 40 | import Database.PostgreSQL.Simple.Internal 41 | import Database.PostgreSQL.Simple.Types 42 | import Database.PostgreSQL.Simple.TypeInfo.Types 43 | import Database.PostgreSQL.Simple.TypeInfo.Static 44 | 45 | -- | Returns the metadata of the type with a particular oid. To find 46 | -- this data, 'getTypeInfo' first consults postgresql-simple's 47 | -- built-in 'staticTypeInfo' table, then checks the connection's 48 | -- typeinfo cache. Finally, the database's 'pg_type' table will 49 | -- be queried only if necessary, and the result will be stored 50 | -- in the connections's cache. 51 | 52 | getTypeInfo :: Connection -> PQ.Oid -> IO TypeInfo 53 | getTypeInfo conn@Connection{..} oid = 54 | case staticTypeInfo oid of 55 | Just name -> return name 56 | Nothing -> modifyMVar connectionObjects $ getTypeInfo' conn oid 57 | 58 | getTypeInfo' :: Connection -> PQ.Oid -> TypeInfoCache 59 | -> IO (TypeInfoCache, TypeInfo) 60 | getTypeInfo' conn oid oidmap = 61 | case IntMap.lookup (oid2int oid) oidmap of 62 | Just typeinfo -> return (oidmap, typeinfo) 63 | Nothing -> do 64 | names <- query conn "SELECT oid, typcategory, typdelim, typname,\ 65 | \ typelem, typrelid\ 66 | \ FROM pg_type WHERE oid = ?" 67 | (Only oid) 68 | (oidmap', typeInfo) <- 69 | case names of 70 | [] -> return $ throw (fatalError "invalid type oid") 71 | [(typoid, typcategory, typdelim, typname, typelem_, typrelid)] -> do 72 | case typcategory of 73 | 'A' -> do 74 | (oidmap', typelem) <- getTypeInfo' conn typelem_ oidmap 75 | let !typeInfo = Array{..} 76 | return $! (oidmap', typeInfo) 77 | 'R' -> do 78 | rngsubtypeOids <- query conn "SELECT rngsubtype\ 79 | \ FROM pg_range\ 80 | \ WHERE rngtypid = ?" 81 | (Only oid) 82 | case rngsubtypeOids of 83 | [Only rngsubtype_] -> do 84 | (oidmap', rngsubtype) <- 85 | getTypeInfo' conn rngsubtype_ oidmap 86 | let !typeInfo = Range{..} 87 | return $! (oidmap', typeInfo) 88 | _ -> fail "range subtype query failed to return exactly one result" 89 | 'C' -> do 90 | cols <- query conn "SELECT attname, atttypid\ 91 | \ FROM pg_attribute\ 92 | \ WHERE attrelid = ?\ 93 | \ AND attnum > 0\ 94 | \ AND NOT attisdropped\ 95 | \ ORDER BY attnum" 96 | (Only typrelid) 97 | vec <- MV.new $! length cols 98 | (oidmap', attributes) <- getAttInfos conn cols oidmap vec 0 99 | let !typeInfo = Composite{..} 100 | return $! (oidmap', typeInfo) 101 | _ -> do 102 | let !typeInfo = Basic{..} 103 | return $! (oidmap, typeInfo) 104 | _ -> fail "typename query returned more than one result" 105 | -- oid is a primary key, so the query should 106 | -- never return more than one result 107 | let !oidmap'' = IntMap.insert (oid2int oid) typeInfo oidmap' 108 | return $! (oidmap'', typeInfo) 109 | 110 | getAttInfos :: Connection -> [(B.ByteString, PQ.Oid)] -> TypeInfoCache 111 | -> MV.IOVector Attribute -> Int 112 | -> IO (TypeInfoCache, V.Vector Attribute) 113 | getAttInfos conn cols oidmap vec n = 114 | case cols of 115 | [] -> do 116 | !attributes <- V.unsafeFreeze vec 117 | return $! (oidmap, attributes) 118 | ((attname, attTypeOid):xs) -> do 119 | (oidmap', atttype) <- getTypeInfo' conn attTypeOid oidmap 120 | MV.write vec n $! Attribute{..} 121 | getAttInfos conn xs oidmap' vec (n+1) 122 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Time/Implementation.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- | 3 | -- Module: Database.PostgreSQL.Simple.Time.Implementation 4 | -- Copyright: (c) 2012-2015 Leon P Smith 5 | -- License: BSD3 6 | -- Maintainer: Leon P Smith 7 | -- Stability: experimental 8 | -- 9 | ------------------------------------------------------------------------------ 10 | 11 | {-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} 12 | 13 | module Database.PostgreSQL.Simple.Time.Implementation where 14 | 15 | import Prelude hiding (take) 16 | import Data.ByteString.Builder(Builder, byteString) 17 | import Data.ByteString.Builder.Prim(primBounded) 18 | import Control.Arrow((***)) 19 | import Control.Applicative 20 | import qualified Data.ByteString as B 21 | import Data.Time hiding (getTimeZone, getZonedTime) 22 | import Data.Typeable 23 | import Data.Maybe (fromMaybe) 24 | import qualified Data.Attoparsec.ByteString.Char8 as A 25 | import Database.PostgreSQL.Simple.Compat ((<>)) 26 | import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP 27 | import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP 28 | 29 | data Unbounded a 30 | = NegInfinity 31 | | Finite !a 32 | | PosInfinity 33 | deriving (Eq, Ord, Typeable, Functor) 34 | 35 | instance Show a => Show (Unbounded a) where 36 | showsPrec prec x rest 37 | = case x of 38 | NegInfinity -> "-infinity" <> rest 39 | Finite time -> showsPrec prec time rest 40 | PosInfinity -> "infinity" <> rest 41 | 42 | instance Read a => Read (Unbounded a) where 43 | readsPrec prec = readParen False $ \str -> case str of 44 | ('-':'i':'n':'f':'i':'n':'i':'t':'y':xs) -> [(NegInfinity,xs)] 45 | ( 'i':'n':'f':'i':'n':'i':'t':'y':xs) -> [(PosInfinity,xs)] 46 | xs -> map (Finite *** id) (readsPrec prec xs) 47 | 48 | type LocalTimestamp = Unbounded LocalTime 49 | type UTCTimestamp = Unbounded UTCTime 50 | type ZonedTimestamp = Unbounded ZonedTime 51 | type Date = Unbounded Day 52 | 53 | parseUTCTime :: B.ByteString -> Either String UTCTime 54 | parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput) 55 | 56 | parseZonedTime :: B.ByteString -> Either String ZonedTime 57 | parseZonedTime = A.parseOnly (getZonedTime <* A.endOfInput) 58 | 59 | parseLocalTime :: B.ByteString -> Either String LocalTime 60 | parseLocalTime = A.parseOnly (getLocalTime <* A.endOfInput) 61 | 62 | parseDay :: B.ByteString -> Either String Day 63 | parseDay = A.parseOnly (getDay <* A.endOfInput) 64 | 65 | parseTimeOfDay :: B.ByteString -> Either String TimeOfDay 66 | parseTimeOfDay = A.parseOnly (getTimeOfDay <* A.endOfInput) 67 | 68 | parseUTCTimestamp :: B.ByteString -> Either String UTCTimestamp 69 | parseUTCTimestamp = A.parseOnly (getUTCTimestamp <* A.endOfInput) 70 | 71 | parseZonedTimestamp :: B.ByteString -> Either String ZonedTimestamp 72 | parseZonedTimestamp = A.parseOnly (getZonedTimestamp <* A.endOfInput) 73 | 74 | parseLocalTimestamp :: B.ByteString -> Either String LocalTimestamp 75 | parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput) 76 | 77 | parseDate :: B.ByteString -> Either String Date 78 | parseDate = A.parseOnly (getDate <* A.endOfInput) 79 | 80 | getUnbounded :: A.Parser a -> A.Parser (Unbounded a) 81 | getUnbounded getFinite 82 | = (pure NegInfinity <* A.string "-infinity") 83 | <|> (pure PosInfinity <* A.string "infinity") 84 | <|> (Finite <$> getFinite) 85 | 86 | getDay :: A.Parser Day 87 | getDay = TP.day 88 | 89 | getDate :: A.Parser Date 90 | getDate = getUnbounded getDay 91 | 92 | getTimeOfDay :: A.Parser TimeOfDay 93 | getTimeOfDay = TP.timeOfDay 94 | 95 | getLocalTime :: A.Parser LocalTime 96 | getLocalTime = TP.localTime 97 | 98 | getLocalTimestamp :: A.Parser LocalTimestamp 99 | getLocalTimestamp = getUnbounded getLocalTime 100 | 101 | getTimeZone :: A.Parser TimeZone 102 | getTimeZone = fromMaybe utc <$> TP.timeZone 103 | 104 | type TimeZoneHMS = (Int,Int,Int) 105 | 106 | getTimeZoneHMS :: A.Parser TimeZoneHMS 107 | getTimeZoneHMS = munge <$> TP.timeZoneHMS 108 | where 109 | munge Nothing = (0,0,0) 110 | munge (Just (TP.UTCOffsetHMS h m s)) = (h,m,s) 111 | 112 | localToUTCTimeOfDayHMS :: TimeZoneHMS -> TimeOfDay -> (Integer, TimeOfDay) 113 | localToUTCTimeOfDayHMS (dh, dm, ds) tod = 114 | TP.localToUTCTimeOfDayHMS (TP.UTCOffsetHMS dh dm ds) tod 115 | 116 | getZonedTime :: A.Parser ZonedTime 117 | getZonedTime = TP.zonedTime 118 | 119 | getZonedTimestamp :: A.Parser ZonedTimestamp 120 | getZonedTimestamp = getUnbounded getZonedTime 121 | 122 | getUTCTime :: A.Parser UTCTime 123 | getUTCTime = TP.utcTime 124 | 125 | getUTCTimestamp :: A.Parser UTCTimestamp 126 | getUTCTimestamp = getUnbounded getUTCTime 127 | 128 | dayToBuilder :: Day -> Builder 129 | dayToBuilder = primBounded TPP.day 130 | 131 | timeOfDayToBuilder :: TimeOfDay -> Builder 132 | timeOfDayToBuilder = primBounded TPP.timeOfDay 133 | 134 | timeZoneToBuilder :: TimeZone -> Builder 135 | timeZoneToBuilder = primBounded TPP.timeZone 136 | 137 | utcTimeToBuilder :: UTCTime -> Builder 138 | utcTimeToBuilder = primBounded TPP.utcTime 139 | 140 | zonedTimeToBuilder :: ZonedTime -> Builder 141 | zonedTimeToBuilder = primBounded TPP.zonedTime 142 | 143 | localTimeToBuilder :: LocalTime -> Builder 144 | localTimeToBuilder = primBounded TPP.localTime 145 | 146 | unboundedToBuilder :: (a -> Builder) -> (Unbounded a -> Builder) 147 | unboundedToBuilder finiteToBuilder unbounded 148 | = case unbounded of 149 | NegInfinity -> byteString "-infinity" 150 | Finite a -> finiteToBuilder a 151 | PosInfinity -> byteString "infinity" 152 | 153 | utcTimestampToBuilder :: UTCTimestamp -> Builder 154 | utcTimestampToBuilder = unboundedToBuilder utcTimeToBuilder 155 | 156 | zonedTimestampToBuilder :: ZonedTimestamp -> Builder 157 | zonedTimestampToBuilder = unboundedToBuilder zonedTimeToBuilder 158 | 159 | localTimestampToBuilder :: LocalTimestamp -> Builder 160 | localTimestampToBuilder = unboundedToBuilder localTimeToBuilder 161 | 162 | dateToBuilder :: Date -> Builder 163 | dateToBuilder = unboundedToBuilder dayToBuilder 164 | 165 | nominalDiffTimeToBuilder :: NominalDiffTime -> Builder 166 | nominalDiffTimeToBuilder = TPP.nominalDiffTime 167 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns, ScopedTypeVariables #-} 2 | 3 | -- | 4 | -- Module: Database.PostgreSQL.Simple.Time.Internal.Parser 5 | -- Copyright: (c) 2012-2015 Leon P Smith 6 | -- (c) 2015 Bryan O'Sullivan 7 | -- License: BSD3 8 | -- Maintainer: Leon P Smith 9 | -- Stability: experimental 10 | -- 11 | -- Parsers for parsing dates and times. 12 | 13 | module Database.PostgreSQL.Simple.Time.Internal.Parser 14 | ( 15 | day 16 | , localTime 17 | , timeOfDay 18 | , timeZone 19 | , UTCOffsetHMS(..) 20 | , timeZoneHMS 21 | , localToUTCTimeOfDayHMS 22 | , utcTime 23 | , zonedTime 24 | ) where 25 | 26 | import Control.Applicative ((<$>), (<*>), (<*), (*>)) 27 | import Database.PostgreSQL.Simple.Compat (toPico) 28 | import Data.Attoparsec.ByteString.Char8 as A 29 | import Data.Bits ((.&.)) 30 | import Data.Char (ord) 31 | import Data.Fixed (Pico) 32 | import Data.Int (Int64) 33 | import Data.Maybe (fromMaybe) 34 | import Data.Time.Calendar (Day, fromGregorianValid, addDays) 35 | import Data.Time.Clock (UTCTime(..)) 36 | import qualified Data.ByteString.Char8 as B8 37 | import qualified Data.Time.LocalTime as Local 38 | 39 | -- | Parse a date of the form @YYYY-MM-DD@. 40 | day :: Parser Day 41 | day = do 42 | y <- decimal <* char '-' 43 | m <- twoDigits <* char '-' 44 | d <- twoDigits 45 | maybe (fail "invalid date") return (fromGregorianValid y m d) 46 | 47 | -- | Parse a two-digit integer (e.g. day of month, hour). 48 | twoDigits :: Parser Int 49 | twoDigits = do 50 | a <- digit 51 | b <- digit 52 | let c2d c = ord c .&. 15 53 | return $! c2d a * 10 + c2d b 54 | 55 | -- | Parse a time of the form @HH:MM[:SS[.SSS]]@. 56 | timeOfDay :: Parser Local.TimeOfDay 57 | timeOfDay = do 58 | h <- twoDigits <* char ':' 59 | m <- twoDigits 60 | mc <- peekChar 61 | s <- case mc of 62 | Just ':' -> anyChar *> seconds 63 | _ -> return 0 64 | if h < 24 && m < 60 && s <= 60 65 | then return (Local.TimeOfDay h m s) 66 | else fail "invalid time" 67 | 68 | -- | Parse a count of seconds, with the integer part being two digits 69 | -- long. 70 | seconds :: Parser Pico 71 | seconds = do 72 | real <- twoDigits 73 | mc <- peekChar 74 | case mc of 75 | Just '.' -> do 76 | t <- anyChar *> takeWhile1 isDigit 77 | return $! parsePicos (fromIntegral real) t 78 | _ -> return $! fromIntegral real 79 | where 80 | parsePicos :: Int64 -> B8.ByteString -> Pico 81 | parsePicos a0 t = toPico (fromIntegral (t' * 10^n)) 82 | where n = max 0 (12 - B8.length t) 83 | t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0 84 | (B8.take 12 t) 85 | 86 | -- | Parse a time zone, and return 'Nothing' if the offset from UTC is 87 | -- zero. (This makes some speedups possible.) 88 | timeZone :: Parser (Maybe Local.TimeZone) 89 | timeZone = do 90 | ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' 91 | if ch == 'Z' 92 | then return Nothing 93 | else do 94 | h <- twoDigits 95 | mm <- peekChar 96 | m <- case mm of 97 | Just ':' -> anyChar *> twoDigits 98 | _ -> return 0 99 | let off | ch == '-' = negate off0 100 | | otherwise = off0 101 | off0 = h * 60 + m 102 | case undefined of 103 | _ | off == 0 -> 104 | return Nothing 105 | | h > 23 || m > 59 -> 106 | fail "invalid time zone offset" 107 | | otherwise -> 108 | let !tz = Local.minutesToTimeZone off 109 | in return (Just tz) 110 | 111 | data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int 112 | 113 | -- | Parse a time zone, and return 'Nothing' if the offset from UTC is 114 | -- zero. (This makes some speedups possible.) 115 | timeZoneHMS :: Parser (Maybe UTCOffsetHMS) 116 | timeZoneHMS = do 117 | ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z' 118 | if ch == 'Z' 119 | then return Nothing 120 | else do 121 | h <- twoDigits 122 | m <- maybeTwoDigits 123 | s <- maybeTwoDigits 124 | case undefined of 125 | _ | h == 0 && m == 0 && s == 0 -> 126 | return Nothing 127 | | h > 23 || m >= 60 || s >= 60 -> 128 | fail "invalid time zone offset" 129 | | otherwise -> 130 | if ch == '+' 131 | then let !tz = UTCOffsetHMS h m s 132 | in return (Just tz) 133 | else let !tz = UTCOffsetHMS (-h) (-m) (-s) 134 | in return (Just tz) 135 | where 136 | maybeTwoDigits = do 137 | ch <- peekChar 138 | case ch of 139 | Just ':' -> anyChar *> twoDigits 140 | _ -> return 0 141 | 142 | localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay) 143 | localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) = 144 | (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'') 145 | where 146 | s' = s - fromIntegral ds 147 | (!s'', m') 148 | | s' < 0 = (s' + 60, m - dm - 1) 149 | | s' >= 60 = (s' - 60, m - dm + 1) 150 | | otherwise = (s' , m - dm ) 151 | (!m'', h') 152 | | m' < 0 = (m' + 60, h - dh - 1) 153 | | m' >= 60 = (m' - 60, h - dh + 1) 154 | | otherwise = (m' , h - dh ) 155 | (!h'', dday) 156 | | h' < 0 = (h' + 24, -1) 157 | | h' >= 24 = (h' - 24, 1) 158 | | otherwise = (h' , 0) 159 | 160 | 161 | -- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@. 162 | -- The space may be replaced with a @T@. The number of seconds may be 163 | -- followed by a fractional component. 164 | localTime :: Parser Local.LocalTime 165 | localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay 166 | where daySep = satisfy (\c -> c == ' ' || c == 'T') 167 | 168 | -- | Behaves as 'zonedTime', but converts any time zone offset into a 169 | -- UTC time. 170 | utcTime :: Parser UTCTime 171 | utcTime = do 172 | (Local.LocalTime d t) <- localTime 173 | mtz <- timeZoneHMS 174 | case mtz of 175 | Nothing -> let !tt = Local.timeOfDayToTime t 176 | in return (UTCTime d tt) 177 | Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t 178 | !d' = addDays dd d 179 | !tt = Local.timeOfDayToTime t' 180 | in return (UTCTime d' tt) 181 | 182 | -- | Parse a date with time zone info. Acceptable formats: 183 | -- 184 | -- @YYYY-MM-DD HH:MM:SS Z@ 185 | -- 186 | -- The first space may instead be a @T@, and the second space is 187 | -- optional. The @Z@ represents UTC. The @Z@ may be replaced with a 188 | -- time zone offset of the form @+0000@ or @-08:00@, where the first 189 | -- two digits are hours, the @:@ is optional and the second two digits 190 | -- (also optional) are minutes. 191 | zonedTime :: Parser Local.ZonedTime 192 | zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone) 193 | 194 | utc :: Local.TimeZone 195 | utc = Local.TimeZone 0 False "" 196 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Notification.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE NamedFieldPuns #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | 5 | ----------------------------------------------------------------------------- 6 | -- | 7 | -- Module : Database.PostgreSQL.Simple.Notification 8 | -- Copyright : (c) 2011-2015 Leon P Smith 9 | -- (c) 2012 Joey Adams 10 | -- License : BSD3 11 | -- 12 | -- Maintainer : leon@melding-monads.com 13 | -- Stability : experimental 14 | -- 15 | -- Support for receiving asynchronous notifications via PostgreSQL's 16 | -- Listen/Notify mechanism. See 17 | -- for more 18 | -- information. 19 | -- 20 | -- Note that on Windows, @getNotification@ currently uses a polling loop 21 | -- of 1 second to check for more notifications, due to some inadequacies 22 | -- in GHC's IO implementation and interface on that platform. See GHC 23 | -- issue #7353 for more information. While this workaround is less than 24 | -- ideal, notifications are still better than polling the database directly. 25 | -- Notifications do not create any extra work for the backend, and are 26 | -- likely cheaper on the client side as well. 27 | -- 28 | -- 29 | -- 30 | ----------------------------------------------------------------------------- 31 | 32 | module Database.PostgreSQL.Simple.Notification 33 | ( Notification(..) 34 | , getNotification 35 | , getNotificationNonBlocking 36 | , getBackendPID 37 | ) where 38 | 39 | import Control.Monad ( join, void ) 40 | import Control.Exception ( throwIO, catch ) 41 | import qualified Data.ByteString as B 42 | import qualified Data.ByteString.Char8 as B8 43 | import Database.PostgreSQL.Simple.Internal 44 | import qualified Database.PostgreSQL.LibPQ as PQ 45 | import System.Posix.Types ( CPid ) 46 | import GHC.IO.Exception ( ioe_location ) 47 | 48 | #if defined(mingw32_HOST_OS) 49 | import Control.Concurrent ( threadDelay ) 50 | #elif !MIN_VERSION_base(4,7,0) 51 | import Control.Concurrent ( threadWaitRead ) 52 | #else 53 | import GHC.Conc ( atomically ) 54 | import Control.Concurrent ( threadWaitReadSTM ) 55 | #endif 56 | 57 | data Notification = Notification 58 | { notificationPid :: {-# UNPACK #-} !CPid 59 | , notificationChannel :: {-# UNPACK #-} !B.ByteString 60 | , notificationData :: {-# UNPACK #-} !B.ByteString 61 | } deriving (Show, Eq) 62 | 63 | convertNotice :: PQ.Notify -> Notification 64 | convertNotice PQ.Notify{..} 65 | = Notification { notificationPid = notifyBePid 66 | , notificationChannel = notifyRelname 67 | , notificationData = notifyExtra } 68 | 69 | -- | Returns a single notification. If no notifications are available, 70 | -- 'getNotification' blocks until one arrives. 71 | -- 72 | -- It is safe to call 'getNotification' on a connection that is concurrently 73 | -- being used for other purposes, note however that PostgreSQL does not 74 | -- deliver notifications while a connection is inside a transaction. 75 | 76 | getNotification :: Connection -> IO Notification 77 | getNotification conn = join $ withConnection conn fetch 78 | where 79 | funcName = "Database.PostgreSQL.Simple.Notification.getNotification" 80 | 81 | fetch c = do 82 | mmsg <- PQ.notifies c 83 | case mmsg of 84 | Just msg -> return (return $! convertNotice msg) 85 | Nothing -> do 86 | mfd <- PQ.socket c 87 | case mfd of 88 | Nothing -> return (throwIO $! fdError funcName) 89 | #if defined(mingw32_HOST_OS) 90 | -- threadWaitRead doesn't work for sockets on Windows, so just 91 | -- poll for input every second (PQconsumeInput is non-blocking). 92 | -- 93 | -- We could call select(), but FFI calls can't be interrupted 94 | -- with async exceptions, whereas threadDelay can. 95 | Just _fd -> do 96 | return (threadDelay 1000000 >> loop) 97 | #elif !MIN_VERSION_base(4,7,0) 98 | -- Technically there's a race condition that is usually benign. 99 | -- If the connection is closed or reset after we drop the 100 | -- lock, and then the fd index is reallocated to a new 101 | -- descriptor before we call threadWaitRead, then 102 | -- we could end up waiting on the wrong descriptor. 103 | -- 104 | -- Now, if the descriptor becomes readable promptly, then 105 | -- it's no big deal as we'll wake up and notice the change 106 | -- on the next iteration of the loop. But if are very 107 | -- unlucky, then we could end up waiting a long time. 108 | Just fd -> do 109 | return $ do 110 | threadWaitRead fd `catch` (throwIO . setIOErrorLocation) 111 | loop 112 | #else 113 | -- This case fixes the race condition above. By registering 114 | -- our interest in the descriptor before we drop the lock, 115 | -- there is no opportunity for the descriptor index to be 116 | -- reallocated on us. 117 | -- 118 | -- (That is, assuming there isn't concurrently executing 119 | -- code that manipulates the descriptor without holding 120 | -- the lock... but such a major bug is likely to exhibit 121 | -- itself in an at least somewhat more dramatic fashion.) 122 | Just fd -> do 123 | (waitRead, _) <- threadWaitReadSTM fd 124 | return $ do 125 | atomically waitRead `catch` (throwIO . setIOErrorLocation) 126 | loop 127 | #endif 128 | 129 | loop = join $ withConnection conn $ \c -> do 130 | void $ PQ.consumeInput c 131 | fetch c 132 | 133 | setIOErrorLocation :: IOError -> IOError 134 | setIOErrorLocation err = err { ioe_location = B8.unpack funcName } 135 | 136 | 137 | -- | Non-blocking variant of 'getNotification'. Returns a single notification, 138 | -- if available. If no notifications are available, returns 'Nothing'. 139 | 140 | getNotificationNonBlocking :: Connection -> IO (Maybe Notification) 141 | getNotificationNonBlocking conn = 142 | withConnection conn $ \c -> do 143 | mmsg <- PQ.notifies c 144 | case mmsg of 145 | Just msg -> return $! Just $! convertNotice msg 146 | Nothing -> do 147 | _ <- PQ.consumeInput c 148 | mmsg' <- PQ.notifies c 149 | case mmsg' of 150 | Just msg -> return $! Just $! convertNotice msg 151 | Nothing -> return Nothing 152 | 153 | -- | Returns the process 'CPid' of the backend server process 154 | -- handling this connection. 155 | -- 156 | -- The backend PID is useful for debugging purposes and for comparison 157 | -- to NOTIFY messages (which include the PID of the notifying backend 158 | -- process). Note that the PID belongs to a process executing on the 159 | -- database server host, not the local host! 160 | 161 | getBackendPID :: Connection -> IO CPid 162 | getBackendPID conn = withConnection conn PQ.backendPID 163 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/HStore/Implementation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ViewPatterns, DeriveDataTypeable, GeneralizedNewtypeDeriving #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.PostgreSQL.Simple.HStore.Implementation 6 | -- Copyright: (c) 2013 Leon P Smith 7 | -- License: BSD3 8 | -- Maintainer: Leon P Smith 9 | -- Stability: experimental 10 | -- 11 | -- This code has yet to be profiled and optimized. 12 | -- 13 | ------------------------------------------------------------------------------ 14 | 15 | module Database.PostgreSQL.Simple.HStore.Implementation where 16 | 17 | import Control.Applicative 18 | import qualified Data.Attoparsec.ByteString as P 19 | import qualified Data.Attoparsec.ByteString.Char8 as P (isSpace_w8) 20 | import qualified Data.ByteString as BS 21 | import Data.ByteString.Builder (Builder, byteString, char8) 22 | import qualified Data.ByteString.Builder as BU 23 | import Data.ByteString.Internal (c2w, w2c) 24 | import qualified Data.ByteString.Lazy as BL 25 | #if !MIN_VERSION_bytestring(0,10,0) 26 | import qualified Data.ByteString.Lazy.Internal as BL (foldrChunks) 27 | #endif 28 | import Data.Map(Map) 29 | import qualified Data.Map as Map 30 | import Data.Text(Text) 31 | import qualified Data.Text as TS 32 | import qualified Data.Text.Encoding as TS 33 | import Data.Text.Encoding.Error(UnicodeException) 34 | import qualified Data.Text.Lazy as TL 35 | import Data.Typeable 36 | import Data.Monoid(Monoid(..)) 37 | import Data.Semigroup 38 | import Database.PostgreSQL.Simple.FromField 39 | import Database.PostgreSQL.Simple.ToField 40 | 41 | class ToHStore a where 42 | toHStore :: a -> HStoreBuilder 43 | 44 | -- | Represents valid hstore syntax. 45 | data HStoreBuilder 46 | = Empty 47 | | Comma !Builder 48 | deriving (Typeable) 49 | 50 | instance ToHStore HStoreBuilder where 51 | toHStore = id 52 | 53 | toBuilder :: HStoreBuilder -> Builder 54 | toBuilder x = case x of 55 | Empty -> mempty 56 | Comma x -> x 57 | 58 | toLazyByteString :: HStoreBuilder -> BL.ByteString 59 | toLazyByteString x = case x of 60 | Empty -> BL.empty 61 | Comma x -> BU.toLazyByteString x 62 | 63 | instance Semigroup HStoreBuilder where 64 | Empty <> x = x 65 | Comma a <> x 66 | = Comma (a `mappend` case x of 67 | Empty -> mempty 68 | Comma b -> char8 ',' `mappend` b) 69 | 70 | instance Monoid HStoreBuilder where 71 | mempty = Empty 72 | #if !(MIN_VERSION_base(4,11,0)) 73 | mappend = (<>) 74 | #endif 75 | 76 | class ToHStoreText a where 77 | toHStoreText :: a -> HStoreText 78 | 79 | -- | Represents escape text, ready to be the key or value to a hstore value 80 | newtype HStoreText = HStoreText Builder deriving (Typeable, Semigroup, Monoid) 81 | 82 | instance ToHStoreText HStoreText where 83 | toHStoreText = id 84 | 85 | -- | Assumed to be UTF-8 encoded 86 | instance ToHStoreText BS.ByteString where 87 | toHStoreText str = HStoreText (escapeAppend str mempty) 88 | 89 | -- | Assumed to be UTF-8 encoded 90 | instance ToHStoreText BL.ByteString where 91 | toHStoreText = HStoreText . BL.foldrChunks escapeAppend mempty 92 | 93 | instance ToHStoreText TS.Text where 94 | toHStoreText str = HStoreText (escapeAppend (TS.encodeUtf8 str) mempty) 95 | 96 | instance ToHStoreText TL.Text where 97 | toHStoreText = HStoreText . TL.foldrChunks (escapeAppend . TS.encodeUtf8) mempty 98 | 99 | escapeAppend :: BS.ByteString -> Builder -> Builder 100 | escapeAppend = loop 101 | where 102 | loop (BS.break quoteNeeded -> (a,b)) rest 103 | = byteString a `mappend` 104 | case BS.uncons b of 105 | Nothing -> rest 106 | Just (c,d) -> quoteChar c `mappend` loop d rest 107 | 108 | quoteNeeded c = c == c2w '\"' || c == c2w '\\' 109 | quoteChar c 110 | | c == c2w '\"' = byteString "\\\"" 111 | | otherwise = byteString "\\\\" 112 | 113 | hstore :: (ToHStoreText a, ToHStoreText b) => a -> b -> HStoreBuilder 114 | hstore (toHStoreText -> (HStoreText key)) (toHStoreText -> (HStoreText val)) = 115 | Comma (char8 '"' `mappend` key `mappend` byteString "\"=>\"" 116 | `mappend` val `mappend` char8 '"') 117 | 118 | instance ToField HStoreBuilder where 119 | toField Empty = toField (BS.empty) 120 | toField (Comma x) = toField (BU.toLazyByteString x) 121 | 122 | newtype HStoreList = HStoreList {fromHStoreList :: [(Text,Text)]} deriving (Typeable, Show) 123 | 124 | -- | hstore 125 | instance ToHStore HStoreList where 126 | toHStore (HStoreList xs) = mconcat (map (uncurry hstore) xs) 127 | 128 | instance ToField HStoreList where 129 | toField xs = toField (toHStore xs) 130 | 131 | -- | hstore 132 | instance FromField HStoreList where 133 | fromField f mdat = do 134 | typ <- typename f 135 | if typ /= "hstore" 136 | then returnError Incompatible f "" 137 | else case mdat of 138 | Nothing -> returnError UnexpectedNull f "" 139 | Just dat -> 140 | case P.parseOnly (parseHStore <* P.endOfInput) dat of 141 | Left err -> 142 | returnError ConversionFailed f err 143 | Right (Left err) -> 144 | returnError ConversionFailed f "unicode exception" <|> 145 | conversionError err 146 | Right (Right val) -> 147 | return val 148 | 149 | newtype HStoreMap = HStoreMap {fromHStoreMap :: Map Text Text} deriving (Eq, Ord, Typeable, Show) 150 | 151 | instance ToHStore HStoreMap where 152 | toHStore (HStoreMap xs) = Map.foldrWithKey f mempty xs 153 | where f k v xs = hstore k v `mappend` xs 154 | 155 | instance ToField HStoreMap where 156 | toField xs = toField (toHStore xs) 157 | 158 | instance FromField HStoreMap where 159 | fromField f mdat = convert <$> fromField f mdat 160 | where convert (HStoreList xs) = HStoreMap (Map.fromList xs) 161 | 162 | parseHStoreList :: BS.ByteString -> Either String HStoreList 163 | parseHStoreList dat = 164 | case P.parseOnly (parseHStore <* P.endOfInput) dat of 165 | Left err -> Left (show err) 166 | Right (Left err) -> Left (show err) 167 | Right (Right val) -> Right val 168 | 169 | parseHStore :: P.Parser (Either UnicodeException HStoreList) 170 | parseHStore = do 171 | kvs <- P.sepBy' (skipWhiteSpace *> parseHStoreKeyVal) 172 | (skipWhiteSpace *> P.word8 (c2w ',')) 173 | return $ HStoreList <$> sequence kvs 174 | 175 | parseHStoreKeyVal :: P.Parser (Either UnicodeException (Text,Text)) 176 | parseHStoreKeyVal = do 177 | mkey <- parseHStoreText 178 | case mkey of 179 | Left err -> return (Left err) 180 | Right key -> do 181 | skipWhiteSpace 182 | _ <- P.string "=>" 183 | skipWhiteSpace 184 | mval <- parseHStoreText 185 | case mval of 186 | Left err -> return (Left err) 187 | Right val -> return (Right (key,val)) 188 | 189 | 190 | skipWhiteSpace :: P.Parser () 191 | skipWhiteSpace = P.skipWhile P.isSpace_w8 192 | 193 | parseHStoreText :: P.Parser (Either UnicodeException Text) 194 | parseHStoreText = do 195 | _ <- P.word8 (c2w '"') 196 | mtexts <- parseHStoreTexts id 197 | case mtexts of 198 | Left err -> return (Left err) 199 | Right texts -> do 200 | _ <- P.word8 (c2w '"') 201 | return (Right (TS.concat texts)) 202 | 203 | parseHStoreTexts :: ([Text] -> [Text]) 204 | -> P.Parser (Either UnicodeException [Text]) 205 | parseHStoreTexts acc = do 206 | mchunk <- TS.decodeUtf8' <$> P.takeWhile (not . isSpecialChar) 207 | case mchunk of 208 | Left err -> return (Left err) 209 | Right chunk -> 210 | (do 211 | _ <- P.word8 (c2w '\\') 212 | c <- TS.singleton . w2c <$> P.satisfy isSpecialChar 213 | parseHStoreTexts (acc . (chunk:) . (c:)) 214 | ) <|> return (Right (acc [chunk])) 215 | where 216 | isSpecialChar c = c == c2w '\\' || c == c2w '"' 217 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/ToRow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures, FlexibleInstances, FlexibleContexts #-} 2 | ------------------------------------------------------------------------------ 3 | -- | 4 | -- Module: Database.PostgreSQL.Simple.ToRow 5 | -- Copyright: (c) 2011 MailRank, Inc. 6 | -- (c) 2011-2012 Leon P Smith 7 | -- License: BSD3 8 | -- Maintainer: Leon P Smith 9 | -- Stability: experimental 10 | -- 11 | -- The 'ToRow' typeclass, for rendering a collection of 12 | -- parameters to a SQL query. 13 | -- 14 | -- Predefined instances are provided for tuples containing up to ten 15 | -- elements. 16 | -- 17 | ------------------------------------------------------------------------------ 18 | 19 | module Database.PostgreSQL.Simple.ToRow 20 | ( 21 | ToRow(..) 22 | ) where 23 | 24 | import Database.PostgreSQL.Simple.ToField (Action(..), ToField(..)) 25 | import Database.PostgreSQL.Simple.Types (Only(..), (:.)(..)) 26 | import GHC.Generics 27 | 28 | -- | A collection type that can be turned into a list of rendering 29 | -- 'Action's. 30 | -- 31 | -- Instances should use the 'toField' method of the 'ToField' class 32 | -- to perform conversion of each element of the collection. 33 | class ToRow a where 34 | toRow :: a -> [Action] 35 | default toRow :: (Generic a, GToRow (Rep a)) => a -> [Action] 36 | toRow = gtoRow . from 37 | -- ^ ToField a collection of values. 38 | 39 | instance ToRow () where 40 | toRow _ = [] 41 | 42 | instance (ToField a) => ToRow (Only a) where 43 | toRow (Only v) = [toField v] 44 | 45 | instance (ToField a, ToField b) => ToRow (a,b) where 46 | toRow (a,b) = [toField a, toField b] 47 | 48 | instance (ToField a, ToField b, ToField c) => ToRow (a,b,c) where 49 | toRow (a,b,c) = [toField a, toField b, toField c] 50 | 51 | instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a,b,c,d) where 52 | toRow (a,b,c,d) = [toField a, toField b, toField c, toField d] 53 | 54 | instance (ToField a, ToField b, ToField c, ToField d, ToField e) 55 | => ToRow (a,b,c,d,e) where 56 | toRow (a,b,c,d,e) = 57 | [toField a, toField b, toField c, toField d, toField e] 58 | 59 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) 60 | => ToRow (a,b,c,d,e,f) where 61 | toRow (a,b,c,d,e,f) = 62 | [toField a, toField b, toField c, toField d, toField e, toField f] 63 | 64 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 65 | ToField g) 66 | => ToRow (a,b,c,d,e,f,g) where 67 | toRow (a,b,c,d,e,f,g) = 68 | [toField a, toField b, toField c, toField d, toField e, toField f, 69 | toField g] 70 | 71 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 72 | ToField g, ToField h) 73 | => ToRow (a,b,c,d,e,f,g,h) where 74 | toRow (a,b,c,d,e,f,g,h) = 75 | [toField a, toField b, toField c, toField d, toField e, toField f, 76 | toField g, toField h] 77 | 78 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 79 | ToField g, ToField h, ToField i) 80 | => ToRow (a,b,c,d,e,f,g,h,i) where 81 | toRow (a,b,c,d,e,f,g,h,i) = 82 | [toField a, toField b, toField c, toField d, toField e, toField f, 83 | toField g, toField h, toField i] 84 | 85 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 86 | ToField g, ToField h, ToField i, ToField j) 87 | => ToRow (a,b,c,d,e,f,g,h,i,j) where 88 | toRow (a,b,c,d,e,f,g,h,i,j) = 89 | [toField a, toField b, toField c, toField d, toField e, toField f, 90 | toField g, toField h, toField i, toField j] 91 | 92 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 93 | ToField g, ToField h, ToField i, ToField j, ToField k) 94 | => ToRow (a,b,c,d,e,f,g,h,i,j,k) where 95 | toRow (a,b,c,d,e,f,g,h,i,j,k) = 96 | [toField a, toField b, toField c, toField d, toField e, toField f, 97 | toField g, toField h, toField i, toField j, toField k] 98 | 99 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 100 | ToField g, ToField h, ToField i, ToField j, ToField k, ToField l) 101 | => ToRow (a,b,c,d,e,f,g,h,i,j,k,l) where 102 | toRow (a,b,c,d,e,f,g,h,i,j,k,l) = 103 | [toField a, toField b, toField c, toField d, toField e, toField f, 104 | toField g, toField h, toField i, toField j, toField k, toField l] 105 | 106 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 107 | ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, 108 | ToField m) 109 | => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m) where 110 | toRow (a,b,c,d,e,f,g,h,i,j,k,l,m) = 111 | [toField a, toField b, toField c, toField d, toField e, toField f, 112 | toField g, toField h, toField i, toField j, toField k, toField l, 113 | toField m] 114 | 115 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 116 | ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, 117 | ToField m, ToField n) 118 | => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where 119 | toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n) = 120 | [toField a, toField b, toField c, toField d, toField e, toField f, 121 | toField g, toField h, toField i, toField j, toField k, toField l, 122 | toField m, toField n] 123 | 124 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 125 | ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, 126 | ToField m, ToField n, ToField o) 127 | => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where 128 | toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) = 129 | [toField a, toField b, toField c, toField d, toField e, toField f, 130 | toField g, toField h, toField i, toField j, toField k, toField l, 131 | toField m, toField n, toField o] 132 | 133 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 134 | ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, 135 | ToField m, ToField n, ToField o, ToField p) 136 | => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where 137 | toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) = 138 | [toField a, toField b, toField c, toField d, toField e, toField f, 139 | toField g, toField h, toField i, toField j, toField k, toField l, 140 | toField m, toField n, toField o, toField p] 141 | 142 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 143 | ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, 144 | ToField m, ToField n, ToField o, ToField p, ToField q) 145 | => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where 146 | toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) = 147 | [toField a, toField b, toField c, toField d, toField e, toField f, 148 | toField g, toField h, toField i, toField j, toField k, toField l, 149 | toField m, toField n, toField o, toField p, toField q] 150 | 151 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 152 | ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, 153 | ToField m, ToField n, ToField o, ToField p, ToField q, ToField r) 154 | => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where 155 | toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) = 156 | [toField a, toField b, toField c, toField d, toField e, toField f, 157 | toField g, toField h, toField i, toField j, toField k, toField l, 158 | toField m, toField n, toField o, toField p, toField q, toField r] 159 | 160 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 161 | ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, 162 | ToField m, ToField n, ToField o, ToField p, ToField q, ToField r, 163 | ToField s) 164 | => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where 165 | toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) = 166 | [toField a, toField b, toField c, toField d, toField e, toField f, 167 | toField g, toField h, toField i, toField j, toField k, toField l, 168 | toField m, toField n, toField o, toField p, toField q, toField r, 169 | toField s] 170 | 171 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, 172 | ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, 173 | ToField m, ToField n, ToField o, ToField p, ToField q, ToField r, 174 | ToField s, ToField t) 175 | => ToRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where 176 | toRow (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) = 177 | [toField a, toField b, toField c, toField d, toField e, toField f, 178 | toField g, toField h, toField i, toField j, toField k, toField l, 179 | toField m, toField n, toField o, toField p, toField q, toField r, 180 | toField s, toField t] 181 | 182 | instance (ToField a) => ToRow [a] where 183 | toRow = map toField 184 | 185 | instance (ToRow a, ToRow b) => ToRow (a :. b) where 186 | toRow (a :. b) = toRow a ++ toRow b 187 | 188 | 189 | -- Type class for default implementation of ToRow using generics 190 | class GToRow f where 191 | gtoRow :: f p -> [Action] 192 | 193 | instance GToRow f => GToRow (M1 c i f) where 194 | gtoRow (M1 x) = gtoRow x 195 | 196 | instance (GToRow f, GToRow g) => GToRow (f :*: g) where 197 | gtoRow (f :*: g) = gtoRow f ++ gtoRow g 198 | 199 | instance (ToField a) => GToRow (K1 R a) where 200 | gtoRow (K1 a) = [toField a] 201 | 202 | instance GToRow U1 where 203 | gtoRow _ = [] 204 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Copy.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, DeriveDataTypeable #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.PostgreSQL.Simple.Copy 6 | -- Copyright: (c) 2013 Leon P Smith 7 | -- License: BSD3 8 | -- Maintainer: Leon P Smith 9 | -- Stability: experimental 10 | -- 11 | -- mid-level support for COPY IN and COPY OUT. See 12 | -- for 13 | -- more information. 14 | -- 15 | -- To use this binding, first call 'copy' with an appropriate 16 | -- query as documented in the link above. Then, in the case of a 17 | -- @COPY TO STDOUT@ query, call 'getCopyData' repeatedly until it 18 | -- returns 'CopyOutDone'. In the case of a @COPY FROM STDIN@ 19 | -- query, call 'putCopyData' repeatedly and then finish by calling 20 | -- either 'putCopyEnd' to proceed or 'putCopyError' to abort. 21 | -- 22 | -- You cannot issue another query on the same connection while a copy 23 | -- is ongoing; this will result in an exception. It is harmless to 24 | -- concurrently call @getNotification@ on a connection while it is in 25 | -- a @CopyIn@ or @CopyOut@ state, however be aware that current versions 26 | -- of the PostgreSQL backend will not deliver notifications to a client 27 | -- while a transaction is ongoing. 28 | -- 29 | ------------------------------------------------------------------------------ 30 | 31 | module Database.PostgreSQL.Simple.Copy 32 | ( copy 33 | , copy_ 34 | , CopyOutResult(..) 35 | , getCopyData 36 | , putCopyData 37 | , putCopyEnd 38 | , putCopyError 39 | ) where 40 | 41 | import Control.Applicative 42 | import Control.Concurrent 43 | import Control.Exception ( throwIO ) 44 | import qualified Data.Attoparsec.ByteString.Char8 as P 45 | import Data.Typeable(Typeable) 46 | import Data.Int(Int64) 47 | import qualified Data.ByteString.Char8 as B 48 | import qualified Database.PostgreSQL.LibPQ as PQ 49 | import Database.PostgreSQL.Simple 50 | import Database.PostgreSQL.Simple.Types 51 | import Database.PostgreSQL.Simple.Internal 52 | 53 | 54 | -- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former 55 | -- case, the connection's state will change to @CopyIn@; in the latter, 56 | -- @CopyOut@. The connection must be in the ready state in order 57 | -- to call this function. Performs parameter subsitution. 58 | 59 | copy :: ( ToRow params ) => Connection -> Query -> params -> IO () 60 | copy conn template qs = do 61 | q <- formatQuery conn template qs 62 | doCopy "Database.PostgreSQL.Simple.Copy.copy" conn template q 63 | 64 | 65 | -- | Issue a @COPY FROM STDIN@ or @COPY TO STDOUT@ query. In the former 66 | -- case, the connection's state will change to @CopyIn@; in the latter, 67 | -- @CopyOut@. The connection must be in the ready state in order 68 | -- to call this function. Does not perform parameter subsitution. 69 | 70 | copy_ :: Connection -> Query -> IO () 71 | copy_ conn (Query q) = do 72 | doCopy "Database.PostgreSQL.Simple.Copy.copy_" conn (Query q) q 73 | 74 | doCopy :: B.ByteString -> Connection -> Query -> B.ByteString -> IO () 75 | doCopy funcName conn template q = do 76 | result <- exec conn q 77 | status <- PQ.resultStatus result 78 | let errMsg msg = throwIO $ QueryError 79 | (B.unpack funcName ++ " " ++ msg) 80 | template 81 | let err = errMsg $ show status 82 | case status of 83 | PQ.EmptyQuery -> err 84 | PQ.CommandOk -> err 85 | PQ.TuplesOk -> err 86 | PQ.CopyOut -> return () 87 | PQ.CopyIn -> return () 88 | #if MIN_VERSION_postgresql_libpq(0,9,3) 89 | PQ.CopyBoth -> errMsg "COPY BOTH is not supported" 90 | #endif 91 | #if MIN_VERSION_postgresql_libpq(0,9,2) 92 | PQ.SingleTuple -> errMsg "single-row mode is not supported" 93 | #endif 94 | PQ.BadResponse -> throwResultError funcName result status 95 | PQ.NonfatalError -> throwResultError funcName result status 96 | PQ.FatalError -> throwResultError funcName result status 97 | 98 | data CopyOutResult 99 | = CopyOutRow !B.ByteString -- ^ Data representing either exactly 100 | -- one row of the result, or header 101 | -- or footer data depending on format. 102 | | CopyOutDone {-# UNPACK #-} !Int64 -- ^ No more rows, and a count of the 103 | -- number of rows returned. 104 | deriving (Eq, Typeable, Show) 105 | 106 | 107 | -- | Retrieve some data from a @COPY TO STDOUT@ query. A connection 108 | -- must be in the @CopyOut@ state in order to call this function. If this 109 | -- returns a 'CopyOutRow', the connection remains in the @CopyOut@ state, 110 | -- if it returns 'CopyOutDone', then the connection has reverted to the 111 | -- ready state. 112 | 113 | getCopyData :: Connection -> IO CopyOutResult 114 | getCopyData conn = withConnection conn loop 115 | where 116 | funcName = "Database.PostgreSQL.Simple.Copy.getCopyData" 117 | loop pqconn = do 118 | #if defined(mingw32_HOST_OS) 119 | row <- PQ.getCopyData pqconn False 120 | #else 121 | row <- PQ.getCopyData pqconn True 122 | #endif 123 | case row of 124 | PQ.CopyOutRow rowdata -> return $! CopyOutRow rowdata 125 | PQ.CopyOutDone -> CopyOutDone <$> getCopyCommandTag funcName pqconn 126 | #if defined(mingw32_HOST_OS) 127 | PQ.CopyOutWouldBlock -> do 128 | fail (B.unpack funcName ++ ": the impossible happened") 129 | #else 130 | PQ.CopyOutWouldBlock -> do 131 | mfd <- PQ.socket pqconn 132 | case mfd of 133 | Nothing -> throwIO (fdError funcName) 134 | Just fd -> do 135 | threadWaitRead fd 136 | _ <- PQ.consumeInput pqconn 137 | loop pqconn 138 | #endif 139 | PQ.CopyOutError -> do 140 | mmsg <- PQ.errorMessage pqconn 141 | throwIO SqlError { 142 | sqlState = "", 143 | sqlExecStatus = FatalError, 144 | sqlErrorMsg = maybe "" id mmsg, 145 | sqlErrorDetail = "", 146 | sqlErrorHint = funcName 147 | } 148 | 149 | 150 | -- | Feed some data to a @COPY FROM STDIN@ query. Note that 151 | -- the data does not need to represent a single row, or even an 152 | -- integral number of rows. The net result of 153 | -- @putCopyData conn a >> putCopyData conn b@ 154 | -- is the same as @putCopyData conn c@ whenever @c == BS.append a b@. 155 | -- 156 | -- A connection must be in the @CopyIn@ state in order to call this 157 | -- function, otherwise a 'SqlError' exception will result. The 158 | -- connection remains in the @CopyIn@ state after this function 159 | -- is called. 160 | 161 | putCopyData :: Connection -> B.ByteString -> IO () 162 | putCopyData conn dat = withConnection conn $ \pqconn -> do 163 | doCopyIn funcName (\c -> PQ.putCopyData c dat) pqconn 164 | where 165 | funcName = "Database.PostgreSQL.Simple.Copy.putCopyData" 166 | 167 | 168 | -- | Completes a @COPY FROM STDIN@ query. Returns the number of rows 169 | -- processed. 170 | -- 171 | -- A connection must be in the @CopyIn@ state in order to call this 172 | -- function, otherwise a 'SqlError' exception will result. The 173 | -- connection's state changes back to ready after this function 174 | -- is called. 175 | 176 | putCopyEnd :: Connection -> IO Int64 177 | putCopyEnd conn = withConnection conn $ \pqconn -> do 178 | doCopyIn funcName (\c -> PQ.putCopyEnd c Nothing) pqconn 179 | getCopyCommandTag funcName pqconn 180 | where 181 | funcName = "Database.PostgreSQL.Simple.Copy.putCopyEnd" 182 | 183 | 184 | -- | Aborts a @COPY FROM STDIN@ query. The string parameter is simply 185 | -- an arbitrary error message that may show up in the PostgreSQL 186 | -- server's log. 187 | -- 188 | -- A connection must be in the @CopyIn@ state in order to call this 189 | -- function, otherwise a 'SqlError' exception will result. The 190 | -- connection's state changes back to ready after this function 191 | -- is called. 192 | 193 | putCopyError :: Connection -> B.ByteString -> IO () 194 | putCopyError conn err = withConnection conn $ \pqconn -> do 195 | doCopyIn funcName (\c -> PQ.putCopyEnd c (Just err)) pqconn 196 | consumeResults pqconn 197 | where 198 | funcName = "Database.PostgreSQL.Simple.Copy.putCopyError" 199 | 200 | 201 | doCopyIn :: B.ByteString -> (PQ.Connection -> IO PQ.CopyInResult) 202 | -> PQ.Connection -> IO () 203 | doCopyIn funcName action = loop 204 | where 205 | loop pqconn = do 206 | stat <- action pqconn 207 | case stat of 208 | PQ.CopyInOk -> return () 209 | PQ.CopyInError -> do 210 | mmsg <- PQ.errorMessage pqconn 211 | throwIO SqlError { 212 | sqlState = "", 213 | sqlExecStatus = FatalError, 214 | sqlErrorMsg = maybe "" id mmsg, 215 | sqlErrorDetail = "", 216 | sqlErrorHint = funcName 217 | } 218 | PQ.CopyInWouldBlock -> do 219 | mfd <- PQ.socket pqconn 220 | case mfd of 221 | Nothing -> throwIO (fdError funcName) 222 | Just fd -> do 223 | threadWaitWrite fd 224 | loop pqconn 225 | {-# INLINE doCopyIn #-} 226 | 227 | getCopyCommandTag :: B.ByteString -> PQ.Connection -> IO Int64 228 | getCopyCommandTag funcName pqconn = do 229 | result <- maybe (fail errCmdStatus) return =<< PQ.getResult pqconn 230 | cmdStat <- maybe (fail errCmdStatus) return =<< PQ.cmdStatus result 231 | consumeResults pqconn 232 | let rowCount = P.string "COPY " *> (P.decimal <* P.endOfInput) 233 | case P.parseOnly rowCount cmdStat of 234 | Left _ -> do mmsg <- PQ.errorMessage pqconn 235 | fail $ errCmdStatusFmt 236 | ++ maybe "" (\msg -> "\nConnection error: "++B.unpack msg) mmsg 237 | Right n -> return $! n 238 | where 239 | errCmdStatus = B.unpack funcName ++ ": failed to fetch command status" 240 | errCmdStatusFmt = B.unpack funcName ++ ": failed to parse command status" 241 | 242 | 243 | consumeResults :: PQ.Connection -> IO () 244 | consumeResults pqconn = do 245 | mres <- PQ.getResult pqconn 246 | case mres of 247 | Nothing -> return () 248 | Just _ -> consumeResults pqconn 249 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Transaction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.PostgreSQL.Simple.Transaction 6 | -- Copyright: (c) 2011-2013 Leon P Smith 7 | -- (c) 2013 Joey Adams 8 | -- License: BSD3 9 | -- Maintainer: Leon P Smith 10 | -- 11 | ------------------------------------------------------------------------------ 12 | 13 | module Database.PostgreSQL.Simple.Transaction 14 | ( 15 | -- * Transaction handling 16 | withTransaction 17 | , withTransactionLevel 18 | , withTransactionMode 19 | , withTransactionModeRetry 20 | , withTransactionSerializable 21 | , TransactionMode(..) 22 | , IsolationLevel(..) 23 | , ReadWriteMode(..) 24 | , defaultTransactionMode 25 | , defaultIsolationLevel 26 | , defaultReadWriteMode 27 | -- , Base.autocommit 28 | , begin 29 | , beginLevel 30 | , beginMode 31 | , commit 32 | , rollback 33 | 34 | -- * Savepoint 35 | , withSavepoint 36 | , Savepoint 37 | , newSavepoint 38 | , releaseSavepoint 39 | , rollbackToSavepoint 40 | , rollbackToAndReleaseSavepoint 41 | 42 | -- * Error predicates 43 | , isSerializationError 44 | , isNoActiveTransactionError 45 | , isFailedTransactionError 46 | ) where 47 | 48 | import qualified Control.Exception as E 49 | import qualified Data.ByteString as B 50 | import Database.PostgreSQL.Simple.Internal 51 | import Database.PostgreSQL.Simple.Types 52 | import Database.PostgreSQL.Simple.Errors 53 | import Database.PostgreSQL.Simple.Compat (mask, (<>)) 54 | 55 | 56 | -- | Of the four isolation levels defined by the SQL standard, 57 | -- these are the three levels distinguished by PostgreSQL as of version 9.0. 58 | -- See 59 | -- for more information. Note that prior to PostgreSQL 9.0, 'RepeatableRead' 60 | -- was equivalent to 'Serializable'. 61 | 62 | data IsolationLevel 63 | = DefaultIsolationLevel -- ^ the isolation level will be taken from 64 | -- PostgreSQL's per-connection 65 | -- @default_transaction_isolation@ variable, 66 | -- which is initialized according to the 67 | -- server's config. The default configuration 68 | -- is 'ReadCommitted'. 69 | | ReadCommitted 70 | | RepeatableRead 71 | | Serializable 72 | deriving (Show, Eq, Ord, Enum, Bounded) 73 | 74 | data ReadWriteMode 75 | = DefaultReadWriteMode -- ^ the read-write mode will be taken from 76 | -- PostgreSQL's per-connection 77 | -- @default_transaction_read_only@ variable, 78 | -- which is initialized according to the 79 | -- server's config. The default configuration 80 | -- is 'ReadWrite'. 81 | | ReadWrite 82 | | ReadOnly 83 | deriving (Show, Eq, Ord, Enum, Bounded) 84 | 85 | data TransactionMode = TransactionMode { 86 | isolationLevel :: !IsolationLevel, 87 | readWriteMode :: !ReadWriteMode 88 | } deriving (Show, Eq) 89 | 90 | defaultTransactionMode :: TransactionMode 91 | defaultTransactionMode = TransactionMode 92 | defaultIsolationLevel 93 | defaultReadWriteMode 94 | 95 | defaultIsolationLevel :: IsolationLevel 96 | defaultIsolationLevel = DefaultIsolationLevel 97 | 98 | defaultReadWriteMode :: ReadWriteMode 99 | defaultReadWriteMode = DefaultReadWriteMode 100 | 101 | -- | Execute an action inside a SQL transaction. 102 | -- 103 | -- This function initiates a transaction with a \"@begin 104 | -- transaction@\" statement, then executes the supplied action. If 105 | -- the action succeeds, the transaction will be completed with 106 | -- 'Base.commit' before this function returns. 107 | -- 108 | -- If the action throws /any/ kind of exception (not just a 109 | -- PostgreSQL-related exception), the transaction will be rolled back using 110 | -- 'rollback', then the exception will be rethrown. 111 | -- 112 | -- For nesting transactions, see 'withSavepoint'. 113 | withTransaction :: Connection -> IO a -> IO a 114 | withTransaction = withTransactionMode defaultTransactionMode 115 | 116 | -- | Execute an action inside of a 'Serializable' transaction. If a 117 | -- serialization failure occurs, roll back the transaction and try again. 118 | -- Be warned that this may execute the IO action multiple times. 119 | -- 120 | -- A 'Serializable' transaction creates the illusion that your program has 121 | -- exclusive access to the database. This means that, even in a concurrent 122 | -- setting, you can perform queries in sequence without having to worry about 123 | -- what might happen between one statement and the next. 124 | -- 125 | -- Think of it as STM, but without @retry@. 126 | withTransactionSerializable :: Connection -> IO a -> IO a 127 | withTransactionSerializable = 128 | withTransactionModeRetry 129 | TransactionMode 130 | { isolationLevel = Serializable 131 | , readWriteMode = ReadWrite 132 | } 133 | isSerializationError 134 | 135 | -- | Execute an action inside a SQL transaction with a given isolation level. 136 | withTransactionLevel :: IsolationLevel -> Connection -> IO a -> IO a 137 | withTransactionLevel lvl 138 | = withTransactionMode defaultTransactionMode { isolationLevel = lvl } 139 | 140 | -- | Execute an action inside a SQL transaction with a given transaction mode. 141 | withTransactionMode :: TransactionMode -> Connection -> IO a -> IO a 142 | withTransactionMode mode conn act = 143 | mask $ \restore -> do 144 | beginMode mode conn 145 | r <- restore act `E.onException` rollback_ conn 146 | commit conn 147 | return r 148 | 149 | -- | Like 'withTransactionMode', but also takes a custom callback to 150 | -- determine if a transaction should be retried if an 'SqlError' occurs. 151 | -- If the callback returns True, then the transaction will be retried. 152 | -- If the callback returns False, or an exception other than an 'SqlError' 153 | -- occurs then the transaction will be rolled back and the exception rethrown. 154 | -- 155 | -- This is used to implement 'withTransactionSerializable'. 156 | withTransactionModeRetry :: TransactionMode -> (SqlError -> Bool) -> Connection -> IO a -> IO a 157 | withTransactionModeRetry mode shouldRetry conn act = 158 | mask $ \restore -> 159 | retryLoop $ E.try $ do 160 | a <- restore act 161 | commit conn 162 | return a 163 | where 164 | retryLoop :: IO (Either E.SomeException a) -> IO a 165 | retryLoop act' = do 166 | beginMode mode conn 167 | r <- act' 168 | case r of 169 | Left e -> do 170 | rollback_ conn 171 | case fmap shouldRetry (E.fromException e) of 172 | Just True -> retryLoop act' 173 | _ -> E.throwIO e 174 | Right a -> 175 | return a 176 | 177 | -- | Rollback a transaction. 178 | rollback :: Connection -> IO () 179 | rollback conn = execute_ conn "ROLLBACK" >> return () 180 | 181 | -- | Rollback a transaction, ignoring any @IOErrors@ 182 | rollback_ :: Connection -> IO () 183 | rollback_ conn = rollback conn `E.catch` \(_ :: IOError) -> return () 184 | 185 | -- | Commit a transaction. 186 | commit :: Connection -> IO () 187 | commit conn = execute_ conn "COMMIT" >> return () 188 | 189 | -- | Begin a transaction. 190 | begin :: Connection -> IO () 191 | begin = beginMode defaultTransactionMode 192 | 193 | -- | Begin a transaction with a given isolation level 194 | beginLevel :: IsolationLevel -> Connection -> IO () 195 | beginLevel lvl = beginMode defaultTransactionMode { isolationLevel = lvl } 196 | 197 | -- | Begin a transaction with a given transaction mode 198 | beginMode :: TransactionMode -> Connection -> IO () 199 | beginMode mode conn = do 200 | _ <- execute_ conn $! Query (B.concat ["BEGIN", isolevel, readmode]) 201 | return () 202 | where 203 | isolevel = case isolationLevel mode of 204 | DefaultIsolationLevel -> "" 205 | ReadCommitted -> " ISOLATION LEVEL READ COMMITTED" 206 | RepeatableRead -> " ISOLATION LEVEL REPEATABLE READ" 207 | Serializable -> " ISOLATION LEVEL SERIALIZABLE" 208 | readmode = case readWriteMode mode of 209 | DefaultReadWriteMode -> "" 210 | ReadWrite -> " READ WRITE" 211 | ReadOnly -> " READ ONLY" 212 | 213 | ------------------------------------------------------------------------ 214 | -- Savepoint 215 | 216 | -- | Create a savepoint, and roll back to it if an error occurs. This may only 217 | -- be used inside of a transaction, and provides a sort of 218 | -- \"nested transaction\". 219 | -- 220 | -- See 221 | withSavepoint :: Connection -> IO a -> IO a 222 | withSavepoint conn body = 223 | mask $ \restore -> do 224 | sp <- newSavepoint conn 225 | r <- restore body `E.onException` rollbackToAndReleaseSavepoint conn sp 226 | releaseSavepoint conn sp `E.catch` \err -> 227 | if isFailedTransactionError err 228 | then rollbackToAndReleaseSavepoint conn sp 229 | else E.throwIO err 230 | return r 231 | 232 | -- | Create a new savepoint. This may only be used inside of a transaction. 233 | newSavepoint :: Connection -> IO Savepoint 234 | newSavepoint conn = do 235 | name <- newTempName conn 236 | _ <- execute_ conn ("SAVEPOINT " <> name) 237 | return (Savepoint name) 238 | 239 | -- | Destroy a savepoint, but retain its effects. 240 | -- 241 | -- Warning: this will throw a 'SqlError' matching 'isFailedTransactionError' if 242 | -- the transaction is aborted due to an error. 'commit' would merely warn and 243 | -- roll back. 244 | releaseSavepoint :: Connection -> Savepoint -> IO () 245 | releaseSavepoint conn (Savepoint name) = 246 | execute_ conn ("RELEASE SAVEPOINT " <> name) >> return () 247 | 248 | -- | Roll back to a savepoint. This will not release the savepoint. 249 | rollbackToSavepoint :: Connection -> Savepoint -> IO () 250 | rollbackToSavepoint conn (Savepoint name) = 251 | execute_ conn ("ROLLBACK TO SAVEPOINT " <> name) >> return () 252 | 253 | -- | Roll back to a savepoint and release it. This is like calling 254 | -- 'rollbackToSavepoint' followed by 'releaseSavepoint', but avoids a 255 | -- round trip to the database server. 256 | rollbackToAndReleaseSavepoint :: Connection -> Savepoint -> IO () 257 | rollbackToAndReleaseSavepoint conn (Savepoint name) = 258 | execute_ conn sql >> return () 259 | where 260 | sql = "ROLLBACK TO SAVEPOINT " <> name <> "; RELEASE SAVEPOINT " <> name 261 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-} 2 | 3 | ------------------------------------------------------------------------------ 4 | -- | 5 | -- Module: Database.PostgreSQL.Simple.Types 6 | -- Copyright: (c) 2011 MailRank, Inc. 7 | -- (c) 2011-2012 Leon P Smith 8 | -- License: BSD3 9 | -- Maintainer: Leon P Smith 10 | -- Stability: experimental 11 | -- 12 | -- Basic types. 13 | -- 14 | ------------------------------------------------------------------------------ 15 | 16 | module Database.PostgreSQL.Simple.Types 17 | ( 18 | Null(..) 19 | , Default(..) 20 | , Only(..) 21 | , In(..) 22 | , Binary(..) 23 | , Identifier(..) 24 | , QualifiedIdentifier(..) 25 | , Query(..) 26 | , Oid(..) 27 | , (:.)(..) 28 | , Savepoint(..) 29 | , PGArray(..) 30 | , Values(..) 31 | ) where 32 | 33 | import Control.Arrow (first) 34 | import Data.ByteString (ByteString) 35 | import Data.Hashable (Hashable(hashWithSalt)) 36 | import Data.Foldable (toList) 37 | import Data.Monoid (Monoid(..)) 38 | import Data.Semigroup 39 | import Data.String (IsString(..)) 40 | import Data.Typeable (Typeable) 41 | import Data.ByteString.Builder ( stringUtf8 ) 42 | import qualified Data.ByteString as B 43 | import Data.Text (Text) 44 | import qualified Data.Text as T 45 | import Data.Tuple.Only (Only(..)) 46 | import Database.PostgreSQL.LibPQ (Oid(..)) 47 | import Database.PostgreSQL.Simple.Compat (toByteString) 48 | 49 | -- | A placeholder for the SQL @NULL@ value. 50 | data Null = Null 51 | deriving (Read, Show, Typeable) 52 | 53 | instance Eq Null where 54 | _ == _ = False 55 | _ /= _ = False 56 | 57 | -- | A placeholder for the PostgreSQL @DEFAULT@ value. 58 | data Default = Default 59 | deriving (Read, Show, Typeable) 60 | 61 | -- | A query string. This type is intended to make it difficult to 62 | -- construct a SQL query by concatenating string fragments, as that is 63 | -- an extremely common way to accidentally introduce SQL injection 64 | -- vulnerabilities into an application. 65 | -- 66 | -- This type is an instance of 'IsString', so the easiest way to 67 | -- construct a query is to enable the @OverloadedStrings@ language 68 | -- extension and then simply write the query in double quotes. 69 | -- 70 | -- > {-# LANGUAGE OverloadedStrings #-} 71 | -- > 72 | -- > import Database.PostgreSQL.Simple 73 | -- > 74 | -- > q :: Query 75 | -- > q = "select ?" 76 | -- 77 | -- The underlying type is a 'ByteString', and literal Haskell strings 78 | -- that contain Unicode characters will be correctly transformed to 79 | -- UTF-8. 80 | newtype Query = Query { 81 | fromQuery :: ByteString 82 | } deriving (Eq, Ord, Typeable) 83 | 84 | instance Show Query where 85 | show = show . fromQuery 86 | 87 | instance Read Query where 88 | readsPrec i = fmap (first Query) . readsPrec i 89 | 90 | instance IsString Query where 91 | fromString = Query . toByteString . stringUtf8 92 | 93 | instance Semigroup Query where 94 | Query a <> Query b = Query (B.append a b) 95 | {-# INLINE (<>) #-} 96 | sconcat xs = Query (B.concat $ map fromQuery $ toList xs) 97 | 98 | instance Monoid Query where 99 | mempty = Query B.empty 100 | #if !(MIN_VERSION_base(4,11,0)) 101 | mappend = (<>) 102 | #endif 103 | 104 | -- | Wrap a list of values for use in an @IN@ clause. Replaces a 105 | -- single \"@?@\" character with a parenthesized list of rendered 106 | -- values. 107 | -- 108 | -- Example: 109 | -- 110 | -- > query c "select * from whatever where id in ?" (Only (In [3,4,5])) 111 | -- 112 | -- Note that @In []@ expands to @(null)@, which works as expected in 113 | -- the query above, but evaluates to the logical null value on every 114 | -- row instead of @TRUE@. This means that changing the query above 115 | -- to @... id NOT in ?@ and supplying the empty list as the parameter 116 | -- returns zero rows, instead of all of them as one would expect. 117 | -- 118 | -- Since postgresql doesn't seem to provide a syntax for actually specifying 119 | -- an empty list, which could solve this completely, there are two 120 | -- workarounds particularly worth mentioning, namely: 121 | -- 122 | -- 1. Use postgresql-simple's 'Values' type instead, which can handle the 123 | -- empty case correctly. Note however that while specifying the 124 | -- postgresql type @"int4"@ is mandatory in the empty case, specifying 125 | -- the haskell type @Values (Only Int)@ would not normally be needed in 126 | -- realistic use cases. 127 | -- 128 | -- > query c "select * from whatever where id not in ?" 129 | -- > (Only (Values ["int4"] [] :: Values (Only Int))) 130 | -- 131 | -- 132 | -- 2. Use sql's @COALESCE@ operator to turn a logical @null@ into the correct 133 | -- boolean. Note however that the correct boolean depends on the use 134 | -- case: 135 | -- 136 | -- > query c "select * from whatever where coalesce(id NOT in ?, TRUE)" 137 | -- > (Only (In [] :: In [Int])) 138 | -- 139 | -- > query c "select * from whatever where coalesce(id IN ?, FALSE)" 140 | -- > (Only (In [] :: In [Int])) 141 | -- 142 | -- Note that at as of PostgreSQL 9.4, the query planner cannot see inside 143 | -- the @COALESCE@ operator, so if you have an index on @id@ then you 144 | -- probably don't want to write the last example with @COALESCE@, which 145 | -- would result in a table scan. There are further caveats if @id@ can 146 | -- be null or you want null treated sensibly as a component of @IN@ or 147 | -- @NOT IN@. 148 | 149 | newtype In a = In a 150 | deriving (Eq, Ord, Read, Show, Typeable, Functor) 151 | 152 | -- | Wrap binary data for use as a @bytea@ value. 153 | newtype Binary a = Binary {fromBinary :: a} 154 | deriving (Eq, Ord, Read, Show, Typeable, Functor) 155 | 156 | -- | Wrap text for use as sql identifier, i.e. a table or column name. 157 | newtype Identifier = Identifier {fromIdentifier :: Text} 158 | deriving (Eq, Ord, Read, Show, Typeable, IsString) 159 | 160 | instance Hashable Identifier where 161 | hashWithSalt i (Identifier t) = hashWithSalt i t 162 | 163 | -- | Wrap text for use as (maybe) qualified identifier, i.e. a table 164 | -- with schema, or column with table. 165 | data QualifiedIdentifier = QualifiedIdentifier (Maybe Text) Text 166 | deriving (Eq, Ord, Read, Show, Typeable) 167 | 168 | instance Hashable QualifiedIdentifier where 169 | hashWithSalt i (QualifiedIdentifier q t) = hashWithSalt i (q, t) 170 | 171 | -- | @\"foo.bar\"@ will get turned into 172 | -- @QualifiedIdentifier (Just \"foo\") \"bar\"@, while @\"foo\"@ will get 173 | -- turned into @QualifiedIdentifier Nothing \"foo\"@. Note this instance 174 | -- is for convenience, and does not match postgres syntax. It 175 | -- only examines the first period character, and thus cannot be used if the 176 | -- qualifying identifier contains a period for example. 177 | 178 | instance IsString QualifiedIdentifier where 179 | fromString str = let (x,y) = T.break (== '.') (fromString str) 180 | in if T.null y 181 | then QualifiedIdentifier Nothing x 182 | else QualifiedIdentifier (Just x) (T.tail y) 183 | 184 | -- | Wrap a list for use as a PostgreSQL array. 185 | newtype PGArray a = PGArray {fromPGArray :: [a]} 186 | deriving (Eq, Ord, Read, Show, Typeable, Functor) 187 | 188 | -- | A composite type to parse your custom data structures without 189 | -- having to define dummy newtype wrappers every time. 190 | -- 191 | -- 192 | -- > instance FromRow MyData where ... 193 | -- 194 | -- > instance FromRow MyData2 where ... 195 | -- 196 | -- 197 | -- then I can do the following for free: 198 | -- 199 | -- @ 200 | -- res <- query' c "..." 201 | -- forM res $ \\(MyData{..} :. MyData2{..}) -> do 202 | -- .... 203 | -- @ 204 | data h :. t = h :. t deriving (Eq,Ord,Show,Read,Typeable) 205 | 206 | infixr 3 :. 207 | 208 | newtype Savepoint = Savepoint Query 209 | deriving (Eq, Ord, Show, Read, Typeable) 210 | 211 | -- | Represents a @VALUES@ table literal, usable as an alternative to 212 | -- 'Database.PostgreSQL.Simple.executeMany' and 213 | -- 'Database.PostgreSQL.Simple.returning'. The main advantage is that 214 | -- you can parametrize more than just a single @VALUES@ expression. 215 | -- For example, here's a query to insert a thing into one table 216 | -- and some attributes of that thing into another, returning the 217 | -- new id generated by the database: 218 | -- 219 | -- 220 | -- > query c [sql| 221 | -- > WITH new_thing AS ( 222 | -- > INSERT INTO thing (name) VALUES (?) RETURNING id 223 | -- > ), new_attributes AS ( 224 | -- > INSERT INTO thing_attributes 225 | -- > SELECT new_thing.id, attrs.* 226 | -- > FROM new_thing JOIN ? attrs ON TRUE 227 | -- > ) SELECT * FROM new_thing 228 | -- > |] ("foo", Values [ "int4", "text" ] 229 | -- > [ ( 1 , "hello" ) 230 | -- > , ( 2 , "world" ) ]) 231 | -- 232 | -- (Note this example uses writable common table expressions, 233 | -- which were added in PostgreSQL 9.1) 234 | -- 235 | -- The second parameter gets expanded into the following SQL syntax: 236 | -- 237 | -- > (VALUES (1::"int4",'hello'::"text"),(2,'world')) 238 | -- 239 | -- When the list of attributes is empty, the second parameter expands to: 240 | -- 241 | -- > (VALUES (null::"int4",null::"text") LIMIT 0) 242 | -- 243 | -- By contrast, @executeMany@ and @returning@ don't issue the query 244 | -- in the empty case, and simply return @0@ and @[]@ respectively. 245 | -- This behavior is usually correct given their intended use cases, 246 | -- but would certainly be wrong in the example above. 247 | -- 248 | -- The first argument is a list of postgresql type names. Because this 249 | -- is turned into a properly quoted identifier, the type name is case 250 | -- sensitive and must be as it appears in the @pg_type@ table. Thus, 251 | -- you must write @timestamptz@ instead of @timestamp with time zone@, 252 | -- @int4@ instead of @integer@ or @serial@, @_int8@ instead of @bigint[]@, 253 | -- etcetera. 254 | -- 255 | -- You may omit the type names, however, if you do so the list 256 | -- of values must be non-empty, and postgresql must be able to infer 257 | -- the types of the columns from the surrounding context. If the first 258 | -- condition is not met, postgresql-simple will throw an exception 259 | -- without issuing the query. In the second case, the postgres server 260 | -- will return an error which will be turned into a @SqlError@ exception. 261 | -- 262 | -- See for 263 | -- more information. 264 | data Values a = Values [QualifiedIdentifier] [a] 265 | deriving (Eq, Ord, Show, Read, Typeable) 266 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Range.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | 6 | ------------------------------------------------------------------------------ 7 | -- | 8 | -- Module: Database.PostgreSQL.Simple.Range 9 | -- Copyright: (c) 2014-2015 Leonid Onokhov 10 | -- (c) 2014-2015 Leon P Smith 11 | -- License: BSD3 12 | -- Maintainer: Leon P Smith 13 | -- 14 | ------------------------------------------------------------------------------ 15 | 16 | module Database.PostgreSQL.Simple.Range 17 | ( RangeBound(..) 18 | , PGRange(..) 19 | , empty 20 | , isEmpty, isEmptyBy 21 | , contains, containsBy 22 | , fromFieldRange 23 | ) where 24 | 25 | import Control.Applicative hiding (empty) 26 | import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly) 27 | import qualified Data.Attoparsec.ByteString.Char8 as A 28 | import qualified Data.ByteString as B 29 | import Data.ByteString.Builder 30 | ( Builder, byteString, lazyByteString, char8 31 | , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec 32 | , wordDec, word8Dec, word16Dec, word32Dec, word64Dec 33 | , doubleDec, floatDec ) 34 | import Data.Int (Int16, Int32, Int64, 35 | Int8) 36 | import Data.Function (on) 37 | import Data.Monoid (mempty) 38 | import Data.Scientific (Scientific) 39 | import qualified Data.Text.Lazy.Builder as LT 40 | import qualified Data.Text.Lazy.Encoding as LT 41 | import Data.Time (Day, LocalTime, 42 | NominalDiffTime, 43 | TimeOfDay, UTCTime, 44 | ZonedTime, 45 | zonedTimeToUTC) 46 | import Data.Typeable (Typeable) 47 | import Data.Word (Word, Word16, Word32, 48 | Word64, Word8) 49 | 50 | import Database.PostgreSQL.Simple.Compat (scientificBuilder, (<>), toByteString) 51 | import Database.PostgreSQL.Simple.FromField 52 | import Database.PostgreSQL.Simple.Time 53 | hiding (PosInfinity, NegInfinity) 54 | -- import qualified Database.PostgreSQL.Simple.Time as Time 55 | import Database.PostgreSQL.Simple.ToField 56 | 57 | -- | Represents boundary of a range 58 | data RangeBound a = NegInfinity 59 | | Inclusive !a 60 | | Exclusive !a 61 | | PosInfinity 62 | deriving (Show, Typeable, Eq, Functor) 63 | 64 | -- | Generic range type 65 | data PGRange a = PGRange !(RangeBound a) !(RangeBound a) 66 | deriving (Show, Typeable, Functor) 67 | 68 | empty :: PGRange a 69 | empty = PGRange PosInfinity NegInfinity 70 | 71 | instance Ord a => Eq (PGRange a) where 72 | x == y = eq x y || (isEmpty x && isEmpty y) 73 | where eq (PGRange a m) (PGRange b n) = a == b && m == n 74 | 75 | isEmptyBy :: (a -> a -> Ordering) -> PGRange a -> Bool 76 | isEmptyBy cmp v = 77 | case v of 78 | (PGRange PosInfinity _) -> True 79 | (PGRange _ NegInfinity) -> True 80 | (PGRange NegInfinity _) -> False 81 | (PGRange _ PosInfinity) -> False 82 | (PGRange (Inclusive x) (Inclusive y)) -> cmp x y == GT 83 | (PGRange (Inclusive x) (Exclusive y)) -> cmp x y /= LT 84 | (PGRange (Exclusive x) (Inclusive y)) -> cmp x y /= LT 85 | (PGRange (Exclusive x) (Exclusive y)) -> cmp x y /= LT 86 | 87 | -- | Is a range empty? If this returns 'True', then the 'contains' 88 | -- predicate will always return 'False'. However, if this returns 89 | -- 'False', it is not necessarily true that there exists a point for 90 | -- which 'contains' returns 'True'. 91 | -- Consider @'PGRange' ('Excludes' 2) ('Excludes' 3) :: PGRange Int@, 92 | -- for example. 93 | isEmpty :: Ord a => PGRange a -> Bool 94 | isEmpty = isEmptyBy compare 95 | 96 | 97 | -- | Does a range contain a given point? Note that in some cases, this may 98 | -- not correspond exactly with a server-side computation. Consider @UTCTime@ 99 | -- for example, which has a resolution of a picosecond, whereas postgresql's 100 | -- @timestamptz@ types have a resolution of a microsecond. Putting such 101 | -- Haskell values into the database will result in them being rounded, which 102 | -- can change the value of the containment predicate. 103 | 104 | contains :: Ord a => PGRange a -> (a -> Bool) 105 | contains = containsBy compare 106 | 107 | containsBy :: (a -> a -> Ordering) -> PGRange a -> (a -> Bool) 108 | containsBy cmp rng x = 109 | case rng of 110 | PGRange _lb NegInfinity -> False 111 | PGRange lb ub -> checkLB lb x && checkUB ub x 112 | where 113 | checkLB lb x = 114 | case lb of 115 | NegInfinity -> True 116 | PosInfinity -> False 117 | Inclusive a -> cmp a x /= GT 118 | Exclusive a -> cmp a x == LT 119 | 120 | checkUB ub x = 121 | case ub of 122 | NegInfinity -> False 123 | PosInfinity -> True 124 | Inclusive z -> cmp x z /= GT 125 | Exclusive z -> cmp x z == LT 126 | 127 | lowerBound :: Parser (a -> RangeBound a) 128 | lowerBound = (A.char '(' *> pure Exclusive) <|> (A.char '[' *> pure Inclusive) 129 | {-# INLINE lowerBound #-} 130 | 131 | upperBound :: Parser (a -> RangeBound a) 132 | upperBound = (A.char ')' *> pure Exclusive) <|> (A.char ']' *> pure Inclusive) 133 | {-# INLINE upperBound #-} 134 | 135 | -- | Generic range parser 136 | pgrange :: Parser (RangeBound B.ByteString, RangeBound B.ByteString) 137 | pgrange = do 138 | lb <- lowerBound 139 | v1 <- (A.char ',' *> "") <|> (rangeElem (==',') <* A.char ',') 140 | v2 <- rangeElem $ \c -> c == ')' || c == ']' 141 | ub <- upperBound 142 | A.endOfInput 143 | let low = if B.null v1 then NegInfinity else lb v1 144 | up = if B.null v2 then PosInfinity else ub v2 145 | return (low, up) 146 | 147 | rangeElem :: (Char -> Bool) -> Parser B.ByteString 148 | rangeElem end = (A.char '"' *> doubleQuoted) 149 | <|> A.takeTill end 150 | {-# INLINE rangeElem #-} 151 | 152 | -- | Simple double quoted value parser 153 | doubleQuoted :: Parser B.ByteString 154 | doubleQuoted = toByteString <$> go mempty 155 | where 156 | go acc = do 157 | h <- byteString <$> A.takeTill (\c -> c == '\\' || c == '"') 158 | let rest = do 159 | start <- A.anyChar 160 | case start of 161 | '\\' -> do 162 | c <- A.anyChar 163 | go (acc <> h <> char8 c) 164 | '"' -> (A.char '"' *> go (acc <> h <> char8 '"')) 165 | <|> pure (acc <> h) 166 | _ -> error "impossible in doubleQuoted" 167 | rest 168 | 169 | rangeToBuilder :: Ord a => (a -> Builder) -> PGRange a -> Builder 170 | rangeToBuilder = rangeToBuilderBy compare 171 | 172 | -- | Generic range to builder for plain values 173 | rangeToBuilderBy :: (a -> a -> Ordering) -> (a -> Builder) -> PGRange a -> Builder 174 | rangeToBuilderBy cmp f x = 175 | if isEmptyBy cmp x 176 | then byteString "'empty'" 177 | else let (PGRange a b) = x 178 | in buildLB a <> buildUB b 179 | where 180 | buildLB NegInfinity = byteString "'[," 181 | buildLB (Inclusive v) = byteString "'[\"" <> f v <> byteString "\"," 182 | buildLB (Exclusive v) = byteString "'(\"" <> f v <> byteString "\"," 183 | buildLB PosInfinity = error "impossible in rangeToBuilder" 184 | 185 | buildUB NegInfinity = error "impossible in rangeToBuilder" 186 | buildUB (Inclusive v) = char8 '"' <> f v <> byteString "\"]'" 187 | buildUB (Exclusive v) = char8 '"' <> f v <> byteString "\")'" 188 | buildUB PosInfinity = byteString "]'" 189 | {-# INLINE rangeToBuilder #-} 190 | 191 | 192 | instance (FromField a, Typeable a) => FromField (PGRange a) where 193 | fromField = fromFieldRange fromField 194 | 195 | fromFieldRange :: Typeable a => FieldParser a -> FieldParser (PGRange a) 196 | fromFieldRange fromField' f mdat = do 197 | info <- typeInfo f 198 | case info of 199 | Range{} -> 200 | let f' = f { typeOid = typoid (rngsubtype info) } 201 | in case mdat of 202 | Nothing -> returnError UnexpectedNull f "" 203 | Just "empty" -> pure $ empty 204 | Just bs -> 205 | let parseIt NegInfinity = pure NegInfinity 206 | parseIt (Inclusive v) = Inclusive <$> fromField' f' (Just v) 207 | parseIt (Exclusive v) = Exclusive <$> fromField' f' (Just v) 208 | parseIt PosInfinity = pure PosInfinity 209 | in case parseOnly pgrange bs of 210 | Left e -> returnError ConversionFailed f e 211 | Right (lb,ub) -> PGRange <$> parseIt lb <*> parseIt ub 212 | _ -> returnError Incompatible f "" 213 | 214 | 215 | instance ToField (PGRange Int8) where 216 | toField = Plain . rangeToBuilder int8Dec 217 | {-# INLINE toField #-} 218 | 219 | instance ToField (PGRange Int16) where 220 | toField = Plain . rangeToBuilder int16Dec 221 | {-# INLINE toField #-} 222 | 223 | instance ToField (PGRange Int32) where 224 | toField = Plain . rangeToBuilder int32Dec 225 | {-# INLINE toField #-} 226 | 227 | instance ToField (PGRange Int) where 228 | toField = Plain . rangeToBuilder intDec 229 | {-# INLINE toField #-} 230 | 231 | instance ToField (PGRange Int64) where 232 | toField = Plain . rangeToBuilder int64Dec 233 | {-# INLINE toField #-} 234 | 235 | instance ToField (PGRange Integer) where 236 | toField = Plain . rangeToBuilder integerDec 237 | {-# INLINE toField #-} 238 | 239 | instance ToField (PGRange Word8) where 240 | toField = Plain . rangeToBuilder word8Dec 241 | {-# INLINE toField #-} 242 | 243 | instance ToField (PGRange Word16) where 244 | toField = Plain . rangeToBuilder word16Dec 245 | {-# INLINE toField #-} 246 | 247 | instance ToField (PGRange Word32) where 248 | toField = Plain . rangeToBuilder word32Dec 249 | {-# INLINE toField #-} 250 | 251 | instance ToField (PGRange Word) where 252 | toField = Plain . rangeToBuilder wordDec 253 | {-# INLINE toField #-} 254 | 255 | instance ToField (PGRange Word64) where 256 | toField = Plain . rangeToBuilder word64Dec 257 | {-# INLINE toField #-} 258 | 259 | instance ToField (PGRange Float) where 260 | toField = Plain . rangeToBuilder floatDec 261 | {-# INLINE toField #-} 262 | 263 | instance ToField (PGRange Double) where 264 | toField = Plain . rangeToBuilder doubleDec 265 | {-# INLINE toField #-} 266 | 267 | instance ToField (PGRange Scientific) where 268 | toField = Plain . rangeToBuilder f 269 | where 270 | f = lazyByteString . LT.encodeUtf8 . LT.toLazyText . scientificBuilder 271 | {-# INLINE toField #-} 272 | 273 | instance ToField (PGRange UTCTime) where 274 | toField = Plain . rangeToBuilder utcTimeToBuilder 275 | {-# INLINE toField #-} 276 | 277 | instance ToField (PGRange ZonedTime) where 278 | toField = Plain . rangeToBuilderBy cmpZonedTime zonedTimeToBuilder 279 | {-# INLINE toField #-} 280 | 281 | cmpZonedTime :: ZonedTime -> ZonedTime -> Ordering 282 | cmpZonedTime = compare `on` zonedTimeToUTC -- FIXME: optimize 283 | 284 | instance ToField (PGRange LocalTime) where 285 | toField = Plain . rangeToBuilder localTimeToBuilder 286 | {-# INLINE toField #-} 287 | 288 | instance ToField (PGRange Day) where 289 | toField = Plain . rangeToBuilder dayToBuilder 290 | {-# INLINE toField #-} 291 | 292 | instance ToField (PGRange TimeOfDay) where 293 | toField = Plain . rangeToBuilder timeOfDayToBuilder 294 | {-# INLINE toField #-} 295 | 296 | instance ToField (PGRange UTCTimestamp) where 297 | toField = Plain . rangeToBuilder utcTimestampToBuilder 298 | {-# INLINE toField #-} 299 | 300 | instance ToField (PGRange ZonedTimestamp) where 301 | toField = Plain . rangeToBuilderBy cmpZonedTimestamp zonedTimestampToBuilder 302 | {-# INLINE toField #-} 303 | 304 | cmpZonedTimestamp :: ZonedTimestamp -> ZonedTimestamp -> Ordering 305 | cmpZonedTimestamp = compare `on` (zonedTimeToUTC <$>) 306 | 307 | instance ToField (PGRange LocalTimestamp) where 308 | toField = Plain . rangeToBuilder localTimestampToBuilder 309 | {-# INLINE toField #-} 310 | 311 | instance ToField (PGRange Date) where 312 | toField = Plain . rangeToBuilder dateToBuilder 313 | {-# INLINE toField #-} 314 | 315 | instance ToField (PGRange NominalDiffTime) where 316 | toField = Plain . rangeToBuilder nominalDiffTimeToBuilder 317 | {-# INLINE toField #-} 318 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/Time.hs: -------------------------------------------------------------------------------- 1 | {- | 2 | Module: Database.PostgreSQL.Simple.Time 3 | Copyright: (c) 2012-2015 Leon P Smith 4 | License: BSD3 5 | Maintainer: Leon P Smith 6 | Stability: experimental 7 | 8 | This module provides time types that supports positive and negative 9 | infinity, as well as some functions for converting to and from strings. 10 | 11 | Also, this module also contains commentary regarding postgresql's timestamp 12 | types, civil timekeeping in general, and how it relates to 13 | postgresql-simple. You can read more about PostgreSQL's date and time types 14 | at , 15 | and the IANA time zone database at . 16 | 17 | Stack Overflow also has some excellent commentary on time, if it is a 18 | wiki page or a highly upvoted question and answer. If the answer regarding 19 | time has not received about a hundred upvotes at least, then the answer is 20 | almost invariably completely and painfully wrong, even if it's the chosen 21 | answer or the most highly upvoted answer to a question. 22 | 23 | PostgreSQL's @timestamp with time zone@ (hereafter, @timestamptz@) can be 24 | converted to Haskell's 'Data.Time.UTCTime' and 'Data.Time.ZonedTime' types, 25 | because values of these types represent a self-contained, unambiguous point 26 | in time. PostgreSQL's @timestamp without time zone@ (hereafter, @timestamp@) 27 | can be converted to Haskell's 'Data.Time.LocalTime', because values of these 28 | types are ambiguous by themselves, and require context to disambiguate. 29 | 30 | While this behavior may be superficially counterintuitive because the 31 | names might suggest otherwise, this behavior is correct. In fact, 32 | the \"timezone\" language in both the postgresql and haskell types would 33 | be better read as \"offset (from UTC)\", thus we have postgresql's 34 | \"timestamp with offset\" corresponding to Haskell's \"time with the 35 | offset \'zero\'\" and Haskell's \"time with an offset (that might be 36 | nonzero)\". Similarly, postgresql's \"timestamp without an offset\" 37 | corresponds to Haskell's \"local time (without an offset)\". 38 | 39 | It's important to distinguish between an offset, a standard time, and 40 | a time zone. An offset is simply a difference of a local time from UTC, 41 | such as @+00@, @-05@, or @+05:30@. A standard time specifies an offset 42 | (which may vary throughout the year, due to daylight savings) that a 43 | region follows, such as Universal Coordinated Time (UTC), Eastern Standard 44 | Time\/Eastern Daylight Time (EST\/EDT), or India Standard Time (IST). 45 | And a time zone, much like a standard time, is a function from 46 | timestamps to offsets. 47 | 48 | A time zone is different from a standard time because different regions 49 | inside a standard time can be governed by different civil authorities with 50 | different laws and thus have different histories of civil time. An IANA 51 | time zone is any region of the world that has had the same history of 52 | civil time since @1970-01-01 00:00+00@. 53 | 54 | For example, as of today, both @America\/New_York@ and 55 | @America\/Indiana\/Indianapolis@ are on the EST\/EDT time standard, but 56 | Indiana used to be on Central Standard Time until 1942, and did not observe 57 | daylight savings time (EST only) until 2006. Thus, the choice between 58 | these two time zones still matters if you are dealing with timestamps 59 | prior to 2006, and could become relevant again if (most of) Indiana 60 | moves back to Central Time. (Of course, if the Central to Eastern switch 61 | was the only difference, then these two time zones would be the same in 62 | IANA's eyes, due to their cutoff date of 1970-01-01.) 63 | 64 | Getting back to practicalities, PostgreSQL's @timestamptz@ type does not 65 | actually store an offset; rather, it uses the offset provided to calculate 66 | UTC, and stores the timestamp as UTC. If an offset is not provided, the 67 | given timestamp is assumed to be a local time for whatever the @timezone@ 68 | variable is set to, and the IANA TZ database is consulted to calculate an 69 | offset from UTC for the time in question. 70 | 71 | Note that while most (local timestamp, time zone) pairs correspond to exactly 72 | one UTC timestamp, some correspond to two UTC timestamps, while others 73 | correspond to none at all. The ambiguous case occurs when the civil time 74 | is rolled back, making a calendar day longer than 24 hours. In this case, 75 | PostgreSQL silently chooses the second, later possibility. The inconsistent 76 | case occurs when the civil time is moved forward, making a calendar day less 77 | than 24 hours. In this case, PostgreSQL silently assumes the local time 78 | was read off a clock that had not been moved forward at the prescribed time, 79 | and moves the clock forward for you. Thus, converting from local time 80 | to UTC need not be monotonic, if these inconsistent cases are allowed. 81 | 82 | When retrieving a @timestamptz@, the backend looks at the @time zone@ 83 | connection variable and then consults the IANA TZ database to calculate 84 | an offset for the timestamp in the given time zone. 85 | 86 | Note that while some of the information contained in the IANA TZ database 87 | is a bit of a standardized fiction, the conversion from UTC time to a 88 | (local time, offset) pair in a particular time zone is always unambiguous, 89 | and the result can always be unambiguously converted back to UTC. Thus, 90 | postgresql-simple can interpret such a result as a 'Data.Time.ZonedTime', 91 | or use the offset to convert back to 'Data.Time.UTCTime'. 92 | 93 | By contrast, the @timestamp@ type ignores any offsets provided to it, 94 | and never sends back an offset. Thus, postgresql-simple equates this 95 | with 'Data.Time.LocalTime', which has no concept of an offset. One can 96 | convert between @timestamptz@ and @timestamp@ using the @AT TIME ZONE@ 97 | operator, whose semantics also demonstrates that @timestamptz@ is 98 | 'Data.Time.UTCTime' whereas @timestamp@ is 'Data.Time.LocalTime'. 99 | 100 | PostgreSQL's @timezone@ is a per-connection variable that by default is 101 | initialized to @\'localtime\'@, which normally corresponds to the server's 102 | time zone. However, this default can be modified on the server side for an 103 | entire cluster, or on a per-user or per-database basis. Moreover, a client 104 | can modify their instance of the variable at any time, and can apply that 105 | change to the remaining duration of the connection, the current transaction, 106 | or the execution context of a server-side function. In addition, upon 107 | connection initialization, the libpq client checks for the existence of 108 | the @PGTZ@ environment variable, and if it exists, modifies @timezone@ 109 | accordingly. 110 | 111 | With a few caveats, postgresql-simple is designed so that you can both send 112 | and receive timestamps with the server and get a correct result, no matter 113 | what the @timezone@ setting is. But it is important to understand the caveats: 114 | 115 | 1. The correctness of server-side computations can depend on the @timezone@ 116 | setting. Examples include adding an @interval@ to a @timestamptz@, or 117 | type casting between @timestamp@ and @timestamptz@, or applying 118 | the @DATE@ function to a @timestamptz@. 119 | 120 | 2. The (localtime, offset) pair contained in a 'Data.Time.ZonedTime' result 121 | will depend on the @timezone@ setting, although the result will always 122 | represent the same instant in time regardless of the time zone. 123 | 124 | 3. Sending a 'Data.Time.LocalTime' and interpreting it as a @timestamptz@ 125 | can be useful, as it will be converted to UTC via the tz database, 126 | but correctness will depend on the @timezone@ setting. You may prefer 127 | to use an explicit @AT TIME ZONE@ conversion instead, which would avoid 128 | this contextual dependence. 129 | 130 | Furthermore, although these following points don't involve the @timezone@ 131 | setting, they are related to the last point above: 132 | 133 | 1. Sending a 'Data.Time.UTCTime' and interpreting it as a @timestamp@ can 134 | be useful. In practice, the most common context used to disambiguate 135 | @timestamp@ is that it represents UTC, and this coding technique will 136 | work as expected in this situation. 137 | 138 | 2. Sending a 'Data.Time.ZonedTime' and interpreting it as a @timestamp@ is 139 | almost always the wrong thing to do, as the offset will be ignored and 140 | discarded. This is likely to lead to inconsistencies in the database, 141 | and may lead to partial data loss. 142 | 143 | When dealing with local timestamps that refer to the future, it is often 144 | useful to store it as a local time in a @timestamp@ column and store the 145 | time zone in a second column. One reason to do this is so that you can 146 | convert to UTC on the fly as needed, and be protected against future changes 147 | to the TZ database due to changes in local time standards. In any case, 148 | 'Data.Time.ZonedTime' is not suitable for this application, because despite 149 | its name, it represents an offset and not a time zone. Time zones can change; 150 | offsets do not. In reality, we can't convert a local timestamp that occurs 151 | sufficiently far in the future to UTC, because we don't know how to do it yet. 152 | 153 | There are a few limitations and caveats that one might need to be aware 154 | of with the current implementation when dealing with older timestamps: 155 | 156 | For sufficiently old timestamps in almost all time zones, the IANA TZ 157 | database specifies offsets from UTC that is not an integral number of 158 | minutes. This corresponds to local mean time; that is, astronomical 159 | time in the city that defines the time zone. Different time zones moved 160 | away from local mean time to a standard time at different points in 161 | history, so \"sufficiently old\" depends on the time zone in question. 162 | 163 | Thus, when retrieving a @timestamptz@ postgresql will in some cases 164 | provide seconds in the offset. For example: 165 | 166 | @ 167 | $ psql 168 | psql (9.4.5) 169 | Type \"help\" for help. 170 | 171 | lpsmith=> SET timezone TO \'America/New_York\'; 172 | SET 173 | lpsmith=> VALUES (\'1883-11-18 16:59:59+00\'::timestamptz), 174 | (\'1883-11-18 17:00:00+00\'::timestamptz); 175 | column1 176 | ------------------------------ 177 | 1883-11-18 12:03:57-04:56:02 178 | 1883-11-18 12:00:00-05 179 | (2 rows) 180 | @ 181 | 182 | Both of these timestamps can be parsed as a 'Data.Time.UTCTime' type, 183 | however 'Data.Time.ZonedTime' will fail on the former timestamp. 184 | Because 'Data.Time.ZonedTime' assumes that offsets are an integer number 185 | of minutes, there isn't an particularly good solution here. 186 | 187 | PostgreSQL, like most software, uses the proleptic Gregorian calendar 188 | for its date calculations, extending the Gregorian calendar backwards 189 | in time before its introduction and pretending that the Julian calendar 190 | does not exist. For most purposes, the adoption of the Gregorian calendar 191 | ranges from @1582-10-15@ to @1923-03-01@, depending on location and 192 | sometimes even political allegiances within a single location. 193 | 194 | Timestamps BCE are not supported. For example, PostgreSQL 195 | will emit \"@0045-01-01 BC@\" for the first proleptic Gregorian day of 196 | the year the Roman Empire adopted the Julian Calendar, but 197 | postgresql-simple does not (yet?) have the ability to either parse or 198 | generate this syntax. Unfortunately this syntax isn't convenient to 199 | print or especially parse. 200 | 201 | Also, postgresql itself cannot parse or print dates before @4714-11-24 BC@, 202 | which is the Julian date on the proleptic Gregorian Calendar. Although 203 | postgresql's timestamp types are perfectly capable of representing timestamps 204 | nearly 300,000 years in the past, using this would require postgresql-simple 205 | and other client programs to support binary parameters and results. 206 | 207 | Dealing with years BCE is also complicated slightly by the fact that 208 | Haskell's time library has a year \"0000\", which is a convention often 209 | used by astronomers, while postgresql adopts the more historically 210 | accurate convention that there is no year zero, but rather \"1 BCE\" 211 | was immediately followed by \"1 CE\". 212 | 213 | -} 214 | 215 | module Database.PostgreSQL.Simple.Time 216 | ( Unbounded(..) 217 | , Date 218 | , UTCTimestamp 219 | , ZonedTimestamp 220 | , LocalTimestamp 221 | , parseDay 222 | , parseUTCTime 223 | , parseZonedTime 224 | , parseLocalTime 225 | , parseTimeOfDay 226 | , parseDate 227 | , parseUTCTimestamp 228 | , parseZonedTimestamp 229 | , parseLocalTimestamp 230 | , dayToBuilder 231 | , utcTimeToBuilder 232 | , zonedTimeToBuilder 233 | , localTimeToBuilder 234 | , timeOfDayToBuilder 235 | , timeZoneToBuilder 236 | , dateToBuilder 237 | , utcTimestampToBuilder 238 | , zonedTimestampToBuilder 239 | , localTimestampToBuilder 240 | , unboundedToBuilder 241 | , nominalDiffTimeToBuilder 242 | ) where 243 | 244 | import Database.PostgreSQL.Simple.Time.Implementation 245 | -------------------------------------------------------------------------------- /tools/GenTypeInfo.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | -- | 3 | -- Module: GenTypeInfo 4 | -- Copyright: (c) 2011-2012 Leon P Smith 5 | -- License: BSD3 6 | -- Maintainer: Leon P Smith 7 | -- Stability: experimental 8 | -- 9 | -- Queries a PostgreSQL database for the Object IDs and other type 10 | -- information associated with typenames, and generates a module with 11 | -- data constants representing part of the pg_type table. 12 | -- 13 | -- Note that only some of the built-in types have stable type OIDs, and 14 | -- thus a TypeInfo module that contains user-defined types is liable to 15 | -- not work across different database instances. For these types, it is 16 | -- better for `FromField` to use the `typeinfo` operator that works for 17 | -- any type, whether or not it is in this module. 18 | -- 19 | -- `typeinfo` works because postgresql-simple will dynamically query 20 | -- the pg_types table the first time it receives a type OID it doesn't 21 | -- know about. It then constructs a TypeInfo record and stores it in 22 | -- a per-connection cache for later use. 23 | -- 24 | ------------------------------------------------------------------------------ 25 | 26 | {-# LANGUAGE OverloadedStrings, QuasiQuotes, ViewPatterns, RecordWildCards #-} 27 | 28 | module GenBuiltinTypes where 29 | 30 | import Prelude hiding ((++), concat) 31 | 32 | import StringsQQ 33 | import Control.Arrow((&&&)) 34 | import Control.Applicative 35 | import Control.Exception(bracket) 36 | import Database.PostgreSQL.Simple 37 | import Database.PostgreSQL.Simple.FromRow 38 | import Database.PostgreSQL.Simple.Ok 39 | import Database.PostgreSQL.Simple.Types(Oid(..)) 40 | import Database.PostgreSQL.Simple.SqlQQ 41 | import qualified Data.ByteString.Char8 as B 42 | import Data.ByteString(ByteString) 43 | import qualified Data.ByteString.Lazy as L 44 | import qualified Blaze.ByteString.Builder as Blaze 45 | import qualified Blaze.ByteString.Builder.ByteString as Blaze 46 | import qualified Blaze.ByteString.Builder.Char8 as Blaze 47 | import Data.String 48 | import Data.List ( sort, intersperse ) 49 | import qualified Data.Map as Map 50 | 51 | import Data.Monoid 52 | 53 | (++) :: Monoid a => a -> a -> a 54 | (++) = mappend 55 | infixr 5 ++ 56 | 57 | concat :: Monoid a => [a] -> a 58 | concat = mconcat 59 | 60 | data TypeInfo = TypeInfo 61 | { typoid :: Oid 62 | , typcategory :: Char 63 | , typdelim :: Char 64 | , typname :: ByteString 65 | , typelem :: Oid 66 | , rngsubtype :: Maybe Oid 67 | } 68 | 69 | instance FromRow TypeInfo where 70 | fromRow = TypeInfo <$> field <*> field <*> field <*> field <*> field <*> field 71 | 72 | type NameMap = Map.Map B.ByteString TypeInfo 73 | 74 | type OidMap = Map.Map Oid TypeInfo 75 | 76 | type TypeName = (B.ByteString, B.ByteString) 77 | 78 | type TypeNames = [TypeName] 79 | 80 | -- Note that the following syntax is "pgName hsName", though 81 | -- they default to the same thing if there is only one identifier 82 | typeNames :: TypeNames 83 | typeNames = [typenames| 84 | bool 85 | bytea 86 | char 87 | name 88 | int8 89 | int2 90 | int4 91 | regproc 92 | text 93 | oid 94 | tid 95 | xid 96 | cid 97 | xml 98 | point 99 | lseg 100 | path 101 | box 102 | polygon 103 | line 104 | cidr 105 | float4 106 | float8 107 | unknown 108 | circle 109 | money 110 | macaddr 111 | inet 112 | bpchar 113 | varchar 114 | date 115 | time 116 | timestamp 117 | timestamptz 118 | interval 119 | timetz 120 | bit 121 | varbit 122 | numeric 123 | refcursor 124 | record 125 | void 126 | _record array_record 127 | regprocedure 128 | regoper 129 | regoperator 130 | regclass 131 | regtype 132 | uuid 133 | json 134 | jsonb 135 | int2vector 136 | oidvector 137 | _xml array_xml 138 | _json array_json 139 | _line array_line 140 | _cidr array_cidr 141 | _circle array_circle 142 | _money array_money 143 | _bool array_bool 144 | _bytea array_bytea 145 | _char array_char 146 | _name array_name 147 | _int2 array_int2 148 | _int2vector array_int2vector 149 | _int4 array_int4 150 | _regproc array_regproc 151 | _text array_text 152 | _tid array_tid 153 | _xid array_xid 154 | _cid array_cid 155 | _oidvector array_oidvector 156 | _bpchar array_bpchar 157 | _varchar array_varchar 158 | _int8 array_int8 159 | _point array_point 160 | _lseg array_lseg 161 | _path array_path 162 | _box array_box 163 | _float4 array_float4 164 | _float8 array_float8 165 | _polygon array_polygon 166 | _oid array_oid 167 | _macaddr array_macaddr 168 | _inet array_inet 169 | _timestamp array_timestamp 170 | _date array_date 171 | _time array_time 172 | _timestamptz array_timestamptz 173 | _interval array_interval 174 | _numeric array_numeric 175 | _timetz array_timetz 176 | _bit array_bit 177 | _varbit array_varbit 178 | _refcursor array_refcursor 179 | _regprocedure array_regprocedure 180 | _regoper array_regoper 181 | _regoperator array_regoperator 182 | _regclass array_regclass 183 | _regtype array_regtype 184 | _uuid array_uuid 185 | _jsonb array_jsonb 186 | int4range 187 | _int4range 188 | numrange 189 | _numrange 190 | tsrange 191 | _tsrange 192 | tstzrange 193 | _tstzrange 194 | daterange 195 | _daterange 196 | int8range 197 | _int8range 198 | |] 199 | 200 | instance IsString Blaze.Builder where 201 | fromString = Blaze.fromByteString . fromString 202 | 203 | connectionString = "dbname=postgres" 204 | 205 | withPostgreSQL = bracket (connectPostgreSQL connectionString) close 206 | 207 | getTypeInfos :: TypeNames -> IO (OidMap, NameMap) 208 | getTypeInfos typnames = withPostgreSQL $ \conn -> do 209 | infos <- query conn [sql| 210 | WITH types AS 211 | (SELECT oid, typcategory, typdelim, typname, typelem 212 | FROM pg_type WHERE typname IN ?) 213 | SELECT types.*, rngsubtype FROM types LEFT JOIN pg_range ON oid = rngtypid 214 | |] (Only (In (sort (map pg typnames)))) 215 | loop conn (oidMap infos) (nameMap infos) infos 216 | where 217 | oidMap = Map.fromList . map (typoid &&& id) 218 | nameMap = Map.fromList . map (typname &&& id) 219 | loop conn oids names infos = do 220 | let unknowns = [ x | x <- map typelem infos ++ 221 | [ x | Just x <- map rngsubtype infos ], 222 | x /= Oid 0, 223 | not (Map.member x oids) ] 224 | case unknowns of 225 | [] -> return (oids, names) 226 | (_:_) -> do 227 | infos' <- query conn [sql| 228 | WITH types AS 229 | (SELECT oid, typcategory, typdelim, typname, typelem 230 | FROM pg_type WHERE oid IN ?) 231 | SELECT types.*, rngsubtype 232 | FROM types LEFT JOIN pg_range ON oid = rngtypid 233 | |] (Only (In (sort unknowns))) 234 | let oids' = oids `Map.union` oidMap infos' 235 | names' = names `Map.union` nameMap infos' 236 | loop conn oids' names' infos' 237 | 238 | main = do 239 | (oidmap, namemap) <- getTypeInfos typeNames 240 | L.writeFile "../src/Database/PostgreSQL/Simple/TypeInfo/Static.hs" 241 | (Blaze.toLazyByteString (renderFile oidmap namemap typeNames)) 242 | 243 | 244 | showOid (Oid n) = show n 245 | 246 | renderOid :: NameMap -> TypeName -> Blaze.Builder 247 | renderOid byName name 248 | = case Map.lookup (pg name) byName of 249 | Nothing -> error (B.unpack (pg name)) 250 | Just (showOid . typoid -> n) -> fromString n 251 | ++ fromString (replicate (4 - length n) ' ') 252 | 253 | renderElem :: OidMap -> Oid -> Blaze.Builder 254 | renderElem byOid elemOid 255 | | elemOid == Oid 0 = "Nothing" 256 | | otherwise = case Map.lookup elemOid byOid of 257 | Nothing -> error ("oid not found: " ++ show elemOid) 258 | Just x -> "Just " ++ bs (typname x) 259 | 260 | renderTypeInfo :: OidMap -> TypeInfo -> TypeName -> Blaze.Builder 261 | renderTypeInfo byOid info name 262 | | typcategory info == 'A' || typname info == "_record" = 263 | let (Just typelem_info) = Map.lookup (typelem info) byOid 264 | typelem_hs_name = 265 | case lookup (typname typelem_info) typeNames of 266 | Nothing -> error ( "type not found: " 267 | ++ B.unpack( typname typelem_info) 268 | ++ " (typelem of " ++ B.unpack (typname info) 269 | ++ ")") 270 | Just x -> x 271 | in concat 272 | [ "\n" 273 | , bs (hs name), " :: TypeInfo\n" 274 | , bs (hs name), " = Array {\n" 275 | , " typoid = ", fromString (show (typoid info)), ",\n" 276 | , " typcategory = '", Blaze.fromChar (typcategory info), "',\n" 277 | , " typdelim = '", Blaze.fromChar (typdelim info), "',\n" 278 | , " typname = \"", bs (typname info), "\",\n" 279 | , " typelem = ", bs typelem_hs_name, "\n" 280 | , " }\n" 281 | ] 282 | | typcategory info == 'R' = 283 | let (Just rngsubtype_oid) = rngsubtype info 284 | (Just rngsubtype_info) = Map.lookup rngsubtype_oid byOid 285 | rngsubtype_hs_name = 286 | case lookup (typname rngsubtype_info) typeNames of 287 | Nothing -> error ( "type not found: " 288 | ++ B.unpack (typname rngsubtype_info) 289 | ++ " (rngsubtype of " 290 | ++ B.unpack (typname info) ++ ")") 291 | Just x -> x 292 | in concat 293 | [ "\n" 294 | , bs (hs name), " :: TypeInfo\n" 295 | , bs (hs name), " = Range {\n" 296 | , " typoid = ", fromString (show (typoid info)), ",\n" 297 | , " typcategory = '", Blaze.fromChar (typcategory info), "',\n" 298 | , " typdelim = '", Blaze.fromChar (typdelim info), "',\n" 299 | , " typname = \"", bs (typname info), "\",\n" 300 | , " rngsubtype = ", bs rngsubtype_hs_name, "\n" 301 | , " }\n" 302 | ] 303 | | otherwise = 304 | concat 305 | [ "\n" 306 | , bs (hs name), " :: TypeInfo\n" 307 | , bs (hs name), " = Basic {\n" 308 | , " typoid = ", fromString (show (typoid info)), ",\n" 309 | , " typcategory = '", Blaze.fromChar (typcategory info), "',\n" 310 | , " typdelim = '", Blaze.fromChar (typdelim info), "',\n" 311 | , " typname = \"", bs (typname info), "\"\n" 312 | , " }\n" 313 | ] 314 | 315 | -- FIXME: add in any names that we need that we didn't specify, (i.e. 316 | -- the "unknowns" in getTypeInfos 317 | -- and munge them into a valid haskell identifier if needed. 318 | getNames :: NameMap -> TypeNames -> TypeNames 319 | getNames _ x = x 320 | 321 | bs = Blaze.fromByteString 322 | 323 | pg = fst 324 | 325 | hs = snd 326 | 327 | renderFile :: OidMap -> NameMap -> TypeNames -> Blaze.Builder 328 | renderFile byOid byName names = ([longstring| 329 | ------------------------------------------------------------------------------ 330 | -- | 331 | -- Module: Database.PostgreSQL.Simple.TypeInfo 332 | -- Copyright: (c) 2011-2012 Leon P Smith 333 | -- License: BSD3 334 | -- Maintainer: Leon P Smith 335 | -- Stability: experimental 336 | -- 337 | -- This module contains portions of the @pg_type@ table that are relevant 338 | -- to postgresql-simple and are believed to not change between PostgreSQL 339 | -- versions. 340 | -- 341 | ------------------------------------------------------------------------------ 342 | 343 | -- Note that this file is generated by tools/GenTypeInfo.hs, and should 344 | -- not be edited directly 345 | 346 | module Database.PostgreSQL.Simple.TypeInfo.Static 347 | ( TypeInfo(..) 348 | , staticTypeInfo 349 | |] ++ concat [ " , " ++ bs (hs name) ++ "\n" 350 | | name <- names ] ++ [longstring| 351 | ) where 352 | 353 | import Database.PostgreSQL.LibPQ (Oid(..)) 354 | import Database.PostgreSQL.Simple.TypeInfo.Types 355 | 356 | staticTypeInfo :: Oid -> Maybe TypeInfo 357 | staticTypeInfo (Oid x) = case x of 358 | |] ++ concat [concat [ " ", renderOid byName name, 359 | " -> Just ", bs (hs name), "\n" 360 | ] 361 | | name <- names ] 362 | ++ [longstring| 363 | _ -> Nothing 364 | |] 365 | ++ concat [ renderTypeInfo byOid typeInfo name 366 | | name <- getNames byName names 367 | , let (Just typeInfo) = Map.lookup (pg name) byName]) 368 | -------------------------------------------------------------------------------- /src/Database/PostgreSQL/Simple/ToField.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} 3 | 4 | ------------------------------------------------------------------------------ 5 | -- | 6 | -- Module: Database.PostgreSQL.Simple.ToField 7 | -- Copyright: (c) 2011 MailRank, Inc. 8 | -- (c) 2011-2012 Leon P Smith 9 | -- License: BSD3 10 | -- Maintainer: Leon P Smith 11 | -- Stability: experimental 12 | -- 13 | -- The 'ToField' typeclass, for rendering a parameter to a SQL query. 14 | -- 15 | ------------------------------------------------------------------------------ 16 | 17 | module Database.PostgreSQL.Simple.ToField 18 | ( 19 | Action(..) 20 | , ToField(..) 21 | , toJSONField 22 | , inQuotes 23 | ) where 24 | 25 | import qualified Data.Aeson as JSON 26 | import Data.ByteString (ByteString) 27 | import Data.ByteString.Builder 28 | ( Builder, byteString, char8, stringUtf8 29 | , intDec, int8Dec, int16Dec, int32Dec, int64Dec, integerDec 30 | , wordDec, word8Dec, word16Dec, word32Dec, word64Dec 31 | , floatDec, doubleDec 32 | ) 33 | import Data.Int (Int8, Int16, Int32, Int64) 34 | import Data.List (intersperse) 35 | import Data.Monoid (mappend) 36 | import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime, NominalDiffTime) 37 | import Data.Typeable (Typeable) 38 | import Data.Word (Word, Word8, Word16, Word32, Word64) 39 | import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow 40 | import Database.PostgreSQL.Simple.Types 41 | import Database.PostgreSQL.Simple.Compat (toByteString) 42 | 43 | import qualified Data.ByteString as SB 44 | import qualified Data.ByteString.Lazy as LB 45 | import Data.CaseInsensitive (CI) 46 | import qualified Data.CaseInsensitive as CI 47 | import qualified Data.Text as ST 48 | import qualified Data.Text.Encoding as ST 49 | import qualified Data.Text.Lazy as LT 50 | import qualified Data.Text.Lazy.Builder as LT 51 | import Data.UUID.Types (UUID) 52 | import qualified Data.UUID.Types as UUID 53 | import Data.Vector (Vector) 54 | import qualified Data.Vector as V 55 | import qualified Database.PostgreSQL.LibPQ as PQ 56 | import Database.PostgreSQL.Simple.Time 57 | import Data.Scientific (Scientific) 58 | #if MIN_VERSION_scientific(0,3,0) 59 | import Data.Text.Lazy.Builder.Scientific (scientificBuilder) 60 | #else 61 | import Data.Scientific (scientificBuilder) 62 | #endif 63 | import Foreign.C.Types (CUInt(..)) 64 | 65 | -- | How to render an element when substituting it into a query. 66 | data Action = 67 | Plain Builder 68 | -- ^ Render without escaping or quoting. Use for non-text types 69 | -- such as numbers, when you are /certain/ that they will not 70 | -- introduce formatting vulnerabilities via use of characters such 71 | -- as spaces or \"@'@\". 72 | | Escape ByteString 73 | -- ^ Escape and enclose in quotes before substituting. Use for all 74 | -- text-like types, and anything else that may contain unsafe 75 | -- characters when rendered. 76 | | EscapeByteA ByteString 77 | -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding 78 | -- quotes. This is used by the 'Binary' newtype wrapper. 79 | | EscapeIdentifier ByteString 80 | -- ^ Escape before substituting. Use for all sql identifiers like 81 | -- table, column names, etc. This is used by the 'Identifier' newtype 82 | -- wrapper. 83 | | Many [Action] 84 | -- ^ Concatenate a series of rendering actions. 85 | deriving (Typeable) 86 | 87 | instance Show Action where 88 | show (Plain b) = "Plain " ++ show (toByteString b) 89 | show (Escape b) = "Escape " ++ show b 90 | show (EscapeByteA b) = "EscapeByteA " ++ show b 91 | show (EscapeIdentifier b) = "EscapeIdentifier " ++ show b 92 | show (Many b) = "Many " ++ show b 93 | 94 | -- | A type that may be used as a single parameter to a SQL query. 95 | class ToField a where 96 | toField :: a -> Action 97 | -- ^ Prepare a value for substitution into a query string. 98 | 99 | instance ToField Action where 100 | toField a = a 101 | {-# INLINE toField #-} 102 | 103 | instance (ToField a) => ToField (Maybe a) where 104 | toField Nothing = renderNull 105 | toField (Just a) = toField a 106 | {-# INLINE toField #-} 107 | 108 | instance (ToField a) => ToField (In [a]) where 109 | toField (In []) = Plain $ byteString "(null)" 110 | toField (In xs) = Many $ 111 | Plain (char8 '(') : 112 | (intersperse (Plain (char8 ',')) . map toField $ xs) ++ 113 | [Plain (char8 ')')] 114 | 115 | renderNull :: Action 116 | renderNull = Plain (byteString "null") 117 | 118 | instance ToField Null where 119 | toField _ = renderNull 120 | {-# INLINE toField #-} 121 | 122 | instance ToField Default where 123 | toField _ = Plain (byteString "default") 124 | {-# INLINE toField #-} 125 | 126 | instance ToField Bool where 127 | toField True = Plain (byteString "true") 128 | toField False = Plain (byteString "false") 129 | {-# INLINE toField #-} 130 | 131 | instance ToField Int8 where 132 | toField = Plain . int8Dec 133 | {-# INLINE toField #-} 134 | 135 | instance ToField Int16 where 136 | toField = Plain . int16Dec 137 | {-# INLINE toField #-} 138 | 139 | instance ToField Int32 where 140 | toField = Plain . int32Dec 141 | {-# INLINE toField #-} 142 | 143 | instance ToField Int where 144 | toField = Plain . intDec 145 | {-# INLINE toField #-} 146 | 147 | instance ToField Int64 where 148 | toField = Plain . int64Dec 149 | {-# INLINE toField #-} 150 | 151 | instance ToField Integer where 152 | toField = Plain . integerDec 153 | {-# INLINE toField #-} 154 | 155 | instance ToField Word8 where 156 | toField = Plain . word8Dec 157 | {-# INLINE toField #-} 158 | 159 | instance ToField Word16 where 160 | toField = Plain . word16Dec 161 | {-# INLINE toField #-} 162 | 163 | instance ToField Word32 where 164 | toField = Plain . word32Dec 165 | {-# INLINE toField #-} 166 | 167 | instance ToField Word where 168 | toField = Plain . wordDec 169 | {-# INLINE toField #-} 170 | 171 | instance ToField Word64 where 172 | toField = Plain . word64Dec 173 | {-# INLINE toField #-} 174 | 175 | instance ToField PQ.Oid where 176 | toField = Plain . \(PQ.Oid (CUInt x)) -> word32Dec x 177 | {-# INLINE toField #-} 178 | 179 | instance ToField Float where 180 | toField v | isNaN v || isInfinite v = Plain (inQuotes (floatDec v)) 181 | | otherwise = Plain (floatDec v) 182 | {-# INLINE toField #-} 183 | 184 | instance ToField Double where 185 | toField v | isNaN v || isInfinite v = Plain (inQuotes (doubleDec v)) 186 | | otherwise = Plain (doubleDec v) 187 | {-# INLINE toField #-} 188 | 189 | instance ToField Scientific where 190 | toField x = toField (LT.toLazyText (scientificBuilder x)) 191 | {-# INLINE toField #-} 192 | 193 | instance ToField (Binary SB.ByteString) where 194 | toField (Binary bs) = EscapeByteA bs 195 | {-# INLINE toField #-} 196 | 197 | instance ToField (Binary LB.ByteString) where 198 | toField (Binary bs) = (EscapeByteA . SB.concat . LB.toChunks) bs 199 | {-# INLINE toField #-} 200 | 201 | instance ToField Identifier where 202 | toField (Identifier bs) = EscapeIdentifier (ST.encodeUtf8 bs) 203 | {-# INLINE toField #-} 204 | 205 | instance ToField QualifiedIdentifier where 206 | toField (QualifiedIdentifier (Just s) t) = 207 | Many [ EscapeIdentifier (ST.encodeUtf8 s) 208 | , Plain (char8 '.') 209 | , EscapeIdentifier (ST.encodeUtf8 t) 210 | ] 211 | toField (QualifiedIdentifier Nothing t) = 212 | EscapeIdentifier (ST.encodeUtf8 t) 213 | {-# INLINE toField #-} 214 | 215 | instance ToField SB.ByteString where 216 | toField = Escape 217 | {-# INLINE toField #-} 218 | 219 | instance ToField LB.ByteString where 220 | toField = toField . SB.concat . LB.toChunks 221 | {-# INLINE toField #-} 222 | 223 | instance ToField ST.Text where 224 | toField = Escape . ST.encodeUtf8 225 | {-# INLINE toField #-} 226 | 227 | instance ToField [Char] where 228 | toField = Escape . toByteString . stringUtf8 229 | {-# INLINE toField #-} 230 | 231 | instance ToField LT.Text where 232 | toField = toField . LT.toStrict 233 | {-# INLINE toField #-} 234 | 235 | -- | citext 236 | instance ToField (CI ST.Text) where 237 | toField = toField . CI.original 238 | {-# INLINE toField #-} 239 | 240 | -- | citext 241 | instance ToField (CI LT.Text) where 242 | toField = toField . LT.toStrict . CI.original 243 | {-# INLINE toField #-} 244 | 245 | instance ToField UTCTime where 246 | toField = Plain . inQuotes . utcTimeToBuilder 247 | {-# INLINE toField #-} 248 | 249 | instance ToField ZonedTime where 250 | toField = Plain . inQuotes . zonedTimeToBuilder 251 | {-# INLINE toField #-} 252 | 253 | instance ToField LocalTime where 254 | toField = Plain . inQuotes . localTimeToBuilder 255 | {-# INLINE toField #-} 256 | 257 | instance ToField Day where 258 | toField = Plain . inQuotes . dayToBuilder 259 | {-# INLINE toField #-} 260 | 261 | instance ToField TimeOfDay where 262 | toField = Plain . inQuotes . timeOfDayToBuilder 263 | {-# INLINE toField #-} 264 | 265 | instance ToField UTCTimestamp where 266 | toField = Plain . inQuotes . utcTimestampToBuilder 267 | {-# INLINE toField #-} 268 | 269 | instance ToField ZonedTimestamp where 270 | toField = Plain . inQuotes . zonedTimestampToBuilder 271 | {-# INLINE toField #-} 272 | 273 | instance ToField LocalTimestamp where 274 | toField = Plain . inQuotes . localTimestampToBuilder 275 | {-# INLINE toField #-} 276 | 277 | instance ToField Date where 278 | toField = Plain . inQuotes . dateToBuilder 279 | {-# INLINE toField #-} 280 | 281 | instance ToField NominalDiffTime where 282 | toField = Plain . inQuotes . nominalDiffTimeToBuilder 283 | {-# INLINE toField #-} 284 | 285 | instance (ToField a) => ToField (PGArray a) where 286 | toField pgArray = 287 | case fromPGArray pgArray of 288 | [] -> Plain (byteString "'{}'") 289 | xs -> Many $ 290 | Plain (byteString "ARRAY[") : 291 | (intersperse (Plain (char8 ',')) . map toField $ xs) ++ 292 | [Plain (char8 ']')] 293 | -- Because the ARRAY[...] input syntax is being used, it is possible 294 | -- that the use of type-specific separator characters is unnecessary. 295 | 296 | instance (ToField a) => ToField (Vector a) where 297 | toField = toField . PGArray . V.toList 298 | 299 | instance ToField UUID where 300 | toField = Plain . inQuotes . byteString . UUID.toASCIIBytes 301 | 302 | instance ToField JSON.Value where 303 | toField = toField . JSON.encode 304 | 305 | -- | Convert a Haskell value to a JSON 'JSON.Value' using 306 | -- 'JSON.toJSON' and convert that to a field using 'toField'. 307 | -- 308 | -- This can be used as the default implementation for the 'toField' 309 | -- method for Haskell types that have a JSON representation in 310 | -- PostgreSQL. 311 | toJSONField :: JSON.ToJSON a => a -> Action 312 | toJSONField = toField . JSON.toJSON 313 | 314 | -- | Surround a string with single-quote characters: \"@'@\" 315 | -- 316 | -- This function /does not/ perform any other escaping. 317 | inQuotes :: Builder -> Builder 318 | inQuotes b = quote `mappend` b `mappend` quote 319 | where quote = char8 '\'' 320 | 321 | interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b] 322 | interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as 323 | {-# INLINE interleaveFoldr #-} 324 | 325 | instance ToRow a => ToField (Values a) where 326 | toField (Values types rows) = 327 | case rows of 328 | [] -> case types of 329 | [] -> error norows 330 | (_:_) -> values $ typedRow (repeat (lit "null")) 331 | types 332 | [lit " LIMIT 0)"] 333 | (_:_) -> case types of 334 | [] -> values $ untypedRows rows [litC ')'] 335 | (_:_) -> values $ typedRows rows types [litC ')'] 336 | where 337 | funcname = "Database.PostgreSQL.Simple.toField :: Values a -> Action" 338 | norows = funcname ++ " either values or types must be non-empty" 339 | emptyrow = funcname ++ " each row must contain at least one column" 340 | lit = Plain . byteString 341 | litC = Plain . char8 342 | values x = Many (lit "(VALUES ": x) 343 | 344 | typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action] 345 | typedField (val,typ) rest = val : lit "::" : toField typ : rest 346 | 347 | typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action] 348 | typedRow (val:vals) (typ:typs) rest = 349 | litC '(' : 350 | typedField (val,typ) ( interleaveFoldr 351 | typedField 352 | (litC ',') 353 | (litC ')' : rest) 354 | (zip vals typs) ) 355 | typedRow _ _ _ = error emptyrow 356 | 357 | untypedRow :: [Action] -> [Action] -> [Action] 358 | untypedRow (val:vals) rest = 359 | litC '(' : val : 360 | interleaveFoldr 361 | (:) 362 | (litC ',') 363 | (litC ')' : rest) 364 | vals 365 | untypedRow _ _ = error emptyrow 366 | 367 | typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action] 368 | typedRows [] _ _ = error funcname 369 | typedRows (val:vals) types rest = 370 | typedRow (toRow val) types (multiRows vals rest) 371 | 372 | untypedRows :: ToRow a => [a] -> [Action] -> [Action] 373 | untypedRows [] _ = error funcname 374 | untypedRows (val:vals) rest = 375 | untypedRow (toRow val) (multiRows vals rest) 376 | 377 | multiRows :: ToRow a => [a] -> [Action] -> [Action] 378 | multiRows vals rest = interleaveFoldr 379 | (untypedRow . toRow) 380 | (litC ',') 381 | rest 382 | vals 383 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DoAndIfThenElse #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | import Common 7 | import Database.PostgreSQL.Simple.FromField (FromField) 8 | import Database.PostgreSQL.Simple.Types(Query(..),Values(..)) 9 | import Database.PostgreSQL.Simple.HStore 10 | import Database.PostgreSQL.Simple.Copy 11 | import qualified Database.PostgreSQL.Simple.Transaction as ST 12 | 13 | import Control.Applicative 14 | import Control.Exception as E 15 | import Control.Monad 16 | import Data.Char 17 | import Data.List (sort) 18 | import Data.IORef 19 | import Data.Typeable 20 | import GHC.Generics (Generic) 21 | 22 | import Data.Aeson 23 | import Data.ByteString (ByteString) 24 | import qualified Data.ByteString as B 25 | import qualified Data.ByteString.Lazy.Char8 as BL 26 | import Data.CaseInsensitive (CI) 27 | import qualified Data.CaseInsensitive as CI 28 | import Data.Map (Map) 29 | import qualified Data.Map as Map 30 | import Data.Text(Text) 31 | import qualified Data.Text.Encoding as T 32 | import qualified Data.Vector as V 33 | import System.FilePath 34 | import System.Timeout(timeout) 35 | import Data.Time(getCurrentTime, diffUTCTime) 36 | 37 | import Test.Tasty 38 | import Test.Tasty.Golden 39 | import Notify 40 | import Serializable 41 | import Time 42 | 43 | tests :: TestEnv -> TestTree 44 | tests env = testGroup "tests" 45 | $ map ($ env) 46 | [ testBytea 47 | , testCase "ExecuteMany" . testExecuteMany 48 | , testCase "Fold" . testFold 49 | , testCase "Notify" . testNotify 50 | , testCase "Serializable" . testSerializable 51 | , testCase "Time" . testTime 52 | , testCase "Array" . testArray 53 | , testCase "Array of nullables" . testNullableArray 54 | , testCase "HStore" . testHStore 55 | , testCase "citext" . testCIText 56 | , testCase "JSON" . testJSON 57 | , testCase "Savepoint" . testSavepoint 58 | , testCase "Unicode" . testUnicode 59 | , testCase "Values" . testValues 60 | , testCase "Copy" . testCopy 61 | , testCopyFailures 62 | , testCase "Double" . testDouble 63 | , testCase "1-ary generic" . testGeneric1 64 | , testCase "2-ary generic" . testGeneric2 65 | , testCase "3-ary generic" . testGeneric3 66 | , testCase "Timeout" . testTimeout 67 | ] 68 | 69 | testBytea :: TestEnv -> TestTree 70 | testBytea TestEnv{..} = testGroup "Bytea" 71 | [ testStr "empty" [] 72 | , testStr "\"hello\"" $ map (fromIntegral . fromEnum) ("hello" :: String) 73 | , testStr "ascending" [0..255] 74 | , testStr "descending" [255,254..0] 75 | , testStr "ascending, doubled up" $ doubleUp [0..255] 76 | , testStr "descending, doubled up" $ doubleUp [255,254..0] 77 | ] 78 | where 79 | testStr label bytes = testCase label $ do 80 | let bs = B.pack bytes 81 | 82 | [Only h] <- query conn "SELECT md5(?::bytea)" [Binary bs] 83 | assertBool "Haskell -> SQL conversion altered the string" $ md5 bs == h 84 | 85 | [Only (Binary r)] <- query conn "SELECT ?::bytea" [Binary bs] 86 | assertBool "SQL -> Haskell conversion altered the string" $ bs == r 87 | 88 | doubleUp = concatMap (\x -> [x, x]) 89 | 90 | testExecuteMany :: TestEnv -> Assertion 91 | testExecuteMany TestEnv{..} = do 92 | execute_ conn "CREATE TEMPORARY TABLE tmp_executeMany (i INT, t TEXT, b BYTEA)" 93 | 94 | let rows :: [(Int, String, Binary ByteString)] 95 | rows = [ (1, "hello", Binary "bye") 96 | , (2, "world", Binary "\0\r\t\n") 97 | , (3, "?", Binary "") 98 | ] 99 | 100 | count <- executeMany conn "INSERT INTO tmp_executeMany VALUES (?, ?, ?)" rows 101 | count @?= fromIntegral (length rows) 102 | 103 | rows' <- query_ conn "SELECT * FROM tmp_executeMany" 104 | rows' @?= rows 105 | 106 | return () 107 | 108 | testFold :: TestEnv -> Assertion 109 | testFold TestEnv{..} = do 110 | xs <- fold_ conn "SELECT generate_series(1,10000)" 111 | [] $ \xs (Only x) -> return (x:xs) 112 | reverse xs @?= ([1..10000] :: [Int]) 113 | 114 | ref <- newIORef [] 115 | forEach conn "SELECT * FROM generate_series(1,?) a, generate_series(1,?) b" 116 | (100 :: Int, 50 :: Int) $ \(a :: Int, b :: Int) -> do 117 | xs <- readIORef ref 118 | writeIORef ref $! (a,b):xs 119 | xs <- readIORef ref 120 | reverse xs @?= [(a,b) | a <- [1..100], b <- [1..50]] 121 | 122 | -- Make sure fold propagates our exception. 123 | ref <- newIORef [] 124 | True <- expectError (== TestException) $ 125 | forEach_ conn "SELECT generate_series(1,10)" $ \(Only a) -> 126 | if a == 5 then do 127 | -- Cause a SQL error to trip up CLOSE. 128 | True <- expectError isSyntaxError $ 129 | execute_ conn "asdf" 130 | True <- expectError ST.isFailedTransactionError $ 131 | (query_ conn "SELECT 1" :: IO [(Only Int)]) 132 | throwIO TestException 133 | else do 134 | xs <- readIORef ref 135 | writeIORef ref $! (a :: Int) : xs 136 | xs <- readIORef ref 137 | reverse xs @?= [1..4] 138 | 139 | withTransaction conn $ replicateM_ 2 $ do 140 | xs <- fold_ conn "VALUES (1), (2), (3), (4), (5)" 141 | [] $ \xs (Only x) -> return (x:xs) 142 | reverse xs @?= ([1..5] :: [Int]) 143 | 144 | ref <- newIORef [] 145 | forEach_ conn "SELECT generate_series(1,101)" $ \(Only a) -> 146 | forEach_ conn "SELECT generate_series(1,55)" $ \(Only b) -> do 147 | xs <- readIORef ref 148 | writeIORef ref $! (a :: Int, b :: Int) : xs 149 | xs <- readIORef ref 150 | reverse xs @?= [(a,b) | a <- [1..101], b <- [1..55]] 151 | 152 | xs <- fold_ conn "SELECT 1 WHERE FALSE" 153 | [] $ \xs (Only x) -> return (x:xs) 154 | xs @?= ([] :: [Int]) 155 | 156 | -- TODO: add more complete tests, e.g.: 157 | -- 158 | -- * Fold in a transaction 159 | -- 160 | -- * Fold in a transaction after a previous fold has been performed 161 | -- 162 | -- * Nested fold 163 | 164 | return () 165 | 166 | queryFailure :: forall a. (FromField a, Typeable a, Show a) 167 | => Connection -> Query -> a -> Assertion 168 | queryFailure conn q resultType = do 169 | x :: Either SomeException [Only a] <- E.try $ query_ conn q 170 | case x of 171 | Left _ -> return () 172 | Right val -> assertFailure ("Did not fail as expected: " 173 | ++ show q 174 | ++ " :: " 175 | ++ show (typeOf resultType) 176 | ++ " -> " ++ show val) 177 | 178 | testArray :: TestEnv -> Assertion 179 | testArray TestEnv{..} = do 180 | xs <- query_ conn "SELECT '{1,2,3,4}'::_int4" 181 | xs @?= [Only (V.fromList [1,2,3,4 :: Int])] 182 | xs <- query_ conn "SELECT '{{1,2},{3,4}}'::_int4" 183 | xs @?= [Only (V.fromList [V.fromList [1,2], 184 | V.fromList [3,4 :: Int]])] 185 | queryFailure conn "SELECT '{1,2,3,4}'::_int4" (undefined :: V.Vector Bool) 186 | queryFailure conn "SELECT '{{1,2},{3,4}}'::_int4" (undefined :: V.Vector Int) 187 | 188 | testNullableArray :: TestEnv -> Assertion 189 | testNullableArray TestEnv{..} = do 190 | xs <- query_ conn "SELECT '{sometext, \"NULL\"}'::_text" 191 | xs @?= [Only (V.fromList ["sometext", "NULL" :: Text])] 192 | xs <- query_ conn "SELECT '{sometext, NULL}'::_text" 193 | xs @?= [Only (V.fromList [Just "sometext", Nothing :: Maybe Text])] 194 | queryFailure conn "SELECT '{sometext, NULL}'::_text" (undefined :: V.Vector Text) 195 | 196 | testHStore :: TestEnv -> Assertion 197 | testHStore TestEnv{..} = do 198 | execute_ conn "CREATE EXTENSION IF NOT EXISTS hstore" 199 | roundTrip [] 200 | roundTrip [("foo","bar"),("bar","baz"),("baz","hello")] 201 | roundTrip [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] 202 | where 203 | roundTrip :: [(Text,Text)] -> Assertion 204 | roundTrip xs = do 205 | let m = Only (HStoreMap (Map.fromList xs)) 206 | m' <- query conn "SELECT ?::hstore" m 207 | [m] @?= m' 208 | 209 | testCIText :: TestEnv -> Assertion 210 | testCIText TestEnv{..} = do 211 | execute_ conn "CREATE EXTENSION IF NOT EXISTS citext" 212 | roundTrip (CI.mk "") 213 | roundTrip (CI.mk "UPPERCASE") 214 | roundTrip (CI.mk "lowercase") 215 | where 216 | roundTrip :: (CI Text) -> Assertion 217 | roundTrip cit = do 218 | let toPostgres = Only cit 219 | fromPostgres <- query conn "SELECT ?::citext" toPostgres 220 | [toPostgres] @?= fromPostgres 221 | 222 | testJSON :: TestEnv -> Assertion 223 | testJSON TestEnv{..} = do 224 | roundTrip (Map.fromList [] :: Map Text Text) 225 | roundTrip (Map.fromList [("foo","bar"),("bar","baz"),("baz","hello")] :: Map Text Text) 226 | roundTrip (Map.fromList [("fo\"o","bar"),("b\\ar","baz"),("baz","\"value\\with\"escapes")] :: Map Text Text) 227 | roundTrip (V.fromList [1,2,3,4,5::Int]) 228 | roundTrip ("foo" :: Text) 229 | roundTrip (42 :: Int) 230 | where 231 | roundTrip :: ToJSON a => a -> Assertion 232 | roundTrip a = do 233 | let js = Only (toJSON a) 234 | js' <- query conn "SELECT ?::json" js 235 | [js] @?= js' 236 | 237 | testSavepoint :: TestEnv -> Assertion 238 | testSavepoint TestEnv{..} = do 239 | True <- expectError ST.isNoActiveTransactionError $ 240 | withSavepoint conn $ return () 241 | 242 | let getRows :: IO [Int] 243 | getRows = map fromOnly <$> query_ conn "SELECT a FROM tmp_savepoint ORDER BY a" 244 | withTransaction conn $ do 245 | execute_ conn "CREATE TEMPORARY TABLE tmp_savepoint (a INT UNIQUE)" 246 | execute_ conn "INSERT INTO tmp_savepoint VALUES (1)" 247 | [1] <- getRows 248 | 249 | withSavepoint conn $ do 250 | execute_ conn "INSERT INTO tmp_savepoint VALUES (2)" 251 | [1,2] <- getRows 252 | return () 253 | [1,2] <- getRows 254 | 255 | withSavepoint conn $ do 256 | execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" 257 | [1,2,3] <- getRows 258 | True <- expectError isUniqueViolation $ 259 | execute_ conn "INSERT INTO tmp_savepoint VALUES (2)" 260 | True <- expectError ST.isFailedTransactionError getRows 261 | 262 | -- Body returning successfully after handling error, 263 | -- but 'withSavepoint' will roll back without complaining. 264 | return () 265 | -- Rolling back clears the error condition. 266 | [1,2] <- getRows 267 | 268 | -- 'withSavepoint' will roll back after an exception, even if the 269 | -- exception wasn't SQL-related. 270 | True <- expectError (== TestException) $ 271 | withSavepoint conn $ do 272 | execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" 273 | [1,2,3] <- getRows 274 | throwIO TestException 275 | [1,2] <- getRows 276 | 277 | -- Nested savepoint can be rolled back while the 278 | -- outer effects are retained. 279 | withSavepoint conn $ do 280 | execute_ conn "INSERT INTO tmp_savepoint VALUES (3)" 281 | True <- expectError isUniqueViolation $ 282 | withSavepoint conn $ do 283 | execute_ conn "INSERT INTO tmp_savepoint VALUES (4)" 284 | [1,2,3,4] <- getRows 285 | execute_ conn "INSERT INTO tmp_savepoint VALUES (4)" 286 | [1,2,3] <- getRows 287 | return () 288 | [1,2,3] <- getRows 289 | 290 | return () 291 | 292 | -- Transaction committed successfully, even though there were errors 293 | -- (but we rolled them back). 294 | [1,2,3] <- getRows 295 | 296 | return () 297 | 298 | testUnicode :: TestEnv -> Assertion 299 | testUnicode TestEnv{..} = do 300 | let q = Query . T.encodeUtf8 -- Handle encoding ourselves to ensure 301 | -- the table gets created correctly. 302 | let messages = map Only ["привет","мир"] :: [Only Text] 303 | execute_ conn (q "CREATE TEMPORARY TABLE ру́сский (сообщение TEXT)") 304 | executeMany conn "INSERT INTO ру́сский (сообщение) VALUES (?)" messages 305 | messages' <- query_ conn "SELECT сообщение FROM ру́сский" 306 | sort messages @?= sort messages' 307 | 308 | testValues :: TestEnv -> Assertion 309 | testValues TestEnv{..} = do 310 | execute_ conn "CREATE TEMPORARY TABLE values_test (x int, y text)" 311 | test (Values ["int4","text"] []) 312 | test (Values ["int4","text"] [(1,"hello")]) 313 | test (Values ["int4","text"] [(1,"hello"),(2,"world")]) 314 | test (Values ["int4","text"] [(1,"hello"),(2,"world"),(3,"goodbye")]) 315 | test (Values [] [(1,"hello")]) 316 | test (Values [] [(1,"hello"),(2,"world")]) 317 | test (Values [] [(1,"hello"),(2,"world"),(3,"goodbye")]) 318 | where 319 | test :: Values (Int, Text) -> Assertion 320 | test table@(Values _ vals) = do 321 | execute conn "INSERT INTO values_test ?" (Only table) 322 | vals' <- query_ conn "DELETE FROM values_test RETURNING *" 323 | sort vals @?= sort vals' 324 | 325 | 326 | testCopy :: TestEnv -> Assertion 327 | testCopy TestEnv{..} = do 328 | execute_ conn "CREATE TEMPORARY TABLE copy_test (x int, y text)" 329 | copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)" 330 | mapM_ (putCopyData conn) copyRows 331 | putCopyEnd conn 332 | copy_ conn "COPY copy_test FROM STDIN (FORMAT CSV)" 333 | mapM_ (putCopyData conn) abortRows 334 | putCopyError conn "aborted" 335 | -- Hmm, does postgres always produce \n as an end-of-line here, or 336 | -- are there cases where it will use a \r\n as well? 337 | copy_ conn "COPY copy_test TO STDOUT (FORMAT CSV)" 338 | rows <- loop [] 339 | sort rows @?= sort copyRows 340 | -- Now, let's just verify that the connection state is back to ready, 341 | -- so that we can issue more queries: 342 | [Only (x::Int)] <- query_ conn "SELECT 2 + 2" 343 | x @?= 4 344 | where 345 | copyRows = ["1,foo\n" 346 | ,"2,bar\n"] 347 | abortRows = ["3,baz\n"] 348 | loop rows = do 349 | mrow <- getCopyData conn 350 | case mrow of 351 | CopyOutDone _ -> return rows 352 | CopyOutRow row -> loop (row:rows) 353 | 354 | testCopyFailures :: TestEnv -> TestTree 355 | testCopyFailures env = testGroup "Copy failures" 356 | $ map ($ env) 357 | [ testCopyUniqueConstraintError 358 | , testCopyMalformedError 359 | ] 360 | 361 | goldenTest :: TestName -> IO BL.ByteString -> TestTree 362 | goldenTest testName = 363 | goldenVsString testName (resultsDir fileName<.>"expected") 364 | where 365 | resultsDir = "test" "results" 366 | fileName = map normalize testName 367 | normalize c | not (isAlpha c) = '-' 368 | | otherwise = c 369 | 370 | -- | Test that we provide a sensible error message on failure 371 | testCopyUniqueConstraintError :: TestEnv -> TestTree 372 | testCopyUniqueConstraintError TestEnv{..} = 373 | goldenTest "unique constraint violation" 374 | $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do 375 | execute_ conn "CREATE TEMPORARY TABLE copy_unique_constraint_error_test (x int PRIMARY KEY, y text)" 376 | copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)" 377 | mapM_ (putCopyData conn) copyRows 378 | _n <- putCopyEnd conn 379 | return BL.empty 380 | where 381 | copyRows = ["1,foo\n" 382 | ,"2,bar\n" 383 | ,"1,baz\n"] 384 | 385 | testCopyMalformedError :: TestEnv -> TestTree 386 | testCopyMalformedError TestEnv{..} = 387 | goldenTest "malformed input" 388 | $ handle (\(SomeException exc) -> return $ BL.pack $ show exc) $ do 389 | execute_ conn "CREATE TEMPORARY TABLE copy_malformed_input_error_test (x int PRIMARY KEY, y text)" 390 | copy_ conn "COPY copy_unique_constraint_error_test FROM STDIN (FORMAT CSV)" 391 | mapM_ (putCopyData conn) copyRows 392 | _n <- putCopyEnd conn 393 | return BL.empty 394 | where 395 | copyRows = ["1,foo\n" 396 | ,"2,bar\n" 397 | ,"z,baz\n"] 398 | 399 | testTimeout :: TestEnv -> Assertion 400 | testTimeout TestEnv{..} = 401 | withConn $ \c -> do 402 | start_t <- getCurrentTime 403 | res <- timeout 200000 $ do 404 | withTransaction c $ do 405 | query_ c "SELECT pg_sleep(1)" :: IO [Only ()] 406 | end_t <- getCurrentTime 407 | assertBool "Timeout did not occur" (res == Nothing) 408 | #if !defined(mingw32_HOST_OS) 409 | -- At the moment, you cannot timely abandon queries with async exceptions on 410 | -- Windows. 411 | let d = end_t `diffUTCTime` start_t 412 | assertBool "Timeout didn't work in a timely fashion" (0.1 < d && d < 0.6) 413 | #endif 414 | 415 | testDouble :: TestEnv -> Assertion 416 | testDouble TestEnv{..} = do 417 | [Only (x :: Double)] <- query_ conn "SELECT 'NaN'::float8" 418 | assertBool "expected NaN" (isNaN x) 419 | [Only (x :: Double)] <- query_ conn "SELECT 'Infinity'::float8" 420 | x @?= (1 / 0) 421 | [Only (x :: Double)] <- query_ conn "SELECT '-Infinity'::float8" 422 | x @?= (-1 / 0) 423 | 424 | 425 | testGeneric1 :: TestEnv -> Assertion 426 | testGeneric1 TestEnv{..} = do 427 | roundTrip conn (Gen1 123) 428 | where 429 | roundTrip conn x0 = do 430 | r <- query conn "SELECT ?::int" (x0 :: Gen1) 431 | r @?= [x0] 432 | 433 | testGeneric2 :: TestEnv -> Assertion 434 | testGeneric2 TestEnv{..} = do 435 | roundTrip conn (Gen2 123 "asdf") 436 | where 437 | roundTrip conn x0 = do 438 | r <- query conn "SELECT ?::int, ?::text" x0 439 | r @?= [x0] 440 | 441 | testGeneric3 :: TestEnv -> Assertion 442 | testGeneric3 TestEnv{..} = do 443 | roundTrip conn (Gen3 123 "asdf" True) 444 | where 445 | roundTrip conn x0 = do 446 | r <- query conn "SELECT ?::int, ?::text, ?::bool" x0 447 | r @?= [x0] 448 | 449 | data Gen1 = Gen1 Int 450 | deriving (Show,Eq,Generic) 451 | instance FromRow Gen1 452 | instance ToRow Gen1 453 | 454 | data Gen2 = Gen2 Int Text 455 | deriving (Show,Eq,Generic) 456 | instance FromRow Gen2 457 | instance ToRow Gen2 458 | 459 | data Gen3 = Gen3 Int Text Bool 460 | deriving (Show,Eq,Generic) 461 | instance FromRow Gen3 462 | instance ToRow Gen3 463 | 464 | data TestException 465 | = TestException 466 | deriving (Eq, Show, Typeable) 467 | 468 | instance Exception TestException 469 | 470 | expectError :: Exception e => (e -> Bool) -> IO a -> IO Bool 471 | expectError p io = 472 | (io >> return False) `E.catch` \ex -> 473 | if p ex then return True else throwIO ex 474 | 475 | isUniqueViolation :: SqlError -> Bool 476 | isUniqueViolation SqlError{..} = sqlState == "23505" 477 | 478 | isSyntaxError :: SqlError -> Bool 479 | isSyntaxError SqlError{..} = sqlState == "42601" 480 | 481 | ------------------------------------------------------------------------ 482 | 483 | -- | Action for connecting to the database that will be used for testing. 484 | -- 485 | -- Note that some tests, such as Notify, use multiple connections, and assume 486 | -- that 'testConnect' connects to the same database every time it is called. 487 | testConnect :: IO Connection 488 | testConnect = connectPostgreSQL "" 489 | 490 | withTestEnv :: (TestEnv -> IO a) -> IO a 491 | withTestEnv cb = 492 | withConn $ \conn -> 493 | cb TestEnv 494 | { conn = conn 495 | , withConn = withConn 496 | } 497 | where 498 | withConn = bracket testConnect close 499 | 500 | main :: IO () 501 | main = withTestEnv $ defaultMain . tests 502 | --------------------------------------------------------------------------------