postgresql-pure (empty) → 0.1.0.0
raw patch · 44 files changed
+8343/−0 lines, 44 filesdep +HDBCdep +HDBC-postgresqldep +HDBC-sessionsetup-changed
Dependencies added: HDBC, HDBC-postgresql, HDBC-session, HUnit, Only, QuickCheck, attoparsec, base, base16-bytestring, bytestring, cassava, clock, containers, convertible, cryptohash-md5, data-default-class, deepseq, doctest, double-conversion, homotuple, hourglass, hspec, hspec-core, list-tuple, memory, mtl, network, old-time, optparse-applicative, persistable-record, postgres-wire, postgresql-binary, postgresql-libpq, postgresql-pure, postgresql-simple, postgresql-typed, pretty-hex, pureMD5, random-shuffle, relational-query, relational-query-HDBC, relational-record, safe-exceptions, scientific, single-tuple, text, time, utf8-string, vector
Files
- ChangeLog.md +11/−0
- LICENSE +175/−0
- README.md +15/−0
- Setup.hs +2/−0
- benchmark/RepeatThreadPool.hs +36/−0
- benchmark/requests-per-second-constant.hs +335/−0
- benchmark/requests-per-second.hs +324/−0
- postgresql-pure.cabal +412/−0
- src/Database/HDBC/PostgreSQL/Pure.hs +603/−0
- src/Database/HDBC/PostgreSQL/Pure/Parser.hs +157/−0
- src/Database/PostgreSQL/Pure.hs +376/−0
- src/Database/PostgreSQL/Pure/Internal/Builder.hs +609/−0
- src/Database/PostgreSQL/Pure/Internal/Connection.hs +157/−0
- src/Database/PostgreSQL/Pure/Internal/Data.hs +593/−0
- src/Database/PostgreSQL/Pure/Internal/Exception.hs +101/−0
- src/Database/PostgreSQL/Pure/Internal/IsLabel.hs +14/−0
- src/Database/PostgreSQL/Pure/Internal/MonadFail.hs +18/−0
- src/Database/PostgreSQL/Pure/Internal/Parser.hs +839/−0
- src/Database/PostgreSQL/Pure/Internal/Query.hs +300/−0
- src/Database/PostgreSQL/Pure/Internal/SocketIO.hs +118/−0
- src/Database/PostgreSQL/Pure/List.hs +123/−0
- src/Database/PostgreSQL/Pure/Oid.hs +1059/−0
- src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs +219/−0
- src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs +129/−0
- test-doctest/doctest.hs +9/−0
- test-hdbc-postgresql/SpecificDB.hs +43/−0
- test-hdbc-postgresql/SpecificDBTests.hs +26/−0
- test-hdbc-postgresql/TestMisc.hs +180/−0
- test-hdbc-postgresql/TestSbasics.hs +171/−0
- test-hdbc-postgresql/TestTime.hs +119/−0
- test-hdbc-postgresql/TestUtils.hs +25/−0
- test-hdbc-postgresql/Testbasics.hs +168/−0
- test-hdbc-postgresql/Tests.hs +19/−0
- test-hdbc-postgresql/runtests.hs +12/−0
- test-relational-record/DataSource.hs +7/−0
- test-relational-record/DataSource/Pure.hs +7/−0
- test-relational-record/Relation/Person.hs +17/−0
- test-relational-record/Relation/Pure/Person.hs +17/−0
- test-relational-record/Spec.hs +19/−0
- test/Database/HDBC/PostgreSQL/PureSpec.hs +120/−0
- test/Database/PostgreSQL/Pure/ListSpec.hs +313/−0
- test/Database/PostgreSQL/PureSpec.hs +315/−0
- test/Spec.hs +1/−0
- test/Test/Hspec/Core/Hooks/Extra.hs +30/−0
+ ChangeLog.md view
@@ -0,0 +1,11 @@+# Changelog for postgres-pure++## 0.1.0++2019.10.21++Release.++### Known Issues++- Sometimes missing “Error” responses after “Sync” requests
+ LICENSE view
@@ -0,0 +1,175 @@+Copyright (c) 2019, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in+ the documentation and/or other materials provided with the+ distribution.+ * Neither the name of the copyright holders nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.++# postgresql-simple++## Files++- src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs+- src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs++## Full Text++Copyright (c) 2011, Leon P Smith++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Leon P Smith nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++Copyright (c) 2011, MailRank, Inc.++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.++# HDBC-postgresql++## Files++- test-hdbc-postgresql/runtests.hs+- test-hdbc-postgresql/SpecificDB.hs+- test-hdbc-postgresql/SpecificDBTests.hs+- test-hdbc-postgresql/Testbasics.hs+- test-hdbc-postgresql/TestMisc.hs+- test-hdbc-postgresql/TestSbasics.hs+- test-hdbc-postgresql/Tests.hs+- test-hdbc-postgresql/TestTime.hs+- test-hdbc-postgresql/TestUtils.hs++## Full Text++Copyright (c) 2005-2011 John Goerzen+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice, this+ list of conditions and the following disclaimer in the documentation and/or+ other materials provided with the distribution.++* Neither the name of John Goerzen nor the names of its+ contributors may be used to endorse or promote products derived from this+ software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.++# postgres-wire++## Files++- benchmark/requests-per-second.hs++## Full Text++MIT License++Copyright (c) 2017 Vyacheslav Hashov++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,15 @@+# postgresql-pure++## Copyright++2019 IIJ Innovation Institute Inc.++And some files are licensed by followings. See the LICENSE file for details.++- BSD-3-Clause+ - 2012-2015 Leon P Smith+ - 2015 Bryan O'Sullivan+- BSD-3-Clause+ - 2005-2011 John Goerzen+- MIT+ - 2017 Vyacheslav Hashov
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benchmark/RepeatThreadPool.hs view
@@ -0,0 +1,36 @@+module RepeatThreadPool+ ( Pool+ , start+ , state+ , kill+ ) where++import Control.Concurrent (ThreadId, forkIO, killThread)+import Control.Monad (replicateM)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Traversable (for)++newtype Pool a = Pool [(ThreadId, IORef a)]++start :: Word -> IO a -> (a -> IO a) -> IO (Pool a)+start n ini task = do+ ts <- replicateM (fromIntegral n) $ do+ s <- ini+ ref <- newIORef s+ tid <- forkIO $ go ref s+ pure (tid, ref)+ pure $ Pool ts+ where+ go r s = do+ s' <- task s+ writeIORef r s'+ go r s'++state :: Pool a -> IO [a]+state (Pool ts) = for ts $ \(_, ref) -> readIORef ref++kill :: Pool a -> IO [a]+kill (Pool ts) =+ for ts $ \(tid, ref) -> do+ killThread tid+ readIORef ref
+ benchmark/requests-per-second-constant.hs view
@@ -0,0 +1,335 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}++{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- for postgresql-typed's pgSQL quasiquotes++import qualified Database.PostgreSQL.Simple as S+#if !MIN_VERSION_postgresql_simple(0,6,0)+import qualified Database.PostgreSQL.Simple.FromField as S+import qualified Database.PostgreSQL.Simple.FromRow as S+#endif++import qualified Database.PostgreSQL.Pure as P+import qualified Database.PostgreSQL.Pure.Oid as P++import qualified Database.PostgreSQL.Typed as T++#ifndef mingw32_HOST_OS+import qualified Database.PostgreSQL.Driver as W+import qualified Database.PostgreSQL.Protocol.Codecs.Decoders as WD+import qualified Database.PostgreSQL.Protocol.DataRows as W+import qualified Database.PostgreSQL.Protocol.Decoders as WD+import qualified Database.PostgreSQL.Protocol.Store.Decode as WD+#endif++import qualified RepeatThreadPool as Pool++import Control.Applicative ((<|>))+import Control.Concurrent (threadDelay)+import Control.DeepSeq (NFData (rnf), deepseq)+import Control.Exception (AsyncException (ThreadKilled), catchJust, throwIO)+import Control.Monad (void)+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.Attoparsec.ByteString.Char8 as APC+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.UTF8 as BSU+import qualified Data.Csv as Csv+import Data.Default.Class (def)+import Data.Functor (($>))+import Data.Hourglass (TimeFormatElem (Format_Day2, Format_Hour, Format_Minute, Format_Month2, Format_Second, Format_Text, Format_TzHM, Format_Year),+ TimeFormatString (TimeFormatString), timePrint)+import Data.Int (Int32, Int64)+import Data.IORef+import Data.List (sortOn)+import Data.Maybe (fromJust, fromMaybe)+import Data.Proxy (Proxy (Proxy))+import Data.Scientific+import Data.String (IsString)+import Data.Time+import Data.Traversable (for)+import GHC.Generics (Generic)+import System.CPUTime (getCPUTime)+import System.Environment (lookupEnv)+import System.Hourglass (timeCurrent)+import System.IO (IOMode (WriteMode), withFile)+import System.Random.Shuffle (shuffleM)+import Time.System (timeCurrentP)+import Time.Types (Elapsed (Elapsed), ElapsedP (ElapsedP),+ NanoSeconds (NanoSeconds), Seconds (Seconds))++#if !MIN_VERSION_postgresql_typed(0,6,0)+import Network (PortID (PortNumber))+#endif++main :: IO ()+main = do+ current <- timeCurrent+ host <- getEnvDef "PB_HOST" "localhost"+ concurrencies <- parseEnvDef "PB_CONCURRENCY" [10] (listParser concurrencyParser)+ period <- parseEnvDef "PB_PERIOD" 60 periodParser+ sample <- readEnvDef "PB_SAMPLE" 1+ libraries <- parseEnvDef "PB_LIBRARY" measures (listParser libraryParser)+ patterns <- shuffleM $ (,,) <$> libraries <*> concurrencies <*> [0 .. sample - 1]+ dat <-+ for patterns $ \((name, measure), concurrency, nth) -> do+ let config = Config { concurrency, period, host }+ putStrLn $ "target: " <> name <> ", concurrency: " <> show concurrency <> ", nth: " <> show nth+ Result cpuTime tps <- measure config+ pure $ ResultRecord name concurrency nth cpuTime tps+ let+ sortedDat =+ sortOn+ (\ResultRecord { methodName, concurrency, nth } -> (methodName, concurrency, nth))+ dat+ let csv = Csv.encodeDefaultOrderedByName sortedDat+ withFile ("constant-" <> timePrint timeFormat current <> ".csv") WriteMode $ flip BSL.hPutStr csv++listParser :: AP.Parser a -> AP.Parser [a]+listParser p = ((:) <$> (p <* APC.char ',' <* AP.many' APC.space) <*> listParser p) <|> ((:[]) <$> p)++concurrencyParser :: AP.Parser Word+concurrencyParser = APC.decimal++periodParser :: AP.Parser Word+periodParser = do+ n <- APC.decimal+ unit <- (APC.char 's' $> 1) <|> (APC.char 'm' $> 60)+ pure $ n * unit++libraryParser :: AP.Parser (String, Config -> IO Result)+libraryParser =+ ("pure" $> ("pure", measurePure))+ <|> ("simple" $> ("simple", measureSimple))+ <|> ("typed" $> ("typed", measureTyped))+ <|> ("wire" $> ("wire", measureWire))++query :: IsString a => a+query = "SELECT 2147483647 :: int4, 9223372036854775807 :: int8, 1234567890.0123456789 :: numeric, 0.015625 :: float4, 0.00024414062 :: float8, 'hello' :: varchar, 'hello' :: text, '\\xDEADBEEF' :: bytea, '1000-01-01 00:00:00.000001' :: timestamp, '2000-01-01 00:00:00.000001+14:30' :: timestamptz, '0001-01-01' :: date, '23:00:00' :: time, true :: bool"++measures :: [(String, Config -> IO Result)]+measures =+ [ ("pure", measurePure)+ , ("simple", measureSimple)+ , ("typed", measureTyped)+#ifndef mingw32_HOST_OS+ , ("wire", measureWire)+#endif+ ]++data PureConnection = PureConnection { psRef :: IORef (Maybe (P.PreparedStatement 0 13)), connection :: P.Connection }++measurePure :: Config -> IO Result+measurePure config@Config { host } = do+ let+ pureConfig =+ def+ { P.user = "postgres"+ , P.database = "tiny_tpcc"+ , P.address = P.AddressNotResolved host "5432"+ }+ doMeasure+ config+ (PureConnection <$> newIORef Nothing <*> P.connect pureConfig)+ (P.disconnect . connection)+ $ \PureConnection { psRef, connection } -> do+ mps <- readIORef psRef+ case mps of+ Nothing -> do+ let+ resultOids = (P.int4, P.int8, P.numeric, P.float4, P.float8, P.varchar, P.text, P.bytea, P.timestamp, P.timestamptz, P.date, P.time, P.bool)+ psProc = P.parse "ps" (P.Query query) (Just (Proxy, resultOids)) :: P.PreparedStatementProcedure 0 13+ pProc = fromJust $ P.bind "" P.BinaryFormat P.BinaryFormat (P.parameters connection) (const $ fail "") () psProc :: P.PortalProcedure 0 13+ eProc = P.execute 0 (const $ fail "") pProc :: P.ExecutedProcedure 0 13 (Int32, Int64, Scientific, Float, Double, ByteString, ByteString, ByteString, LocalTime, UTCTime, Day, TimeOfDay, Bool)+ ((ps, _, e, _), _) <- P.sync connection eProc+ deepseq (P.records e) $ pure ()+ writeIORef psRef $ Just ps+ Just ps -> do+ let+ pProc = fromJust $ P.bind "" P.BinaryFormat P.BinaryFormat (P.parameters connection) (const $ fail "") () ps :: P.PortalProcedure 0 13+ eProc = P.execute 0 (const $ fail "") pProc :: P.ExecutedProcedure 0 13 (Int32, Int64, Scientific, Float, Double, ByteString, ByteString, ByteString, LocalTime, UTCTime, Day, TimeOfDay, Bool)+ void $ P.sync connection eProc++measureSimple :: Config -> IO Result+measureSimple config@Config { host } = do+ let libpqParam = "user='postgres' dbname='tiny_tpcc' host='" <> BSU.fromString host <> "'"+ doMeasure+ config+ (S.connectPostgreSQL libpqParam)+ S.close+ $ \conn -> do+ r <- S.query_ conn query :: IO [(Int32, Int64, Scientific, Float, Double, ByteString, ByteString, ByteString, LocalTime, UTCTime, Day, TimeOfDay, Bool)]+ deepseq r $ pure ()++measureTyped :: Config -> IO Result+measureTyped config@Config { host } = do+ let+ postgresqlConfig =+ T.defaultPGDatabase+ { T.pgDBUser = "postgres"+ , T.pgDBName = "tiny_tpcc"+#if MIN_VERSION_postgresql_typed(0,6,0)+ , T.pgDBAddr = Left (host, "5432")+#else+ , T.pgDBHost = host+ , T.pgDBPort = PortNumber 5432+#endif+ }+ doMeasure+ config+ (T.pgConnect postgresqlConfig)+ T.pgDisconnect+ $ \conn -> do+ r <-+ T.pgQuery+ conn+ [T.pgSQL|! SELECT 2147483647 :: int4, 9223372036854775807 :: int8, 1234567890.0123456789 :: numeric, 0.015625 :: float4, 0.00024414062 :: float8, 'hello' :: varchar, 'hello' :: text, '\xDEADBEEF' :: bytea, '1000-01-01 00:00:00.000001' :: timestamp, '2000-01-01 00:00:00.000001+14:30' :: timestamptz, '0001-01-01' :: date, '23:00:00' :: time, true :: bool |]+ :: IO [(Int32, Int64, Scientific, Float, Double, ByteString, ByteString, ByteString, LocalTime, UTCTime, Day, TimeOfDay, Bool)]+ deepseq r $ pure ()++measureWire :: Config -> IO Result+#ifdef mingw32_HOST_OS+measureWire = error "postgres-wire can run on only UNIX-like environments"+#else+measureWire config@Config { host } = do+ let+ wireConfig =+ W.defaultConnectionSettings+ { W.settingsUser = "postgres"+ , W.settingsDatabase = "tiny_tpcc"+ , W.settingsHost = BSU.fromString host+ , W.settingsPort = 5432+ }+ doMeasure+ config+ (either (error . show) id <$> W.connect wireConfig)+ W.close+ $ \conn -> do+ W.sendBatchAndSync conn [W.Query query [] W.Binary W.Binary W.AlwaysCache]+ rows <- either (error . show) id <$> W.readNextData conn+ let+ decoder = do+ void WD.decodeHeader+ void WD.getInt16BE+ (,,,,,,,,,,,,)+ <$> WD.getNonNullable WD.int4+ <*> WD.getNonNullable WD.int8+ <*> WD.getNonNullable WD.numeric+ <*> WD.getNonNullable WD.float4+ <*> WD.getNonNullable WD.float8+ <*> WD.getNonNullable WD.bsText+ <*> WD.getNonNullable WD.bsText+ <*> WD.getNonNullable WD.bytea+ <*> WD.getNonNullable WD.timestamp+ <*> WD.getNonNullable WD.timestamptz+ <*> WD.getNonNullable WD.date+ <*> WD.getNonNullable WD.time+ <*> WD.getNonNullable WD.bool+ records = W.decodeManyRows decoder rows+ deepseq records $ pure ()+ either (error . show) id <$> W.waitReadyForQuery conn+#endif++doMeasure :: Config -> IO conn -> (conn -> IO ()) -> (conn -> IO ())-> IO Result+doMeasure Config { concurrency, period } makeConn disposeConn target = do+ time <- timeCurrentP -- nanoseconds+ cpuTime <- getCPUTime -- picoseconds+ pool <-+ Pool.start+ concurrency+ ( do+ conn <- makeConn+ pure (conn, 0 :: Word)+ )+ ( \(conn, count) ->+ catchJust+ (\e -> if e == ThreadKilled then Just e else Nothing)+ (target conn $> (conn, count + 1))+ (\e -> disposeConn conn *> throwIO e)+ )+ threadDelay $ fromIntegral period * 1000 * 1000 -- microseconds+ time' <- timeCurrentP+ cpuTime' <- getCPUTime+ (_, counts) <- unzip <$> Pool.kill pool+ let+ count = sum counts+ actualPeriod@(ElapsedP (Elapsed (Seconds apSecs)) (NanoSeconds apNanosecs)) = time' - time+ cpuPeriod = cpuTime' - cpuTime+ (cpuSecs, cpuPicosecs) = cpuPeriod `divMod` (1000 ^ (4 :: Int))+ tps' = fromIntegral count / (fromIntegral apSecs + fromIntegral apNanosecs / 1000 ^ (3 :: Int)) :: Double+ putStrLn $ "measurement period: " <> show actualPeriod+ putStrLn $ "CPU time: " <> show cpuSecs <> "s " <> show cpuPicosecs <> "ps"+ putStrLn $ "transactions per second: " <> show tps'+ pure $ Result cpuPeriod tps'++data Config =+ Config+ { concurrency :: Word -- ^ the number of threads+ , period :: Word -- ^ measurement period in second+ , host :: String+ } deriving (Show, Read, Eq)++data ResultRecord =+ ResultRecord+ { methodName :: String+ , concurrency :: Word+ , nth :: Word+ , cpuTime :: Integer+ , tps :: Double+ }+ deriving (Show, Read, Generic)++data Result = Result { cpuTime :: Integer, tps :: Double } deriving (Show, Read, Eq)++instance Csv.FromNamedRecord ResultRecord+instance Csv.ToNamedRecord ResultRecord+instance Csv.DefaultOrdered ResultRecord++getEnvDef :: String -> String -> IO String+getEnvDef name value = fromMaybe value <$> lookupEnv name++readEnvDef :: Read a => String -> a -> IO a+readEnvDef name value = maybe value read <$> lookupEnv name++parseEnvDef :: String -> a -> AP.Parser a -> IO a+parseEnvDef name value parser = do+ mstr <- lookupEnv name+ case mstr of+ Nothing -> pure value+ Just str ->+ case AP.parseOnly parser $ BSC.pack str of+ Left e -> error $ "parseEnv " <> name <> ": " <> e+ Right a -> pure a++timeFormat :: TimeFormatString+timeFormat =+ TimeFormatString+ [ Format_Year, dash, Format_Month2, dash, Format_Day2 -- date+ , Format_Text 'T'+ , Format_Hour, dash, Format_Minute, dash, Format_Second -- time+ , Format_TzHM+ ]+ where+ dash = Format_Text '-'++instance+ (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9, NFData a10, NFData a11, NFData a12, NFData a13)+ => NFData ((,,,,,,,,,,,,) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13) where+ rnf (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` rnf x13++#if !MIN_VERSION_postgresql_simple(0,6,0)+-- 13-tuple+instance+ ( S.FromField a, S.FromField b, S.FromField c, S.FromField d, S.FromField e, S.FromField f, S.FromField g+ , S.FromField h, S.FromField i, S.FromField j, S.FromField k, S.FromField l, S.FromField m)+ => S.FromRow (a, b, c, d, e, f, g, h, i, j, k, l, m) where+ fromRow = (,,,,,,,,,,,,) <$> S.field <*> S.field <*> S.field <*> S.field <*> S.field <*> S.field <*> S.field+ <*> S.field <*> S.field <*> S.field <*> S.field <*> S.field <*> S.field+#endif
+ benchmark/requests-per-second.hs view
@@ -0,0 +1,324 @@+{- original: https://github.com/postgres-haskell/postgres-wire/blob/master/bench/Bench.hs -}++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++{-# OPTIONS_GHC -Wno-orphans#-}++import Control.Concurrent+import Control.DeepSeq (NFData, deepseq, rnf)+import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import Data.Default.Class (def)+import Data.Foldable+import Data.Int+import Data.IORef+import Data.Maybe+import Data.Proxy+import Data.Scientific (Scientific)+import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone, UTCTime)+import Data.Tuple.Homotuple.Only ()+import Data.Tuple.List.Only ()+import Data.Tuple.Only+import Options.Applicative+import System.Clock+import System.Environment (lookupEnv)++import qualified Database.PostgreSQL.LibPQ as LibPQ++import qualified Database.PostgreSQL.Pure as Pure+import qualified Database.PostgreSQL.Pure.Oid as Pure++#ifndef mingw32_HOST_OS+import qualified Data.ByteString.Lazy as BL++import Database.PostgreSQL.Driver+import qualified Database.PostgreSQL.Protocol.Codecs.Decoders as WD+import Database.PostgreSQL.Protocol.DataRows+import qualified Database.PostgreSQL.Protocol.Decoders as WD+import qualified Database.PostgreSQL.Protocol.Store.Decode as WD+import Database.PostgreSQL.Protocol.Types+#endif++{-+CREATE TABLE _bytes_100_of_1k(b bytea);+CREATE TABLE _bytes_400_of_200(b bytea);+CREATE TABLE _bytes_10_of_20k(b bytea);+CREATE TABLE _bytes_1_of_200(b bytea);+CREATE TABLE _bytes_300_of_100(b bytea);++INSERT INTO _bytes_100_of_1k(b)+ (SELECT repeat('a', 1000)::bytea FROM generate_series(1, 100));++INSERT INTO _bytes_400_of_200(b)+ (SELECT repeat('a', 200)::bytea FROM generate_series(1, 400));++INSERT INTO _bytes_10_of_20k(b)+ (SELECT repeat('a', 20000)::bytea FROM generate_series(1, 10));++INSERT INTO _bytes_1_of_200(b) VALUES(repeat('a', 200)::bytea);++INSERT INTO _bytes_300_of_100(b)+ (SELECT repeat('a', 100)::bytea FROM generate_series(1, 300));+-}++data Action+ = BenchPW RowsType+ | BenchPure RowsType+ | BenchLibPQ RowsType+ | BenchLoop+ deriving (Show, Eq)++data RowsType+ = Bytes100_1k+ | Bytes400_200+ | Bytes10_20k+ | Bytes1_200+ | Bytes300_100+ | Constant+ deriving (Show, Eq)++data Config =+ Config+ { host :: String+ , database :: String+ , user :: String+ , password :: String+ }+ deriving (Show, Read, Eq)++cli :: Parser Action+cli = hsubparser $+ cmd "pw" "benchmark postgres-wire" (BenchPW <$> rowTypeParser)+ <> cmd "pure" "benchmark postgresql-pure" (BenchPure <$> rowTypeParser)+ <> cmd "libpq" "benchmark libpq" (BenchLibPQ <$> rowTypeParser)+ <> cmd "loop" "benchmark datarows decoding loop" (pure BenchLoop)+ where+ cmd c h p = command c (info (helper <*> p) $ header h)+ rowTypeParser = hsubparser $+ cmd "b100_1k" "100 rows of 1k bytes" (pure Bytes100_1k)+ <> cmd "b400_200" "400 rows of 200 bytes" (pure Bytes400_200)+ <> cmd "b10_20k" "10 rows of 20k bytes" (pure Bytes10_20k)+ <> cmd "b1_200" "1 row of 200 bytes" (pure Bytes1_200)+ <> cmd "b300_100" "300 rows of 100 bytes" (pure Bytes300_100)+ <> cmd "constant" "constant values" (pure Constant)++main :: IO ()+main = do+ host <- getEnvDef "PB_HOST" "localhost"+ database <- getEnvDef "PB_DB" "postgres"+ user <- getEnvDef "PB_USER" "postgres"+ password <- getEnvDef "PB_PASSWORD" ""+ act <- execParser (info (helper <*> cli) $ header "Postgres-wire benchmark")+ execAction Config { host, database, user, password } act++execAction :: Config -> Action -> IO ()+execAction config (BenchPW rows) = benchPw config rows+execAction config (BenchPure rows) = benchPure config rows+execAction config (BenchLibPQ rows) = benchLibpq config rows+execAction config BenchLoop = benchLoop config++queryStatement :: RowsType -> B.ByteString+queryStatement = \case+ Bytes100_1k -> "SELECT * from _bytes_100_of_1k"+ Bytes400_200 -> "SELECT * from _bytes_400_of_200"+ Bytes10_20k -> "SELECT * from _bytes_10_of_20k"+ Bytes1_200 -> "SELECT * from _bytes_1_of_200"+ Bytes300_100 -> "SELECT * from _bytes_300_of_100"+ Constant -> "SELECT 2147483647 :: int4, 9223372036854775807 :: int8, 1234567890.0123456789 :: numeric, 0.015625 :: float4, 0.00024414062 :: float8, 'hello' :: varchar, 'hello' :: text, '\\xDEADBEEF' :: bytea, '1000-01-01 00:00:00.000001' :: timestamp, '2000-01-01 00:00:00.000001+14:30' :: timestamptz, '0001-01-01 BC' :: date, '24:00:00' :: time, '00:00:00+1459' :: timetz, '177999 millenniums 0.999999 sec' :: interval, true :: bool;"++benchPw :: Config -> RowsType -> IO ()+#ifdef mingw32_HOST_OS+benchPw = error "postgres-wire can run on only UNIX-like environments"+#else+benchPw Config { host, database, user, password } rowsType =+ benchRequests createConnection $ \c ->+ case rowsType of+ Constant -> do+ sendBatchAndSync c [q]+ rows <- either (error . show) id <$> readNextData c+ let+ decoder = do+ void WD.decodeHeader+ void WD.getInt16BE+ (,,,,,,,,,,,,,,)+ <$> WD.getNonNullable WD.int4+ <*> WD.getNonNullable WD.int8+ <*> WD.getNonNullable WD.numeric+ <*> WD.getNonNullable WD.float4+ <*> WD.getNonNullable WD.float8+ <*> WD.getNonNullable WD.bsText+ <*> WD.getNonNullable WD.bsText+ <*> WD.getNonNullable WD.bytea+ <*> WD.getNonNullable WD.timestamp+ <*> WD.getNonNullable WD.timestamptz+ <*> WD.getNonNullable WD.date+ <*> WD.getNonNullable WD.time+ <*> WD.getNonNullable WD.timetz+ <*> WD.getNonNullable WD.interval+ <*> WD.getNonNullable WD.bool+ records = decodeManyRows decoder rows+ deepseq records $ pure ()+ waitReadyForQuery c+ _ -> do+ sendBatchAndSync c [q]+ void $ readNextData c+ waitReadyForQuery c+ where+ statement = queryStatement rowsType+ q = Query statement [] Binary Binary AlwaysCache+ createConnection = connect defaultSettings >>=+ either (error . ("Connection error " <>) . show) pure++ defaultSettings = defaultConnectionSettings+ { settingsHost = BC.pack host+ , settingsDatabase = BC.pack database+ , settingsUser = BC.pack user+ , settingsPassword = BC.pack password+ }+#endif++benchPure :: Config -> RowsType -> IO ()+benchPure Config { host, database, user, password } rowsType =+ case rowsType of+ Constant ->+ benchRequests ((,) <$> connect <*> newIORef Nothing) $ \(c, psRef) -> do+ mps <- readIORef psRef+ case mps of+ Nothing -> do+ let+ resultOids = (Pure.int4, Pure.int8, Pure.numeric, Pure.float4, Pure.float8, Pure.varchar, Pure.text, Pure.bytea, Pure.timestamp, Pure.timestamptz, Pure.date, Pure.time, Pure.timetz, Pure.interval, Pure.bool)+ psProc = Pure.parse "ps" (Pure.Query statement) (Just (Proxy, resultOids)) :: Pure.PreparedStatementProcedure 0 15+ pProc = fromJust $ Pure.bind "" Pure.BinaryFormat Pure.BinaryFormat (Pure.parameters c) (const $ fail "") () psProc :: Pure.PortalProcedure 0 15+ eProc = Pure.execute 0 (const $ fail "") pProc :: Pure.ExecutedProcedure 0 15 (Int32, Int64, Scientific, Float, Double, ByteString, ByteString, ByteString, LocalTime, UTCTime, Day, TimeOfDay, (TimeOfDay, TimeZone), DiffTime, Bool)+ ((ps, _, e, _), _) <- Pure.sync c eProc+ deepseq (Pure.records e) $ pure ()+ writeIORef psRef $ Just ps+ Just ps -> do+ let+ pProc = fromJust $ Pure.bind "" Pure.BinaryFormat Pure.BinaryFormat (Pure.parameters c) (const $ fail "") () ps :: Pure.PortalProcedure 0 15+ eProc = Pure.execute 0 (const $ fail "") pProc :: Pure.ExecutedProcedure 0 15 (Int32, Int64, Scientific, Float, Double, ByteString, ByteString, ByteString, LocalTime, UTCTime, Day, TimeOfDay, (TimeOfDay, TimeZone), DiffTime, Bool)+ void $ Pure.sync c eProc+ _ ->+ benchRequests ((,) <$> connect <*> newIORef Nothing) $ \(c, psRef) -> do+ mps <- readIORef psRef+ case mps of+ Nothing -> do+ let+ psProc = Pure.parse "ps" (Pure.Query statement) (Just (Proxy, Only Pure.bytea)) :: Pure.PreparedStatementProcedure 0 1+ pProc = fromJust $ Pure.bind "" Pure.BinaryFormat Pure.BinaryFormat (Pure.parameters c) (const $ fail "") () psProc :: Pure.PortalProcedure 0 1+ eProc = Pure.execute 0 (const $ fail "") pProc :: Pure.ExecutedProcedure 0 1 (Only Pure.Raw)+ ((ps, _, _, _), _) <- Pure.sync c eProc+ writeIORef psRef $ Just ps+ Just ps -> do+ let+ pProc = fromJust $ Pure.bind "" Pure.BinaryFormat Pure.BinaryFormat (Pure.parameters c) (const $ fail "") () ps :: Pure.PortalProcedure 0 1+ eProc = Pure.execute 0 (const $ fail "") pProc :: Pure.ExecutedProcedure 0 1 (Only Pure.Raw)+ void $ Pure.sync c eProc+ where+ statement = queryStatement rowsType+ connect =+ Pure.connect+ def+ { Pure.user = user+ , Pure.password = password+ , Pure.database = database+ , Pure.address = Pure.AddressNotResolved host "5432"+ }++benchLibpq :: Config -> RowsType -> IO ()+benchLibpq Config { host, database, user, password } rowsType = benchRequests libpqConnection $ \c -> do+ r <- fromJust <$> LibPQ.execPrepared c "" [] LibPQ.Binary+ rows <- LibPQ.ntuples r+ parseRows r (rows - 1)+ where+ statement = queryStatement rowsType+ libpqConnection = do+ conn <- LibPQ.connectdb $ "host='" <> BC.pack host <> "' user='" <> BC.pack user <> "' dbname='" <> BC.pack database <> "' password='" <> BC.pack password <> "'"+ Just result <- LibPQ.prepare conn "" statement Nothing+ status <- LibPQ.resultStatus result+ unless (status == LibPQ.CommandOk) $ error "prepare failed"+ pure conn+ parseRows _ (-1) = pure ()+ parseRows r n = LibPQ.getvalue r n 0 >> parseRows r (n - 1)++benchRequests :: IO c -> (c -> IO a) -> IO ()+benchRequests connectAction queryAction = do+ results <- replicateM 8 newThread+ threadDelay $ durationSeconds * 1000 * 1000+ for_ results $ \(_, _, tid) -> killThread tid+ s <- sum <$> traverse (\(ref, _, _) -> readIORef ref) results+ latency_total <- sum <$> traverse (\(_, ref, _) -> readIORef ref) results++ putStrLn $ "Requests per second: " ++ show (s `div` durationSeconds)+ putStrLn $ "Average latency [ms]: " ++ displayLatency latency_total s+ where+ durationSeconds :: Int+ durationSeconds = 10+ newThread = do+ ref_count <- newIORef 0 :: IO (IORef Int)+ ref_latency <- newIORef 0 :: IO (IORef Int64)+ c <- connectAction+ tid <- forkIO $ forever $ do+ t1 <- getTime Monotonic+ r <- queryAction c+ r `seq` pure ()+ t2 <- getTime Monotonic+ modifyIORef' ref_latency (+ getDifference t2 t1)+ modifyIORef' ref_count (+1)+ pure (ref_count, ref_latency, tid)++ getDifference (TimeSpec end_s end_ns) (TimeSpec start_s start_ns) =+ (end_s - start_s) * 1000000000 + end_ns - start_ns++ displayLatency latency reqs =+ let a = latency `div` fromIntegral reqs+ (ms, ns) = a `divMod` 1000000+ in show ms <> "." <> show ns++benchLoop :: Config -> IO ()+#ifdef mingw32_HOST_OS+benchLoop = error "postgres-wire can run on only UNIX-like environments"+#else+benchLoop _config = do+ counter <- newIORef 0 :: IO (IORef Word)+ content <- newIORef "" :: IO (IORef BL.ByteString)+ -- File contains a PostgreSQL binary response on the query:+ -- "SELECT typname, typnamespace, typowner, typlen, typbyval,+ -- typcategory, typispreferred, typisdefined, typdelim,+ -- typrelid, typelem, typarray from pg_type"+ !bs <- B.readFile "bench/pg_type_rows.out"+ writeIORef content . BL.cycle $ BL.fromStrict bs++ let handler dm = case dm of+ DataMessage _ -> modifyIORef' counter (+1)+ _ -> pure ()+ newChunk preBs = do+ b <- readIORef content+ let (nb, rest) = BL.splitAt 4096 b+ writeIORef content rest+ let res = preBs <> BL.toStrict nb+ res `seq` pure res+ tid <- forkIO . forever $ loopExtractDataRows newChunk handler+ threadDelay $ durationSeconds * 1000 * 1000+ killThread tid+ s <- readIORef counter+ putStrLn $ "Data messages parsed per second: "+ ++ show (s `div` fromIntegral durationSeconds)+ where+ durationSeconds :: Int+ durationSeconds = 10+#endif++getEnvDef :: String -> String -> IO String+getEnvDef name val = fromMaybe val <$> lookupEnv name++instance (NFData a1, NFData a2, NFData a3, NFData a4, NFData a5, NFData a6, NFData a7, NFData a8, NFData a9, NFData a10, NFData a11, NFData a12, NFData a13, NFData a14, NFData a15) =>+ NFData ((,,,,,,,,,,,,,,) a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 a13 a14 a15) where+ rnf (x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11,x12,x13,x14,x15) = rnf x1 `seq` rnf x2 `seq` rnf x3 `seq` rnf x4 `seq` rnf x5 `seq` rnf x6 `seq` rnf x7 `seq` rnf x8 `seq` rnf x9 `seq` rnf x10 `seq` rnf x11 `seq` rnf x12 `seq` rnf x13 `seq` rnf x14 `seq` rnf x15
+ postgresql-pure.cabal view
@@ -0,0 +1,412 @@+cabal-version: 2.2 ++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: bbd1588f7e1a8f7ac0f863daa68188df3e5ac652f2214749c877d9d10d1610d4++name: postgresql-pure+version: 0.1.0.0+synopsis: pure Haskell PostgreSQL driver+description: pure Haskell PostgreSQL driver+category: Database+homepage: https://github.com/iij-ii/postgresql-pure#readme+bug-reports: https://github.com/iij-ii/postgresql-pure/issues+author: Kazuki Okamoto+maintainer: kazukiokamoto@iij.ad.jp+copyright: 2019 IIJ Innovation Institute Inc.+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ ChangeLog.md++source-repository head+ type: git+ location: https://github.com/iij-ii/postgresql-pure++flag pure-md5+ manual: False+ default: False++library+ exposed-modules:+ Database.HDBC.PostgreSQL.Pure+ Database.PostgreSQL.Pure+ Database.PostgreSQL.Pure.List+ Database.PostgreSQL.Pure.Oid+ other-modules:+ Database.HDBC.PostgreSQL.Pure.Parser+ Database.PostgreSQL.Pure.Internal.Builder+ Database.PostgreSQL.Pure.Internal.Connection+ Database.PostgreSQL.Pure.Internal.Data+ Database.PostgreSQL.Pure.Internal.Exception+ Database.PostgreSQL.Pure.Internal.IsLabel+ Database.PostgreSQL.Pure.Internal.MonadFail+ Database.PostgreSQL.Pure.Internal.Parser+ Database.PostgreSQL.Pure.Internal.Query+ Database.PostgreSQL.Pure.Internal.SocketIO+ Database.PostgreSQL.Simple.Time.Internal.Parser+ Database.PostgreSQL.Simple.Time.Internal.Printer+ Paths_postgresql_pure+ autogen-modules:+ Paths_postgresql_pure+ hs-source-dirs:+ src+ default-extensions: Strict+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -Wmissing-import-lists+ build-depends:+ HDBC+ , Only+ , attoparsec+ , base >=4.7+ , base16-bytestring+ , bytestring+ , containers+ , convertible+ , data-default-class+ , double-conversion+ , homotuple+ , list-tuple+ , memory+ , mtl+ , network+ , postgresql-binary+ , pretty-hex+ , safe-exceptions+ , scientific+ , single-tuple+ , text+ , time+ , utf8-string+ if flag(pure-md5)+ cpp-options: -DPURE_MD5+ build-depends:+ pureMD5+ else+ build-depends:+ cryptohash-md5+ default-language: Haskell2010++test-suite doctest+ type: exitcode-stdio-1.0+ main-is: doctest.hs+ other-modules:+ Paths_postgresql_pure+ hs-source-dirs:+ test-doctest+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N -Wno-all -Wno-compat -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates -Wno-monomorphism-restriction -Wno-missing-exported-signatures -Wno-missing-export-lists -Wno-missing-home-modules -Wno-identities -Wno-redundant-constraints -Wno-partial-fields+ build-depends:+ HDBC+ , Only+ , attoparsec+ , base >=4.7+ , base16-bytestring+ , bytestring+ , containers+ , convertible+ , data-default-class+ , doctest+ , double-conversion+ , homotuple+ , list-tuple+ , memory+ , mtl+ , network+ , postgresql-binary+ , pretty-hex+ , safe-exceptions+ , scientific+ , single-tuple+ , text+ , time+ , utf8-string+ if flag(pure-md5)+ cpp-options: -DPURE_MD5+ build-depends:+ pureMD5+ else+ build-depends:+ cryptohash-md5+ default-language: Haskell2010++test-suite hdbc-postgresql+ type: exitcode-stdio-1.0+ main-is: runtests.hs+ other-modules:+ SpecificDB+ SpecificDBTests+ Testbasics+ TestMisc+ Tests+ TestSbasics+ TestTime+ TestUtils+ Database.HDBC.PostgreSQL.Pure+ Database.HDBC.PostgreSQL.Pure.Parser+ Database.PostgreSQL.Pure+ Database.PostgreSQL.Pure.Internal.Builder+ Database.PostgreSQL.Pure.Internal.Connection+ Database.PostgreSQL.Pure.Internal.Data+ Database.PostgreSQL.Pure.Internal.Exception+ Database.PostgreSQL.Pure.Internal.IsLabel+ Database.PostgreSQL.Pure.Internal.MonadFail+ Database.PostgreSQL.Pure.Internal.Parser+ Database.PostgreSQL.Pure.Internal.Query+ Database.PostgreSQL.Pure.Internal.SocketIO+ Database.PostgreSQL.Pure.List+ Database.PostgreSQL.Pure.Oid+ Database.PostgreSQL.Simple.Time.Internal.Parser+ Database.PostgreSQL.Simple.Time.Internal.Printer+ Paths_postgresql_pure+ hs-source-dirs:+ test-hdbc-postgresql+ src+ default-extensions: Strict+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N -Wno-all -Wno-compat -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates -Wno-monomorphism-restriction -Wno-missing-exported-signatures -Wno-missing-export-lists -Wno-missing-home-modules -Wno-identities -Wno-redundant-constraints -Wno-partial-fields+ build-depends:+ HDBC+ , HUnit+ , Only+ , QuickCheck+ , attoparsec+ , base >=4.7+ , base16-bytestring+ , bytestring+ , containers+ , convertible+ , data-default-class+ , double-conversion+ , homotuple+ , list-tuple+ , memory+ , mtl+ , network+ , old-time+ , postgresql-binary+ , pretty-hex+ , safe-exceptions+ , scientific+ , single-tuple+ , text+ , time+ , utf8-string+ if flag(pure-md5)+ cpp-options: -DPURE_MD5+ build-depends:+ pureMD5+ else+ build-depends:+ cryptohash-md5+ default-language: Haskell2010++test-suite original+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Database.HDBC.PostgreSQL.PureSpec+ Database.PostgreSQL.Pure.ListSpec+ Database.PostgreSQL.PureSpec+ Test.Hspec.Core.Hooks.Extra+ Paths_postgresql_pure+ hs-source-dirs:+ test+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N -Wno-incomplete-uni-patterns -Wno-missing-export-lists -Wno-monomorphism-restriction+ build-depends:+ HDBC+ , Only+ , attoparsec+ , base >=4.7+ , base16-bytestring+ , bytestring+ , containers+ , convertible+ , data-default-class+ , double-conversion+ , homotuple+ , hspec+ , hspec-core+ , list-tuple+ , memory+ , mtl+ , network+ , postgresql-binary+ , postgresql-pure+ , pretty-hex+ , safe-exceptions+ , scientific+ , single-tuple+ , text+ , time+ , utf8-string+ if flag(pure-md5)+ cpp-options: -DPURE_MD5+ build-depends:+ pureMD5+ else+ build-depends:+ cryptohash-md5+ default-language: Haskell2010++test-suite relational-record+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ DataSource+ DataSource.Pure+ Relation.Person+ Relation.Pure.Person+ Paths_postgresql_pure+ hs-source-dirs:+ test-relational-record+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N -Wno-all -Wno-compat -Wno-incomplete-uni-patterns -Wno-incomplete-record-updates -Wno-monomorphism-restriction -Wno-missing-exported-signatures -Wno-missing-export-lists -Wno-missing-home-modules -Wno-identities -Wno-redundant-constraints -Wno-partial-fields+ build-depends:+ HDBC+ , HDBC-postgresql+ , HDBC-session+ , Only+ , attoparsec+ , base >=4.7+ , base16-bytestring+ , bytestring+ , containers+ , convertible+ , data-default-class+ , double-conversion+ , homotuple+ , hspec+ , hspec-core+ , list-tuple+ , memory+ , mtl+ , network+ , persistable-record+ , postgresql-binary+ , postgresql-pure+ , pretty-hex+ , relational-query+ , relational-query-HDBC+ , relational-record+ , safe-exceptions+ , scientific+ , single-tuple+ , text+ , time+ , utf8-string+ if flag(pure-md5)+ cpp-options: -DPURE_MD5+ build-depends:+ pureMD5+ else+ build-depends:+ cryptohash-md5+ default-language: Haskell2010++benchmark requests-per-second+ type: exitcode-stdio-1.0+ main-is: requests-per-second.hs+ other-modules:+ RepeatThreadPool+ Paths_postgresql_pure+ hs-source-dirs:+ benchmark+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HDBC+ , Only+ , attoparsec+ , base >=4.7 && <5+ , base16-bytestring+ , bytestring+ , clock+ , containers+ , convertible+ , data-default-class+ , deepseq+ , double-conversion+ , homotuple+ , list-tuple+ , memory+ , mtl+ , network+ , optparse-applicative+ , postgresql-binary+ , postgresql-libpq+ , postgresql-pure+ , pretty-hex+ , safe-exceptions+ , scientific+ , single-tuple+ , text+ , time+ , utf8-string+ , vector+ if flag(pure-md5)+ cpp-options: -DPURE_MD5+ build-depends:+ pureMD5+ else+ build-depends:+ cryptohash-md5+ if !os(windows)+ build-depends:+ postgres-wire+ default-language: Haskell2010++benchmark requests-per-second-constant+ type: exitcode-stdio-1.0+ main-is: requests-per-second-constant.hs+ other-modules:+ RepeatThreadPool+ Paths_postgresql_pure+ hs-source-dirs:+ benchmark+ ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmonomorphism-restriction -Wmissing-exported-signatures -Wmissing-export-lists -Wmissing-home-modules -Widentities -Wredundant-constraints -Wpartial-fields -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HDBC+ , Only+ , attoparsec+ , base >=4.7 && <5+ , base16-bytestring+ , bytestring+ , cassava+ , clock+ , containers+ , convertible+ , data-default-class+ , deepseq+ , double-conversion+ , homotuple+ , hourglass+ , list-tuple+ , memory+ , mtl+ , network+ , optparse-applicative+ , postgresql-binary+ , postgresql-libpq+ , postgresql-pure+ , postgresql-simple+ , postgresql-typed+ , pretty-hex+ , random-shuffle+ , safe-exceptions+ , scientific+ , single-tuple+ , text+ , time+ , utf8-string+ , vector+ if flag(pure-md5)+ cpp-options: -DPURE_MD5+ build-depends:+ pureMD5+ else+ build-depends:+ cryptohash-md5+ if !os(windows)+ build-depends:+ postgres-wire+ default-language: Haskell2010
+ src/Database/HDBC/PostgreSQL/Pure.hs view
@@ -0,0 +1,603 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++-- |+-- This is a compatible interface with @HDBC-postgresql@'s @Database.HDBC.PostgreSQL@ except 'Config'.+--+-- Prepared statements are closed when some requests come once 'Statement's are GCed, because HDBC doesn't have “close” interface.+module Database.HDBC.PostgreSQL.Pure+ ( -- * Connection+ Config (..)+ , Connection (config)+ , Pure.Address (..)+ , withConnection+ , connect+ -- * Transaction+ , begin+ ) where++import Database.HDBC.PostgreSQL.Pure.Parser (convertQuestionMarkStyleToDollarSignStyle, splitQueries)++import qualified Database.PostgreSQL.Pure.Internal.Connection as Pure+import qualified Database.PostgreSQL.Pure.Internal.Data as Pure+import qualified Database.PostgreSQL.Pure.Internal.Exception as Pure+import qualified Database.PostgreSQL.Pure.Internal.MonadFail as MonadFail+import qualified Database.PostgreSQL.Pure.List as Pure+import qualified Database.PostgreSQL.Pure.Oid as Oid++import Paths_postgresql_pure (version)++import Database.HDBC (IConnection (clone, commit, dbServerVer, dbTransactionSupport, describeTable, disconnect, getTables, hdbcClientVer, hdbcDriverName, prepare, proxiedClientName, proxiedClientVer, rollback, run, runRaw),+ SqlColDesc (SqlColDesc, colDecDigits, colNullable, colOctetLength, colSize, colType),+ SqlError (SqlError, seErrorMsg, seNativeError, seState),+ SqlTypeId, throwSqlError)+import Database.HDBC.ColTypes (SqlInterval (SqlIntervalSecondT), SqlTypeId (SqlBigIntT, SqlBitT, SqlCharT, SqlDateT, SqlDecimalT, SqlDoubleT, SqlFloatT, SqlIntervalT, SqlTimeT, SqlTimeWithZoneT, SqlTimestampT, SqlTimestampWithZoneT, SqlUnknownT, SqlVarBinaryT, SqlVarCharT))+import Database.HDBC.Statement (SqlValue (SqlBool, SqlByteString, SqlChar, SqlDiffTime, SqlDouble, SqlInt32, SqlInt64, SqlInteger, SqlLocalDate, SqlLocalTime, SqlLocalTimeOfDay, SqlNull, SqlPOSIXTime, SqlRational, SqlString, SqlUTCTime, SqlWord32, SqlWord64, SqlZonedLocalTimeOfDay, SqlZonedTime),+ Statement (Statement, describeResult, execute, executeMany, executeRaw, fetchRow, finish, getColumnNames, originalQuery))++import Control.Concurrent (MVar, modifyMVar_, newMVar)+import Control.Exception.Safe (Exception (displayException, fromException, toException),+ impureThrow, try)+import Control.Monad (unless, void)+import Control.Monad.Fail (MonadFail)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as BSS+import qualified Data.ByteString.UTF8 as BSU+import Data.Convertible (Convertible (safeConvert), convert)+import Data.Default.Class (Default (def))+import Data.Foldable (for_)+import Data.Int (Int32, Int64)+import Data.IORef (IORef, mkWeakIORef, newIORef, readIORef, writeIORef)+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)+import Data.Scientific (FPFormat (Exponent), Scientific, formatScientific,+ fromRationalRepetend)+import Data.String (IsString (fromString))+import Data.Time (DiffTime, NominalDiffTime, zonedTimeToUTC)+import Data.Traversable (for)+import Data.Tuple.Only (Only (Only))+import Data.Typeable (Typeable, cast)+import Data.Version (showVersion)+import Data.Word (Word32, Word64)+import qualified PostgreSQL.Binary.Encoding as BE++-- | A configuration of a connection.+--+-- Default configuration is 'def', which is following.+--+-- @+-- let 'Pure.Config' { address, user, password, database, sendingBufferSize, receptionBufferSize } = 'def'+-- in+-- 'Config'+-- { address = address+-- , user = user+-- , password = password+-- , database = database+-- , sendingBufferSize = sendingBufferSize+-- , receptionBufferSize = receptionBufferSize+-- , encodeString = \code -> case code of \"UTF8\" -> 'pure' . 'BSU.fromString'; _ -> 'const' $ 'fail' $ "unexpected character code: " <> 'show' code+-- , decodeString = \code -> case code of \"UTF8\" -> 'pure' . 'BSU.toString'; _ -> 'const' $ 'fail' $ "unexpected character code: " <> 'show' code+-- }+-- @+data Config =+ Config+ { address :: Pure.Address+ , user :: String+ , password :: String+ , database :: String+ , sendingBufferSize :: Int -- ^ in byte+ , receptionBufferSize :: Int -- ^ in byte+ , encodeString :: BSS.ShortByteString -> Pure.StringEncoder+ , decodeString :: BSS.ShortByteString -> Pure.StringDecoder+ }++instance Show Config where+ show Config { address, user, password, database, sendingBufferSize, receptionBufferSize } =+ mconcat+ [ "Config { address = "+ , show address+ , ", user = "+ , show user+ , ", password = "+ , show password+ , ", database = "+ , show database+ , ", sendingBufferSize = "+ , show sendingBufferSize+ , ", receptionBufferSize = "+ , show receptionBufferSize+ , ", encodeString = <function>, decodeString = <function> }"+ ]++instance Default Config where+ def =+ let Pure.Config { address, user, password, database, sendingBufferSize, receptionBufferSize } = def+ in+ Config+ { address+ , user+ , password+ , database+ , sendingBufferSize+ , receptionBufferSize+ , encodeString = \code -> case code of "UTF8" -> pure . BSU.fromString; _ -> const $ fail $ "unexpected character code: " <> show code+ , decodeString = \code -> case code of "UTF8" -> pure . BSU.toString; _ -> const $ fail $ "unexpected character code: " <> show code+ }++-- | PostgreSQL connection.+data Connection =+ Connection+ { connection :: Pure.Connection+ , statementCounter :: IORef Word+ , unnecessaryPreparedStatemtnts :: MVar [Pure.PreparedStatement] -- To accumulate unnecessary prepared statements+ -- to dispose them when some requests come,+ -- because HDBC doesn't have a interface to close statements.+ , config :: Config+ }++-- | Bracket function for a connection.+withConnection :: Config -> (Connection -> IO a) -> IO a+withConnection config@Config { address, user, password, database, sendingBufferSize, receptionBufferSize } f =+ Pure.withConnection Pure.Config { address, user, password, database, sendingBufferSize, receptionBufferSize } $ \c -> do+ void $ Pure.sync c Pure.begin+ conn <- Connection c <$> newIORef 0 <*> newMVar [] <*> pure config+ f conn++-- | To connect to the server.+connect :: Config -> IO Connection+connect config@Config { address, user, password, database, sendingBufferSize, receptionBufferSize } = do+ c <- Pure.connect Pure.Config { address, user, password, database, sendingBufferSize, receptionBufferSize }+ void $ Pure.sync c Pure.begin+ Connection c <$> newIORef 0 <*> newMVar [] <*> pure config++instance IConnection Connection where+ disconnect = Pure.disconnect . connection++ commit hc@Connection { connection } =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ void $ Pure.sync connection (Pure.commit, Pure.begin)++ rollback hc@Connection { connection } =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ void $ Pure.sync connection (Pure.rollback, Pure.begin)++ run hc@Connection { connection = connection@Pure.Connection { parameters }, config = Config { encodeString, decodeString } } query values =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ charCode <- lookupClientEncoding parameters+ let+ encode = encodeString charCode+ decode = decodeString charCode+ queryQS :: Pure.Query+ queryQS = fromString query+ queryDS =+ case convertQuestionMarkStyleToDollarSignStyle queryQS of+ Right q -> q+ Left err -> impureThrow $ RequestBuildingFailed $ "conversion from question mark style to dollar sign style: " <> err+ ps <- Pure.flush connection $ Pure.parse "" queryDS (Left (0, 0)) -- footnote [1]+ let+ pProc = forceBind $ Pure.bind "" Pure.TextFormat Pure.TextFormat parameters encode values ps+ eProc = Pure.execute @_ @() 0 decode pProc+ (_, _, e, _) <- Pure.flush connection eProc+ pure $ resultCount $ Pure.result e++ runRaw hc@Connection { connection = connection@Pure.Connection { parameters }, config = Config { encodeString, decodeString } } query =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ charCode <- lookupClientEncoding parameters+ let+ encode = encodeString charCode+ decode = decodeString charCode+ queries = splitQueries $ fromString query+ for_ queries $ \q -> do+ ps <- Pure.flush connection $ Pure.parse "" q (Left (0, 0)) -- footnote [1]+ Pure.flush connection $ Pure.execute @_ @() 0 decode $ forceBind $ Pure.bind "" Pure.TextFormat Pure.TextFormat parameters encode ([] :: [SqlValue]) ps++ prepare hc@Connection { connection = connection@Pure.Connection { parameters }, statementCounter, unnecessaryPreparedStatemtnts, config = Config { encodeString, decodeString } } query =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ count <- incrementCounter statementCounter+ portalCounter <- newIORef 0+ charCode <- lookupClientEncoding parameters+ let+ encode = encodeString charCode+ decode = decodeString charCode+ encodeIO = MonadFail.fromEither . encode :: String -> IO BS.ByteString+ decodeIO = MonadFail.fromEither . decode :: BS.ByteString -> IO String+ queryBS <- encodeIO query+ let+ queryDS =+ case convertQuestionMarkStyleToDollarSignStyle $ Pure.Query queryBS of+ Right q -> q+ Left err -> impureThrow $ RequestBuildingFailed $ "conversion from question mark style to dollar sign style: " <> err+ countBS <- encodeIO $ show count+ let+ psName = Pure.PreparedStatementName $ countBS <> ": " <> queryBS+ (preparedStatement, _) <- Pure.sync connection $ Pure.parse psName queryDS (Left (0, 0)) -- footnote [1]+ portalsRef <- newIORef [] :: IO (IORef [(Maybe [SqlValue], Pure.Portal)])+ alive <- newIORef () -- see the document of 'keepPreparedStatementAlive'+ let+ execute :: [SqlValue] -> IO Integer+ execute values =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ finish'+ count <- incrementCounter portalCounter+ countBS <- encodeIO $ show count+ let+ pName =+ case psName of+ Pure.PreparedStatementName n -> Pure.PortalName $ countBS <> ": " <> n+ ((_, p, e, _), _) <- Pure.sync connection $ Pure.execute 1 decode $ forceBind $ Pure.bind pName Pure.TextFormat Pure.TextFormat parameters encode values preparedStatement+ keepPreparedStatementAlive+ writeIORef portalsRef $+ case Pure.result e of+ Pure.ExecuteSuspended -> [(Just $ head $ Pure.records e, p)]+ _ -> []+ pure $ resultCount $ Pure.result e++ executeRaw :: IO ()+ executeRaw = void $ execute []++ executeMany :: [[SqlValue]] -> IO ()+ executeMany valuess =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ finish'+ eProcs <-+ for valuess $ \values -> do+ count <- incrementCounter portalCounter+ countBS <- encodeIO $ show count+ let+ pName =+ case psName of+ Pure.PreparedStatementName n -> Pure.PortalName $ countBS <> ": " <> n+ pure $ Pure.execute 1 decode $ forceBind $ Pure.bind pName Pure.TextFormat Pure.TextFormat parameters encode values preparedStatement+ (rs, _) <- Pure.sync connection eProcs+ keepPreparedStatementAlive+ writeIORef portalsRef $+ mconcat $+ (<$> rs) $ \(_, p, e, _) ->+ case Pure.result e of+ Pure.ExecuteSuspended -> [(Just $ head $ Pure.records e, p)]+ _ -> mempty++ finish :: IO ()+ finish =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ finish'+ keepPreparedStatementAlive+ writeIORef portalsRef []++ finish' :: IO ()+ finish' = do+ ps <- readIORef portalsRef+ unless (null ps) $ void $ Pure.sync connection $ Pure.close . snd <$> ps++ fetchRow :: IO (Maybe [SqlValue])+ fetchRow =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ ps <- readIORef portalsRef+ case ps of+ (Just r, p):ps -> do+ writeIORef portalsRef ((Nothing, p):ps)+ pure $ Just r+ (Nothing, p):ps -> do+ ((_, _, e, _), _) <- Pure.sync connection $ Pure.execute 1 decode p+ keepPreparedStatementAlive+ case Pure.result e of+ Pure.ExecuteSuspended ->+ pure $ Just $ head $ Pure.records e+ _ -> do+ void $ Pure.sync connection $ Pure.close p+ keepPreparedStatementAlive+ writeIORef portalsRef ps+ pure Nothing+ [] -> pure Nothing++ getColumnNames :: IO [String]+ getColumnNames =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ sequence $ decodeIO . #name <$> Pure.resultInfos preparedStatement++ originalQuery :: String+ originalQuery = query++ describeResult :: IO [(String, SqlColDesc)]+ describeResult =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ let+ columnInfos = Pure.resultInfos preparedStatement+ psProc = Pure.parse "attr" "SELECT attnotnull FROM pg_attribute WHERE attrelid = $1 AND attnum = $2" (Right ([Oid.oid, Oid.int2], [Oid.bool]))+ (ps, _) <- Pure.sync connection psProc+ results <-+ for columnInfos $ \Pure.ColumnInfo { name, tableOid, attributeNumber, typeOid, typeLength, typeModifier } -> do+ ((_, _, e, _), _) <- Pure.sync connection $ Pure.execute 1 decode $ forceBind $ Pure.bind "" Pure.TextFormat Pure.TextFormat parameters encode (tableOid, attributeNumber) ps+ let+ (Only attnotnull) = head $ Pure.records e+ (colSize, colDecDigits) = columnSize typeOid typeLength typeModifier+ nameStr <- decodeIO name+ pure+ ( nameStr+ , SqlColDesc+ { colType = convert typeOid+ , colSize+ , colOctetLength = Nothing+ , colDecDigits+ , colNullable = Just $ not attnotnull+ }+ )+ void $ Pure.sync connection $ Pure.close ps+ keepPreparedStatementAlive+ pure results++ -- The GHC optimiser make 'Statement's be GCed in advance of exiting those scopes.+ -- To prevent it, insert 'readIORef's at the end of actions.+ -- Finalisers of 'IORef's are set, instead of ones of 'Statement's.+ -- See: https://github.com/snoyberg/http-client/pull/352+ keepPreparedStatementAlive :: IO ()+ keepPreparedStatementAlive = void $ readIORef alive++ statement =+ Statement+ { execute+ , executeRaw+ , executeMany+ , finish+ , fetchRow+ , getColumnNames+ , originalQuery+ , describeResult+ }++ -- set up a finaliser+ void $ mkWeakIORef alive $ modifyMVar_ unnecessaryPreparedStatemtnts $ pure . (preparedStatement:)+ pure statement++ clone hc@Connection { config } =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ connect config++ hdbcDriverName _ = "postgresql"++ hdbcClientVer _ = showVersion version++ proxiedClientName = hdbcDriverName++ proxiedClientVer = hdbcClientVer++ dbServerVer Connection { connection = Pure.Connection { parameters }, config = Config { decodeString } } =+ fromMaybe "" $ do+ serverVersion <- M.lookup "server_version" parameters+ decode <- decodeString <$> lookupClientEncoding parameters+ MonadFail.fromEither $ decode $ BSS.fromShort serverVersion++ dbTransactionSupport _ = True++ getTables hc@Connection { connection = connection@Pure.Connection { parameters }, config = Config { encodeString, decodeString } } =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ charCode <- lookupClientEncoding parameters+ let+ encode = encodeString charCode+ decode = decodeString charCode+ decodeIO = MonadFail.fromEither . decode :: BS.ByteString -> IO String+ q :: Pure.Query+ q = "SELECT table_name FROM information_schema.tables WHERE table_schema != 'pg_catalog' AND table_schema != 'information_schema'"+ ((_, _, e, _), _) <- Pure.sync connection $ Pure.execute 0 decode $ forceBind $ Pure.bind "" Pure.TextFormat Pure.TextFormat parameters encode () $ Pure.parse "" q (Right ([], [Oid.sqlIdentifier]))+ sequence $ decodeIO . (\(Only (Pure.SqlIdentifier str)) -> str) <$> Pure.records e++ describeTable hc@Connection { connection = connection@Pure.Connection { parameters }, config = Config { encodeString, decodeString } } tableName =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ charCode <- lookupClientEncoding parameters+ let+ encode = encodeString charCode+ decode = decodeString charCode+ decodeIO = MonadFail.fromEither . decode :: BS.ByteString -> IO String+ q :: Pure.Query+ q =+ "SELECT attname, atttypid, attlen, atttypmod, attnotnull\+ \ FROM pg_attribute, pg_class, pg_namespace\+ \ WHERE attnum > 0 AND attisdropped IS FALSE AND attrelid = pg_class.oid AND relnamespace = pg_namespace.oid AND relname = $1\+ \ ORDER BY attnum"+ ((_, _, e, _), _) <-+ Pure.sync connection $ Pure.execute 0 decode $ forceBind $ Pure.bind "" Pure.TextFormat Pure.TextFormat parameters encode (Only tableName) $ Pure.parse "" q (Right ([Oid.name], [Oid.name, Oid.oid, Oid.int2, Oid.int4, Oid.bool]))+ for (Pure.records e) $ \(attname, atttypid, attlen, atttypmod, attnotnull) -> do+ let+ typeLength = case attlen of { (-1) -> Pure.VariableLength ; _ -> Pure.FixedLength attlen }+ (colSize, colDecDigits) = columnSize atttypid typeLength atttypmod+ attnameBS <- decodeIO attname+ pure+ ( attnameBS+ , SqlColDesc+ { colType = convert atttypid+ , colSize+ , colOctetLength = Nothing+ , colDecDigits+ , colNullable = Just $ not attnotnull+ }+ )++-- | To send @BEGIN@ SQL statement.+begin :: Connection -> IO ()+begin hc@Connection { connection } =+ convertException $ do+ closeUnnecessaryPreparedStatemtnts hc+ void $ Pure.sync connection Pure.begin++columnSize :: Pure.Oid -> Pure.TypeLength -> Pure.TypeModifier -> (Maybe Int, Maybe Int)+columnSize typeOid Pure.VariableLength typeModifier+ | typeOid `elem` [Oid.bpchar, Oid.varchar] = (Just $ fromIntegral typeModifier - 4, Nothing) -- minus header size+ | typeOid == Oid.numeric = let (p, q) = (fromIntegral typeModifier - 4) `divMod` (2 ^ (16 :: Int) :: Int) in (Just p, Just q)+ | otherwise = (Nothing, Nothing)+columnSize _ (Pure.FixedLength l) _ = (Just $ fromIntegral l, Nothing)++forceBind :: Either String Pure.PortalProcedure -> Pure.PortalProcedure+forceBind (Right a) = a+forceBind (Left err) = impureThrow $ RequestBuildingFailed err++incrementCounter :: IORef Word -> IO Word+incrementCounter ref = do+ n <- readIORef ref+ writeIORef ref (n + 1)+ pure n++closeUnnecessaryPreparedStatemtnts :: Connection -> IO ()+closeUnnecessaryPreparedStatemtnts Connection { connection, unnecessaryPreparedStatemtnts } =+ modifyMVar_ unnecessaryPreparedStatemtnts $ \pss -> do+ unless (null pss) $ void $ Pure.sync connection $ Pure.close <$> pss+ pure []++convertException :: IO a -> IO a+convertException a = do+ r <- try a+ case r of+ Right v -> pure v+ Left e -> throwSqlError $ SqlError { seState = "", seNativeError = -1, seErrorMsg = displayException (e :: Pure.Exception) }++newtype RequestBuildingFailed = RequestBuildingFailed { message :: String } deriving (Show, Read, Eq, Typeable)++instance Exception RequestBuildingFailed where+ toException = toException . Pure.Exception+ fromException = ((\(Pure.Exception e) -> cast e) =<<) . fromException++instance Pure.FromField SqlValue where+ fromField _ _ Nothing = pure SqlNull+ fromField decode info@Pure.ColumnInfo { typeOid } v+ | typeOid == Oid.char+ = SqlChar <$> Pure.fromField decode info v+ | typeOid `elem` [Oid.bpchar, Oid.varchar, Oid.text, Oid.name]+ = SqlByteString <$> Pure.fromField decode info v+ | typeOid `elem` [Oid.int2, Oid.int4]+ = SqlInt32 <$> Pure.fromField decode info v+ | typeOid == Oid.int8+ = SqlInt64 <$> Pure.fromField decode info v+ | typeOid == Oid.bool+ = SqlBool <$> Pure.fromField decode info v+ | typeOid `elem` [Oid.float4, Oid.float8]+ = SqlDouble <$> Pure.fromField decode info v+ | typeOid == Oid.numeric+ = SqlRational . toRational @Scientific <$> Pure.fromField decode info v+ | typeOid == Oid.date+ = SqlLocalDate <$> Pure.fromField decode info v+ | typeOid == Oid.time+ = SqlLocalTimeOfDay <$> Pure.fromField decode info v+ | typeOid == Oid.timetz+ = uncurry SqlZonedLocalTimeOfDay <$> Pure.fromField decode info v+ | typeOid == Oid.timestamp+ = SqlLocalTime <$> Pure.fromField decode info v+ | typeOid == Oid.timestamptz+ = SqlUTCTime <$> Pure.fromField decode info v+ | typeOid == Oid.interval+ = SqlDiffTime . fromRational . toRational @DiffTime <$> Pure.fromField decode info v+ | typeOid == Oid.oid+ = SqlInt32 . (\(Oid.Oid n) -> n) <$> Pure.fromField decode info v+ | otherwise = fail $ "unsupported type: " <> show typeOid++instance Pure.ToField SqlValue where+ toField backendParams encode oid format (SqlString v) = Pure.toField backendParams encode oid format v+ toField backendParams encode oid format (SqlByteString v) = Pure.toField backendParams encode oid format v+ toField backendParams encode oid format (SqlWord32 v) = Pure.toField backendParams encode oid format $ fromIntegral @Word32 @Int32 v -- may get overflow+ toField backendParams encode oid format (SqlWord64 v) = Pure.toField backendParams encode oid format $ fromIntegral @Word64 @Int64 v -- may get overflow+ toField backendParams encode oid format (SqlInt32 v) = Pure.toField backendParams encode oid format v+ toField backendParams encode oid format (SqlInt64 v)+ | fromIntegral (minBound :: Int32) <= v && v <= fromIntegral (maxBound :: Int32) = Pure.toField backendParams encode oid format (fromIntegral v :: Int32)+ | otherwise = Pure.toField backendParams encode oid format v+ toField backendParams encode oid format (SqlInteger v) = Pure.toField backendParams encode oid format $ fromInteger @Scientific v+ toField backendParams encode oid format (SqlChar v) = Pure.toField backendParams encode oid format [v]+ toField backendParams encode oid format (SqlBool v) = Pure.toField backendParams encode oid format v+ toField backendParams encode oid format (SqlDouble v) = Pure.toField backendParams encode oid format v+ toField backendParams encode oid format (SqlRational v) = Pure.toField backendParams encode oid format v+ toField backendParams encode oid format (SqlLocalDate v) = Pure.toField backendParams encode oid format v+ toField backendParams encode oid format (SqlLocalTimeOfDay v) = Pure.toField backendParams encode oid format v+ toField backendParams encode oid format (SqlZonedLocalTimeOfDay t tz) = Pure.toField backendParams encode oid format (t, tz)+ toField backendParams encode oid format (SqlLocalTime v) = Pure.toField backendParams encode oid format v+ toField backendParams encode oid format (SqlZonedTime v) = Pure.toField backendParams encode oid format $ zonedTimeToUTC v+ toField backendParams encode oid format (SqlUTCTime v) = Pure.toField backendParams encode oid format v+ toField backendParams encode oid format (SqlDiffTime v) = Pure.toField backendParams encode oid format $ fromRational @DiffTime $ toRational @NominalDiffTime v+ toField backendParams encode oid format (SqlPOSIXTime v) = Pure.toField backendParams encode oid format v+ toField _ _ _ Pure.TextFormat SqlNull = pure Nothing+ toField _ _ _ _ _ = fail "unsupported" -- SqlEpochTime and SqlTimeDiff are deprecated++-- | Security risk of DoS attack.+--+-- You should convert 'Rational' to 'Scientific' with 'fromRationalRepetend' in the user side.+-- If the rational value is computed to repeating decimals like 1/3 = 0.3333…, this consumes a lot of memories.+-- This is provided because of the HDBC compatibility.+instance Pure.ToField Rational where+ toField _ encode Nothing format v =+ let+ s =+ case fromRationalRepetend Nothing v of+ Left (s, _) -> s+ Right (s, _) -> s+ in+ case format of+ Pure.TextFormat -> Just <$> MonadFail.fromEither (encode $ formatScientific Exponent Nothing s)+ Pure.BinaryFormat -> pure $ Just $ BE.encodingBytes $ BE.numeric s+ toField backendParams encode (Just o) f v | o == Oid.numeric = Pure.toField backendParams encode Nothing f v+ | otherwise = fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Rational"++resultCount :: Pure.ExecuteResult -> Integer+resultCount e =+ toInteger $+ case e of+ Pure.ExecuteComplete tag ->+ case tag of+ Pure.InsertTag _ n -> n+ Pure.DeleteTag n -> n+ Pure.UpdateTag n -> n+ Pure.SelectTag _ -> 0+ Pure.MoveTag n -> n+ Pure.FetchTag n -> n+ Pure.CopyTag n -> n+ Pure.CreateTableTag -> 0+ Pure.DropTableTag -> 0+ Pure.BeginTag -> 0+ Pure.CommitTag -> 0+ Pure.RollbackTag -> 0+ Pure.SetTag -> 0+ Pure.ExecuteEmptyQuery -> 0+ Pure.ExecuteSuspended -> 0++instance Convertible Pure.Oid SqlTypeId where+ safeConvert oid | oid `elem` [Oid.int2, Oid.int4, Oid.int8] = pure SqlBigIntT+ | oid == Oid.numeric = pure SqlDecimalT+ | oid == Oid.float4 = pure SqlFloatT+ | oid == Oid.float8 = pure SqlDoubleT+ | oid `elem` [Oid.char, Oid.bpchar] = pure SqlCharT+ | oid `elem` [Oid.varchar, Oid.text] = pure SqlVarCharT+ | oid == Oid.bytea = pure SqlVarBinaryT+ | oid == Oid.timestamp = pure SqlTimestampT+ | oid == Oid.timestamptz = pure SqlTimestampWithZoneT+ | oid == Oid.date = pure SqlDateT+ | oid == Oid.time = pure SqlTimeT+ | oid == Oid.timetz = pure SqlTimeWithZoneT+ | oid == Oid.interval = pure $ SqlIntervalT SqlIntervalSecondT+ | oid == Oid.bool = pure SqlBitT+ | otherwise = pure $ SqlUnknownT $ show oid++lookupClientEncoding :: MonadFail m => Pure.BackendParameters -> m BSS.ShortByteString+lookupClientEncoding params =+ case M.lookup "client_encoding" params of+ Nothing -> fail "\"client_encoding\" backend parameter not found"+ Just code -> pure code++-- Footnote+-- [1] Dirty hack: The numbers 0 and 0 are not used, when the prepared statement procedure is not given to "bind".
+ src/Database/HDBC/PostgreSQL/Pure/Parser.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedStrings #-}++module Database.HDBC.PostgreSQL.Pure.Parser+ ( convertQuestionMarkStyleToDollarSignStyle+ , splitQueries+ ) where++import qualified Database.PostgreSQL.Pure.Internal.Data as Pure+import qualified Database.PostgreSQL.Pure.Internal.Parser as Pure++import Control.Monad (void)+import Control.Monad.State.Strict (StateT, evalStateT, lift, state)+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.Attoparsec.ByteString.Char8 as APC+import Data.Attoparsec.Combinator ((<?>))+import qualified Data.Attoparsec.Combinator as AP+import qualified Data.Attoparsec.Internal.Types as API+import qualified Data.ByteString as BS+import qualified Data.ByteString.UTF8 as BSU++convertQuestionMarkStyleToDollarSignStyle :: Pure.Query -> Either String Pure.Query+convertQuestionMarkStyleToDollarSignStyle (Pure.Query q) =+ flip AP.parseOnly q $+ flip evalStateT 1 $+ (Pure.Query . mconcat <$>) $ do+ ss <-+ AP.many' $+ AP.choice+ [ question+ , lift questionLiteral+ , lift singleQuoteLiteral+ , lift doubleQuoteLiteral+ , lift dollarQuoteLiteral+ , lift lineComment+ , lift blockComment+ , lift $ BS.pack . (:[]) <$> AP.anyWord8+ ]+ lift AP.endOfInput+ pure ss++singleQuoteLiteral :: AP.Parser BS.ByteString+singleQuoteLiteral = oneCharQuoteLiteral '\'' <?> "singleQuoteLiteral"++doubleQuoteLiteral :: AP.Parser BS.ByteString+doubleQuoteLiteral = oneCharQuoteLiteral '"' <?> "doubleQuoteLiteral"++oneCharQuoteLiteral :: Char -> AP.Parser BS.ByteString+oneCharQuoteLiteral quote =+ takeConsumed $ do+ void $ APC.char quote+ body+ void $ APC.char quote+ where+ body = do+ void $ APC.takeTill ((||) <$> (== '\\') <*> (== quote))+ AP.option () $ do+ void $ APC.char '\\'+ void APC.anyChar -- It continues although it is somthing wrong if the character does not stand for escape sequence.+ body++dollarQuoteLiteral :: AP.Parser BS.ByteString+dollarQuoteLiteral =+ (<?> "dollarQuoteLiteral") $+ takeConsumed $ do+ quote <- dollarQuote+ go quote+ where+ dollarQuote =+ (<?> "dollarQuote") $+ takeConsumed $ do+ void $ APC.char '$'+ void $ AP.many' $ APC.satisfy ((&&) <$> (/= ' ') <*> (/= '$'))+ void $ APC.char '$'+ go quote = go'+ where+ go' = do+ void $ AP.many' $ APC.satisfy (/= '$')+ AP.choice+ [ void $ AP.string quote+ , APC.char '$' *> go'+ ]++lineComment :: AP.Parser BS.ByteString+lineComment =+ (<?> "lineComment") $+ takeConsumed $ do+ void "--"+ void $ AP.many' $ APC.satisfy ((&&) <$> (/= '\r') <*> (/= '\n'))+ AP.option () $ void APC.endOfLine++blockComment :: AP.Parser BS.ByteString+blockComment =+ (<?> "blockComment") $+ takeConsumed $ do+ void "/*"+ go+ where+ go = do+ void $+ AP.many' $+ AP.choice+ [ void blockComment+ , void $ APC.satisfy ((&&) <$> (/= '/') <*> (/= '*'))+ ]+ AP.choice+ [ void "*/"+ , AP.lookAhead "/*" *> go+ , APC.satisfy ((||) <$> (== '/') <*> (== '*')) *> go+ ]++question :: StateT Int AP.Parser BS.ByteString+question = do+ void $ lift $ APC.char '?'+ i <- getAndIncrement+ pure $ "$" <> BSU.fromString (show i)+ where+ getAndIncrement :: StateT Int AP.Parser Int+ getAndIncrement = state (\i -> (i, i + 1))++questionLiteral :: AP.Parser BS.ByteString+questionLiteral = takeConsumed "\\?"++splitQueries :: Pure.Query -> [Pure.Query]+splitQueries query@(Pure.Query q) =+ case AP.parseOnly parser q of+ Right qs -> qs+ Left _ -> [query]+ where+ parser =+ ((Pure.Query <$>) . conv <$>) $+ AP.many' $+ AP.choice+ [ APC.char ';' >> pure Nothing+ , Just <$> singleQuoteLiteral+ , Just <$> doubleQuoteLiteral+ , Just <$> dollarQuoteLiteral+ , Just <$> lineComment+ , Just <$> blockComment+ , Just . BS.pack . (:[]) <$> AP.anyWord8+ ]+ conv :: [Maybe BS.ByteString] -> [BS.ByteString]+ conv =+ foldr go []+ where+ go (Just s) (a:as) = (s <> a):as+ go (Just s) [] = [s]+ go Nothing acc = "":acc++takeConsumed :: AP.Parser a -> AP.Parser BS.ByteString+takeConsumed p = do+ n <-+ AP.lookAhead $ do+ API.Pos startPos <- Pure.currentPos+ void p+ API.Pos endPos <- Pure.currentPos+ pure $ endPos - startPos+ AP.take n
+ src/Database/PostgreSQL/Pure.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- These warnings are raised, although constraints are necessary.+{-# OPTIONS_GHC -Wno-unused-top-binds #-} -- These warnings are raised, although "builder", "parser" fields are necessary for IsLabel instances.++-- |+-- This is a client library for PostgreSQL Database which has following features.+--+-- - faster and less CPU load+--+-- - especially on multi-core environments+--+-- - pure Haskell implementations+--+-- - no libpq dependency+-- - easy to build even on Windows+--+-- - implements extended query protocol+--+-- - about extended query protocol, see <https://www.postgresql.org/docs/current/protocol-flow.html#PROTOCOL-FLOW-EXT-QUERY>+--+-- = Typical Example+--+-- Prepare a following table.+--+-- @+-- CREATE TABLE person (+-- id serial PRIMARY KEY,+-- name varchar(255) NOT NULL+-- );+-- INSERT INTO person (name) VALUES (\'Ada\');+-- @+--+-- You can run like following to get the record whose ID is 1.+--+-- >>> :set -XOverloadedStrings+-- >>> :set -XFlexibleContexts+-- >>> :set -XDataKinds+-- >>> :set -XTypeFamilies+-- >>> :set -XTypeApplications+-- >>>+-- >>> import Database.PostgreSQL.Pure+-- >>> import Data.Default.Class (def)+-- >>> import Data.Int (Int32)+-- >>> import Data.ByteString (ByteString)+-- >>> import Data.Tuple.Only (Only (Only))+-- >>> import Data.Tuple.List.Only ()+-- >>> import Data.Tuple.Homotuple.Only ()+-- >>>+-- >>> conn <- connect def+-- >>> preparedStatementProcedure = parse "" "SELECT id, name FROM person WHERE id = $1" Nothing+-- >>> portalProcedure <- bind @_ @2 @_ @_ "" BinaryFormat BinaryFormat (parameters conn) (const $ fail "") (Only (1 :: Int32)) preparedStatementProcedure+-- >>> executedProcedure = execute @_ @_ @(Int32, ByteString) 0 (const $ fail "") portalProcedure+-- >>> ((_, _, e, _), _) <- sync conn executedProcedure+-- >>> records e+-- [(1,"Ada")]+--+-- = Hints for Type Errors+--+-- This module uses type level natural numbers as the number of columns of parameters and results.+--+-- If you have constranit errors about tuples, you may forget to import @Data.Tuple.List@, @Data.Tuple.Homotuple@ and so on, because tuples are treated as vecters with typle level lengths.+-- You can use list interfaces with @Database.PostgreSQL.Pure.List@, if these errors bother you.+module Database.PostgreSQL.Pure+ ( -- * Connection+ Config (..)+ , Connection+ , pid+ , parameters+ , config+ , Address (..)+ , BackendParameters+ , Pid+ , withConnection+ , connect+ , disconnect+ -- * Extended Query+ , parse+ , bind+ , execute+ , flush+ , sync+ , close+ , PreparedStatement+ , PreparedStatementProcedure+ , PreparedStatementName (..)+ , Portal+ , PortalProcedure+ , PortalName (..)+ , Executed+ , ExecutedProcedure+ , ExecuteResult (..)+ , CloseProcedure+ , CommandTag (..)+ , Query (..)+ , FormatCode (..)+ , ColumnInfo+ , Message+ , MessageResult+ , Bind+ , Execute+ , Close+ , StringEncoder+ , StringDecoder+ , HasName+ , Name+ , HasParameterOids+ , name+ , parameterOids+ , resultInfos+ , result+ , records+ -- * Transaction+ , begin+ , commit+ , rollback+ , TransactionState (..)+ -- * Record+ , FromField (..)+ , FromRecord (..)+ , ToField (..)+ , ToRecord (..)+ , Raw (..)+ -- * Exception+ , Exception.Exception (..)+ , Exception.ErrorResponse (..)+ , Exception.ResponseParsingFailed (..)+ -- * OID+ , Oid+ ) where++import Database.PostgreSQL.Pure.Internal.Connection (connect, disconnect, withConnection)+import Database.PostgreSQL.Pure.Internal.Data (Address (AddressNotResolved, AddressResolved),+ BackendParameters, CloseProcedure, ColumnInfo,+ CommandTag (BeginTag, CommitTag, CopyTag, CreateTableTag, DeleteTag, DropTableTag, FetchTag, InsertTag, MoveTag, RollbackTag, SelectTag, UpdateTag),+ Config (Config, address, database, password, receptionBufferSize, sendingBufferSize, user),+ Connection (config, parameters, pid), ErrorFields,+ ExecuteResult (ExecuteComplete, ExecuteEmptyQuery, ExecuteSuspended),+ FormatCode (BinaryFormat, TextFormat),+ FromField (fromField), FromRecord (fromRecord),+ MessageResult, Oid, Pid, PortalName (PortalName),+ PreparedStatementName (PreparedStatementName),+ Query (Query), Raw (Null, Value), StringDecoder,+ StringEncoder, ToField (toField), ToRecord (toRecord),+ TransactionState)+import qualified Database.PostgreSQL.Pure.Internal.Data as Data+import qualified Database.PostgreSQL.Pure.Internal.Exception as Exception+import Database.PostgreSQL.Pure.Internal.IsLabel ()+import Database.PostgreSQL.Pure.Internal.Query (Close, Message, close, flush, sync)+import qualified Database.PostgreSQL.Pure.Internal.Query as Query++import Control.Monad.Fail (MonadFail)+import Data.Bifunctor (bimap)+import Data.Kind (Type)+import Data.Proxy (Proxy (Proxy))+import Data.Tuple.Homotuple (Homotuple, IsHomolisttuple, IsHomotupleItem)+import Data.Tuple.List (HasLength, Length)+import GHC.Exts (IsList (Item, fromList, toList))+import GHC.OverloadedLabels (IsLabel)+import GHC.Records (HasField (getField))+import GHC.TypeLits (KnownNat, Nat, natVal)++-- | This represents a prepared statement which is already processed by a server.+--+-- @parameterLength@ is the number of columns of the parameter and @resultLength@ is the number of columns of the results.+-- This is the same with 'PreparedStatementProcedure', 'Portal', 'PortalProcedure', 'Executed' and 'ExecutedProcedure'.+newtype PreparedStatement (parameterLength :: Nat) (resultLength :: Nat) =+ PreparedStatement Data.PreparedStatement+ deriving newtype (Show, Eq, Close)++instance HasField "name" (PreparedStatement n m) PreparedStatementName where+ getField (PreparedStatement Data.PreparedStatement { name }) = name++instance (oids ~ Homotuple n Oid, Item oids ~ Oid, IsList oids) => HasField "parameterOids" (PreparedStatement n m) oids where+ getField (PreparedStatement Data.PreparedStatement { parameterOids }) = fromList parameterOids++-- | To get a list of column infos of the result record.+resultInfos :: (IsHomolisttuple m ColumnInfo, IsHomotupleItem m ColumnInfo) => PreparedStatement n m -> Homotuple m ColumnInfo+resultInfos (PreparedStatement Data.PreparedStatement { resultInfos }) = fromList resultInfos++-- | This represents a prepared statemnt which is not yet processed by a server.+newtype PreparedStatementProcedure (parameterLength :: Nat) (resultLength :: Nat) =+ PreparedStatementProcedure Data.PreparedStatementProcedure+ deriving newtype (Show, Message)++instance HasField "name" (PreparedStatementProcedure n m) PreparedStatementName where+ getField (PreparedStatementProcedure Data.PreparedStatementProcedure { name }) = name++instance (oids ~ Homotuple n Oid, Item oids ~ Oid, IsList oids) => HasField "parameterOids" (PreparedStatementProcedure n m) (Maybe oids) where+ getField (PreparedStatementProcedure Data.PreparedStatementProcedure { parameterOids }) = fromList <$> parameterOids++type instance MessageResult (PreparedStatementProcedure n m) = (PreparedStatement n m)++-- | This represents a portal which is already processed by a server.+newtype Portal (parameterLength :: Nat) (resultLength :: Nat) =+ Portal Data.Portal+ deriving newtype (Show, Eq, Close)++instance HasField "name" (Portal n m) PortalName where+ getField (Portal Data.Portal { name }) = name++-- | This represents a portal which is not yet processed by a server.+newtype PortalProcedure (parameterLength :: Nat) (resultLength :: Nat) =+ PortalProcedure Data.PortalProcedure+ deriving newtype (Show, Message)++instance HasField "name" (PortalProcedure n m) PortalName where+ getField (PortalProcedure Data.PortalProcedure { name }) = name++type instance MessageResult (PortalProcedure n m) = (PreparedStatement n m, Portal n m)++-- | This represents a result of a “Execute” message which is already processed by a server.+newtype Executed (parameterLength :: Nat) (resultLength :: Nat) r =+ Executed (Data.Executed r)+ deriving newtype (Show, Eq)++-- | To get the result of 'Executed'.+result :: Executed n m r -> ExecuteResult+result (Executed Data.Executed { result }) = result++-- | To get the records of 'Executed'.+records :: Executed n m r -> [r]+records (Executed Data.Executed { records }) = records++-- | This represents a result of a “Execute” message which is not yet processed by a server.+newtype ExecutedProcedure (parameterLength :: Nat) (resultLength :: Nat) r =+ ExecutedProcedure (Data.ExecutedProcedure r)+ deriving newtype (Show, Message)++type instance MessageResult (ExecutedProcedure n m r) = (PreparedStatement n m, Portal n m, Executed n m r, Maybe ErrorFields) -- TODO don't error fields themselves++-- | This means that @r@ has a 'name' accesser.+class HasName r where+ -- | Type of name of @r@.+ type Name r :: Type++ -- | To get a name of @r@.+ name :: r -> Name r+ default name :: IsLabel "name" (r -> Name r) => r -> Name r+ name = #name++instance HasName (PreparedStatement n m) where+ type Name (PreparedStatement n m) = PreparedStatementName++instance HasName (PreparedStatementProcedure n m) where+ type Name (PreparedStatementProcedure n m) = PreparedStatementName++instance HasName (Portal n m) where+ type Name (Portal n m) = PortalName++instance HasName (PortalProcedure n m) where+ type Name (PortalProcedure n m) = PortalName++-- | This means that @r@ has a 'parameterOids' accesser.+class HasParameterOids r a where+ -- | To get OIDs of a parameter.+ parameterOids :: r -> a+ default parameterOids :: IsLabel "parameterOids" (r -> a) => r -> a+ parameterOids = #parameterOids++instance (oids ~ Homotuple n Oid, Item oids ~ Oid, IsList oids) => HasParameterOids (PreparedStatement n m) oids++instance (oids ~ Homotuple n Oid, Item oids ~ Oid, IsList oids) => HasParameterOids (PreparedStatementProcedure n m) (Maybe oids)++-- Values++-- | To get the procedure to build the message of parsing SQL query and to parse its response.+parse+ :: forall plen rlen.+ ( KnownNat plen+ , KnownNat rlen+ , IsHomotupleItem plen Oid+ , IsHomotupleItem rlen ColumnInfo+ , IsHomotupleItem rlen Oid+ , IsHomolisttuple rlen Oid+ , IsHomolisttuple plen Oid+ , IsHomolisttuple rlen ColumnInfo+ )+ => PreparedStatementName -- ^ A new name of prepared statement.+ -> Query -- ^ SQL whose placeoholder style is dollar style.+ -> Maybe (Homotuple plen Oid, Homotuple rlen Oid) -- ^ On 'Nothing' an additional pair of a request and a resposne is necessary.+ -- If concrete OIDs are given, it will be pass over.+ -> PreparedStatementProcedure plen rlen+parse name query oids =+ let+ lensOrOids =+ case oids of+ Nothing -> Left (fromInteger $ natVal (Proxy :: Proxy plen), fromInteger $ natVal (Proxy :: Proxy rlen))+ Just v -> Right $ bimap toList toList v+ in+ PreparedStatementProcedure $ Query.parse name query lensOrOids++-- | This means that @ps@ is a objective of 'bind'.+class Bind ps where+ -- | To get the procedure to build the message of binding the parameter and to parse its response.+ bind+ :: forall rlen param m.+ ( ToRecord param+ , KnownNat rlen+ , HasLength (Homotuple rlen ColumnInfo)+ , MonadFail m+ )+ => PortalName -- ^ A new name of portal.+ -> FormatCode -- ^ Binary format or text format for the parameter.+ -> FormatCode -- ^ Binary format or text format for the results.+ -> BackendParameters -- ^ The set of the server parameters.+ -> StringEncoder -- ^ How to encode strings.+ -> param -- ^ Parameter for this query.+ -> ps (Length param) rlen -- ^ Prepared statement.+ -> m (PortalProcedure (Length param) rlen)++instance Bind PreparedStatement where+ bind+ :: forall rlen param m.+ ( ToRecord param+ , HasLength (Homotuple rlen ColumnInfo)+ , MonadFail m+ )+ => PortalName -> FormatCode -> FormatCode -> BackendParameters -> StringEncoder -> param -> PreparedStatement (Length param) rlen -> m (PortalProcedure (Length param) rlen)+ bind name parameterFormat resultFormat backendParams encode parameters (PreparedStatement ps) = PortalProcedure <$> Query.bind name parameterFormat resultFormat backendParams encode parameters ps++instance Bind PreparedStatementProcedure where+ bind+ :: forall rlen param m.+ ( ToRecord param+ , KnownNat rlen+ , MonadFail m+ )+ => PortalName -> FormatCode -> FormatCode -> BackendParameters -> StringEncoder -> param -> PreparedStatementProcedure (Length param) rlen -> m (PortalProcedure (Length param) rlen)+ bind name parameterFormat resultFormat backendParams encode parameters (PreparedStatementProcedure psProc) = PortalProcedure <$> Query.bind name parameterFormat resultFormat backendParams encode parameters psProc++-- | This means that @p@ is a objective of 'execute'.+class Execute p where+ -- | To get the procedure to build the message of execution and to parse its response.+ execute+ :: forall plen result.+ ( FromRecord result+ , IsHomotupleItem (Length result) ColumnInfo+ , IsHomolisttuple (Length result) ColumnInfo+ )+ => Word -- ^ How many records to get. “0” means unlimited.+ -> StringDecoder -- ^ How to decode strings.+ -> p plen (Length result) -- ^ Portal.+ -> ExecutedProcedure plen (Length result) result++instance Execute Portal where+ execute rowLimit decode (Portal p) = ExecutedProcedure $ Query.execute rowLimit decode p++instance Execute PortalProcedure where+ execute rowLimit decode (PortalProcedure pProc) = ExecutedProcedure $ Query.execute rowLimit decode pProc++-- | To send @BEGIN@ SQL statement.+begin :: ExecutedProcedure 0 0 ()+begin = ExecutedProcedure Query.begin++-- | To send @COMMIT@ SQL statement.+commit :: ExecutedProcedure 0 0 ()+commit = ExecutedProcedure Query.commit++-- | To send @ROLLBACK@ SQL statement.+rollback :: ExecutedProcedure 0 0 ()+rollback = ExecutedProcedure Query.rollback
+ src/Database/PostgreSQL/Pure/Internal/Builder.hs view
@@ -0,0 +1,609 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++#include "MachDeps.h"++module Database.PostgreSQL.Pure.Internal.Builder+ ( startup+ , password+ , terminate+ , query+ , parse+ , bind+ , execute+ , describePreparedStatement+ , describePortal+ , flush+ , sync+ , closePreparedStatement+ , closePortal+ ) where++import Database.PostgreSQL.Pure.Internal.Data (BindParameterFormatCodes (BindParameterFormatCodesAll, BindParameterFormatCodesAllDefault, BindParameterFormatCodesEach),+ BindResultFormatCodes (BindResultFormatCodesAllDefault, BindResultFormatCodesEach, BindResultFormatCodesNothing),+ FormatCode (BinaryFormat, TextFormat), Oid (Oid),+ PortalName (PortalName),+ PreparedStatementName (PreparedStatementName),+ Query (Query), ToField (toField),+ ToRecord (toRecord))+import Database.PostgreSQL.Pure.Internal.Exception (cantReachHere)+import qualified Database.PostgreSQL.Pure.Internal.MonadFail as MonadFail+import qualified Database.PostgreSQL.Pure.Oid as Oid+import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as Time++import Control.Exception.Safe (assert)+import qualified Data.Bool as B+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Builder.Prim as BSBP+import qualified Data.ByteString.Lazy as BSL+import qualified Data.Double.Conversion.ByteString as DC+import Data.Fixed (Fixed (MkFixed), HasResolution, Pico, resolution)+import Data.Int (Int16, Int32, Int64)+import qualified Data.Map.Strict as M+import Data.Scientific (FPFormat (Exponent), Scientific, formatScientific,+ scientific)+import Data.Time (Day, DiffTime, NominalDiffTime, TimeOfDay, TimeZone,+ UTCTime)+import Data.Time.LocalTime (LocalTime)+import Data.Tuple.Single (Single, pattern Single)+import qualified PostgreSQL.Binary.Encoding as BE++startup+ :: String -- ^ user name. ASCII text.+ -> String -- ^ database name. ASCII text.+ -> BSB.Builder+startup user database =+ let+ len =+ 4 -- length field+ + 2 -- protocol major version+ + 2 -- protocol minor version+ + 5 -- "user\0"+ + length user+ + 1 -- '\0'+ + 9 -- "database\0"+ + length database+ + 1 -- '\0'+ + 1 -- '\0'+ in+ BSB.int32BE (fromIntegral len)+ <> BSB.int16BE 3 -- protocol major version+ <> BSB.int16BE 0 -- protocol minor version+ <> BSB.string7 "user\0"+ <> BSB.string7 user+ <> BSB.char7 '\0'+ <> BSB.string7 "database\0" <> BSB.string7 database <> BSB.char7 '\0'+ <> BSB.char7 '\0'++password+ :: BS.ByteString -- ^ password, which may be hashed. ASCII text.+ -> BSB.Builder+password password =+ let+ len = 4 + BS.length password + 1+ in+ BSB.char7 'p'+ <> BSB.int32BE (fromIntegral len)+ <> BSB.byteString password+ <> BSB.char7 '\0'++query :: Query -> BSB.Builder+query (Query q) =+ let+ len = 4 + BS.length q + 1+ in+ BSB.char7 'Q'+ <> BSB.int32BE (fromIntegral len)+ <> BSB.byteString q+ <> BSB.char7 '\0'++terminate :: BS.ByteString+terminate = BS.pack [0x58, 0, 0, 0, 4]++parse+ :: PreparedStatementName+ -> Query+ -> [Oid] -- ^ OIDs of data types of parameters+ -> BSB.Builder+parse (PreparedStatementName name) (Query q) oids =+ let+ len = 4 + BS.length name + 1 + BS.length q + 1 + 2 + noids * 4+ noids = length oids+ in+ BSB.char7 'P'+ <> BSB.int32BE (fromIntegral len)+ <> BSB.byteString name+ <> BSB.char7 '\0'+ <> BSB.byteString q+ <> BSB.char7 '\0'+ <> BSB.int16BE (fromIntegral noids)+ <> mconcat (BSB.int32BE . (\(Oid n) -> n) <$> oids)++bind+ :: PortalName+ -> PreparedStatementName+ -> BindParameterFormatCodes+ -> [Maybe BS.ByteString]+ -> BindResultFormatCodes+ -> BSB.Builder+bind (PortalName portalName) (PreparedStatementName preparedStatementName) parameterFormatCodes parameters resultFormatCodes =+ let+ len =+ 4 -- length field+ + BS.length portalName+ + 1 -- '\0'+ + BS.length preparedStatementName+ + 1 -- '\0'+ + 2 -- the number of parameter format codes+ + ( case parameterFormatCodes of -- format codes+ BindParameterFormatCodesAllDefault -> 0+ BindParameterFormatCodesAll _ -> 2+ BindParameterFormatCodesEach cs -> 2 * length cs+ )+ + 2 -- the number of parameters+ + 4 * length parameters -- length field of each parameters+ + sum ((\p -> case p of Just bs -> BS.length bs; Nothing -> 0) <$> parameters) -- parameters themselves+ + 2 -- the number of result format codes+ + ( case resultFormatCodes of -- format codes+ BindResultFormatCodesNothing -> 0+ BindResultFormatCodesAllDefault -> 0+ BindResultFormatCodesEach cs -> 2 * length cs+ )+ in+ BSB.char7 'B'+ <> BSB.int32BE (fromIntegral len)+ <> BSB.byteString portalName+ <> BSB.char7 '\0'+ <> BSB.byteString preparedStatementName+ <> BSB.char7 '\0'+ <> ( case parameterFormatCodes of+ BindParameterFormatCodesAllDefault -> BSB.int16BE 0+ BindParameterFormatCodesAll c -> BSB.int16BE 1 <> BSB.int16BE (fromIntegral $ fromEnum c)+ BindParameterFormatCodesEach cs -> BSB.int16BE (fromIntegral $ length cs) <> mconcat (BSB.int16BE . fromIntegral . fromEnum <$> cs)+ )+ <> BSB.int16BE (fromIntegral $ length parameters)+ <> mconcat+ ( ( \p ->+ case p of+ Just bs -> BSB.int32BE (fromIntegral $ BS.length bs) <> BSB.byteString bs+ Nothing -> BSB.int32BE (-1)+ ) <$> parameters+ )+ <> ( case resultFormatCodes of+ BindResultFormatCodesNothing -> BSB.int16BE 0+ BindResultFormatCodesAllDefault -> BSB.int16BE 1+ BindResultFormatCodesEach cs -> BSB.int16BE (fromIntegral $ length cs) <> mconcat (BSB.int16BE . fromIntegral . fromEnum <$> cs)+ )++execute+ :: PortalName+ -> Int -- ^ limit of the number of rows+ -> BSB.Builder+execute (PortalName name) limitRows =+ let+ len = 4 + BS.length name + 1 + 4+ in+ BSB.char7 'E'+ <> BSB.int32BE (fromIntegral len)+ <> BSB.byteString name+ <> BSB.char7 '\0'+ <> BSB.int32BE (fromIntegral limitRows)++flush :: BS.ByteString+flush = BS.pack [0x48, 0, 0, 0, 4]++sync :: BS.ByteString+sync = BS.pack [0x53, 0, 0, 0, 4]++describePreparedStatement :: PreparedStatementName -> BSB.Builder+describePreparedStatement (PreparedStatementName name) = doDescribe 'S' name++closePreparedStatement :: PreparedStatementName -> BSB.Builder+closePreparedStatement (PreparedStatementName name) = doClose 'S' name++describePortal :: PortalName -> BSB.Builder+describePortal (PortalName name) = doDescribe 'P' name++closePortal :: PortalName -> BSB.Builder+closePortal (PortalName name) = doClose 'P' name++doDescribe :: Char -> BS.ByteString -> BSB.Builder+doDescribe typ name =+ let+ len = 4 + 1 + BS.length name + 1+ in+ BSB.char7 'D'+ <> BSB.int32BE (fromIntegral len)+ <> BSB.char7 typ+ <> BSB.byteString name+ <> BSB.char7 '\0'++doClose :: Char -> BS.ByteString -> BSB.Builder+doClose typ name =+ let+ len = 4 + 1 + BS.length name + 1+ in+ BSB.char7 'C'+ <> BSB.int32BE (fromIntegral len)+ <> BSB.char7 typ+ <> BSB.byteString name+ <> BSB.char7 '\0'++instance ToField () where+ toField _ _ _ _ _ = fail "no values for units"++instance ToField Bool where+ toField _ _ Nothing TextFormat = pure . Just . B.bool "TRUE" "FALSE"+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.bool+ toField backendParams encode (Just o) f | o == Oid.bool = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Bool"++instance ToField Int where+#if WORD_SIZE_IN_BITS > 64+ toField _ _ _ _ _ = fail "the Int's size is too large, larger then 64 bits"+#else+ toField _ _ Nothing TextFormat = pure . Just. BSL.toStrict . BSB.toLazyByteString . BSB.intDec+#if WORD_SIZE_IN_BITS > 32+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.int8_int64 . fromIntegral+ toField backendParams encode (Just o) TextFormat | o == Oid.int8 = toField backendParams encode Nothing TextFormat+ toField backendParams encode (Just o) BinaryFormat | o == Oid.int8 = toField backendParams encode Nothing BinaryFormat+#else /* the width of Int is wider than 30 bits */+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.int4_int32 . fromIntegral+ toField backendParams encode (Just o) TextFormat | o `elem` [Oid.int4, Oid.int8] = toField backendParams encode Nothing TextFormat+ toField backendParams encode (Just o) BinaryFormat | o == Oid.int4 = toField backendParams encode Nothing BinaryFormat+ | o == Oid.int8 = pure . Just . BE.encodingBytes . BE.int8_int64 . fromIntegral+#endif+ toField _ _ (Just o) _ = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Int"+#endif++instance ToField Int16 where+ toField _ _ Nothing TextFormat = pure . Just . BSL.toStrict . BSB.toLazyByteString . BSB.int16Dec+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.int2_int16+ toField backendParams encode (Just o) f | o == Oid.int2 = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Int16"++instance ToField Int32 where+ toField _ _ Nothing TextFormat = pure . Just . BSL.toStrict . BSB.toLazyByteString . BSB.int32Dec+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.int4_int32+ toField backendParams encode (Just o) TextFormat | o `elem` [Oid.int4, Oid.int8] = toField backendParams encode Nothing TextFormat+ toField backendParams encode (Just o) BinaryFormat | o == Oid.int4 = toField backendParams encode Nothing BinaryFormat+ | o == Oid.int8 = pure . Just . BE.encodingBytes . BE.int8_int64 . fromIntegral+ toField _ _ (Just o) _ = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Int32"++instance ToField Int64 where+ toField _ _ Nothing TextFormat = pure . Just . BSL.toStrict . BSB.toLazyByteString . BSB.int64Dec+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.int8_int64+ toField backendParams encode (Just o) f | o == Oid.int8 = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Int64"++instance ToField Float where+ toField _ _ Nothing TextFormat = pure . Just . DC.toShortest . realToFrac+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.float4+ toField backendParams encode (Just o) TextFormat | o `elem` [Oid.float4, Oid.float8] = toField backendParams encode Nothing TextFormat+ toField backendParams encode (Just o) BinaryFormat | o == Oid.float4 = toField backendParams encode Nothing BinaryFormat+ | o == Oid.float8 = pure . Just . BE.encodingBytes . BE.float8 . realToFrac+ toField _ _ (Just o) _ = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Float"++instance ToField Double where+ toField _ _ Nothing TextFormat = pure . Just . DC.toShortest+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.float8+ toField backendParams encode (Just o) f | o == Oid.float8 = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Double"++instance ToField Scientific where+ toField _ encode Nothing TextFormat = (Just <$>) . MonadFail.fromEither . encode . formatScientific Exponent Nothing+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.numeric+ toField backendParams encode (Just o) f | o == Oid.numeric = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Scientific"++instance HasResolution a => ToField (Fixed a) where+ toField _ encode Nothing TextFormat v = Just <$> MonadFail.fromEither (encode (show v)) -- XXX maybe slow+ toField _ _ Nothing BinaryFormat v@(MkFixed i) = pure $ Just $ BE.encodingBytes $ BE.numeric $ scientific i (fromInteger $ resolution v)+ toField backendParams encode (Just o) f v | o == Oid.numeric = toField backendParams encode Nothing f v+ | otherwise = fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Fixed a (" <> show (resolution v) <> ")"++instance ToField Char where+ toField _ encode Nothing _ v = Just <$> MonadFail.fromEither (encode [v])+ toField backendParams encode (Just o) f v | o == Oid.char = toField backendParams encode Nothing f v+ | otherwise = fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Char"++instance ToField String where+ toField _ encode Nothing _ = (Just <$>) . MonadFail.fromEither . encode+ toField backendParams encode (Just _) TextFormat = toField backendParams encode Nothing TextFormat+ toField backendParams encode (Just o) BinaryFormat | o `elem` [Oid.text, Oid.bpchar, Oid.varchar, Oid.name] = toField backendParams encode Nothing BinaryFormat+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: String"++instance ToField BS.ByteString where+ toField _ _ Nothing _ = pure . Just+ toField backendParams encode (Just o) f | o `elem` [Oid.text, Oid.bpchar, Oid.varchar, Oid.name, Oid.bytea] = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: ByteString (strict)"++instance ToField Day where -- TODO infinity/-infinity+ toField _ _ Nothing TextFormat = pure . Just . BSL.toStrict . BSB.toLazyByteString . BSBP.primBounded Time.day+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.date+ toField backendParams encode (Just o) f | o == Oid.date = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Day"++instance ToField TimeOfDay where+ toField _ _ Nothing TextFormat = pure . Just . BSL.toStrict . BSB.toLazyByteString . BSBP.primBounded Time.timeOfDay+ toField backendParams _ Nothing BinaryFormat =+ case M.lookup "integer_datetimes" backendParams of+ Nothing -> const $ fail "not found \"integer_datetimes\" backend parameter"+ Just "on" -> pure . Just . BE.encodingBytes . BE.time_int+ Just "off" -> pure . Just . BE.encodingBytes . BE.time_float+ Just v -> const $ fail $ "\"integer_datetimes\" has unrecognized value: " <> show v+ toField backendParams encode (Just o) f | o == Oid.time = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: TimeOfDay"++instance ToField (TimeOfDay, TimeZone) where+ toField _ _ Nothing TextFormat = pure . Just . BSL.toStrict . BSB.toLazyByteString . BSBP.primBounded (Time.timeOfDay BSBP.>*< Time.timeZone)+ toField backendParams _ Nothing BinaryFormat =+ case M.lookup "integer_datetimes" backendParams of+ Nothing -> const $ fail "not found \"integer_datetimes\" backend parameter"+ Just "on" -> pure . Just . BE.encodingBytes . BE.timetz_int+ Just "off" -> pure . Just . BE.encodingBytes . BE.timetz_float+ Just v -> const $ fail $ "\"integer_datetimes\" has unrecognized value: " <> show v+ toField backendParams encode (Just o) f | o == Oid.timetz = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: (TimeOfDay, TimeZone)"++instance ToField LocalTime where+ toField _ _ Nothing TextFormat = pure . Just . BSL.toStrict . BSB.toLazyByteString . BSBP.primBounded Time.localTime+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.timestamp_int+ toField backendParams encode (Just o) f | o == Oid.timestamp = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: LocalTime"++instance ToField UTCTime where+ toField _ _ Nothing TextFormat = pure . Just . BSL.toStrict . BSB.toLazyByteString . BSBP.primBounded Time.utcTime+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.timestamptz_int+ toField backendParams encode (Just o) f | o == Oid.timestamptz = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: UTCTime"++instance ToField DiffTime where+ toField _ encode Nothing TextFormat = (Just <$>) . MonadFail.fromEither . encode . show -- XXX maybe slow+ toField _ _ Nothing BinaryFormat = pure . Just . BE.encodingBytes . BE.interval_int+ toField backendParams encode (Just o) f | o == Oid.interval = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: DiffTime"++instance ToField NominalDiffTime where+ toField backendParams encode Nothing f = toField backendParams encode Nothing f . (realToFrac :: NominalDiffTime -> Pico)+ toField backendParams encode (Just o) f | o == Oid.numeric = toField backendParams encode Nothing f+ | otherwise = const $ fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: NominalDiffTime"++instance ToField Oid where+ toField _ _ Nothing TextFormat (Oid v) = pure $ Just $ BSL.toStrict $ BSB.toLazyByteString $ BSB.int32Dec v+ toField _ _ Nothing BinaryFormat (Oid v) = pure $ Just $ BE.encodingBytes $ BE.int4_int32 v+ toField backendParams encode (Just o) f v | o == Oid.oid = toField backendParams encode Nothing f v+ | otherwise = fail $ "type mismatch (ToField): OID: " <> show o <> ", Haskell: Oid"++-- 0 tuple+instance ToRecord () where+ toRecord _ _ Nothing [] _ =+ pure []+ toRecord _ _ Nothing fs _ =+ fail $ "the number of format codes must be 0, actually " <> show (length fs)+ toRecord _ _ (Just []) [] _ =+ pure []+ toRecord _ _ (Just os) [] _ =+ fail $ "the number of OIDs must be 0, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 0, actually " <> show (length fs)++-- 1 tuple+instance+ {-# OVERLAPPABLE #-}+ (ToField a, Single c, t ~ c a)+ => ToRecord t where+ toRecord backendParams encode Nothing [format] (Single v) =+ sequence [toField backendParams encode Nothing format v]+ toRecord _ _ Nothing [_] _ =+ cantReachHere+ toRecord backendParams encode (Just [o]) [format] (Single v) =+ sequence [toField backendParams encode (Just o) format v]+ toRecord _ _ (Just os) [_] _ =+ fail $ "the number of OIDs must be 1, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 1, actually " <> show (length fs)++-- 2 tuple+instance+ (ToField a, ToField b)+ => ToRecord (a, b) where+ toRecord backendParams encode Nothing [f0, f1] (v0, v1) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1]+ toRecord backendParams encode (Just [o0, o1]) [f0, f1] (v0, v1) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 2, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 2, actually " <> show (length fs)++-- 3 tuple+instance+ (ToField a, ToField b, ToField c)+ => ToRecord (a, b, c) where+ toRecord backendParams encode Nothing [f0, f1, f2] (v0, v1, v2) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2]+ toRecord backendParams encode (Just [o0, o1, o2]) [f0, f1, f2] (v0, v1, v2) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 3, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 3, actually " <> show (length fs)++-- 4 tuple+instance+ (ToField a, ToField b, ToField c, ToField d)+ => ToRecord (a, b, c, d) where+ toRecord backendParams encode Nothing [f0, f1, f2, f3] (v0, v1, v2, v3) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2, toField backendParams encode Nothing f3 v3]+ toRecord backendParams encode (Just [o0, o1, o2, o3]) [f0, f1, f2, f3] (v0, v1, v2, v3) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2, toField backendParams encode (Just o3) f3 v3]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 4, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 4, actually " <> show (length fs)++-- 5 tuple+instance+ (ToField a, ToField b, ToField c, ToField d, ToField e)+ => ToRecord (a, b, c, d, e) where+ toRecord backendParams encode Nothing [f0, f1, f2, f3, f4] (v0, v1, v2, v3, v4) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2, toField backendParams encode Nothing f3 v3, toField backendParams encode Nothing f4 v4]+ toRecord backendParams encode (Just [o0, o1, o2, o3, o4]) [f0, f1, f2, f3, f4] (v0, v1, v2, v3, v4) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2, toField backendParams encode (Just o3) f3 v3, toField backendParams encode (Just o4) f4 v4]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 5, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 5, actually " <> show (length fs)++-- 6 tuple+instance+ (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f)+ => ToRecord (a, b, c, d, e, f) where+ toRecord backendParams encode Nothing [f0, f1, f2, f3, f4, f5] (v0, v1, v2, v3, v4, v5) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2, toField backendParams encode Nothing f3 v3, toField backendParams encode Nothing f4 v4, toField backendParams encode Nothing f5 v5]+ toRecord backendParams encode (Just [o0, o1, o2, o3, o4, o5]) [f0, f1, f2, f3, f4, f5] (v0, v1, v2, v3, v4, v5) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2, toField backendParams encode (Just o3) f3 v3, toField backendParams encode (Just o4) f4 v4, toField backendParams encode (Just o5) f5 v5]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 6, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 6, actually " <> show (length fs)++-- 7 tuple+instance+ (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g)+ => ToRecord (a, b, c, d, e, f, g) where+ toRecord backendParams encode Nothing [f0, f1, f2, f3, f4, f5, f6] (v0, v1, v2, v3, v4, v5, v6) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2, toField backendParams encode Nothing f3 v3, toField backendParams encode Nothing f4 v4, toField backendParams encode Nothing f5 v5, toField backendParams encode Nothing f6 v6]+ toRecord backendParams encode (Just [o0, o1, o2, o3, o4, o5, o6]) [f0, f1, f2, f3, f4, f5, f6] (v0, v1, v2, v3, v4, v5, v6) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2, toField backendParams encode (Just o3) f3 v3, toField backendParams encode (Just o4) f4 v4, toField backendParams encode (Just o5) f5 v5, toField backendParams encode (Just o6) f6 v6]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 7, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 7, actually " <> show (length fs)++-- 8 tuple+instance+ (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h)+ => ToRecord (a, b, c, d, e, f, g, h) where+ toRecord backendParams encode Nothing [f0, f1, f2, f3, f4, f5, f6, f7] (v0, v1, v2, v3, v4, v5, v6, v7) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2, toField backendParams encode Nothing f3 v3, toField backendParams encode Nothing f4 v4, toField backendParams encode Nothing f5 v5, toField backendParams encode Nothing f6 v6, toField backendParams encode Nothing f7 v7]+ toRecord backendParams encode (Just [o0, o1, o2, o3, o4, o5, o6, o7]) [f0, f1, f2, f3, f4, f5, f6, f7] (v0, v1, v2, v3, v4, v5, v6, v7) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2, toField backendParams encode (Just o3) f3 v3, toField backendParams encode (Just o4) f4 v4, toField backendParams encode (Just o5) f5 v5, toField backendParams encode (Just o6) f6 v6, toField backendParams encode (Just o7) f7 v7]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 8, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 8, actually " <> show (length fs)++-- 9 tuple+instance+ (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i)+ => ToRecord (a, b, c, d, e, f, g, h, i) where+ toRecord backendParams encode Nothing [f0, f1, f2, f3, f4, f5, f6, f7, f8] (v0, v1, v2, v3, v4, v5, v6, v7, v8) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2, toField backendParams encode Nothing f3 v3, toField backendParams encode Nothing f4 v4, toField backendParams encode Nothing f5 v5, toField backendParams encode Nothing f6 v6, toField backendParams encode Nothing f7 v7, toField backendParams encode Nothing f8 v8]+ toRecord backendParams encode (Just [o0, o1, o2, o3, o4, o5, o6, o7, o8]) [f0, f1, f2, f3, f4, f5, f6, f7, f8] (v0, v1, v2, v3, v4, v5, v6, v7, v8) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2, toField backendParams encode (Just o3) f3 v3, toField backendParams encode (Just o4) f4 v4, toField backendParams encode (Just o5) f5 v5, toField backendParams encode (Just o6) f6 v6, toField backendParams encode (Just o7) f7 v7, toField backendParams encode (Just o8) f8 v8]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 9, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 9, actually " <> show (length fs)++-- 10 tuple+instance+ (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j)+ => ToRecord (a, b, c, d, e, f, g, h, i, j) where+ toRecord backendParams encode Nothing [f0, f1, f2, f3, f4, f5, f6, f7, f8, f9] (v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2, toField backendParams encode Nothing f3 v3, toField backendParams encode Nothing f4 v4, toField backendParams encode Nothing f5 v5, toField backendParams encode Nothing f6 v6, toField backendParams encode Nothing f7 v7, toField backendParams encode Nothing f8 v8, toField backendParams encode Nothing f9 v9]+ toRecord backendParams encode (Just [o0, o1, o2, o3, o4, o5, o6, o7, o8, o9]) [f0, f1, f2, f3, f4, f5, f6, f7, f8, f9] (v0, v1, v2, v3, v4, v5, v6, v7, v8, v9) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2, toField backendParams encode (Just o3) f3 v3, toField backendParams encode (Just o4) f4 v4, toField backendParams encode (Just o5) f5 v5, toField backendParams encode (Just o6) f6 v6, toField backendParams encode (Just o7) f7 v7, toField backendParams encode (Just o8) f8 v8, toField backendParams encode (Just o9) f9 v9]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 10, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 10, actually " <> show (length fs)++-- 11 tuple+instance+ (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k)+ => ToRecord (a, b, c, d, e, f, g, h, i, j, k) where+ toRecord backendParams encode Nothing [f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10] (v0, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2, toField backendParams encode Nothing f3 v3, toField backendParams encode Nothing f4 v4, toField backendParams encode Nothing f5 v5, toField backendParams encode Nothing f6 v6, toField backendParams encode Nothing f7 v7, toField backendParams encode Nothing f8 v8, toField backendParams encode Nothing f9 v9, toField backendParams encode Nothing f10 v10]+ toRecord backendParams encode (Just [o0, o1, o2, o3, o4, o5, o6, o7, o8, o9, o10]) [f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10] (v0, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2, toField backendParams encode (Just o3) f3 v3, toField backendParams encode (Just o4) f4 v4, toField backendParams encode (Just o5) f5 v5, toField backendParams encode (Just o6) f6 v6, toField backendParams encode (Just o7) f7 v7, toField backendParams encode (Just o8) f8 v8, toField backendParams encode (Just o9) f9 v9, toField backendParams encode (Just o10) f10 v10]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 11, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 11, actually " <> show (length fs)++-- 12 tuple+instance+ (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l)+ => ToRecord (a, b, c, d, e, f, g, h, i, j, k, l) where+ toRecord backendParams encode Nothing [f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11] (v0, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2, toField backendParams encode Nothing f3 v3, toField backendParams encode Nothing f4 v4, toField backendParams encode Nothing f5 v5, toField backendParams encode Nothing f6 v6, toField backendParams encode Nothing f7 v7, toField backendParams encode Nothing f8 v8, toField backendParams encode Nothing f9 v9, toField backendParams encode Nothing f10 v10, toField backendParams encode Nothing f11 v11]+ toRecord backendParams encode (Just [o0, o1, o2, o3, o4, o5, o6, o7, o8, o9, o10, o11]) [f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11] (v0, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2, toField backendParams encode (Just o3) f3 v3, toField backendParams encode (Just o4) f4 v4, toField backendParams encode (Just o5) f5 v5, toField backendParams encode (Just o6) f6 v6, toField backendParams encode (Just o7) f7 v7, toField backendParams encode (Just o8) f8 v8, toField backendParams encode (Just o9) f9 v9, toField backendParams encode (Just o10) f10 v10, toField backendParams encode (Just o11) f11 v11]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 12, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 12, actually " <> show (length fs)++-- 13 tuple+instance+ (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, ToField m)+ => ToRecord (a, b, c, d, e, f, g, h, i, j, k, l, m) where+ toRecord backendParams encode Nothing [f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12] (v0, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2, toField backendParams encode Nothing f3 v3, toField backendParams encode Nothing f4 v4, toField backendParams encode Nothing f5 v5, toField backendParams encode Nothing f6 v6, toField backendParams encode Nothing f7 v7, toField backendParams encode Nothing f8 v8, toField backendParams encode Nothing f9 v9, toField backendParams encode Nothing f10 v10, toField backendParams encode Nothing f11 v11, toField backendParams encode Nothing f12 v12]+ toRecord backendParams encode (Just [o0, o1, o2, o3, o4, o5, o6, o7, o8, o9, o10, o11, o12]) [f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12] (v0, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2, toField backendParams encode (Just o3) f3 v3, toField backendParams encode (Just o4) f4 v4, toField backendParams encode (Just o5) f5 v5, toField backendParams encode (Just o6) f6 v6, toField backendParams encode (Just o7) f7 v7, toField backendParams encode (Just o8) f8 v8, toField backendParams encode (Just o9) f9 v9, toField backendParams encode (Just o10) f10 v10, toField backendParams encode (Just o11) f11 v11, toField backendParams encode (Just o12) f12 v12]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 13, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 13, actually " <> show (length fs)++-- 14 tuple+instance+ (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, ToField m, ToField n)+ => ToRecord (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+ toRecord backendParams encode Nothing [f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13] (v0, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2, toField backendParams encode Nothing f3 v3, toField backendParams encode Nothing f4 v4, toField backendParams encode Nothing f5 v5, toField backendParams encode Nothing f6 v6, toField backendParams encode Nothing f7 v7, toField backendParams encode Nothing f8 v8, toField backendParams encode Nothing f9 v9, toField backendParams encode Nothing f10 v10, toField backendParams encode Nothing f11 v11, toField backendParams encode Nothing f12 v12, toField backendParams encode Nothing f13 v13]+ toRecord backendParams encode (Just [o0, o1, o2, o3, o4, o5, o6, o7, o8, o9, o10, o11, o12, o13]) [f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13] (v0, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2, toField backendParams encode (Just o3) f3 v3, toField backendParams encode (Just o4) f4 v4, toField backendParams encode (Just o5) f5 v5, toField backendParams encode (Just o6) f6 v6, toField backendParams encode (Just o7) f7 v7, toField backendParams encode (Just o8) f8 v8, toField backendParams encode (Just o9) f9 v9, toField backendParams encode (Just o10) f10 v10, toField backendParams encode (Just o11) f11 v11, toField backendParams encode (Just o12) f12 v12, toField backendParams encode (Just o13) f13 v13]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 14, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 14, actually " <> show (length fs)++-- 15 tuple+instance+ (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j, ToField k, ToField l, ToField m, ToField n, ToField o)+ => ToRecord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+ toRecord backendParams encode Nothing [f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13, f14] (v0, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14) =+ sequence [toField backendParams encode Nothing f0 v0, toField backendParams encode Nothing f1 v1, toField backendParams encode Nothing f2 v2, toField backendParams encode Nothing f3 v3, toField backendParams encode Nothing f4 v4, toField backendParams encode Nothing f5 v5, toField backendParams encode Nothing f6 v6, toField backendParams encode Nothing f7 v7, toField backendParams encode Nothing f8 v8, toField backendParams encode Nothing f9 v9, toField backendParams encode Nothing f10 v10, toField backendParams encode Nothing f11 v11, toField backendParams encode Nothing f12 v12, toField backendParams encode Nothing f13 v13, toField backendParams encode Nothing f14 v14]+ toRecord backendParams encode (Just [o0, o1, o2, o3, o4, o5, o6, o7, o8, o9, o10, o11, o12, o13, o14]) [f0, f1, f2, f3, f4, f5, f6, f7, f8, f9, f10, f11, f12, f13, f14] (v0, v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13, v14) =+ sequence [toField backendParams encode (Just o0) f0 v0, toField backendParams encode (Just o1) f1 v1, toField backendParams encode (Just o2) f2 v2, toField backendParams encode (Just o3) f3 v3, toField backendParams encode (Just o4) f4 v4, toField backendParams encode (Just o5) f5 v5, toField backendParams encode (Just o6) f6 v6, toField backendParams encode (Just o7) f7 v7, toField backendParams encode (Just o8) f8 v8, toField backendParams encode (Just o9) f9 v9, toField backendParams encode (Just o10) f10 v10, toField backendParams encode (Just o11) f11 v11, toField backendParams encode (Just o12) f12 v12, toField backendParams encode (Just o13) f13 v13, toField backendParams encode (Just o14) f14 v14]+ toRecord _ _ (Just os) _ _ =+ fail $ "the number of OIDs must be 15, actually " <> show (length os)+ toRecord _ _ _ fs _ =+ fail $ "the number of format codes must be 15, actually " <> show (length fs)++-- list+instance+ {-# OVERLAPPING #-}+ ToField a+ => ToRecord [a] where+ toRecord backendParams encode Nothing fs vs =+ sequence $ uncurry (toField backendParams encode Nothing) <$> zip fs vs+ toRecord backendParams encode (Just os) fs vs =+ assert (length os == length fs && length fs == length vs) $ sequence $ uncurry3 (toField backendParams encode) <$> zip3 (Just <$> os) fs vs++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (a, b, c) = f a b c
+ src/Database/PostgreSQL/Pure/Internal/Connection.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.PostgreSQL.Pure.Internal.Connection+ ( connect+ , disconnect+ , withConnection+ ) where++import qualified Database.PostgreSQL.Pure.Internal.Builder as Builder+import Database.PostgreSQL.Pure.Internal.Data (Address (AddressNotResolved, AddressResolved),+ AuthenticationMD5Password (AuthenticationMD5Password),+ AuthenticationResponse (AuthenticationMD5PasswordResponse, AuthenticationOkResponse),+ BackendKey, BackendKeyData (BackendKeyData),+ BackendParameters, Buffer (Buffer),+ Config (Config, address, database, password, receptionBufferSize, sendingBufferSize, user),+ Connection (Connection, config, receptionBuffer, sendingBuffer, socket),+ ParameterStatus (ParameterStatus), Pid,+ ReadyForQuery (ReadyForQuery), Salt,+ TransactionState (Idle))+import qualified Database.PostgreSQL.Pure.Internal.Exception as Exception+import qualified Database.PostgreSQL.Pure.Internal.Parser as Parser+import Database.PostgreSQL.Pure.Internal.SocketIO (SocketIO, buildAndSend, receive, runSocketIO, send)++import Control.Exception.Safe (assert, bracket)+import Control.Monad (void)+import Control.Monad.Reader (ask)+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Internal as BSI+import qualified Data.ByteString.UTF8 as BSU+import qualified Data.Map.Strict as Map+import qualified Network.Socket as NS++#ifdef PURE_MD5+import qualified Data.Digest.Pure.MD5 as MD5+#else+import qualified Crypto.Hash.MD5 as MD5+#endif++-- | Bracket function for a connection.+withConnection :: Config -> (Connection -> IO a) -> IO a+withConnection config@Config { address } f =+ Exception.convert $ do+ addr <-+ case address of+ AddressResolved a -> pure $ addrInfo a+ AddressNotResolved h s -> resolve h s+ bracket (open addr) NS.close $ \sock -> do+ conn <- connect' sock config+ f conn++-- | To connect to the server.+connect :: Config -> IO Connection+connect config@Config { address } =+ Exception.convert $ do+ addr <-+ case address of+ AddressResolved a -> pure $ addrInfo a+ AddressNotResolved h s -> resolve h s+ sock <- open addr+ connect' sock config++connect' :: NS.Socket -> Config -> IO Connection+connect' sock config@Config { sendingBufferSize, receptionBufferSize } = do+ sBuff <- flip Buffer sendingBufferSize <$> BSI.mallocByteString sendingBufferSize+ rBuff <- flip Buffer receptionBufferSize <$> BSI.mallocByteString receptionBufferSize+ runSocketIO sock sBuff rBuff config initializeConnection++-- | To disconnect to the server.+disconnect :: Connection -> IO ()+disconnect Connection { socket, sendingBuffer, receptionBuffer, config } =+ Exception.convert $ do+ runSocketIO socket sendingBuffer receptionBuffer config terminate+ NS.close socket++addrInfoHints :: NS.AddrInfo+addrInfoHints =+ NS.defaultHints+ { NS.addrSocketType = NS.Stream+ , NS.addrProtocol = 6 -- TCP+ , NS.addrFlags = [NS.AI_ADDRCONFIG]+ }++addrInfo :: NS.SockAddr -> NS.AddrInfo+addrInfo address =+ addrInfoHints+ { NS.addrAddress = address+ , NS.addrFamily =+ case address of+ NS.SockAddrInet {} -> NS.AF_INET+ NS.SockAddrInet6 {} -> NS.AF_INET6+ NS.SockAddrUnix {} -> NS.AF_UNIX+ _ -> NS.AF_UNSPEC+ }++resolve :: NS.HostName -> NS.ServiceName -> IO NS.AddrInfo+resolve host service = do+ addrs <- NS.getAddrInfo (Just addrInfoHints) (Just host) (Just service)+ case addrs of+ addr:_ -> return addr+ [] -> Exception.cantReachHere++open :: NS.AddrInfo -> IO NS.Socket+open addr = do+ sock <- NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) (NS.addrProtocol addr)+ NS.connect sock $ NS.addrAddress addr+ return sock++initializeConnection :: SocketIO Connection+initializeConnection = do+ response <- startup+ (bps, pid, bk) <- authenticate response+ (sock, sBuff, rBuff, config) <- ask+ pure $ Connection sock pid bk bps sBuff rBuff config++startup :: SocketIO AuthenticationResponse+startup = do+ (_, _, _, Config { user, database }) <- ask+ buildAndSend $ Builder.startup user database+ receive Parser.authentication++authenticate :: AuthenticationResponse -> SocketIO (BackendParameters, Pid, BackendKey)+authenticate response = do+ (_, _, _, Config { user, password }) <- ask+ case response of+ AuthenticationOkResponse -> pure ()+ AuthenticationMD5PasswordResponse (AuthenticationMD5Password salt) -> auth $ hashMD5 user password salt+ (bps, pid, bk) <-+ receive $ do+ bps <- Map.fromList . ((\(ParameterStatus k v) -> (k, v)) <$>) <$> AP.many' Parser.parameterStatus+ BackendKeyData pid bk <- Parser.backendKeyData+ ReadyForQuery ts <- Parser.readyForQuery+ assert (ts == Idle) $ pure (bps, pid, bk)+ pure (bps, pid, bk)+ where+ auth pw = do+ buildAndSend $ Builder.password pw+ void $ receive Parser.authenticationOk++terminate :: SocketIO ()+terminate = send Builder.terminate++hashMD5 :: String -> String -> Salt -> BS.ByteString+hashMD5 user password salt =+ let+ user' = BSU.fromString user+ password' = BSU.fromString password+#ifdef PURE_MD5+ hash = B16.encode . MD5.md5DigestBytes . MD5.hash'+#else+ hash = B16.encode . MD5.hash+#endif+ in+ "md5" <> hash (hash (password' <> user') <> salt)
+ src/Database/PostgreSQL/Pure/Internal/Data.hs view
@@ -0,0 +1,593 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.PostgreSQL.Pure.Internal.Data+ ( Connection (..)+ , Config (..)+ , ColumnInfo (..)+ , Response (..)+ , AuthenticationResponse (..)+ , AuthenticationMD5Password (..)+ , BackendKeyData (..)+ , CommandComplete (..)+ , DataRow (..)+ , DataRowRaw (..)+ , Error (..)+ , Notice (..)+ , ParameterStatus (..)+ , ReadyForQuery (..)+ , RowDescription (..)+ , ParameterDescription (..)+ , Debug (..)+ , ExecuteResult (..)+ , DescribeResult (..)+ , AttributeNumber+ , TypeModifier+ , FormatCode (..)+ , BindParameterFormatCodes (..)+ , BindResultFormatCodes (..)+ , TypeLength (..)+ , CommandTag (..)+ , ErrorFields (..)+ , TransactionState (..)+ , Buffer (..)+ , Carry+ , Salt+ , Address (..)+ , BackendParameters+ , Pid+ , BackendKey+ , Oid (..)+ , Raw (Null, Value)+ , Query (..)+ , PreparedStatement (..)+ , PreparedStatementProcedure (..)+ , PreparedStatementName (..)+ , Portal (..)+ , PortalProcedure (..)+ , PortalName (..)+ , Executed (..)+ , ExecutedProcedure (..)+ , CloseProcedure (..)+ , MessageResult+ , StringDecoder+ , StringEncoder+ , FromField (..)+ , FromRecord (..)+ , ToField (..)+ , ToRecord (..)+ , SqlIdentifier (..)+ , Pretty (..)+ ) where++import Database.PostgreSQL.Pure.Oid (Oid (Oid))++import Control.Applicative ((<|>))+import Control.Monad.Fail (MonadFail)+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Short as BSS+import qualified Data.ByteString.UTF8 as BSU+import Data.Char (chr, isPrint, toLower)+import Data.Default.Class (Default (def))+import Data.Int (Int16, Int32)+import Data.Kind (Type)+import Data.List (intercalate)+import Data.Map.Strict (Map)+import Data.String (IsString)+import Data.Word (Word8)+import Foreign (ForeignPtr)+import Hexdump (prettyHex, simpleHex)+import Network.Socket (Socket)+import qualified Network.Socket as NS+import Text.Read (Read (readPrec))+import qualified Text.Read as R+import qualified Text.Read.Lex as R++-- | A configuration of a connection.+--+-- Default configuration is 'def', which is following.+--+-- @+-- 'Config'+-- { address = 'AddressResolved' $ 'NS.SockAddrInet' 5432 $ 'NS.tupleToHostAddress' (127, 0, 0, 1)+-- , user = "postgres"+-- , password = ""+-- , database = ""+-- , sendingBufferSize = 2 ^ (12 :: 'Int')+-- , receptionBufferSize = 2 ^ (12 :: 'Int')+-- }+-- @+data Config =+ Config+ { address :: Address -- ^ Server address.+ , user :: String -- ^ User name.+ , password :: String -- ^ Password of user.+ , database :: String -- ^ Database name.+ , sendingBufferSize :: Int -- ^ The size of sending buffer in byte.+ , receptionBufferSize :: Int -- ^ The size of receiving buffer in byte.+ }+ deriving (Show, Eq)++instance Default Config where+ def =+ Config+ { address = AddressResolved $ NS.SockAddrInet 5432 $ NS.tupleToHostAddress (127, 0, 0, 1)+ , user = "postgres"+ , password = ""+ , database = ""+ , sendingBufferSize = 2 ^ (12 :: Int)+ , receptionBufferSize = 2 ^ (12 :: Int)+ }++-- | IP address.+data Address+ = AddressResolved NS.SockAddr -- ^ Address which is DNS resolved.+ | AddressNotResolved NS.HostName NS.ServiceName -- ^ Address which is not DNS resolved.+ deriving (Show, Eq)++-- | Set of server parameters.+type BackendParameters = Map BSS.ShortByteString BSS.ShortByteString++-- | PostgreSQL connection.+data Connection =+ Connection+ { socket :: Socket+ , pid :: Pid -- ^ The process ID of the server.+ , backendKey :: BackendKey+ , parameters :: BackendParameters -- ^ Set of server parameters.+ , sendingBuffer :: Buffer+ , receptionBuffer :: Buffer+ , config :: Config -- ^ Configuration of this connection.+ }++data Buffer = Buffer (ForeignPtr Word8) Int++type Salt = BS.ByteString++-- | Transaction state of a server.+data TransactionState+ = Idle -- ^ Not in a transaction block.+ | Block -- ^ In a transaction block.+ | Failed -- ^ Transaction failed.+ deriving (Show, Read, Eq, Enum)++-- | Proccess ID+type Pid = Int32++type BackendKey = Int32++type AttributeNumber = Int16++data TypeLength = VariableLength | FixedLength Int16 deriving (Show, Read, Eq, Ord)++type TypeModifier = Int32++-- | Format code of patameters of results.+data FormatCode = TextFormat | BinaryFormat deriving (Show, Read, Eq, Enum)++data BindParameterFormatCodes+ = BindParameterFormatCodesAllDefault+ | BindParameterFormatCodesAll FormatCode+ | BindParameterFormatCodesEach [FormatCode]+ deriving (Show, Read, Eq)++data BindResultFormatCodes+ = BindResultFormatCodesNothing+ | BindResultFormatCodesAllDefault+ | BindResultFormatCodesEach [FormatCode]+ deriving (Show, Read, Eq)++-- | Command tag, which means which SQL command is completed.+data CommandTag+ = InsertTag Oid Int+ | DeleteTag Int+ | UpdateTag Int+ | SelectTag Int+ | MoveTag Int+ | FetchTag Int+ | CopyTag Int -- since PostgreSQL 8.2+ | CreateTableTag+ | DropTableTag+ | BeginTag+ | CommitTag+ | RollbackTag+ | SetTag+ deriving (Show, Read, Eq)++data Response+ = AuthenticationResponse AuthenticationResponse+ | BackendKeyDataResponse BackendKeyData+ | CommandCompleteResponse CommandComplete+ | DataRowResponse DataRowRaw+ | ErrorResponse Error+ | NoticeResponse Notice+ | ParameterStatusResponse ParameterStatus+ | ReadyForQueryResponse ReadyForQuery+ | RowDescriptionResponse RowDescription+ | ParseCompleteResponse+ | BindCompleteResponse+ | EmptyQueryResponse+ | NoDataResponse+ | ParameterDescriptionResponse ParameterDescription+ | DebugResponse Debug -- XXX temporal implimentation++data AuthenticationResponse+ = AuthenticationOkResponse+ | AuthenticationMD5PasswordResponse AuthenticationMD5Password+ deriving (Show, Read, Eq)++newtype AuthenticationMD5Password = AuthenticationMD5Password Salt deriving (Show, Read, Eq)++data BackendKeyData = BackendKeyData Pid BackendKey deriving (Show, Read, Eq)++newtype CommandComplete = CommandComplete CommandTag deriving (Show, Read, Eq)++newtype DataRow r = DataRow r deriving (Show, Read, Eq)++newtype DataRowRaw = DataRowRaw [Raw] deriving (Show, Read, Eq)++newtype Error = Error ErrorFields deriving (Show, Read, Eq)++newtype Notice = Notice ErrorFields deriving (Show, Read, Eq)++data ParameterStatus = ParameterStatus BSS.ShortByteString BSS.ShortByteString deriving (Show, Read, Eq)++newtype ReadyForQuery = ReadyForQuery TransactionState deriving (Show, Read, Eq)++newtype RowDescription = RowDescription [ColumnInfo] deriving (Show, Read, Eq)++newtype ParameterDescription = ParameterDescription [Oid] deriving (Show, Read, Eq)++newtype Debug = Debug BS.ByteString deriving (Show, Read, Eq) -- XXX temporal implimentation++-- | Result of a “Execute” message.+data ExecuteResult+ = ExecuteComplete CommandTag -- ^ All records gotten.+ | ExecuteEmptyQuery -- ^ No records.+ | ExecuteSuspended -- ^ Records are left yet.+ deriving (Show, Read, Eq)++data DescribeResult+ = DescribePreparedStatementResult [Oid] [ColumnInfo]+ | DescribePortalResult [ColumnInfo]+ deriving (Show, Read, Eq)++-- https://www.postgresql.org/docs/current/protocol-error-fields.html+newtype ErrorFields = ErrorFields [(Char, BSS.ShortByteString)] deriving (Show, Read, Eq)++data TypeInfo+ = Basic Oid BS.ByteString+ deriving (Show, Read, Eq)++-- | Metadata of a column.+data ColumnInfo =+ ColumnInfo+ { name :: BS.ByteString+ , tableOid :: Oid+ , attributeNumber :: AttributeNumber+ , typeOid :: Oid+ , typeLength :: TypeLength+ , typeModifier :: TypeModifier+ , formatCode :: FormatCode+ }+ deriving (Show, Read, Eq)++type Carry = BS.ByteString++-- | Data without encoding nor decoding of a field.+newtype Raw = Raw (Maybe BS.ByteString) deriving (Eq, Ord)++instance Show Raw where+ show Null = "NULL"+ show (Value a) = show (BS.unpack a)++instance Read Raw where+ readPrec =+ R.parens+ ( ( do+ R.lift $ R.expect $ R.Ident "NULL"+ pure Null+ )+ <|> (Value . BS.pack <$> readPrec)+ )++-- | @NULL@.+pattern Null :: Raw+pattern Null = Raw Nothing++-- | Not @NULL@.+pattern Value :: BS.ByteString -> Raw+pattern Value a = Raw (Just a)++{-# COMPLETE Null, Value #-}++-- | SQL query.+--+-- This 'Data.String.fromString' counts only ASCII, becouse it is the same with 'BS.ByteString'.+newtype Query = Query BS.ByteString deriving (Show, Read, Eq, Ord, IsString)++-- | To convert a type which means that is is not prcessed by the server to a respective type which means that it is processed by the server.+type family MessageResult m :: Type++-- | This represents a prepared statement which is already processed by a server.+data PreparedStatement =+ PreparedStatement+ { name :: PreparedStatementName+ , parameterOids :: [Oid]+ , resultInfos :: [ColumnInfo]+ }++instance Show PreparedStatement where+ show (PreparedStatement name parameterOids resultInfos) = "PreparedStatement " <> show name <> " " <> show parameterOids <> " " <> show resultInfos++instance Eq PreparedStatement where+ (PreparedStatement name0 parameterOids0 resultInfos0) == (PreparedStatement name1 parameterOids1 resultInfos1) = (name0, parameterOids0, resultInfos0) == (name1, parameterOids1, resultInfos1)++-- | This represents a prepared statemnt which is not yet processed by a server.+data PreparedStatementProcedure =+ PreparedStatementProcedure+ { name :: PreparedStatementName+ , parameterLength :: Word+ , resultLength :: Word+ , parameterOids :: Maybe [Oid]+ , builder :: BSB.Builder+ , parser :: AP.Parser (MessageResult PreparedStatementProcedure)+ }++type instance MessageResult PreparedStatementProcedure = PreparedStatement++instance Show PreparedStatementProcedure where+ show (PreparedStatementProcedure name parameterLength resultLength oids _ _) =+ mconcat ["PreparedStatementProcedure ", show name, " ", show parameterLength, " ", show resultLength, " ", show oids, " _ _"]++-- | Name of a prepared statement.+newtype PreparedStatementName =+ PreparedStatementName BS.ByteString+ deriving stock (Eq, Ord)+ deriving newtype (Show, Read, IsString)++-- | This represents a portal which is already processed by a server.+data Portal =+ Portal+ { name :: PortalName+ , infos :: [ColumnInfo]+ , preparedStatement :: PreparedStatement+ }++instance Show Portal where+ show (Portal name infos ps) = "Portal " <> show name <> " " <> show infos <> " (" <> show ps <> ")"++instance Eq Portal where+ (Portal name0 infos0 ps0) == (Portal name1 infos1 ps1) = (name0, infos0, ps0) == (name1, infos1, ps1)++-- | This represents a portal which is not yet processed by a server.+data PortalProcedure =+ PortalProcedure+ { name :: PortalName+ , format :: FormatCode+ , builder :: BSB.Builder+ , parser :: AP.Parser (MessageResult PortalProcedure)+ }++type instance MessageResult PortalProcedure = (PreparedStatement, Portal)++instance Show PortalProcedure where+ show (PortalProcedure name format _ _) = "PortalProcedure " <> show name <> " " <> show format <> " _ _"++-- | Name of a portal.+newtype PortalName =+ PortalName BS.ByteString+ deriving stock (Eq, Ord)+ deriving newtype (Show, Read, IsString)++-- | This represents a result of a “Execute” message which is already processed by a server.+data Executed r =+ Executed+ { result :: ExecuteResult+ , records :: [r]+ , portal :: Portal+ }++instance Show r => Show (Executed r) where+ show (Executed r rs p) = "Executed " <> show r <> " " <> show rs <> " (" <> show p <> ")"++instance Eq r => Eq (Executed r) where+ (Executed r0 rs0 p0) == (Executed r1 rs1 p1) = (r0, rs0, p0) == (r1, rs1, p1)++-- | This represents a result of a “Execute” message which is not yet processed by a server.+data ExecutedProcedure r =+ ExecutedProcedure+ { builder :: BSB.Builder+ , parser :: AP.Parser (MessageResult (ExecutedProcedure r))+ }++type instance MessageResult (ExecutedProcedure r) = (PreparedStatement, Portal, Executed r, Maybe ErrorFields)++instance Show (ExecutedProcedure r) where+ show (ExecutedProcedure _ _) = "ExecutedProcedure _ _"++-- | This represents a result of a “Close” message which is not yet processed by a server.+data CloseProcedure =+ CloseProcedure+ { builder :: BSB.Builder+ , parser :: AP.Parser (MessageResult CloseProcedure)+ }++type instance MessageResult CloseProcedure = ()++instance Show CloseProcedure where+ show (CloseProcedure _ _) = "CloseProcedure _ _"++-- | Decoder of strings which may fail.+type StringDecoder = BS.ByteString -> Either String String++-- | Encoder of strings which may fail.+type StringEncoder = String -> Either String BS.ByteString++-- | This means that a field can be decoded as @a@.+class FromField a where+ -- | Decoder of a field.+ fromField :: MonadFail m => StringDecoder -> ColumnInfo -> Maybe BS.ByteString -> m a++-- | This means that a record can be parsed as @a@.+class FromRecord a where+ -- | Decoder of a record.+ fromRecord :: StringDecoder -> [ColumnInfo] -> AP.Parser a++-- | This means that @a@ can be encoded to a field.+class ToField a where+ -- | Encoder of a field.+ toField :: MonadFail m => BackendParameters -> StringEncoder -> Maybe Oid -> FormatCode -> a -> m (Maybe BS.ByteString)++-- | This means that @a@ can be encoded to a record.+class ToRecord a where+ -- | Encoder of a field.+ toRecord :: MonadFail m => BackendParameters -> StringEncoder -> Maybe [Oid] -> [FormatCode] -> a -> m [Maybe BS.ByteString]++-- | Type of PostgreSQL @sql_identifier@ type.+newtype SqlIdentifier = SqlIdentifier BS.ByteString deriving (Show, Read, Eq)++class Pretty a where+ pretty :: a -> String++instance Pretty Response where+ pretty (AuthenticationResponse r) = pretty r+ pretty (CommandCompleteResponse r) = pretty r+ pretty (DataRowResponse r) = pretty r+ pretty (ErrorResponse r) = pretty r+ pretty (NoticeResponse r) = pretty r+ pretty (ParameterStatusResponse r) = pretty r+ pretty (BackendKeyDataResponse r) = pretty r+ pretty (ReadyForQueryResponse r) = pretty r+ pretty (RowDescriptionResponse r) = pretty r+ pretty ParseCompleteResponse = "parse complete"+ pretty BindCompleteResponse = "bind complete"+ pretty (ParameterDescriptionResponse r) = pretty r+ pretty EmptyQueryResponse = "empty query"+ pretty NoDataResponse = "no data"+ pretty (DebugResponse r) = pretty r++instance Pretty AuthenticationResponse where+ pretty AuthenticationOkResponse = "authentication ok"+ pretty (AuthenticationMD5PasswordResponse r) = pretty r++instance Pretty AuthenticationMD5Password where+ pretty (AuthenticationMD5Password salt) = "authentication MD5 password:\n\tsalt: " <> simpleHex salt++instance Pretty CommandComplete where+ pretty (CommandComplete (InsertTag oid rows)) = "command complete:\n\ttag: insert \n\t\toid: " <> show oid <> "\n\t\trows: " <> show rows+ pretty (CommandComplete (DeleteTag rows)) = "command complete:\n\ttag: delete\n\t\trows: " <> show rows+ pretty (CommandComplete (UpdateTag rows)) = "command complete:\n\ttag: update\n\t\trows: " <> show rows+ pretty (CommandComplete (SelectTag rows)) = "command complete:\n\ttag: select\n\t\trows: " <> show rows+ pretty (CommandComplete (MoveTag rows)) = "command complete:\n\ttag: move\n\t\trows: " <> show rows+ pretty (CommandComplete (FetchTag rows)) = "command complete:\n\ttag: fetch\n\t\trows: " <> show rows+ pretty (CommandComplete (CopyTag rows)) = "command complete:\n\ttag: copy\n\t\trows: " <> show rows+ pretty (CommandComplete CreateTableTag) = "command complete:\n\ttag: create table"+ pretty (CommandComplete DropTableTag) = "command complete:\n\ttag: drop table"+ pretty (CommandComplete BeginTag) = "command complete:\n\ttag: begin"+ pretty (CommandComplete CommitTag) = "command complete:\n\ttag: commit"+ pretty (CommandComplete RollbackTag) = "command complete:\n\ttag: rollback"+ pretty (CommandComplete SetTag) = "command complete:\n\ttag: set"++instance Show r => Pretty (DataRow r) where+ pretty (DataRow record) = "data:\n" <> show record++instance Pretty DataRowRaw where+ pretty (DataRowRaw values) =+ "data:\n" <> intercalate "\n" (go <$> zip [0 :: Int ..] values)+ where+ go (idx, v) = "\t" <> show idx <> pretty v++instance Pretty Error where+ pretty (Error fields) = "error response:\n" <> indent (pretty fields)++instance Pretty Notice where+ pretty (Notice fields) = "notice response:\n" <> indent (pretty fields)++instance Pretty ErrorFields where+ pretty (ErrorFields errs) =+ let+ lookups = foldr go ("", "", "") :: [(Char, BSS.ShortByteString)] -> (BSS.ShortByteString, BSS.ShortByteString, BSS.ShortByteString)+ go ('S', largeS') (_, largeC', largeM') = (largeS', largeC', largeM')+ go ('C', largeC') (largeS', _, largeM') = (largeS', largeC', largeM')+ go ('M', largeM') (largeS', largeC', _) = (largeS', largeC', largeM')+ go _ a = a+ (largeS, largeC, largeM) = lookups errs+ pp (code, message) = code : ": " <> shortByteStringToString message+ in+ shortByteStringToString (largeS <> " (" <> largeC <> "): " <> largeM) <> ('\n' : intercalate "\n" (pp <$> errs))++instance Pretty TransactionState where+ pretty Idle = "idle"+ pretty Block = "block"+ pretty Failed = "failed"++instance Pretty ParameterStatus where+ pretty (ParameterStatus key value) = "parameter:\n\t" <> shortByteStringToString key <> ": " <> shortByteStringToString value++instance Pretty BackendKeyData where+ pretty (BackendKeyData pid bk) = "cancellation key:\n\tpid: " <> show pid <> "\n\tbackend key: " <> show bk++instance Pretty ReadyForQuery where+ pretty (ReadyForQuery ts) = "ready for query:\n\ttransaction state: " <> (toLower <$> show ts)++instance Pretty RowDescription where+ -- This uses decoder of UTF-8 although this should read client_encoding parameter, because this is used for debugging.+ pretty (RowDescription infos) =+ "row description:\n" <> intercalate "\n" (go <$> infos)+ where+ go (ColumnInfo name tableOid attrNum typeOid len typeMod format) =+ "\t" <> BSU.toString name <> ":"+ <> "\n\t\ttable object ID: " <> show tableOid+ <> "\n\t\tcolumn attribute number: " <> show attrNum+ <> "\n\t\tdata type object ID: " <> show typeOid+ <> "\n\t\tdata type length: " <> pretty len+ <> "\n\t\ttype modifier: " <> show typeMod+ <> "\n\t\tformat: " <> pretty format++instance Pretty ParameterDescription where+ pretty (ParameterDescription oids) =+ "parameter description: " <> show oids++instance Pretty Debug where+ pretty (Debug bs) = "Debug:\n" <> prettyHex bs++instance Pretty TypeLength where+ pretty VariableLength = "variable"+ pretty (FixedLength l) = show l++instance Pretty FormatCode where+ pretty TextFormat = "text"+ pretty BinaryFormat = "binary"++instance Pretty Raw where+ pretty Null = "NULL"+ pretty (Value r) = "Value [" <> simpleHex r <> "] " <> show (printableString r)++-- This uses decoder of UTF-8 although this should read client_encoding parameter, because this is used for debugging.+printableString :: BS.ByteString -> String+printableString bytes =+ let+ replacePrintable c+ | isPrint c = c+ | otherwise = '.'+ in+ replacePrintable <$> BSU.toString bytes++shortByteStringToString :: BSS.ShortByteString -> String+shortByteStringToString = ((chr . fromIntegral) <$>) . BSS.unpack++indent :: String -> String+indent = unlines . (('\t' :) <$>) . lines
+ src/Database/PostgreSQL/Pure/Internal/Exception.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.PostgreSQL.Pure.Internal.Exception+ ( Exception (..)+ , ErrorResponse (..)+ , ResponseParsingFailed (..)+ , InternalException (..)+ , convert+ , cantReachHere+ ) where++import Database.PostgreSQL.Pure.Internal.Data (ErrorFields (ErrorFields), Pretty (pretty), TransactionState)++import Control.Exception.Safe (displayException, fromException, throw, toException, try)+import qualified Control.Exception.Safe as E+import qualified Data.ByteString as BS+import qualified Data.ByteString.Short as BSS+import qualified Data.ByteString.UTF8 as BSU+import Data.Typeable (Typeable, cast)+import GHC.Stack (HasCallStack)++-- | Root exception.+--+-- @+-- 'Exception'+-- ├ 'ErrorResponse'+-- └ 'ResponseParsingFailed'+-- @+data Exception = forall e. E.Exception e => Exception e deriving (Typeable)++instance Show Exception where+ show (Exception e) = show e++instance E.Exception Exception where+ displayException (Exception e) = displayException e++-- | This means that the server responds an error.+data ErrorResponse =+ ErrorResponse { severity :: BS.ByteString, code :: BS.ByteString, message :: BS.ByteString, transactionState :: Maybe TransactionState }+ deriving (Show, Read, Eq, Typeable)++instance E.Exception ErrorResponse where+ toException = toException . Exception+ fromException = ((\(Exception e) -> cast e) =<<) . fromException+ displayException = pretty++instance Pretty ErrorResponse where+ pretty ErrorResponse { severity, code, message, transactionState } =+ "error response:\n"+ <> "\tseverity: " <> BSU.toString severity -- only supports UTF-8+ <> "\n\tcode: " <> BSU.toString code+ <> "\n\tmessage: " <> BSU.toString message+ <> case transactionState of+ Just ts -> "\n\ttransaction state: " <> pretty ts+ Nothing -> mempty++-- | This means that the server responds an unknown message.+newtype ResponseParsingFailed =+ ResponseParsingFailed { causedBy :: String }+ deriving (Show, Typeable)++instance E.Exception ResponseParsingFailed where+ toException = toException . Exception+ fromException = ((\(Exception e) -> cast e) =<<) . fromException+ displayException = pretty++instance Pretty ResponseParsingFailed where+ pretty (ResponseParsingFailed c) = "response parsing failed:\n\tcaused by " <> c++data InternalException+ = InternalResponseParsingFailed String BS.ByteString+ | InternalErrorResponse ErrorFields (Maybe TransactionState)+ | InternalExtraData BS.ByteString+ deriving (Show, Read, Eq, Typeable)++instance E.Exception InternalException++internalExcepionToExposedException :: InternalException -> Exception+internalExcepionToExposedException e@InternalResponseParsingFailed {} = Exception $ ResponseParsingFailed $ displayException e+internalExcepionToExposedException (InternalErrorResponse (ErrorFields fields) transactionState) =+ Exception ErrorResponse { severity, code, message, transactionState }+ where+ (severity, code, message) = map3 BSS.fromShort $ foldr go ("", "", "") fields+ go ('S', largeS) (_, largeC, largeM) = (largeS, largeC, largeM)+ go ('C', largeC) (largeS, _, largeM) = (largeS, largeC, largeM)+ go ('M', largeM) (largeS, largeC, _) = (largeS, largeC, largeM)+ go _ a = a+ map3 f (v1, v2, v3) = (f v1, f v2, f v3)+internalExcepionToExposedException e@InternalExtraData {} = Exception $ ResponseParsingFailed $ displayException e++convert :: IO a -> IO a+convert a = do+ r <- try a+ case r of+ Right r -> pure r+ Left e -> throw $ internalExcepionToExposedException e++cantReachHere :: HasCallStack => a+cantReachHere = error "can't reach here"
+ src/Database/PostgreSQL/Pure/Internal/IsLabel.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Database.PostgreSQL.Pure.Internal.IsLabel () where++import GHC.OverloadedLabels (IsLabel (fromLabel))+import GHC.Records (HasField (getField))++instance HasField x r a => IsLabel x (r -> a) where+ fromLabel = getField @x
+ src/Database/PostgreSQL/Pure/Internal/MonadFail.hs view
@@ -0,0 +1,18 @@+{-# LANGUAGE FlexibleInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Database.PostgreSQL.Pure.Internal.MonadFail+ ( fromEither+ ) where++import Prelude (Either (Left, Right), String, pure)++import Control.Monad.Fail (MonadFail (fail))++instance MonadFail (Either String) where+ fail = Left++fromEither :: MonadFail m => Either String a -> m a+fromEither (Right a) = pure a+fromEither (Left e) = fail e
+ src/Database/PostgreSQL/Pure/Internal/Parser.hs view
@@ -0,0 +1,839 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-missing-import-lists #-}-- for Prelude+{-# OPTIONS_GHC -Wno-orphans #-}++#include "MachDeps.h"++module Database.PostgreSQL.Pure.Internal.Parser+ ( response+ , authentication+ , authenticationOk+ , error+ , notice+ , parameterStatus+ , backendKeyData+ , readyForQuery+ , rowDescription+ , dataRow+ , dataRowRaw+ , commandComplete+ , parseComplete+ , bindComplete+ , portalSuspended+ , emptyQuery+ , closeComplete+ , noData+ , parameterDescription+ , skipUntilError+ , currentPos+ ) where++import Database.PostgreSQL.Pure.Internal.Data (AuthenticationMD5Password (AuthenticationMD5Password), AuthenticationResponse (AuthenticationMD5PasswordResponse, AuthenticationOkResponse),+ BackendKeyData (BackendKeyData),+ ColumnInfo (ColumnInfo, typeOid),+ CommandComplete (CommandComplete),+ CommandTag (BeginTag, CommitTag, CopyTag, CreateTableTag, DeleteTag, DropTableTag, FetchTag, InsertTag, MoveTag, RollbackTag, SelectTag, SetTag, UpdateTag),+ DataRow (DataRow), DataRowRaw (DataRowRaw),+ Debug (Debug), Error (Error),+ ErrorFields (ErrorFields),+ FormatCode (BinaryFormat, TextFormat),+ FromField (fromField), FromRecord (fromRecord),+ Notice (Notice), Oid (Oid),+ ParameterDescription (ParameterDescription),+ ParameterStatus (ParameterStatus), Raw (Null, Value),+ ReadyForQuery (ReadyForQuery), Response (..),+ RowDescription (RowDescription),+ SqlIdentifier (SqlIdentifier), StringDecoder,+ TransactionState (Block, Failed, Idle),+ TypeLength (FixedLength, VariableLength))+import qualified Database.PostgreSQL.Pure.Internal.Data as Data+import qualified Database.PostgreSQL.Pure.Internal.MonadFail as MonadFail+import qualified Database.PostgreSQL.Pure.Oid as Oid+import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as Time++import Prelude hiding (error, fail)++import Control.Applicative ((*>), (<|>))+import Control.Exception (assert)+import Control.Monad (replicateM, unless, void)+import Control.Monad.Fail (MonadFail (fail))+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.Attoparsec.ByteString.Char8 as APC+import Data.Attoparsec.Combinator ((<?>))+import qualified Data.Attoparsec.Combinator as AP+import qualified Data.Attoparsec.Internal.Types as API+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BSI+import qualified Data.ByteString.Short as BSS+import qualified Data.ByteString.UTF8 as BSU+import Data.Functor (($>))+import Data.Int (Int16, Int32, Int64, Int8)+import Data.Kind (Type)+import Data.Maybe (fromMaybe)+import Data.Memory.Endian (BE, ByteSwap, fromBE)+import Data.Scientific (Scientific, scientific)+import qualified Data.Text as Text+import Data.Time (Day, DiffTime, LocalTime, TimeOfDay, TimeZone,+ UTCTime, utc)+import Data.Tuple.Single (Single, pattern Single)+import Data.Word (Word16, Word32, Word64, Word8)+import Foreign (withForeignPtr)+import Foreign.Storable (Storable, peekByteOff, sizeOf)+import GHC.Stack (HasCallStack, callStack, prettyCallStack)+import qualified PostgreSQL.Binary.Decoding as BD+import System.IO.Unsafe (unsafeDupablePerformIO)++response :: AP.Parser Response+response =+ AuthenticationResponse <$> authentication+ <|> ErrorResponse <$> error+ <|> NoticeResponse <$> notice+ <|> ParameterStatusResponse <$> parameterStatus+ <|> BackendKeyDataResponse <$> backendKeyData+ <|> ReadyForQueryResponse <$> readyForQuery+ <|> RowDescriptionResponse <$> rowDescription+ <|> DataRowResponse <$> dataRowRaw+ <|> CommandCompleteResponse <$> commandComplete+ <|> (parseComplete >> pure ParseCompleteResponse)+ <|> (bindComplete >> pure BindCompleteResponse)+ <|> (emptyQuery >> pure EmptyQueryResponse)+ <|> DebugResponse <$> debug++responseHeader :: AP.Parser Char -> AP.Parser (Char, Int)+responseHeader identParser =+ (<?> "response header") $ do+ ident <- identParser+ len32 <- anyInt32BE+ let len = fromIntegral len32 - 4 :: Int -- minus length of "length field"+ pure (ident, len)++authentication :: AP.Parser AuthenticationResponse+authentication =+ (<?> "authentication") $ do+ (_, len) <- responseHeader $ APC.char 'R'+ checkConsumed len $ do+ method <- anyInt32BE+ case method of+ 0 -> pure AuthenticationOkResponse+ 5 -> AuthenticationMD5PasswordResponse . AuthenticationMD5Password . BS.copy <$> AP.take 4+ t -> fail $ "not yet implemeted authentication type: " <> show t++authenticationOk :: AP.Parser ()+authenticationOk =+ (<?> "authentication ok") $ do+ (_, len) <- responseHeader $ APC.char 'R'+ checkConsumed len $ void $ int32BE 0++error :: AP.Parser Error+error =+ (<?> "error") $ do+ (_, len) <- responseHeader $ APC.char 'E'+ checkConsumed len $ Error . ErrorFields <$> list ((,) <$> APC.anyChar <*> (BSS.toShort <$> string))++notice :: AP.Parser Notice+notice =+ (<?> "notice") $ do+ (_, len) <- responseHeader $ APC.char 'N'+ checkConsumed len $ Notice . ErrorFields <$> list ((,) <$> APC.anyChar <*> (BSS.toShort <$> string))++parameterStatus :: AP.Parser ParameterStatus+parameterStatus =+ (<?> "parameter status") $ do+ (_, len) <- responseHeader $ APC.char 'S'+ checkConsumed len $ ParameterStatus <$> (BSS.toShort <$> string) <*> (BSS.toShort <$> string)++backendKeyData :: AP.Parser BackendKeyData+backendKeyData =+ (<?> "backend key data") $ do+ (_, len) <- responseHeader $ APC.char 'K'+ checkConsumed len $ BackendKeyData <$> anyInt32BE <*> anyInt32BE++readyForQuery :: AP.Parser ReadyForQuery+readyForQuery =+ (<?> "ready for query") $ do+ (_, len) <- responseHeader $ APC.char 'Z'+ checkConsumed len $ do+ t <- APC.anyChar+ case t of+ 'I' -> pure $ ReadyForQuery Idle+ 'T' -> pure $ ReadyForQuery Block+ 'E' -> pure $ ReadyForQuery Failed+ _ -> fail "invalid transacion state character"++rowDescription :: AP.Parser RowDescription+rowDescription =+ (<?> "row description") $ do+ (_, len) <- responseHeader $ APC.char 'T'+ checkConsumed len $ do+ fieldCount <- anyInt16BE+ RowDescription <$>+ replicateM+ (fromIntegral fieldCount)+ (ColumnInfo <$> string <*> oid <*> anyInt16BE <*> oid <*> typeLength <*> anyInt32BE <*> formatCode)++dataRow :: FromRecord r => StringDecoder -> [ColumnInfo] -> AP.Parser (DataRow r)+dataRow decode infos =+ (<?> "data row") $ do+ (_, len) <- responseHeader $ APC.char 'D'+ checkConsumed len $ do+ void $ int16BE (fromIntegral $ length infos)+ DataRow <$> fromRecord decode infos++dataRowRaw :: AP.Parser DataRowRaw+dataRowRaw =+ (<?> "data row raw") $ do+ (_, len) <- responseHeader $ APC.char 'D'+ checkConsumed len $ do+ columnCount <- anyInt16BE+ let+ go = do+ l <- anyInt32BE+ case l of+ (-1) -> pure Null+ _ -> Value . BS.copy <$> AP.take (fromIntegral l)+ DataRowRaw <$>+ replicateM+ (fromIntegral columnCount)+ go++commandComplete :: AP.Parser CommandComplete+commandComplete =+ (<?> "command complete") $ do+ (_, len) <- responseHeader $ APC.char 'C'+ checkConsumed len $+ do+ void $ APC.string "INSERT "+ o <- Oid <$> APC.decimal+ void $ APC.char ' '+ r <- APC.decimal+ void $ AP.word8 0+ pure $ CommandComplete $ InsertTag o r+ <|>+ do+ void $ APC.string "DELETE "+ r <- APC.decimal+ void $ AP.word8 0+ pure $ CommandComplete $ DeleteTag r+ <|>+ do+ void $ APC.string "UPDATE "+ r <- APC.decimal+ void $ AP.word8 0+ pure $ CommandComplete $ UpdateTag r+ <|>+ do+ void $ APC.string "SELECT "+ r <- APC.decimal+ void $ AP.word8 0+ pure $ CommandComplete $ SelectTag r+ <|>+ do+ void $ APC.string "MOVE "+ r <- APC.decimal+ void $ AP.word8 0+ pure $ CommandComplete $ MoveTag r+ <|>+ do+ void $ APC.string "FETCH "+ r <- APC.decimal+ void $ AP.word8 0+ pure $ CommandComplete $ FetchTag r+ <|>+ do+ void $ APC.string "COPY "+ r <- APC.decimal+ void $ AP.word8 0+ pure $ CommandComplete $ CopyTag r+ <|> APC.string "CREATE TABLE" *> AP.word8 0 $> CommandComplete CreateTableTag+ <|> APC.string "DROP TABLE" *> AP.word8 0 $> CommandComplete DropTableTag+ <|> APC.string "BEGIN" *> AP.word8 0 $> CommandComplete BeginTag+ <|> APC.string "COMMIT" *> AP.word8 0 $> CommandComplete CommitTag+ <|> APC.string "ROLLBACK" *> AP.word8 0 $> CommandComplete RollbackTag+ <|> APC.string "SET" *> AP.word8 0 $> CommandComplete SetTag++parseComplete :: AP.Parser ()+parseComplete =+ (<?> "parse complete") $ do+ void $ APC.char8 '1'+ void $ int32BE 4++bindComplete :: AP.Parser ()+bindComplete =+ (<?> "bind complete") $ do+ void $ APC.char8 '2'+ void $ int32BE 4++noData :: AP.Parser ()+noData =+ (<?> "no data") $ do+ void $ APC.char8 'n'+ void $ int32BE 4++parameterDescription :: AP.Parser ParameterDescription+parameterDescription =+ (<?> "parameter description") $ do+ (_, len) <- responseHeader $ APC.char 't'+ checkConsumed len $ do+ n <- anyInt16BE+ ParameterDescription <$> replicateM (fromIntegral n) oid++emptyQuery :: AP.Parser ()+emptyQuery =+ (<?> "empty query") $ do+ void $ APC.char8 'I'+ void $ int32BE 4++portalSuspended :: AP.Parser ()+portalSuspended =+ (<?> "portal suspended") $ do+ void $ APC.char8 's'+ void $ int32BE 4++closeComplete :: AP.Parser ()+closeComplete =+ (<?> "close complete") $ do+ void $ APC.char8 '3'+ void $ int32BE 4++skipUntilError :: AP.Parser Error+skipUntilError =+ (<?> "skip until error") $ do+ (ident, len) <- responseHeader APC.anyChar+ case ident of+ 'E' -> checkConsumed len $ Error . ErrorFields <$> list ((,) <$> APC.anyChar <*> (BSS.toShort <$> string))+ _ -> AP.take len >> skipUntilError++debug :: AP.Parser Debug+debug = do+ ident <- AP.anyWord8+ len <- AP.lookAhead anyInt32BE+ bs <- AP.take $ fromIntegral len+ pure $ Debug $ BS.cons ident bs++satisfyN :: Int -> (BS.ByteString -> a) -> (a -> Bool) -> AP.Parser a+satisfyN l f p = do+ bs <- AP.take l+ let a = f bs+ if p a+ then pure a+ else fail "satisfy n"++satisfyStorable :: forall a. Storable a => (BS.ByteString -> a) -> (a -> Bool) -> AP.Parser a+satisfyStorable f p = satisfyN (sizeOf (undefined :: a)) f p <?> "satisfy storable"++type family Unsigned a :: Type+type instance Unsigned Word8 = Word8+type instance Unsigned Word16 = Word16+type instance Unsigned Word32 = Word32+type instance Unsigned Word64 = Word64+type instance Unsigned Int8 = Word8+type instance Unsigned Int16 = Word16+type instance Unsigned Int32 = Word32+type instance Unsigned Int64 = Word64++satisfyIntegralBE :: forall a. (Integral a, Storable a, Integral (Unsigned a), ByteSwap (Unsigned a)) => (a -> Bool) -> AP.Parser a+satisfyIntegralBE p = satisfyStorable (fromIntegral . castByteSwapBE @(Unsigned a)) p <?> "satisfy integral big endian"++anyIntegralBE :: (Integral a, Storable a, Integral (Unsigned a), ByteSwap (Unsigned a)) => AP.Parser a+anyIntegralBE = satisfyIntegralBE (const True) <?> "any integral big endian"++anyInt16BE :: AP.Parser Int16+anyInt16BE = anyIntegralBE <?> "any int16 big endian"++anyInt32BE :: AP.Parser Int32+anyInt32BE = anyIntegralBE <?> "any int32 big endian"++integralBE :: (Integral a, Storable a, Integral (Unsigned a), ByteSwap (Unsigned a)) => a -> AP.Parser a+integralBE n = satisfyIntegralBE (== n) <?> "integral big endian"++int16BE :: Int16 -> AP.Parser Int16+int16BE n = integralBE n <?> "int16 big endian"++int32BE :: Int32 -> AP.Parser Int32+int32BE n = integralBE n <?> "int32 big endian"++castByteSwapBE :: forall a. ByteSwap a => BS.ByteString -> a+castByteSwapBE (BSI.PS fptr off len) =+ assert (sizeOf (undefined :: a) == len) $+ let+ be :: BE a+ be =+ unsafeDupablePerformIO $+ withForeignPtr fptr $ \ptr ->+ peekByteOff ptr off+ in fromBE be++string :: AP.Parser BS.ByteString+string = AP.takeWhile (/= 0) <* AP.word8 0 <?> "string"++list :: AP.Parser a -> AP.Parser [a]+list p = (AP.word8 0 >> pure []) <|> (:) <$> p <*> list p <?> "list"++typeLength :: AP.Parser TypeLength+typeLength =+ (<?> "type length") $ do+ len <- anyInt16BE+ if len < 0+ then pure VariableLength+ else pure $ FixedLength len++formatCode :: AP.Parser FormatCode+formatCode =+ (<?> "format code") $ do+ code <- anyInt16BE+ case code of+ 0 -> pure TextFormat+ 1 -> pure BinaryFormat+ _ -> fail "invalid format code"++oid :: AP.Parser Oid+oid = Oid <$> anyInt32BE <?> "OID"++checkConsumed :: HasCallStack => Int -> AP.Parser a -> AP.Parser a+checkConsumed expected parser = do+ API.Pos startPos <- currentPos+ r <- parser+ API.Pos endPos <- currentPos+ let consumed = endPos - startPos+ unless (expected == consumed) $+ fail $ "length mismatch: expected: " <> show expected <> ", consumed: " <> show consumed <> "\n" <> prettyCallStack callStack+ pure r++currentPos :: AP.Parser API.Pos+currentPos = API.Parser $ \t pos more _lose suc -> suc t pos more pos++instance FromField Bool where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid == Oid.bool+ = case formatCode of+ TextFormat | v == "t" -> pure True+ | v == "f" -> pure False+ | otherwise -> fail (show (BSU.toString v) <> " is not expected as bool")+ BinaryFormat -> valueParser BD.bool v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: Bool"++instance FromField Int where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+#if WORD_SIZE_IN_BITS < 32 /* the width of Int is wider than 30 bits */+ | typeOid == Oid.int2+#elif WORD_SIZE_IN_BITS < 64+ | typeOid `elem` [Oid.int2, Oid.int4]+#else+ | typeOid `elem` [Oid.int2, Oid.int4, Oid.int8]+#endif+ = case formatCode of+ TextFormat -> attoparsecParser (APC.signed APC.decimal) v+ BinaryFormat -> valueParser BD.int v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: Int"++instance FromField Int16 where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid == Oid.int2+ = case formatCode of+ TextFormat -> attoparsecParser (APC.signed APC.decimal) v+ BinaryFormat -> valueParser BD.int v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: Int16"++instance FromField Int32 where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid `elem` [Oid.int2, Oid.int4]+ = case formatCode of+ TextFormat -> attoparsecParser (APC.signed APC.decimal) v+ BinaryFormat -> valueParser BD.int v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: Int32"++instance FromField Int64 where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid `elem` [Oid.int2, Oid.int4, Oid.int8]+ = case formatCode of+ TextFormat -> attoparsecParser (APC.signed APC.decimal) v+ BinaryFormat -> valueParser BD.int v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: Int64"++instance FromField Scientific where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid `elem` [Oid.int2, Oid.int4, Oid.int8]+ = (flip scientific 0 <$>) $+ case formatCode of+ TextFormat -> attoparsecParser (APC.signed APC.decimal) v+ BinaryFormat -> valueParser BD.int v+ | typeOid == Oid.numeric+ = case formatCode of+ TextFormat -> attoparsecParser APC.scientific v+ BinaryFormat -> valueParser BD.numeric v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: Scientific"++instance FromField Float where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid == Oid.float4+ = case formatCode of+ TextFormat -> attoparsecParser APC.rational v+ BinaryFormat -> valueParser BD.float4 v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: Float"++instance FromField Double where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid == Oid.float4+ = case formatCode of+ TextFormat -> attoparsecParser APC.rational v+ BinaryFormat -> realToFrac <$> valueParser BD.float4 v+ | typeOid == Oid.float8+ = case formatCode of+ TextFormat -> attoparsecParser APC.double v+ BinaryFormat -> valueParser BD.float8 v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: Double"++instance FromField Oid where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid == Oid.oid+ = (Oid <$>) $+ case formatCode of+ TextFormat -> attoparsecParser APC.decimal v+ BinaryFormat -> valueParser BD.int v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: Oid"++instance FromField Char where+ fromField decode ColumnInfo { typeOid } (Just v)+ | typeOid == Oid.char+ = do+ str <- MonadFail.fromEither $ decode v+ case (str :: String) of+ [c] -> pure c+ _ -> fail $ "expected 1 character, actual " <> show (length str) <> " characters"+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: Char"++instance FromField BS.ByteString where+ fromField _ ColumnInfo { typeOid } (Just v)+ | typeOid `elem` [Oid.text, Oid.bpchar, Oid.varchar, Oid.name, Oid.bytea] = pure v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: ByteString (strict)"++instance FromField Day where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid == Oid.date+ = case formatCode of+ TextFormat -> attoparsecParser Time.day v+ BinaryFormat -> valueParser BD.date v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: Day"++instance FromField TimeOfDay where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid == Oid.time+ = case formatCode of+ TextFormat -> attoparsecParser Time.timeOfDay v+ BinaryFormat -> valueParser BD.time_int v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: TimeOfDay"++instance FromField (TimeOfDay, TimeZone) where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid == Oid.timetz+ = case formatCode of+ TextFormat -> attoparsecParser ((,) <$> Time.timeOfDay <*> (fromMaybe utc <$> Time.timeZone)) v+ BinaryFormat -> valueParser BD.timetz_int v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: (TimeOfDay, TimeZone)"++instance FromField LocalTime where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid == Oid.timestamp+ = case formatCode of+ TextFormat -> attoparsecParser Time.localTime v+ BinaryFormat -> valueParser BD.timestamp_int v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: LocalTime"++instance FromField UTCTime where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid == Oid.timestamptz+ = case formatCode of+ TextFormat -> attoparsecParser Time.utcTime v+ BinaryFormat -> valueParser BD.timestamptz_int v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: UTCTime"++instance FromField DiffTime where+ fromField _ ColumnInfo { typeOid, Data.formatCode } (Just v)+ | typeOid == Oid.interval+ = case formatCode of+ TextFormat -> attoparsecParser Time.diffTime v+ BinaryFormat -> valueParser BD.interval_int v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: DiffTime"++instance FromField SqlIdentifier where+ fromField decode info@ColumnInfo { typeOid } v@(Just _)+ | typeOid == Oid.sqlIdentifier = SqlIdentifier <$> fromField decode info { typeOid = Oid.varchar } v -- pg_type.typbasetype+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: SqlIdentifier"++instance FromField Raw where+ fromField _ _ (Just v) = pure $ Value v+ fromField _ _ Nothing = pure Null++instance FromField a => FromField (Maybe a) where+ fromField decode i v@(Just _) = Just <$> fromField decode i v+ fromField _ _ Nothing = pure Nothing++-- 0 tuple+instance FromRecord () where+ fromRecord _ [] = pure ()+ fromRecord _ is = fail $ "length mismatch: expected 0: actual: " <> show (length is)++-- 1 tuple+instance {-# OVERLAPPABLE #-} (FromField a, Single c, t ~ c a) => FromRecord t where+ fromRecord decode [i] = Single <$> column decode i+ fromRecord _ is = fail $ "length mismatch: expected 1: actual: " <> show (length is)++-- 2 tuple+instance (FromField a, FromField b) => FromRecord (a, b) where+ fromRecord decode [i0, i1] =+ (,)+ <$> column decode i0+ <*> column decode i1+ fromRecord _ is = fail $ "length mismatch: expected 2: actual: " <> show (length is)++-- 3 tuple+instance+ (FromField a, FromField b, FromField c) => FromRecord (a, b, c) where+ fromRecord decode [i0, i1, i2] =+ (,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ fromRecord _ is = fail $ "length mismatch: expected 3: actual: " <> show (length is)++-- 4 tuple+instance+ (FromField a, FromField b, FromField c, FromField d) => FromRecord (a, b, c, d) where+ fromRecord decode [i0, i1, i2, i3] =+ (,,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ <*> column decode i3+ fromRecord _ is = fail $ "length mismatch: expected 4: actual: " <> show (length is)++-- 5 tuple+instance+ (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRecord (a, b, c, d, e) where+ fromRecord decode [i0, i1, i2, i3, i4] =+ (,,,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ <*> column decode i3+ <*> column decode i4+ fromRecord _ is = fail $ "length mismatch: expected 5: actual: " <> show (length is)++-- 6 tuple+instance+ (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f)+ => FromRecord (a, b, c, d, e, f) where+ fromRecord decode [i0, i1, i2, i3, i4, i5] =+ (,,,,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ <*> column decode i3+ <*> column decode i4+ <*> column decode i5+ fromRecord _ is = fail $ "length mismatch: expected 6: actual: " <> show (length is)++-- 7 tuple+instance+ (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g)+ => FromRecord (a, b, c, d, e, f, g) where+ fromRecord decode [i0, i1, i2, i3, i4, i5, i6] =+ (,,,,,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ <*> column decode i3+ <*> column decode i4+ <*> column decode i5+ <*> column decode i6+ fromRecord _ is = fail $ "length mismatch: expected 7: actual: " <> show (length is)++-- 8 tuple+instance+ (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h)+ => FromRecord (a, b, c, d, e, f, g, h) where+ fromRecord decode [i0, i1, i2, i3, i4, i5, i6, i7] =+ (,,,,,,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ <*> column decode i3+ <*> column decode i4+ <*> column decode i5+ <*> column decode i6+ <*> column decode i7+ fromRecord _ is = fail $ "length mismatch: expected 8: actual: " <> show (length is)++-- 9 tuple+instance+ (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i)+ => FromRecord (a, b, c, d, e, f, g, h, i) where+ fromRecord decode [i0, i1, i2, i3, i4, i5, i6, i7, i8] =+ (,,,,,,,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ <*> column decode i3+ <*> column decode i4+ <*> column decode i5+ <*> column decode i6+ <*> column decode i7+ <*> column decode i8+ fromRecord _ is = fail $ "length mismatch: expected 9: actual: " <> show (length is)++-- 10 tuple+instance+ (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j)+ => FromRecord (a, b, c, d, e, f, g, h, i, j) where+ fromRecord decode [i0, i1, i2, i3, i4, i5, i6, i7, i8, i9] =+ (,,,,,,,,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ <*> column decode i3+ <*> column decode i4+ <*> column decode i5+ <*> column decode i6+ <*> column decode i7+ <*> column decode i8+ <*> column decode i9+ fromRecord _ is = fail $ "length mismatch: expected 10: actual: " <> show (length is)++-- 11 tuple+instance+ (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k)+ => FromRecord (a, b, c, d, e, f, g, h, i, j, k) where+ fromRecord decode [i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10] =+ (,,,,,,,,,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ <*> column decode i3+ <*> column decode i4+ <*> column decode i5+ <*> column decode i6+ <*> column decode i7+ <*> column decode i8+ <*> column decode i9+ <*> column decode i10+ fromRecord _ is = fail $ "length mismatch: expected 11: actual: " <> show (length is)++-- 12 tuple+instance+ (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l)+ => FromRecord (a, b, c, d, e, f, g, h, i, j, k, l) where+ fromRecord decode [i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11] =+ (,,,,,,,,,,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ <*> column decode i3+ <*> column decode i4+ <*> column decode i5+ <*> column decode i6+ <*> column decode i7+ <*> column decode i8+ <*> column decode i9+ <*> column decode i10+ <*> column decode i11+ fromRecord _ is = fail $ "length mismatch: expected 12: actual: " <> show (length is)++-- 13 tuple+instance+ (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m)+ => FromRecord (a, b, c, d, e, f, g, h, i, j, k, l, m) where+ fromRecord decode [i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12] =+ (,,,,,,,,,,,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ <*> column decode i3+ <*> column decode i4+ <*> column decode i5+ <*> column decode i6+ <*> column decode i7+ <*> column decode i8+ <*> column decode i9+ <*> column decode i10+ <*> column decode i11+ <*> column decode i12+ fromRecord _ is = fail $ "length mismatch: expected 13: actual: " <> show (length is)++-- 14 tuple+instance+ (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n)+ => FromRecord (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where+ fromRecord decode [i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13] =+ (,,,,,,,,,,,,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ <*> column decode i3+ <*> column decode i4+ <*> column decode i5+ <*> column decode i6+ <*> column decode i7+ <*> column decode i8+ <*> column decode i9+ <*> column decode i10+ <*> column decode i11+ <*> column decode i12+ <*> column decode i13+ fromRecord _ is = fail $ "length mismatch: expected 14: actual: " <> show (length is)++-- 15 tuple+instance+ (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i, FromField j, FromField k, FromField l, FromField m, FromField n, FromField o)+ => FromRecord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where+ fromRecord decode [i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14] =+ (,,,,,,,,,,,,,,)+ <$> column decode i0+ <*> column decode i1+ <*> column decode i2+ <*> column decode i3+ <*> column decode i4+ <*> column decode i5+ <*> column decode i6+ <*> column decode i7+ <*> column decode i8+ <*> column decode i9+ <*> column decode i10+ <*> column decode i11+ <*> column decode i12+ <*> column decode i13+ <*> column decode i14+ fromRecord _ is = fail $ "length mismatch: expected 15: actual: " <> show (length is)++-- list+instance FromField a => FromRecord [a] where+ fromRecord decode is = sequence $ column decode <$> is++column :: FromField a => StringDecoder -> ColumnInfo -> AP.Parser a+column decode info = do+ l <- anyInt32BE+ case l of+ (-1) -> fromField decode info Nothing+ _ -> fromField decode info . Just =<< AP.take (fromIntegral l)++attoparsecParser :: MonadFail m => AP.Parser a -> BS.ByteString -> m a+attoparsecParser parser string =+ case AP.parseOnly (parser <* AP.endOfInput) string of+ Right a -> pure a+ Left e -> fail e++valueParser :: MonadFail m => BD.Value a -> BS.ByteString -> m a+valueParser parser string =+ case BD.valueParser parser string of+ Right a -> pure a+ Left e -> fail $ Text.unpack e
+ src/Database/PostgreSQL/Pure/Internal/Query.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module Database.PostgreSQL.Pure.Internal.Query+ ( -- * Extended Query+ parse+ , Bind (..)+ , Execute (..)+ , flush+ , sync+ , Message (..)+ , Close (..)+ -- * Transaction+ , begin+ , commit+ , rollback+ ) where++import qualified Database.PostgreSQL.Pure.Internal.Builder as Builder+import Database.PostgreSQL.Pure.Internal.Data (BackendParameters,+ BindParameterFormatCodes (BindParameterFormatCodesAll),+ BindResultFormatCodes (BindResultFormatCodesEach),+ CloseProcedure (CloseProcedure),+ ColumnInfo (ColumnInfo, formatCode),+ CommandComplete (CommandComplete),+ Connection (Connection, config, receptionBuffer, sendingBuffer, socket),+ DataRow (DataRow), ErrorFields,+ ExecuteResult (ExecuteComplete, ExecuteEmptyQuery, ExecuteSuspended),+ Executed (Executed),+ ExecutedProcedure (ExecutedProcedure),+ FormatCode (BinaryFormat), FromRecord, MessageResult,+ Notice (Notice), Oid,+ ParameterDescription (ParameterDescription),+ Portal (Portal), PortalName,+ PortalProcedure (PortalProcedure),+ PreparedStatement (PreparedStatement),+ PreparedStatementName,+ PreparedStatementProcedure (PreparedStatementProcedure),+ Query, ReadyForQuery (ReadyForQuery),+ RowDescription (RowDescription), StringDecoder,+ StringEncoder, ToRecord (toRecord), TransactionState,+ TypeLength (FixedLength))+import qualified Database.PostgreSQL.Pure.Internal.Data as Data+import qualified Database.PostgreSQL.Pure.Internal.Exception as Exception+import Database.PostgreSQL.Pure.Internal.IsLabel ()+import qualified Database.PostgreSQL.Pure.Internal.Parser as Parser+import Database.PostgreSQL.Pure.Internal.SocketIO (buildAndSend, receive, runSocketIO, send)++import Control.Applicative ((<|>))+import Control.Exception.Safe (throw, try)+import Control.Monad (void, when)+import Control.Monad.Fail (MonadFail)+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.Attoparsec.Combinator as AP+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Char8 as BSC+import Data.Functor (($>))+import Data.List (genericLength)+import GHC.OverloadedLabels (IsLabel)++-- | To get the procedure to build the message of parsing SQL query and to parse its response.+parse+ :: PreparedStatementName -- ^ A new name of prepared statement.+ -> Query -- ^ SQL whose placeoholder style is dollar style.+ -> Either (Word, Word) ([Oid], [Oid]) -- ^ A pair of the number of columns of the parameter and the result,+ -- or a pair of the list of OIDs of the parameter and the result.+ -- On 'Left' an additional pair of a request and a resposne is necessary.+ -> PreparedStatementProcedure+parse name query (Left (parameterLength, resultLength)) = parse' name query parameterLength resultLength Nothing+parse name query (Right oids@(parameterOids, resultOids)) = parse' name query (genericLength parameterOids) (genericLength resultOids) (Just oids)++parse' :: PreparedStatementName -> Query -> Word -> Word -> Maybe ([Oid], [Oid]) -> PreparedStatementProcedure+parse' name query parameterLength resultLength oids =+ let+ inaneColumnInfo oid = ColumnInfo "" 0 0 oid (FixedLength 0) 0 BinaryFormat+ parameterOids = fst <$> oids+ builder =+ case oids of+ Just (parameterOids, _) -> Builder.parse name query parameterOids+ _ -> Builder.parse name query [] <> Builder.describePreparedStatement name+ parser = do+ Parser.parseComplete+ (parameterOids, resultInfos) <-+ case oids of+ Just (parameterOids, resultOids) -> pure (parameterOids, inaneColumnInfo <$> resultOids)+ _ -> do+ ParameterDescription parameterOids <- Parser.parameterDescription+ resultInfos <-+ AP.choice+ [ do+ RowDescription infos <- Parser.rowDescription+ pure infos+ , Parser.noData $> []+ ]+ pure (parameterOids, resultInfos)+ pure $ PreparedStatement name parameterOids resultInfos+ in PreparedStatementProcedure name parameterLength resultLength parameterOids builder parser++-- | This means that @ps@ is a objective of 'bind'.+class Bind ps where+ -- | To get the procedure to build the message of binding the parameter and to parse its response.+ bind+ :: (ToRecord param, MonadFail m)+ => PortalName -- ^ A new name of portal.+ -> FormatCode -- ^ Binary format or text format for the parameter.+ -> FormatCode -- ^ Binary format or text format for the results.+ -> BackendParameters -- ^ The set of the server parameters.+ -> StringEncoder -- ^ How to encode strings.+ -> param -- ^ Parameter for this query.+ -> ps -- ^ Prepared statement.+ -> m PortalProcedure++instance Bind PreparedStatement where+ bind name parameterFormat resultFormat backendParams encode parameters ps@(PreparedStatement psName psParameterOids psResultInfos) = do+ record <- toRecord backendParams encode (Just psParameterOids) (replicate (length psParameterOids) parameterFormat) parameters+ let+ builder = Builder.bind name psName (BindParameterFormatCodesAll parameterFormat) record (BindResultFormatCodesEach $ replicate (length psResultInfos) resultFormat)+ parser = do+ Parser.bindComplete+ pure (ps, Portal name ((\i -> i { formatCode = resultFormat }) <$> psResultInfos) ps)+ pure $ PortalProcedure name resultFormat builder parser++instance Bind PreparedStatementProcedure where+ bind name parameterFormat resultFormat backendParams encode parameters (PreparedStatementProcedure psName psParameterLength psResultLength psParameterOids psBuilder psParser) = do+ record <- toRecord backendParams encode psParameterOids (replicate (fromIntegral psParameterLength) parameterFormat) parameters+ let+ builder =+ psBuilder+ <> Builder.bind name psName (BindParameterFormatCodesAll parameterFormat) record (BindResultFormatCodesEach $ replicate (fromIntegral psResultLength) resultFormat)+ parser = do+ ps@PreparedStatement { resultInfos } <- psParser+ Parser.bindComplete+ pure (ps, Portal name ((\i -> i { formatCode = resultFormat }) <$> resultInfos) ps)+ pure $ PortalProcedure name resultFormat builder parser++-- | This means that @p@ is a objective of 'execute'.+class Execute p where+ -- | To get the procedure to build the message of execution and to parse its response.+ execute+ :: FromRecord result+ => Word -- ^ How many records to get. “0” means unlimited.+ -> StringDecoder -- ^ How to decode strings.+ -> p -- ^ Portal.+ -> ExecutedProcedure result++instance Execute Portal where+ execute rowLimit decode p@(Portal pName pInfos ps@PreparedStatement {}) =+ let+ builder = Builder.execute pName $ fromIntegral rowLimit+ parser = executeParser ps p pInfos decode+ in ExecutedProcedure builder parser++instance Execute PortalProcedure where+ execute rowLimit decode (PortalProcedure pName pFormat pBuilder pParser) =+ let+ builder = pBuilder <> Builder.execute pName (fromIntegral rowLimit)+ parser = do+ (ps@(PreparedStatement _ _ psInfos), p) <- pParser+ executeParser ps p ((\i -> i { formatCode = pFormat }) <$> psInfos) decode+ in ExecutedProcedure builder parser++executeParser :: forall r. FromRecord r => PreparedStatement -> Portal -> [ColumnInfo] -> StringDecoder -> AP.Parser (PreparedStatement, Portal, Executed r, Maybe ErrorFields)+executeParser ps p infos decode = do+ records <- ((\(DataRow d) -> d) <$>) <$> AP.many' (Parser.dataRow decode infos)+ when (null records) $ do+ -- detect whether no "data row" responses or value parsing failure+ r <- AP.option False $ AP.lookAhead Parser.dataRowRaw >> pure True+ when r $ do+ -- get detailed error+ void (Parser.dataRow decode infos :: AP.Parser (DataRow r))+ fail "can't reach here"+ err <- AP.option Nothing $ (\(Notice err) -> Just err) <$> Parser.notice+ result <-+ ((\(CommandComplete tag) -> ExecuteComplete tag) <$> Parser.commandComplete)+ <|> (Parser.emptyQuery >> pure ExecuteEmptyQuery)+ <|> (Parser.portalSuspended >> pure ExecuteSuspended)+ pure (ps, p, Executed result records p, err)++-- | This means that @p@ is a objective of 'close'.+class Close p where+ -- | To build and send the “Close” message and to receive and parse its response.+ close :: p -> CloseProcedure++instance Close PreparedStatement where+ close p = CloseProcedure (Builder.closePreparedStatement $ #name p) Parser.closeComplete++instance Close Portal where+ close p = CloseProcedure (Builder.closePortal $ #name p) Parser.closeComplete++-- | This means than @r@ is a objective of 'flush' and 'sync'.+class Message m where+ builder :: m -> BSB.Builder+ default builder :: IsLabel "builder" (m -> BSB.Builder) => m -> BSB.Builder+ builder = #builder++ parser :: m -> AP.Parser (MessageResult m)+ default parser :: IsLabel "parser" (m -> AP.Parser (MessageResult m)) => m -> AP.Parser (MessageResult m)+ parser = #parser++instance Message PreparedStatementProcedure++instance Message PortalProcedure++instance Message (ExecutedProcedure r)++instance Message CloseProcedure++instance Message () where+ builder _ = mempty+ parser _ = pure ()++type instance MessageResult () = ()++instance (Message m0, Message m1) => Message (m0, m1) where+ builder (m0, m1) = builder m0 <> builder m1+ parser (m0, m1) = (,) <$> parser m0 <*> parser m1++type instance MessageResult (m0, m1) = (MessageResult m0, MessageResult m1)++instance (Message m0, Message m1, Message m2) => Message (m0, m1, m2) where+ builder (m0, m1, m2) = builder m0 <> builder m1 <> builder m2+ parser (m0, m1, m2) = (,,) <$> parser m0 <*> parser m1 <*> parser m2++type instance MessageResult (m0, m1, m2) = (MessageResult m0, MessageResult m1, MessageResult m2)++instance (Message m0, Message m1, Message m2, Message m3) => Message (m0, m1, m2, m3) where+ builder (m0, m1, m2, m3) = builder m0 <> builder m1 <> builder m2 <> builder m3+ parser (m0, m1, m2, m3) = (,,,) <$> parser m0 <*> parser m1 <*> parser m2 <*> parser m3++type instance MessageResult (m0, m1, m2, m3) = (MessageResult m0, MessageResult m1, MessageResult m2, MessageResult m3)++instance Message m => Message [m] where+ builder = mconcat . (builder <$>)+ parser = sequence . (parser <$>)++type instance MessageResult [m] = [MessageResult m]++-- | To build and send the given message and a “Flush” message and to receive and parse those responses.+flush :: Message m => Connection -> m -> IO (MessageResult m)+flush Connection { socket, sendingBuffer, receptionBuffer, config } m =+ Exception.convert $ do+ r <- try $+ runSocketIO socket sendingBuffer receptionBuffer config $ do+ buildAndSend $ builder m <> BSB.byteString Builder.flush+ receive $ parser m+ case r of+ Right r -> pure r+ Left (Exception.InternalErrorResponse fields _) -> do+ ReadyForQuery ts <-+ runSocketIO socket sendingBuffer receptionBuffer config $ do+ send Builder.sync+ receive Parser.readyForQuery+ throw $ Exception.InternalErrorResponse fields $ Just ts+ Left e -> throw e++-- | To build and send the given message and a “Sync” message and to receive and parse those responses.+sync :: Message m => Connection -> m -> IO (MessageResult m, TransactionState)+sync Connection { socket, sendingBuffer, receptionBuffer, config } m =+ Exception.convert $ do+ r <-+ try $+ runSocketIO socket sendingBuffer receptionBuffer config $ do+ buildAndSend $ builder m <> BSB.byteString Builder.sync+ (r, ReadyForQuery ts) <- receive $ (,) <$> parser m <*> Parser.readyForQuery+ pure (r, ts)+ case r of+ Right r -> pure r+ Left (Exception.InternalErrorResponse fields _) -> do+ ReadyForQuery ts <- runSocketIO socket sendingBuffer receptionBuffer config $ receive Parser.readyForQuery+ throw $ Exception.InternalErrorResponse fields $ Just ts+ Left e -> throw e++-- | To send @BEGIN@ SQL statement.+begin :: ExecutedProcedure ()+begin = transact "BEGIN"++-- | To send @COMMIT@ SQL statement.+commit :: ExecutedProcedure ()+commit = transact "COMMIT"++-- | To send @ROLLBACK@ SQL statement.+rollback :: ExecutedProcedure ()+rollback = transact "ROLLBACK"++transact :: Query -> ExecutedProcedure ()+transact q =+ let+ psProc = parse "" q (Right ([], []))+ in+ case bind "" BinaryFormat BinaryFormat mempty (pure . BSC.pack) () psProc of -- mempty (backend parameters) and BSC.pack (string encoder) are not used.+ Right pProc -> execute 1 (pure . BSC.unpack) pProc+ Left err -> error err
+ src/Database/PostgreSQL/Pure/Internal/SocketIO.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE CPP #-}++module Database.PostgreSQL.Pure.Internal.SocketIO+ ( SocketIO+ , runSocketIO+ , send+ , buildAndSend+ , receive+ ) where++import Database.PostgreSQL.Pure.Internal.Data (Buffer (Buffer), Carry, Config, Error (Error))+import qualified Database.PostgreSQL.Pure.Internal.Exception as Exception+import qualified Database.PostgreSQL.Pure.Internal.Parser as Parser++import Control.Concurrent (yield)+import Control.Exception.Safe (throw, try, tryJust)+import Control.Monad (guard, unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Reader (ReaderT, ask, runReaderT)+import Control.Monad.State.Strict (StateT, get, put, runStateT)+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Builder.Extra as BSB+import qualified Data.ByteString.Internal as BSI+import Data.List (intercalate)+import Data.Word (Word8)+import Foreign (ForeignPtr, Ptr, withForeignPtr)+import qualified Network.Socket as NS+import qualified Network.Socket.ByteString as NSB+import System.IO.Error (isEOFError)++type SocketIO = StateT Carry (ReaderT (NS.Socket, Buffer, Buffer, Config) IO)++runSocketIO :: NS.Socket -> Buffer -> Buffer -> Config -> SocketIO a -> IO a+runSocketIO s sb rb c m =+ flip runReaderT (s, sb, rb, c) $ do+ (a, carry) <- runStateT m BS.empty+ unless (BS.null carry) $ throw $ Exception.InternalExtraData carry+ pure a++send :: BS.ByteString -> SocketIO ()+send message = do+ (sock, _, _, _) <- ask+ liftIO $ do+ NSB.sendAll sock message+ yield++buildAndSend :: BSB.Builder -> SocketIO ()+buildAndSend builder = do+ (_, Buffer fp len, _, _) <- ask+ go fp len $ BSB.runBuilder builder+ where+ go :: ForeignPtr Word8 -> Int -> BSB.BufferWriter -> SocketIO ()+ go bfp blen writer = do+ (wc, next) <- liftIO $ withForeignPtr bfp $ \ptr -> writer ptr blen+ send $ BSI.PS bfp 0 wc+ case next of+ BSB.Done -> pure ()+ BSB.More newLen w+ | newLen <= blen -> go bfp blen w+ | otherwise -> do+ newFPtr <- liftIO $ BSI.mallocByteString newLen+ go newFPtr newLen w+ BSB.Chunk bs w -> do+ send bs+ go bfp blen w++recvAndParse :: NS.Socket -> Buffer -> Carry -> AP.Parser response -> IO (response, Carry)+recvAndParse sock (Buffer bfptr blen) carry parser =+ withForeignPtr bfptr $ \bptr -> do+ let+ recv :: IO BS.ByteString+ recv = do+ len <- recvBuf sock bptr blen+ case len of+ 0 -> pure BS.empty -- EOF+ _ -> pure $ BS.copy $ BSI.PS bfptr 0 len+ result <- AP.parseWith recv parser carry+ case result of+ AP.Done rest response -> pure (response, rest)+ AP.Fail rest [] msg -> throw $ Exception.InternalResponseParsingFailed msg rest+ AP.Fail rest ctxs msg -> throw $ Exception.InternalResponseParsingFailed (intercalate " > " ctxs <> ": " <> msg) rest+ AP.Partial _ -> Exception.cantReachHere++receiveJust :: AP.Parser response -> SocketIO response+receiveJust parser = do+ carry <- get+ (sock, _, buff, _) <- ask+ (response, carry') <- liftIO $ recvAndParse sock buff carry parser+ put carry'+ pure response++receive :: AP.Parser response -> SocketIO response+receive parser = do+ r <- try $ receiveJust parser+ case r of+ Right r -> pure r+ Left e@(Exception.InternalResponseParsingFailed _ raw) -> do+ let+ r = AP.parseOnly Parser.skipUntilError raw+ throw $+ case r of+ Right (Error fields) -> Exception.InternalErrorResponse fields Nothing+ Left _ -> e+ Left e -> throw e++-- Before network 3.0.0.0, recvBuf raises error on EOF. Otherwise it returns 0 on EOF.+recvBuf :: NS.Socket -> Ptr Word8 -> Int -> IO Int+#if MIN_VERSION_network(3, 0, 0)+recvBuf s ptr nbytes = NS.recvBuf s ptr nBytes+#else+recvBuf s ptr nbytes = do+ r <- tryJust (guard . isEOFError) $ NS.recvBuf s ptr nbytes+ case r of+ Left _ -> pure 0+ Right l -> pure l+#endif
+ src/Database/PostgreSQL/Pure/List.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-- |+-- This is a list interface version of @Database.PostgreSQL.Pure@.+--+-- = Typical Example+--+-- Prepare a following table.+--+-- @+-- CREATE TABLE person (+-- id serial PRIMARY KEY,+-- name varchar(255) NOT NULL+-- );+-- INSERT INTO person (name) VALUES (\'Ada\');+-- @+--+-- You can run like following to get the record whose ID is 1.+--+-- >>> :set -XOverloadedStrings+-- >>> :set -XFlexibleContexts+-- >>> :set -XTypeApplications+-- >>>+-- >>> import Database.PostgreSQL.Pure.List+-- >>> import Data.Default.Class (def)+-- >>> import Data.Int (Int32)+-- >>> import Data.ByteString (ByteString)+-- >>> import Data.Tuple.Only (Only (Only))+-- >>>+-- >>> conn <- connect def+-- >>> preparedStatementProcedure = parse "" "SELECT id, name FROM person WHERE id = $1" (Left (1, 2))+-- >>> portalProcedure <- bind "" BinaryFormat BinaryFormat (parameters conn) (const $ fail "") (Only (1 :: Int32)) preparedStatementProcedure+-- >>> executedProcedure = execute @_ @(Int32, ByteString) 0 (const $ fail "") portalProcedure+-- >>> ((_, _, e, _), _) <- sync conn executedProcedure+-- >>> records e+-- [(1,"Ada")]+module Database.PostgreSQL.Pure.List+ ( -- * Connection+ Config (..)+ , Connection+ , pid+ , parameters+ , config+ , Address (..)+ , BackendParameters+ , Pid+ , withConnection+ , connect+ , disconnect+ -- * Extended Query+ , parse+ , bind+ , execute+ , flush+ , sync+ , close+ , PreparedStatement (name, parameterOids, resultInfos)+ , PreparedStatementProcedure (name, parameterOids)+ , PreparedStatementName (..)+ , Portal (name)+ , PortalProcedure (name)+ , PortalName (..)+ , Executed (result, records)+ , ExecutedProcedure+ , ExecuteResult (..)+ , CommandTag (..)+ , Query (..)+ , FormatCode (..)+ , ColumnInfo+ , Message+ , MessageResult+ , Bind+ , Execute+ , Close+ , StringEncoder+ , StringDecoder+ -- * Transaction+ , begin+ , commit+ , rollback+ , TransactionState (..)+ -- * Record+ , FromField (..)+ , FromRecord (..)+ , ToField (..)+ , ToRecord (..)+ , Raw (..)+ -- * Exception+ , Exception.Exception (..)+ , Exception.ErrorResponse (..)+ , Exception.ResponseParsingFailed (..)+ -- * OID+ , Oid+ ) where++import Database.PostgreSQL.Pure.Internal.Connection (connect, disconnect, withConnection)+import Database.PostgreSQL.Pure.Internal.Data (Address (AddressNotResolved, AddressResolved),+ BackendParameters, ColumnInfo,+ CommandTag (BeginTag, CommitTag, CopyTag, CreateTableTag, DeleteTag, DropTableTag, FetchTag, InsertTag, MoveTag, RollbackTag, SelectTag, UpdateTag),+ Config (Config, address, database, password, receptionBufferSize, sendingBufferSize, user),+ Connection (config, parameters, pid),+ ExecuteResult (ExecuteComplete, ExecuteEmptyQuery, ExecuteSuspended),+ Executed, ExecutedProcedure,+ FormatCode (BinaryFormat, TextFormat),+ FromField (fromField), FromRecord (fromRecord),+ MessageResult, Oid, Pid, Portal, PortalName (PortalName),+ PortalProcedure, PreparedStatement,+ PreparedStatementName (PreparedStatementName),+ PreparedStatementProcedure, Query (Query),+ Raw (Null, Value), StringDecoder, StringEncoder,+ ToField (toField), ToRecord (toRecord),+ TransactionState (Block, Failed, Idle))+import qualified Database.PostgreSQL.Pure.Internal.Data as Data+import qualified Database.PostgreSQL.Pure.Internal.Exception as Exception+import Database.PostgreSQL.Pure.Internal.IsLabel ()+import Database.PostgreSQL.Pure.Internal.Query (Bind (bind), Close (close), Execute (execute), Message,+ begin, commit, flush, parse, rollback, sync)
+ src/Database/PostgreSQL/Pure/Oid.hs view
@@ -0,0 +1,1059 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Database.PostgreSQL.Pure.Oid+ ( Oid (Oid)+ , _daterange+ , _int4range+ , _int8range+ , _numrange+ , _tsrange+ , _tstzrange+ , bit+ , bitArray+ , bool+ , boolArray+ , box+ , boxArray+ , bpchar+ , bpcharArray+ , bytea+ , byteaArray+ , char+ , charArray+ , cid+ , cidArray+ , cidr+ , cidrArray+ , circle+ , circleArray+ , date+ , dateArray+ , daterange+ , float4+ , float4Array+ , float8+ , float8Array+ , inet+ , inetArray+ , int2+ , int2Array+ , int2vector+ , int2vectorArray+ , int4+ , int4Array+ , int4range+ , int8+ , int8Array+ , int8range+ , interval+ , intervalArray+ , json+ , jsonArray+ , jsonb+ , jsonbArray+ , line+ , lineArray+ , lseg+ , lsegArray+ , macaddr+ , macaddrArray+ , money+ , moneyArray+ , name+ , nameArray+ , numeric+ , numericArray+ , numrange+ , oid+ , oidArray+ , oidvector+ , oidvectorArray+ , path+ , pathArray+ , point+ , pointArray+ , polygon+ , polygonArray+ , record+ , recordArray+ , refcursor+ , refcursorArray+ , regclass+ , regclassArray+ , regoper+ , regoperArray+ , regoperator+ , regoperatorArray+ , regproc+ , regprocArray+ , regprocedure+ , regprocedureArray+ , regtype+ , regtypeArray+ , sqlIdentifier+ , text+ , textArray+ , tid+ , tidArray+ , time+ , timeArray+ , timestamp+ , timestampArray+ , timestamptz+ , timestamptzArray+ , timetz+ , timetzArray+ , tsrange+ , tstzrange+ , unknown+ , uuid+ , uuidArray+ , varbit+ , varbitArray+ , varchar+ , varcharArray+ , void+ , xid+ , xidArray+ , xml+ , xmlArray+ ) where++import Control.Applicative (Alternative ((<|>)))+import Data.Int (Int32)+import Text.Read (Read (readPrec))+import qualified Text.Read as R+import qualified Text.Read.Lex as R++-- | OID.+--+-- Constant values are listed in @Database.PostgreSQL.Pure.Oid@.+newtype Oid = Oid Int32 deriving (Eq, Num)++bool :: Oid+bool = 16++bytea :: Oid+bytea = 17++char :: Oid+char = 18++name :: Oid+name = 19++int8 :: Oid+int8 = 20++int2 :: Oid+int2 = 21++int4 :: Oid+int4 = 23++regproc :: Oid+regproc = 24++text :: Oid+text = 25++oid :: Oid+oid = 26++tid :: Oid+tid = 27++xid :: Oid+xid = 28++cid :: Oid+cid = 29++xml :: Oid+xml = 142++point :: Oid+point = 600++lseg :: Oid+lseg = 601++path :: Oid+path = 602++box :: Oid+box = 603++polygon :: Oid+polygon = 604++line :: Oid+line = 628++cidr :: Oid+cidr = 650++float4 :: Oid+float4 = 700++float8 :: Oid+float8 = 701++unknown :: Oid+unknown = 705++circle :: Oid+circle = 718++money :: Oid+money = 790++macaddr :: Oid+macaddr = 829++inet :: Oid+inet = 869++bpchar :: Oid+bpchar = 1042++varchar :: Oid+varchar = 1043++date :: Oid+date = 1082++time :: Oid+time = 1083++timestamp :: Oid+timestamp = 1114++timestamptz :: Oid+timestamptz = 1184++interval :: Oid+interval = 1186++timetz :: Oid+timetz = 1266++bit :: Oid+bit = 1560++varbit :: Oid+varbit = 1562++numeric :: Oid+numeric = 1700++refcursor :: Oid+refcursor = 1790++record :: Oid+record = 2249++void :: Oid+void = 2278++recordArray :: Oid+recordArray = 2287++regprocedure :: Oid+regprocedure = 2202++regoper :: Oid+regoper = 2203++regoperator :: Oid+regoperator = 2204++regclass :: Oid+regclass = 2205++regtype :: Oid+regtype = 2206++uuid :: Oid+uuid = 2950++json :: Oid+json = 114++jsonb :: Oid+jsonb = 3802++int2vector :: Oid+int2vector = 22++oidvector :: Oid+oidvector = 30++xmlArray :: Oid+xmlArray = 143++jsonArray :: Oid+jsonArray = 199++lineArray :: Oid+lineArray = 629++cidrArray :: Oid+cidrArray = 651++circleArray :: Oid+circleArray = 719++moneyArray :: Oid+moneyArray = 791++boolArray :: Oid+boolArray = 1000++byteaArray :: Oid+byteaArray = 1001++charArray :: Oid+charArray = 1002++nameArray :: Oid+nameArray = 1003++int2Array :: Oid+int2Array = 1005++int2vectorArray :: Oid+int2vectorArray = 1006++int4Array :: Oid+int4Array = 1007++regprocArray :: Oid+regprocArray = 1008++textArray :: Oid+textArray = 1009++tidArray :: Oid+tidArray = 1010++xidArray :: Oid+xidArray = 1011++cidArray :: Oid+cidArray = 1012++oidvectorArray :: Oid+oidvectorArray = 1013++bpcharArray :: Oid+bpcharArray = 1014++varcharArray :: Oid+varcharArray = 1015++int8Array :: Oid+int8Array = 1016++pointArray :: Oid+pointArray = 1017++lsegArray :: Oid+lsegArray = 1018++pathArray :: Oid+pathArray = 1019++boxArray :: Oid+boxArray = 1020++float4Array :: Oid+float4Array = 1021++float8Array :: Oid+float8Array = 1022++polygonArray :: Oid+polygonArray = 1027++oidArray :: Oid+oidArray = 1028++macaddrArray :: Oid+macaddrArray = 1040++inetArray :: Oid+inetArray = 1041++timestampArray :: Oid+timestampArray = 1115++dateArray :: Oid+dateArray = 1182++timeArray :: Oid+timeArray = 1183++timestamptzArray :: Oid+timestamptzArray = 1185++intervalArray :: Oid+intervalArray = 1187++numericArray :: Oid+numericArray = 1231++timetzArray :: Oid+timetzArray = 1270++bitArray :: Oid+bitArray = 1561++varbitArray :: Oid+varbitArray = 1563++refcursorArray :: Oid+refcursorArray = 2201++regprocedureArray :: Oid+regprocedureArray = 2207++regoperArray :: Oid+regoperArray = 2208++regoperatorArray :: Oid+regoperatorArray = 2209++regclassArray :: Oid+regclassArray = 2210++regtypeArray :: Oid+regtypeArray = 2211++uuidArray :: Oid+uuidArray = 2951++jsonbArray :: Oid+jsonbArray = 3807++int4range :: Oid+int4range = 3904++_int4range :: Oid+_int4range = 3905++numrange :: Oid+numrange = 3906++_numrange :: Oid+_numrange = 3907++tsrange :: Oid+tsrange = 3908++_tsrange :: Oid+_tsrange = 3909++tstzrange :: Oid+tstzrange = 3910++_tstzrange :: Oid+_tstzrange = 3911++daterange :: Oid+daterange = 3912++_daterange :: Oid+_daterange = 3913++int8range :: Oid+int8range = 3926++_int8range :: Oid+_int8range = 3927++sqlIdentifier :: Oid+sqlIdentifier = 12664++instance Show Oid where+ show o | o == bool = "bool"+ | o == bytea = "bytea"+ | o == char = "char"+ | o == name = "name"+ | o == int8 = "int8"+ | o == int2 = "int2"+ | o == int4 = "int4"+ | o == regproc = "regproc"+ | o == text = "text"+ | o == oid = "oid"+ | o == tid = "tid"+ | o == xid = "xid"+ | o == cid = "cid"+ | o == xml = "xml"+ | o == point = "point"+ | o == lseg = "lseg"+ | o == path = "path"+ | o == box = "box"+ | o == polygon = "polygon"+ | o == line = "line"+ | o == cidr = "cidr"+ | o == float4 = "float4"+ | o == float8 = "float8"+ | o == unknown = "unknown"+ | o == circle = "circle"+ | o == money = "money"+ | o == macaddr = "macaddr"+ | o == inet = "inet"+ | o == bpchar = "bpchar"+ | o == varchar = "varchar"+ | o == date = "date"+ | o == time = "time"+ | o == timestamp = "timestamp"+ | o == timestamptz = "timestamptz"+ | o == interval = "interval"+ | o == timetz = "timetz"+ | o == bit = "bit"+ | o == varbit = "varbit"+ | o == numeric = "numeric"+ | o == refcursor = "refcursor"+ | o == record = "record"+ | o == void = "void"+ | o == recordArray = "recordArray"+ | o == regprocedure = "regprocedure"+ | o == regoper = "regoper"+ | o == regoperator = "regoperator"+ | o == regclass = "regclass"+ | o == regtype = "regtype"+ | o == uuid = "uuid"+ | o == json = "json"+ | o == jsonb = "jsonb"+ | o == int2vector = "int2vector"+ | o == oidvector = "oidvector"+ | o == xmlArray = "xmlArray"+ | o == jsonArray = "jsonArray"+ | o == lineArray = "lineArray"+ | o == cidrArray = "cidrArray"+ | o == circleArray = "circleArray"+ | o == moneyArray = "moneyArray"+ | o == boolArray = "boolArray"+ | o == byteaArray = "byteaArray"+ | o == charArray = "charArray"+ | o == nameArray = "nameArray"+ | o == int2Array = "int2Array"+ | o == int2vectorArray = "int2vectorArray"+ | o == int4Array = "int4Array"+ | o == regprocArray = "regprocArray"+ | o == textArray = "textArray"+ | o == tidArray = "tidArray"+ | o == xidArray = "xidArray"+ | o == cidArray = "cidArray"+ | o == oidvectorArray = "oidvectorArray"+ | o == bpcharArray = "bpcharArray"+ | o == varcharArray = "varcharArray"+ | o == int8Array = "int8Array"+ | o == pointArray = "pointArray"+ | o == lsegArray = "lsegArray"+ | o == pathArray = "pathArray"+ | o == boxArray = "boxArray"+ | o == float4Array = "float4Array"+ | o == float8Array = "float8Array"+ | o == polygonArray = "polygonArray"+ | o == oidArray = "oidArray"+ | o == macaddrArray = "macaddrArray"+ | o == inetArray = "inetArray"+ | o == timestampArray = "timestampArray"+ | o == dateArray = "dateArray"+ | o == timeArray = "timeArray"+ | o == timestamptzArray = "timestamptzArray"+ | o == intervalArray = "intervalArray"+ | o == numericArray = "numericArray"+ | o == timetzArray = "timetzArray"+ | o == bitArray = "bitArray"+ | o == varbitArray = "varbitArray"+ | o == refcursorArray = "refcursorArray"+ | o == regprocedureArray = "regprocedureArray"+ | o == regoperArray = "regoperArray"+ | o == regoperatorArray = "regoperatorArray"+ | o == regclassArray = "regclassArray"+ | o == regtypeArray = "regtypeArray"+ | o == uuidArray = "uuidArray"+ | o == jsonbArray = "jsonbArray"+ | o == int4range = "int4range"+ | o == _int4range = "_int4range"+ | o == numrange = "numrange"+ | o == _numrange = "_numrange"+ | o == tsrange = "tsrange"+ | o == _tsrange = "_tsrange"+ | o == tstzrange = "tstzrange"+ | o == _tstzrange = "_tstzrange"+ | o == daterange = "daterange"+ | o == _daterange = "_daterange"+ | o == int8range = "int8range"+ | o == _int8range = "_int8range"+ | o == sqlIdentifier = "sqlIdentifier"+ show (Oid n) = show n++instance Read Oid where+ readPrec =+ R.parens+ ( do+ R.lift $ R.expect $ R.Ident "bool"+ pure bool+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "bytea"+ pure bytea+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "char"+ pure char+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "name"+ pure name+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "int8"+ pure int8+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "int2"+ pure int2+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "int4"+ pure int4+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "regproc"+ pure regproc+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "text"+ pure text+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "oid"+ pure oid+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "tid"+ pure tid+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "xid"+ pure xid+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "cid"+ pure cid+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "xml"+ pure xml+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "point"+ pure point+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "lseg"+ pure lseg+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "path"+ pure path+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "box"+ pure box+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "polygon"+ pure polygon+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "line"+ pure line+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "cidr"+ pure cidr+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "float4"+ pure float4+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "float8"+ pure float8+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "unknown"+ pure unknown+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "circle"+ pure circle+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "money"+ pure money+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "macaddr"+ pure macaddr+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "inet"+ pure inet+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "bpchar"+ pure bpchar+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "varchar"+ pure varchar+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "date"+ pure date+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "time"+ pure time+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "timestamp"+ pure timestamp+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "timestamptz"+ pure timestamptz+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "interval"+ pure interval+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "timetz"+ pure timetz+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "bit"+ pure bit+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "varbit"+ pure varbit+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "numeric"+ pure numeric+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "refcursor"+ pure refcursor+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "record"+ pure record+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "void"+ pure void+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "recordArray"+ pure recordArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "regprocedure"+ pure regprocedure+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "regoper"+ pure regoper+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "regoperator"+ pure regoperator+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "regclass"+ pure regclass+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "regtype"+ pure regtype+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "uuid"+ pure uuid+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "json"+ pure json+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "jsonb"+ pure jsonb+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "int2vector"+ pure int2vector+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "oidvector"+ pure oidvector+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "xmlArray"+ pure xmlArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "jsonArray"+ pure jsonArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "lineArray"+ pure lineArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "cidrArray"+ pure cidrArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "circleArray"+ pure circleArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "moneyArray"+ pure moneyArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "boolArray"+ pure boolArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "byteaArray"+ pure byteaArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "charArray"+ pure charArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "nameArray"+ pure nameArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "int2Array"+ pure int2Array+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "int2vectorArray"+ pure int2vectorArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "int4Array"+ pure int4Array+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "regprocArray"+ pure regprocArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "textArray"+ pure textArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "tidArray"+ pure tidArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "xidArray"+ pure xidArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "cidArray"+ pure cidArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "oidvectorArray"+ pure oidvectorArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "bpcharArray"+ pure bpcharArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "varcharArray"+ pure varcharArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "int8Array"+ pure int8Array+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "pointArray"+ pure pointArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "lsegArray"+ pure lsegArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "pathArray"+ pure pathArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "boxArray"+ pure boxArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "float4Array"+ pure float4Array+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "float8Array"+ pure float8Array+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "polygonArray"+ pure polygonArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "oidArray"+ pure oidArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "macaddrArray"+ pure macaddrArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "inetArray"+ pure inetArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "timestampArray"+ pure timestampArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "dateArray"+ pure dateArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "timeArray"+ pure timeArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "timestamptzArray"+ pure timestamptzArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "intervalArray"+ pure intervalArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "numericArray"+ pure numericArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "timetzArray"+ pure timetzArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "bitArray"+ pure bitArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "varbitArray"+ pure varbitArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "refcursorArray"+ pure refcursorArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "regprocedureArray"+ pure regprocedureArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "regoperArray"+ pure regoperArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "regoperatorArray"+ pure regoperatorArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "regclassArray"+ pure regclassArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "regtypeArray"+ pure regtypeArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "uuidArray"+ pure uuidArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "jsonbArray"+ pure jsonbArray+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "int4range"+ pure int4range+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "_int4range"+ pure _int4range+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "numrange"+ pure numrange+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "_numrange"+ pure _numrange+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "tsrange"+ pure tsrange+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "_tsrange"+ pure _tsrange+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "tstzrange"+ pure tstzrange+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "_tstzrange"+ pure _tstzrange+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "daterange"+ pure daterange+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "_daterange"+ pure _daterange+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "int8range"+ pure int8range+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "_int8range"+ pure _int8range+ )+ <|> ( do+ R.lift $ R.expect $ R.Ident "sqlIdentifier"+ pure sqlIdentifier+ )+ <|> (Oid <$> readPrec)
+ src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}++-- |+-- Module: Database.PostgreSQL.Simple.Time.Internal.Parser+-- Copyright: (c) 2012-2015 Leon P Smith+-- (c) 2015 Bryan O'Sullivan+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+--+-- Parsers for parsing dates and times.++module Database.PostgreSQL.Simple.Time.Internal.Parser+ (+ day+ , localTime+ , timeOfDay+ , timeZone+ , UTCOffsetHMS(..)+ , timeZoneHMS+ , localToUTCTimeOfDayHMS+ , utcTime+ , zonedTime+ , diffTime+ ) where++import Control.Applicative ((<$>), (<*>), (<*), (*>))+import Data.Attoparsec.ByteString.Char8 (Parser, peekChar, anyChar, satisfy, option, digit, isDigit, char, takeWhile1, decimal)+import Data.Bits ((.&.))+import Data.Char (ord)+import Data.Fixed (Fixed (MkFixed), Pico)+import Data.Int (Int64)+import Data.Maybe (fromMaybe)+import Data.Time.Calendar (Day, fromGregorianValid, addDays)+import Data.Time.Clock (UTCTime(UTCTime), DiffTime, picosecondsToDiffTime)+import qualified Data.ByteString.Char8 as B8+import qualified Data.Time.LocalTime as Local++-- | Parse a date of the form @YYYY-MM-DD@.+day :: Parser Day+day = do+ y <- decimal <* char '-'+ m <- twoDigits <* char '-'+ d <- twoDigits+ maybe (fail "invalid date") return (fromGregorianValid y m d)++-- | Parse a two-digit integer (e.g. day of month, hour).+twoDigits :: Parser Int+twoDigits = do+ a <- digit+ b <- digit+ return $! c2d a * 10 + c2d b++-- | Parse a time of the form @HH:MM[:SS[.SSS]]@.+timeOfDay :: Parser Local.TimeOfDay+timeOfDay = do+ h <- twoDigits <* char ':'+ m <- twoDigits+ mc <- peekChar+ s <- case mc of+ Just ':' -> anyChar *> seconds+ _ -> return 0+ if h < 24 && m < 60 && s <= 60+ then return (Local.TimeOfDay h m s)+ else fail "invalid time"++-- | Parse a count of seconds, with the integer part being two digits+-- long.+seconds :: Parser Pico+seconds = do+ real <- twoDigits+ mc <- peekChar+ case mc of+ Just '.' -> do+ t <- anyChar *> takeWhile1 isDigit+ return $! parsePicos (fromIntegral real) t+ _ -> return $! fromIntegral real+ where+ parsePicos :: Int64 -> B8.ByteString -> Pico+ parsePicos a0 t = toPico (fromIntegral (t' * 10^n))+ where n = max 0 (12 - B8.length t)+ t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0+ (B8.take 12 t)++-- TODO to check minus values, values which is smaller than an hour and so on+diffTime :: Parser DiffTime+diffTime = do+ h <- digits <* char ':'+ m <- toInteger <$> twoDigits <* char ':'+ MkFixed ps <- seconds+ return $ picosecondsToDiffTime $ (h * 60 + m) * 60 * 10 ^ (12 :: Int) + ps+ where+ digits =+ go 0+ where+ go acc = do+ md <- option Nothing $ Just . toInteger . c2d <$> digit+ case md of+ Just d -> go $ d + acc * 10+ Nothing -> return acc++-- | Parse a time zone, and return 'Nothing' if the offset from UTC is+-- zero. (This makes some speedups possible.)+timeZone :: Parser (Maybe Local.TimeZone)+timeZone = do+ ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'+ if ch == 'Z'+ then return Nothing+ else do+ h <- twoDigits+ mm <- peekChar+ m <- case mm of+ Just ':' -> anyChar *> twoDigits+ _ -> return 0+ let off | ch == '-' = negate off0+ | otherwise = off0+ off0 = h * 60 + m+ case () of+ _ | off == 0 ->+ return Nothing+ | h > 23 || m > 59 ->+ fail "invalid time zone offset"+ | otherwise ->+ let !tz = Local.minutesToTimeZone off+ in return (Just tz)++data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int++-- | Parse a time zone, and return 'Nothing' if the offset from UTC is+-- zero. (This makes some speedups possible.)+timeZoneHMS :: Parser (Maybe UTCOffsetHMS)+timeZoneHMS = do+ ch <- satisfy $ \c -> c == '+' || c == '-' || c == 'Z'+ if ch == 'Z'+ then return Nothing+ else do+ h <- twoDigits+ m <- maybeTwoDigits+ s <- maybeTwoDigits+ case () of+ _ | h == 0 && m == 0 && s == 0 ->+ return Nothing+ | h > 23 || m >= 60 || s >= 60 ->+ fail "invalid time zone offset"+ | otherwise ->+ if ch == '+'+ then let !tz = UTCOffsetHMS h m s+ in return (Just tz)+ else let !tz = UTCOffsetHMS (-h) (-m) (-s)+ in return (Just tz)+ where+ maybeTwoDigits = do+ ch <- peekChar+ case ch of+ Just ':' -> anyChar *> twoDigits+ _ -> return 0++localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)+localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) =+ (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'')+ where+ s' = s - fromIntegral ds+ (!s'', m')+ | s' < 0 = (s' + 60, m - dm - 1)+ | s' >= 60 = (s' - 60, m - dm + 1)+ | otherwise = (s' , m - dm )+ (!m'', h')+ | m' < 0 = (m' + 60, h - dh - 1)+ | m' >= 60 = (m' - 60, h - dh + 1)+ | otherwise = (m' , h - dh )+ h'' :: Int+ dday :: Integer+ (!h'', dday)+ | h' < 0 = (h' + 24, -1)+ | h' >= 24 = (h' - 24, 1)+ | otherwise = (h' , 0)+++-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.+-- The space may be replaced with a @T@. The number of seconds may be+-- followed by a fractional component.+localTime :: Parser Local.LocalTime+localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay+ where daySep = satisfy (\c -> c == ' ' || c == 'T')++-- | Behaves as 'zonedTime', but converts any time zone offset into a+-- UTC time.+utcTime :: Parser UTCTime+utcTime = do+ (Local.LocalTime d t) <- localTime+ mtz <- timeZoneHMS+ case mtz of+ Nothing -> let !tt = Local.timeOfDayToTime t+ in return (UTCTime d tt)+ Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t+ !d' = addDays dd d+ !tt = Local.timeOfDayToTime t'+ in return (UTCTime d' tt)++-- | Parse a date with time zone info. Acceptable formats:+--+-- @YYYY-MM-DD HH:MM:SS Z@+--+-- The first space may instead be a @T@, and the second space is+-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a+-- time zone offset of the form @+0000@ or @-08:00@, where the first+-- two digits are hours, the @:@ is optional and the second two digits+-- (also optional) are minutes.+zonedTime :: Parser Local.ZonedTime+zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)++c2d :: Char -> Int+c2d c = ord c .&. 15++utc :: Local.TimeZone+utc = Local.TimeZone 0 False ""++toPico :: Integer -> Pico+toPico = MkFixed
+ src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE BangPatterns, ViewPatterns #-}++------------------------------------------------------------------------------+-- Module: Database.PostgreSQL.Pure.Time.Internal.Printer+-- Copyright: (c) 2012-2015 Leon P Smith+-- License: BSD3+-- Maintainer: Leon P Smith <leon@melding-monads.com>+-- Stability: experimental+------------------------------------------------------------------------------++module Database.PostgreSQL.Simple.Time.Internal.Printer+ (+ day+ , timeOfDay+ , timeZone+ , utcTime+ , localTime+ , zonedTime+ , nominalDiffTime+ ) where++import Control.Arrow ((>>>))+import Data.ByteString.Builder (Builder, integerDec)+import Data.ByteString.Builder.Prim+ ( liftFixedToBounded, (>$<), (>*<)+ , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec)+import Data.Char ( chr )+import Data.Fixed (Fixed (MkFixed), Pico)+import Data.Int ( Int32, Int64 )+import Data.Time+ ( UTCTime(UTCTime), ZonedTime(ZonedTime), LocalTime(LocalTime), NominalDiffTime+ , Day, toGregorian, TimeOfDay(TimeOfDay), timeToTimeOfDay+ , TimeZone, timeZoneMinutes )+import Unsafe.Coerce (unsafeCoerce)++liftB :: FixedPrim a -> BoundedPrim a+liftB = liftFixedToBounded++digit :: FixedPrim Int+digit = (\x -> chr (x + 48)) >$< char8++digits2 :: FixedPrim Int+digits2 = (`quotRem` 10) >$< (digit >*< digit)++digits3 :: FixedPrim Int+digits3 = (`quotRem` 10) >$< (digits2 >*< digit)++digits4 :: FixedPrim Int+digits4 = (`quotRem` 10) >$< (digits3 >*< digit)++frac :: BoundedPrim Int64+frac = condB (== 0) emptyB ((,) '.' >$< (liftB char8 >*< trunc12))+ where+ trunc12 :: BoundedPrim Int64+ trunc12 = (`quotRem` 1000000) >$<+ condB (\(_,y) -> y == 0)+ (fst >$< trunc6)+ (liftB digits6 >*< trunc6)++ digitB = liftB digit++ digits6 :: FixedPrim Int64+ digits6 = (fromIntegral >>> (`quotRem` 10)) >$< (digits5 >*< digit)+ digits5 = (`quotRem` 10) >$< (digits4 >*< digit)++ trunc6 :: BoundedPrim Int64+ trunc6 = (fromIntegral >>> (`quotRem` 100000)) >$< (digitB >*< trunc5)+ trunc5 = condB (== 0) emptyB ((`quotRem` 10000) >$< (digitB >*< trunc4))+ trunc4 = condB (== 0) emptyB ((`quotRem` 1000) >$< (digitB >*< trunc3))+ trunc3 = condB (== 0) emptyB ((`quotRem` 100) >$< (digitB >*< trunc2))+ trunc2 = condB (== 0) emptyB ((`quotRem` 10) >$< (digitB >*< trunc1))+ trunc1 = condB (== 0) emptyB digitB+++year :: BoundedPrim Int32+year = condB (>= 10000) int32Dec (checkBCE >$< liftB digits4)+ where+ checkBCE :: Int32 -> Int+ checkBCE y+ | y > 0 = fromIntegral y+ | otherwise = error msg++ msg :: String+ msg = "Database.PostgreSQL.Simple.Time.Printer.year: years BCE not supported"++day :: BoundedPrim Day+day = toYMD >$< (year >*< liftB (char8 >*< digits2 >*< char8 >*< digits2))+ where+ toYMD (toGregorian -> (fromIntegral -> !y, !m,!d)) = (y,('-',(m,('-',d))))++timeOfDay :: BoundedPrim TimeOfDay+timeOfDay = f >$< (hh_mm_ >*< ss)+ where+ f (TimeOfDay h m s) = ((h,(':',(m,':'))),s)++ hh_mm_ = liftB (digits2 >*< char8 >*< digits2 >*< char8)++ ss = (\s -> fromIntegral (fromPico s) `quotRem` 1000000000000) >$<+ (liftB (fromIntegral >$< digits2) >*< frac)++timeZone :: BoundedPrim TimeZone+timeZone = timeZoneMinutes >$< tz+ where+ tz = condB (>= 0) ((,) '+' >$< tzh) ((,) '-' . negate >$< tzh)++ tzh = liftB char8 >*< ((`quotRem` 60) >$< (liftB digits2 >*< tzm))++ tzm = condB (==0) emptyB ((,) ':' >$< liftB (char8 >*< digits2))++utcTime :: BoundedPrim UTCTime+utcTime = f >$< (day >*< liftB char8 >*< timeOfDay >*< liftB char8)+ where f (UTCTime d (timeToTimeOfDay -> tod)) = (d,(' ',(tod,'Z')))++localTime :: BoundedPrim LocalTime+localTime = f >$< (day >*< liftB char8 >*< timeOfDay)+ where f (LocalTime d tod) = (d, (' ', tod))++zonedTime :: BoundedPrim ZonedTime+zonedTime = f >$< (localTime >*< timeZone)+ where f (ZonedTime lt tz) = (lt, tz)+++nominalDiffTime :: NominalDiffTime -> Builder+nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y))+ where+ (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000++fromPico :: Pico -> Integer+fromPico (MkFixed i) = i
+ test-doctest/doctest.hs view
@@ -0,0 +1,9 @@+import Test.DocTest (doctest)++main :: IO ()+main =+ doctest+ [ "-isrc"+ , "src/Database/PostgreSQL/Pure.hs"+ , "src/Database/PostgreSQL/Pure/List.hs"+ ]
+ test-hdbc-postgresql/SpecificDB.hs view
@@ -0,0 +1,43 @@+module SpecificDB where+import Database.HDBC+import Database.HDBC.PostgreSQL.Pure+import Test.HUnit+import Data.Default.Class(Default(def))+import Data.Maybe(fromMaybe)+import System.Environment(lookupEnv)++connectDB = + handleSqlError (do hostString <- getEnvDef "PURE_HOST" "127.0.0.1"+ portString <- getEnvDef "PURE_PORT" "5432"+ user <- getEnvDef "PURE_USER" "postgres"+ password <- getEnvDef "PURE_PASSWORD" ""+ database <- getEnvDef "PURE_DATABASE" "postgres"+ let+ config =+ def+ { address = AddressNotResolved hostString portString+ , user = user+ , password = password+ , database = database+ }+ dbh <- connect config+ run dbh "SET client_min_messages=WARNING" []+ return dbh)++dateTimeTypeOfSqlValue :: SqlValue -> String+dateTimeTypeOfSqlValue (SqlLocalDate _) = "date"+dateTimeTypeOfSqlValue (SqlLocalTimeOfDay _) = "time without time zone"+dateTimeTypeOfSqlValue (SqlZonedLocalTimeOfDay _ _) = "time with time zone"+dateTimeTypeOfSqlValue (SqlLocalTime _) = "timestamp without time zone"+dateTimeTypeOfSqlValue (SqlZonedTime _) = "timestamp with time zone"+dateTimeTypeOfSqlValue (SqlUTCTime _) = "timestamp with time zone"+dateTimeTypeOfSqlValue (SqlDiffTime _) = "interval"+dateTimeTypeOfSqlValue (SqlPOSIXTime _) = "numeric"+dateTimeTypeOfSqlValue (SqlEpochTime _) = "integer"+dateTimeTypeOfSqlValue (SqlTimeDiff _) = "interval"+dateTimeTypeOfSqlValue _ = "text"++supportsFracTime = True++getEnvDef :: String -> String -> IO String+getEnvDef name value = fromMaybe value <$> lookupEnv name
+ test-hdbc-postgresql/SpecificDBTests.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}++module SpecificDBTests where+import Database.HDBC+import Database.HDBC.PostgreSQL.Pure+import Database.HDBC.PostgreSQL.Pure.Parser(convertQuestionMarkStyleToDollarSignStyle)+import Test.HUnit++testp inp exp = TestCase $+ case convertQuestionMarkStyleToDollarSignStyle inp of+ Right x -> assertEqual "" exp x+ Left y -> assertFailure $ show y++tests = TestList + [TestLabel "empty" (testp "" ""),+ TestLabel "simple" (testp "SELECT a from b WHERE c = ?"+ "SELECT a from b WHERE c = $1"),+ TestLabel "multi" (testp "INSERT INTO foo VALUES (?,?)"+ "INSERT INTO foo VALUES ($1,$2)"),+ TestLabel "literal" (testp "INSERT INTO foo VALUES ('?', '''?')"+ "INSERT INTO foo VALUES ('?', '''?')"),+ TestLabel "torture" + (testp "-- really?\n-- yes'?\nINSERT INTO ? VALUES ('', ?, \"?asd\", '?\\'?', '?''?', /* foo? */ /* foo /* bar */ ? */ ?)"+ "-- really?\n-- yes'?\nINSERT INTO $1 VALUES ('', $2, \"?asd\", '?\\'?', '?''?', /* foo? */ /* foo /* bar */ ? */ $3)")+ ] +
+ test-hdbc-postgresql/TestMisc.hs view
@@ -0,0 +1,180 @@+module TestMisc(tests, setup) where+import Test.HUnit+import Database.HDBC+import TestUtils+import System.IO+import Control.Exception+import Data.Char+import Control.Monad+import qualified Data.Map as Map++rowdata = + [[SqlInt32 0, toSql "Testing", SqlNull],+ [SqlInt32 1, toSql "Foo", SqlInt32 5],+ [SqlInt32 2, toSql "Bar", SqlInt32 9]]++colnames = ["testid", "teststring", "testint"]+alrows :: [[(String, SqlValue)]]+alrows = map (zip colnames) rowdata++setup f = dbTestCase $ \dbh ->+ do run dbh "CREATE TABLE hdbctest2 (testid INTEGER PRIMARY KEY NOT NULL, teststring TEXT, testint INTEGER)" []+ sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"+ executeMany sth rowdata+ commit dbh+ finally (f dbh)+ (do run dbh "DROP TABLE hdbctest2" []+ commit dbh+ )++cloneTest dbh a =+ do dbh2 <- clone dbh+ finally (handleSqlError (a dbh2))+ (handleSqlError (disconnect dbh2))++testgetColumnNames = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2"+ execute sth []+ cols <- getColumnNames sth+ finish sth+ ["testid", "teststring", "testint"] @=? map (map toLower) cols++testdescribeResult = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem`+ ["sqlite3"])) $+ do sth <- prepare dbh "SELECT * from hdbctest2"+ execute sth []+ cols <- describeResult sth+ ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols+ let coldata = map snd cols+ assertBool "r0 type" (colType (coldata !! 0) `elem`+ [SqlBigIntT, SqlIntegerT])+ assertBool "r1 type" (colType (coldata !! 1) `elem`+ [SqlVarCharT, SqlLongVarCharT])+ assertBool "r2 type" (colType (coldata !! 2) `elem`+ [SqlBigIntT, SqlIntegerT])+ finish sth++testdescribeTable = setup $ \dbh -> when (not ((hdbcDriverName dbh) `elem`+ ["sqlite3"])) $+ do cols <- describeTable dbh "hdbctest2"+ ["testid", "teststring", "testint"] @=? map (map toLower . fst) cols+ let coldata = map snd cols+ assertBool "r0 type" (colType (coldata !! 0) `elem`+ [SqlBigIntT, SqlIntegerT])+ assertEqual "r0 nullable" (Just False) (colNullable (coldata !! 0))+ assertBool "r1 type" (colType (coldata !! 1) `elem`+ [SqlVarCharT, SqlLongVarCharT])+ assertEqual "r1 nullable" (Just True) (colNullable (coldata !! 1))+ assertBool "r2 type" (colType (coldata !! 2) `elem`+ [SqlBigIntT, SqlIntegerT])+ assertEqual "r2 nullable" (Just True) (colNullable (coldata !! 2))++testquickQuery = setup $ \dbh ->+ do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []+ rowdata @=? results++testfetchRowAL = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth []+ fetchRowAL sth >>= (Just (head alrows) @=?)+ fetchRowAL sth >>= (Just (alrows !! 1) @=?)+ fetchRowAL sth >>= (Just (alrows !! 2) @=?)+ fetchRowAL sth >>= (Nothing @=?)+ finish sth++testfetchRowMap = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid" + execute sth []+ fetchRowMap sth >>= (Just (Map.fromList $ head alrows) @=?)+ fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 1) @=?)+ fetchRowMap sth >>= (Just (Map.fromList $ alrows !! 2) @=?)+ fetchRowMap sth >>= (Nothing @=?)+ finish sth++testfetchAllRowsAL = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid"+ execute sth []+ fetchAllRowsAL sth >>= (alrows @=?)++testfetchAllRowsMap = setup $ \dbh ->+ do sth <- prepare dbh "SELECT * from hdbctest2 ORDER BY testid"+ execute sth []+ fetchAllRowsMap sth >>= (map (Map.fromList) alrows @=?)++testexception = setup $ \dbh ->+ catchSql (do sth <- prepare dbh "SELECT invalidcol FROM hdbctest2"+ execute sth []+ assertFailure "No exception was raised"+ )+ (\e -> commit dbh)++testrowcount = setup $ \dbh ->+ do r <- run dbh "UPDATE hdbctest2 SET testint = 25 WHERE testid = 20" []+ assertEqual "UPDATE with no change" 0 r+ r <- run dbh "UPDATE hdbctest2 SET testint = 26 WHERE testid = 0" []+ assertEqual "UPDATE with 1 change" 1 r+ r <- run dbh "UPDATE hdbctest2 SET testint = 27 WHERE testid <> 0" []+ assertEqual "UPDATE with 2 changes" 2 r+ commit dbh+ res <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []+ assertEqual "final results"+ [[SqlInt32 0, toSql "Testing", SqlInt32 26],+ [SqlInt32 1, toSql "Foo", SqlInt32 27],+ [SqlInt32 2, toSql "Bar", SqlInt32 27]] res+ +{- Since we might be running against a live DB, we can't look at a specific+list here (though a SpecificDB test case may be able to). We can ensure+that our test table is, or is not, present, as appropriate. -}+ +testgetTables1 = setup $ \dbh ->+ do r <- getTables dbh+ True @=? "hdbctest2" `elem` r++testgetTables2 = dbTestCase $ \dbh ->+ do r <- getTables dbh+ False @=? "hdbctest2" `elem` r++testclone = setup $ \dbho -> cloneTest dbho $ \dbh ->+ do results <- quickQuery dbh "SELECT * from hdbctest2 ORDER BY testid" []+ rowdata @=? results++testnulls = setup $ \dbh ->+ do let dn = hdbcDriverName dbh+ when (not (dn `elem` ["postgresql", "odbc"])) (+ do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"+ executeMany sth rows+ finish sth+ res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" []+ seq (length res) rows @=? res+ )+ where rows = [[SqlInt32 100, SqlString "foo\NULbar", SqlNull],+ [SqlInt32 101, SqlString "bar\NUL", SqlNull],+ [SqlInt32 102, SqlString "\NUL", SqlNull],+ [SqlInt32 103, SqlString "\xFF", SqlNull],+ [SqlInt32 104, SqlString "regular", SqlNull]]+ +testunicode = setup $ \dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest2 VALUES (?, ?, ?)"+ executeMany sth rows+ finish sth+ res <- quickQuery dbh "SELECT * from hdbctest2 WHERE testid > 99 ORDER BY testid" []+ seq (length res) rows @=? res+ where rows = [[SqlInt32 100, SqlString "foo\x263a", SqlNull],+ [SqlInt32 101, SqlString "bar\x00A3", SqlNull],+ [SqlInt32 102, SqlString (take 263 (repeat 'a')), SqlNull]]++tests = TestList [TestLabel "getColumnNames" testgetColumnNames,+ TestLabel "describeResult" testdescribeResult,+ TestLabel "describeTable" testdescribeTable,+ TestLabel "quickQuery" testquickQuery,+ TestLabel "fetchRowAL" testfetchRowAL,+ TestLabel "fetchRowMap" testfetchRowMap,+ TestLabel "fetchAllRowsAL" testfetchAllRowsAL,+ TestLabel "fetchAllRowsMap" testfetchAllRowsMap,+ TestLabel "sql exception" testexception,+ TestLabel "clone" testclone,+ TestLabel "update rowcount" testrowcount,+ TestLabel "get tables1" testgetTables1,+ TestLabel "get tables2" testgetTables2,+ TestLabel "nulls" testnulls,+ TestLabel "unicode" testunicode]
+ test-hdbc-postgresql/TestSbasics.hs view
@@ -0,0 +1,171 @@+module TestSbasics(tests) where+import Test.HUnit+import Data.List+import Database.HDBC+import TestUtils+import System.IO+import Control.Exception++openClosedb = sqlTestCase $ + do dbh <- connectDB+ disconnect dbh++multiFinish = dbTestCase (\dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ sExecute sth []+ finish sth+ finish sth+ finish sth+ )++runRawTest = dbTestCase (\dbh ->+ do runRaw dbh "CREATE TABLE valid1 (a int); CREATE TABLE valid2 (a int)"+ tables <- getTables dbh+ assertBool "valid1 table not created!" ("valid1" `elem` tables)+ assertBool "valid2 table not created!" ("valid2" `elem` tables)+ )++runRawErrorTest = dbTestCase (\dbh ->+ let expected = "syntax error at or near \"INVALID\""+ in do err <- (runRaw dbh "CREATE TABLE valid1 (a int); INVALID" >> return "No error") `catchSql`+ (return . seErrorMsg)+ assertBool "Error message inappropriate" (expected `isInfixOf` err)+ rollback dbh+ tables <- getTables dbh+ assertBool "valid1 table created!" (not $ "valid1" `elem` tables)+ )+++basicQueries = dbTestCase (\dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ sExecute sth []+ sFetchRow sth >>= (assertEqual "row 1" (Just [Just "2"]))+ sFetchRow sth >>= (assertEqual "last row" Nothing)+ )+ +createTable = dbTestCase (\dbh ->+ do sRun dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" []+ commit dbh+ )++dropTable = dbTestCase (\dbh ->+ do sRun dbh "DROP TABLE hdbctest1" []+ commit dbh+ )++runReplace = dbTestCase (\dbh ->+ do sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1+ sRun dbh "INSERT INTO hdbctest1 VALUES (?, ?, 2, ?)" r2+ commit dbh+ sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid"+ sExecute sth []+ sFetchRow sth >>= (assertEqual "r1" (Just r1))+ sFetchRow sth >>= (assertEqual "r2" (Just [Just "runReplace", Just "2",+ Just "2", Nothing]))+ sFetchRow sth >>= (assertEqual "lastrow" Nothing)+ )+ where r1 = [Just "runReplace", Just "1", Just "1234", Just "testdata"]+ r2 = [Just "runReplace", Just "2", Nothing]++executeReplace = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)"+ sExecute sth [Just "1", Just "1234", Just "Foo"]+ sExecute sth [Just "2", Nothing, Just "Bar"]+ commit dbh+ sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid"+ sExecute sth [Just "executeReplace"]+ sFetchRow sth >>= (assertEqual "r1" + (Just $ map Just ["executeReplace", "1", "1234", + "Foo"]))+ sFetchRow sth >>= (assertEqual "r2"+ (Just [Just "executeReplace", Just "2", Nothing,+ Just "Bar"]))+ sFetchRow sth >>= (assertEqual "lastrow" Nothing)+ )++testExecuteMany = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)"+ sExecuteMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'"+ sExecute sth []+ mapM_ (\r -> sFetchRow sth >>= (assertEqual "" (Just r))) rows+ sFetchRow sth >>= (assertEqual "lastrow" Nothing)+ )+ where rows = [map Just ["1", "1234", "foo"],+ map Just ["2", "1341", "bar"],+ [Just "3", Nothing, Nothing]]++testsFetchAllRows = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)"+ sExecuteMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid"+ sExecute sth []+ results <- sFetchAllRows sth+ assertEqual "" rows results+ )+ where rows = map (\x -> [Just . show $ x]) [1..9]++basicTransactions = dbTestCase (\dbh ->+ do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)+ sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)"+ sExecute sth [Just "0"]+ commit dbh+ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid"+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]])++ -- Now try a rollback+ sExecuteMany sth rows+ rollback dbh+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]])++ -- Now try another commit+ sExecuteMany sth rows+ commit dbh+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows))+ )+ where rows = map (\x -> [Just . show $ x]) [1..9]++testWithTransaction = dbTestCase (\dbh ->+ do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)+ sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)"+ sExecute sth [Just "0"]+ commit dbh+ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid"+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "initial commit" [[Just "0"]])+ + -- Let's try a rollback.+ catch (withTransaction dbh (\_ -> do sExecuteMany sth rows+ fail "Foo"))+ (\SomeException{} -> return ())+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "rollback" [[Just "0"]])++ -- And now a commit.+ withTransaction dbh (\_ -> sExecuteMany sth rows)+ sExecute qrysth []+ sFetchAllRows qrysth >>= (assertEqual "final commit" ([Just "0"]:rows))+ )+ where rows = map (\x -> [Just . show $ x]) [1..9]+ +tests = TestList+ [+ TestLabel "openClosedb" openClosedb,+ TestLabel "multiFinish" multiFinish,+ TestLabel "runRawTest" runRawTest,+ TestLabel "runRawErrorTest" runRawErrorTest,+ TestLabel "basicQueries" basicQueries,+ TestLabel "createTable" createTable,+ TestLabel "runReplace" runReplace,+ TestLabel "executeReplace" executeReplace,+ TestLabel "executeMany" testExecuteMany,+ TestLabel "sFetchAllRows" testsFetchAllRows,+ TestLabel "basicTransactions" basicTransactions,+ TestLabel "withTransaction" testWithTransaction,+ TestLabel "dropTable" dropTable+ ]
+ test-hdbc-postgresql/TestTime.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE FlexibleContexts, CPP #-}++module TestTime(tests) where+import Test.HUnit+import Database.HDBC+import TestUtils+import Control.Exception+import Data.Time (UTCTime, Day, NominalDiffTime)+import Data.Time.LocalTime+import Data.Time.Clock.POSIX+import Data.Maybe+import Data.Convertible+import SpecificDB+#if MIN_VERSION_time(1, 5, 0)+import Data.Time (parseTimeM, defaultTimeLocale)+#else+import Data.Time (parseTime)+import System.Locale(defaultTimeLocale)+#endif+import Database.HDBC.Locale (iso8601DateFormat)+import qualified System.Time as ST++instance Eq ZonedTime where+ a == b = zonedTimeToUTC a == zonedTimeToUTC b++testZonedTime :: ZonedTime+testZonedTime = fromJust $ parseTime' defaultTimeLocale (iso8601DateFormat (Just "%T %z"))+ "1989-08-01 15:33:01 -0500"++testZonedTimeFrac :: ZonedTime+testZonedTimeFrac = fromJust $ parseTime' defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z"))+ "1989-08-01 15:33:01.536 -0500"+++rowdata t = [[SqlInt32 100, toSql t, SqlNull]]++testDTType :: (Convertible SqlValue a, Show b, Eq b) =>+ a+ -> (a -> SqlValue)+ -> (a -> b)+ -> Test+testDTType inputdata convToSqlValue toComparable = dbTestCase $ \dbh ->+ do run dbh ("CREATE TABLE hdbctesttime (testid INTEGER PRIMARY KEY NOT NULL, testvalue " ++ dateTimeTypeOfSqlValue value ++ ")") []+ commit dbh+ finally (testIt dbh) (do commit dbh+ run dbh "DROP TABLE hdbctesttime" []+ commit dbh+ )+ where testIt dbh =+ do run dbh "INSERT INTO hdbctesttime (testid, testvalue) VALUES (?, ?)"+ [iToSql 5, value]+ commit dbh+ r <- quickQuery' dbh "SELECT testid, testvalue FROM hdbctesttime" []+ case r of+ [[testidsv, testvaluesv]] -> + do assertEqual "testid" (5::Int) (fromSql testidsv)+ assertEqual "testvalue"+ (toComparable inputdata)+ (toComparable$ fromSql testvaluesv)+ value = convToSqlValue inputdata++mkTest label inputdata convfunc toComparable =+ TestLabel label (testDTType inputdata convfunc toComparable)++tests = TestList $+ ((TestLabel "Non-frac" $ testIt testZonedTime) :+ if supportsFracTime then [TestLabel "Frac" $ testIt testZonedTimeFrac] else [])++testIt baseZonedTime =+ TestList [ mkTest "Day" baseDay toSql id+ , mkTest "TimeOfDay" baseTimeOfDay toSql id+ , mkTest "ZonedTimeOfDay" baseZonedTimeOfDay toSql id+ , mkTest "LocalTime" baseLocalTime toSql id+ , mkTest "ZonedTime" baseZonedTime toSql id+ , mkTest "UTCTime" baseUTCTime toSql id+ , mkTest "DiffTime" baseDiffTime toSql id+ , mkTest "POSIXTime" basePOSIXTime posixToSql id+ , mkTest "ClockTime" baseClockTime toSql id+ , mkTest "CalendarTime" baseCalendarTime toSql ST.toClockTime+ , mkTest "TimeDiff" baseTimeDiff toSql id+ ]+ where+ baseDay :: Day+ baseDay = localDay baseLocalTime++ baseTimeOfDay :: TimeOfDay+ baseTimeOfDay = localTimeOfDay baseLocalTime++ baseZonedTimeOfDay :: (TimeOfDay, TimeZone)+ baseZonedTimeOfDay = fromSql (SqlZonedTime baseZonedTime)++ baseLocalTime :: LocalTime+ baseLocalTime = zonedTimeToLocalTime baseZonedTime++ baseUTCTime :: UTCTime+ baseUTCTime = convert baseZonedTime++ baseDiffTime :: NominalDiffTime+ baseDiffTime = basePOSIXTime++ basePOSIXTime :: POSIXTime+ basePOSIXTime = convert baseZonedTime++ baseTimeDiff :: ST.TimeDiff+ baseTimeDiff = convert baseDiffTime++ -- No fractional parts for these two++ baseClockTime :: ST.ClockTime+ baseClockTime = convert testZonedTime++ baseCalendarTime :: ST.CalendarTime+ baseCalendarTime = convert testZonedTime++#if MIN_VERSION_time(1, 5, 0)+parseTime' = parseTimeM True+#else+parseTime' = parseTime+#endif
+ test-hdbc-postgresql/TestUtils.hs view
@@ -0,0 +1,25 @@+module TestUtils(connectDB, sqlTestCase, dbTestCase, printDBInfo) where+import Database.HDBC+import Test.HUnit+import Control.Exception+import SpecificDB(connectDB)++sqlTestCase a = + TestCase (handleSqlError a)++dbTestCase a =+ TestCase (do dbh <- connectDB+ finally (handleSqlError (a dbh))+ (handleSqlError (disconnect dbh))+ )++printDBInfo = handleSqlError $+ do dbh <- connectDB+ putStrLn "+-------------------------------------------------------------------------"+ putStrLn $ "| Testing HDBC database module: " ++ hdbcDriverName dbh +++ ", bound to client: " ++ hdbcClientVer dbh+ putStrLn $ "| Proxied driver: " ++ proxiedClientName dbh +++ ", bound to version: " ++ proxiedClientVer dbh+ putStrLn $ "| Connected to server version: " ++ dbServerVer dbh+ putStrLn "+-------------------------------------------------------------------------\n"+ disconnect dbh
+ test-hdbc-postgresql/Testbasics.hs view
@@ -0,0 +1,168 @@+module Testbasics(tests) where+import Test.HUnit+import Database.HDBC+import TestUtils+import System.IO+import Control.Exception++openClosedb = sqlTestCase $ + do dbh <- connectDB+ disconnect dbh++multiFinish = dbTestCase (\dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ r <- execute sth []+ assertEqual "basic count" 0 r+ finish sth+ finish sth+ finish sth+ )++basicQueries = dbTestCase (\dbh ->+ do sth <- prepare dbh "SELECT 1 + 1"+ execute sth [] >>= (0 @=?)+ r <- fetchAllRows sth+ assertEqual "converted from" [["2"]] (map (map fromSql) r)+ assertEqual "int32 compare" [[SqlInt32 2]] r+ assertEqual "iToSql compare" [[iToSql 2]] r+ assertEqual "num compare" [[toSql (2::Int)]] r+ assertEqual "nToSql compare" [[nToSql (2::Int)]] r+ assertEqual "string compare" [[SqlString "2"]] r+ )+ +createTable = dbTestCase (\dbh ->+ do run dbh "CREATE TABLE hdbctest1 (testname VARCHAR(20), testid INTEGER, testint INTEGER, testtext TEXT)" []+ commit dbh+ )++dropTable = dbTestCase (\dbh ->+ do run dbh "DROP TABLE hdbctest1" []+ commit dbh+ )++runReplace = dbTestCase (\dbh ->+ do r <- run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r1+ assertEqual "insert retval" 1 r+ run dbh "INSERT INTO hdbctest1 VALUES (?, ?, ?, ?)" r2+ commit dbh+ sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = 'runReplace' ORDER BY testid"+ rv2 <- execute sth []+ assertEqual "select retval" 0 rv2+ r <- fetchAllRows sth+ assertEqual "" [r1, r2] r+ )+ where r1 = [toSql "runReplace", iToSql 1, iToSql 1234, SqlString "testdata"] + r2 = [toSql "runReplace", iToSql 2, iToSql 2, SqlNull]++executeReplace = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('executeReplace',?,?,?)"+ execute sth [iToSql 1, iToSql 1234, toSql "Foo"]+ execute sth [SqlInt32 2, SqlNull, toSql "Bar"]+ commit dbh+ sth <- prepare dbh "SELECT * FROM hdbctest1 WHERE testname = ? ORDER BY testid"+ execute sth [SqlString "executeReplace"]+ r <- fetchAllRows sth+ assertEqual "result"+ [[toSql "executeReplace", iToSql 1, toSql "1234",+ toSql "Foo"],+ [toSql "executeReplace", iToSql 2, SqlNull,+ toSql "Bar"]]+ r+ )++testExecuteMany = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('multi',?,?,?)"+ executeMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid, testint, testtext FROM hdbctest1 WHERE testname = 'multi'"+ execute sth []+ r <- fetchAllRows sth+ assertEqual "" rows r+ )+ where rows = [map toSql ["1", "1234", "foo"],+ map toSql ["2", "1341", "bar"],+ [toSql "3", SqlNull, SqlNull]]++testFetchAllRows = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows', ?, NULL, NULL)"+ executeMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows' ORDER BY testid"+ execute sth []+ results <- fetchAllRows sth+ assertEqual "" rows results+ )+ where rows = map (\x -> [iToSql x]) [1..9]++testFetchAllRows' = dbTestCase (\dbh ->+ do sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('sFetchAllRows2', ?, NULL, NULL)"+ executeMany sth rows+ commit dbh+ sth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'sFetchAllRows2' ORDER BY testid"+ execute sth []+ results <- fetchAllRows' sth+ assertEqual "" rows results+ )+ where rows = map (\x -> [iToSql x]) [1..9]++basicTransactions = dbTestCase (\dbh ->+ do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)+ sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('basicTransactions', ?, NULL, NULL)"+ execute sth [iToSql 0]+ commit dbh+ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'basicTransactions' ORDER BY testid"+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]])++ -- Now try a rollback+ executeMany sth rows+ rollback dbh+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "rollback" [[toSql "0"]])++ -- Now try another commit+ executeMany sth rows+ commit dbh+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "final commit" ([SqlString "0"]:rows))+ )+ where rows = map (\x -> [iToSql $ x]) [1..9]++testWithTransaction = dbTestCase (\dbh ->+ do assertBool "Connected database does not support transactions; skipping transaction test" (dbTransactionSupport dbh)+ sth <- prepare dbh "INSERT INTO hdbctest1 VALUES ('withTransaction', ?, NULL, NULL)"+ execute sth [toSql "0"]+ commit dbh+ qrysth <- prepare dbh "SELECT testid FROM hdbctest1 WHERE testname = 'withTransaction' ORDER BY testid"+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "initial commit" [[toSql "0"]])+ + -- Let's try a rollback.+ catch (withTransaction dbh (\_ -> do executeMany sth rows+ fail "Foo"))+ (\SomeException{} -> return ())+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "rollback" [[SqlString "0"]])++ -- And now a commit.+ withTransaction dbh (\_ -> executeMany sth rows)+ execute qrysth []+ fetchAllRows qrysth >>= (assertEqual "final commit" ([iToSql 0]:rows))+ )+ where rows = map (\x -> [iToSql x]) [1..9]+ +tests = TestList+ [+ TestLabel "openClosedb" openClosedb,+ TestLabel "multiFinish" multiFinish,+ TestLabel "basicQueries" basicQueries,+ TestLabel "createTable" createTable,+ TestLabel "runReplace" runReplace,+ TestLabel "executeReplace" executeReplace,+ TestLabel "executeMany" testExecuteMany,+ TestLabel "fetchAllRows" testFetchAllRows,+ TestLabel "fetchAllRows'" testFetchAllRows',+ TestLabel "basicTransactions" basicTransactions,+ TestLabel "withTransaction" testWithTransaction,+ TestLabel "dropTable" dropTable+ ]
+ test-hdbc-postgresql/Tests.hs view
@@ -0,0 +1,19 @@+{- arch-tag: Tests main file+-}++module Tests(tests) where+import Test.HUnit+import qualified Testbasics+import qualified TestSbasics+import qualified SpecificDBTests+import qualified TestMisc+import qualified TestTime++test1 = TestCase ("x" @=? "x")++tests = TestList [TestLabel "test1" test1,+ TestLabel "String basics" TestSbasics.tests,+ TestLabel "SqlValue basics" Testbasics.tests,+ TestLabel "SpecificDB" SpecificDBTests.tests,+ TestLabel "Misc tests" TestMisc.tests,+ TestLabel "Time tests" TestTime.tests]
+ test-hdbc-postgresql/runtests.hs view
@@ -0,0 +1,12 @@+{- arch-tag: Test runner+-}++module Main where ++import Test.HUnit+import Tests+import TestUtils++main = do printDBInfo+ runTestTT tests+
+ test-relational-record/DataSource.hs view
@@ -0,0 +1,7 @@+module DataSource (connect) where++import Data.Default.Class (def)+import Database.HDBC.PostgreSQL (Connection, connectPostgreSQL)++connect :: IO Connection+connect = connectPostgreSQL "user='postgres'"
+ test-relational-record/DataSource/Pure.hs view
@@ -0,0 +1,7 @@+module DataSource.Pure (connect) where++import Data.Default.Class (def)+import qualified Database.HDBC.PostgreSQL.Pure as Pure++connect :: IO Pure.Connection+connect = Pure.connect def
+ test-relational-record/Relation/Person.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}++module Relation.Person where++import DataSource (connect)++import Prelude (Show)++import Database.HDBC.Query.TH (defineTableFromDB)+import Database.HDBC.Schema.PostgreSQL (driverPostgreSQL)+import GHC.Generics (Generic)++defineTableFromDB connect driverPostgreSQL "public" "person" [''Show, ''Generic]
+ test-relational-record/Relation/Pure/Person.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TemplateHaskell #-}++module Relation.Pure.Person where++import DataSource.Pure (connect)++import Prelude (Show)++import Database.HDBC.Query.TH (defineTableFromDB)+import Database.HDBC.Schema.PostgreSQL (driverPostgreSQL)+import GHC.Generics (Generic)++defineTableFromDB connect driverPostgreSQL "public" "person" [''Show, ''Generic]
+ test-relational-record/Spec.hs view
@@ -0,0 +1,19 @@+import Database.HDBC.Record (runQuery)+import Database.HDBC.Session (handleSqlError', withConnectionIO)+import Database.Relational (relationalQuery)+import Test.Hspec++import qualified DataSource as DS+import qualified DataSource.Pure as DSP+import qualified Relation.Person as Person+import qualified Relation.Pure.Person as PersonPure++{-# ANN module "HLint: ignore Redundant do" #-}++main :: IO ()+main = hspec $ do+ it "run" $ do+ handleSqlError' $ withConnectionIO DS.connect $ \conn -> withConnectionIO DSP.connect $ \connPure -> do+ persons <- ((\(Person.Person id name) -> (id, name)) <$>) <$> runQuery conn (relationalQuery Person.person) ()+ personsPure <- ((\(PersonPure.Person id name) -> (id, name)) <$>) <$> runQuery connPure (relationalQuery PersonPure.person) ()+ personsPure `shouldBe` persons
+ test/Database/HDBC/PostgreSQL/PureSpec.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeApplications #-}++module Database.HDBC.PostgreSQL.PureSpec (spec) where++import Database.HDBC+import Database.HDBC.PostgreSQL.Pure++import Test.Hspec++import Control.Exception.Safe (try)+import Control.Monad (void)+import Data.Default.Class (Default (def))+import Data.Maybe (fromMaybe)+import System.Environment (lookupEnv)++{-# ANN module ("HLint: ignore Redundant do" :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}++spec :: Spec+spec = do+ beforeAll+ ( do+ hostString <- getEnvDef "PURE_HOST" "127.0.0.1"+ portString <- getEnvDef "PURE_PORT" "5432"+ user <- getEnvDef "PURE_USER" "postgres"+ password <- getEnvDef "PURE_PASSWORD" ""+ database <- getEnvDef "PURE_DATABASE" "postgres"+ let+ config =+ def+ { address = AddressNotResolved hostString portString+ , user+ , password+ , database+ }+ connect config+ )+ $ afterAll+ disconnect+ $ do+ describe "CREATE TABLE/DROP TABLE" $ do+ it "prepare/execute" $ \conn -> do+ statement <- prepare conn "CREATE TABLE test (value INT NOT NULL)"+ n <- execute statement []+ n `shouldBe` 0+ statement <- prepare conn "DROP TABLE IF EXISTS test"+ n <- execute statement []+ n `shouldBe` 0+ commit conn+ pure ()++ it "run" $ \conn -> do+ run conn "CREATE TABLE test (value INT NOT NULL)" [] `shouldReturn` 0+ run conn "DROP TABLE IF EXISTS test" [] `shouldReturn` 0+ commit conn++ it "runRaw" $ \conn -> do+ let+ query =+ "CREATE TABLE test (value INT NOT NULL);\+ \DROP TABLE IF EXISTS test"+ runRaw conn query+ commit conn++ beforeWith+ ( \conn -> do+ let+ query =+ "CREATE TABLE test (value INT NOT NULL);\+ \INSERT INTO test (value) VALUES (0), (1), (2)"+ runRaw conn query+ commit conn+ pure conn+ )+ $ after+ ( \conn -> do+ void $ try @IO @SqlError $ do+ runRaw conn "DROP TABLE IF EXISTS test"+ commit conn+ )+ $ do+ describe "table: test (value INT NOT NULL)" $ do+ it "DELETE FROM test WHERE value = 0" $ \conn -> do+ run conn "DELETE FROM test WHERE value = 0" [] `shouldReturn` 1+ commit conn++ it "UPDATE test SET value = 10 WHERE value = 1" $ \conn -> do+ run conn "UPDATE test SET value = 10 WHERE value = 1" [] `shouldReturn` 1+ commit conn++ it "SELECT value FROM test ORDER BY value (reuse portal)" $ \conn -> do+ s <- prepare conn "SELECT value FROM test ORDER BY value"+ executeRaw s+ fetchRow s `shouldReturn` Just [SqlInt32 0]+ fetchRow s `shouldReturn` Just [SqlInt32 1]+ fetchRow s `shouldReturn` Just [SqlInt32 2]+ fetchRow s `shouldReturn` Nothing+ finish s++ it "SELECT value FROM test WHERE value = $1 (reuse prepared statement)" $ \conn -> do+ s <- prepare conn "SELECT value FROM test WHERE value = ?"+ void $ execute s [SqlInt32 0]+ fetchRow s `shouldReturn` Just [SqlInt32 0]+ void $ execute s [SqlInt32 1]+ fetchRow s `shouldReturn` Just [SqlInt32 1]+ void $ execute s [SqlInt32 2]+ fetchRow s `shouldReturn` Just [SqlInt32 2]+ finish s++ it "BEGIN/ROLLBACK" $ \conn -> do+ begin conn+ rollback conn++ it "BEGIN/COMMIT" $ \conn -> do+ begin conn+ commit conn++getEnvDef :: String -> String -> IO String+getEnvDef name value = fromMaybe value <$> lookupEnv name
+ test/Database/PostgreSQL/Pure/ListSpec.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Database.PostgreSQL.Pure.ListSpec (spec) where++import Database.PostgreSQL.Pure.List+import qualified Database.PostgreSQL.Pure.Oid as Oid++import Test.Hspec+import Test.Hspec.Core.Hooks.Extra++import Control.Monad (void)+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.Attoparsec.ByteString.Char8 as AP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.UTF8 as BSU+import Data.Default.Class (Default (def))+import Data.Int (Int32)+import Data.Maybe (fromMaybe)+import Data.Tuple.Only (Only (Only))+import qualified Network.Socket as NS+import System.Environment (lookupEnv)+import Text.Read (readMaybe)++{-# ANN module ("HLint: ignore Redundant do" :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-}++data Env =+ Env+ { hostString :: String+ , portString :: String+ , host :: Maybe NS.HostAddress+ , port :: Maybe NS.PortNumber+ , user :: String+ , password :: String+ , database :: String+ }++spec :: Spec+spec = do+ beforeAll+ ( do+ hostString <- getEnvDef "PURE_HOST" "127.0.0.1"+ portString <- getEnvDef "PURE_PORT" "5432"+ let+ host = fromEitherToMaybe $ parseHostIPv4 $ BSC.pack hostString+ port = readMaybe portString :: Maybe NS.PortNumber+ user <- getEnvDef "PURE_USER" "postgres"+ password <- getEnvDef "PURE_PASSWORD" ""+ database <- getEnvDef "PURE_DATABASE" "postgres"+ pure Env { hostString, portString, host, port, user, password, database }+ )+ $ do+ describe "connection" $ do+ describe "connect/disconnect" $ do+ it "resolved address" $ \Env { host, port, user, password, database } -> do+ case (host, port) of+ (Just host, Just port) -> do+ let+ config =+ def+ { address = AddressResolved $ NS.SockAddrInet port host+ , user+ , password+ , database+ }+ conn <- connect config+ disconnect conn+ _ -> pendingWith "the given host and port are not resolved"++ it "not-resolved address" $ \Env { hostString, portString, user, password, database } -> do+ let+ config =+ def+ { address = AddressNotResolved hostString portString+ , user+ , password+ , database+ }+ conn <- connect config+ disconnect conn++ it "withConnection" $ \Env { hostString, portString, user, password, database } -> do+ let+ config =+ def+ { address = AddressNotResolved hostString portString+ , user+ , password+ , database+ }+ withConnection config (const $ pure ())++ beforeAllWith+ ( \Env { hostString, portString, user, password, database } -> do+ let+ config =+ def+ { address = AddressNotResolved hostString portString+ , user+ , password+ , database+ }+ connect config+ )+ $ afterAll+ disconnect+ $ do+ describe "CREATE TABLE/DROP TABLE" $ do+ it "hints, hints" $ \conn -> do+ let+ e0 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "CREATE TABLE test (value INT NOT NULL)" (Right ([], []))+ e1 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "DROP TABLE IF EXISTS test" (Right ([], []))+ (((_, _, e0, _), (_, _, e1, _)), ts) <- sync conn (e0, e1)+ ts `shouldBe` Idle+ result e0 `shouldBe` ExecuteComplete CreateTableTag+ records e0 `shouldBe` ([] :: [()])+ result e1 `shouldBe` ExecuteComplete DropTableTag+ records e1 `shouldBe` ([] :: [()])++ it "no hints, no hints" $ \conn -> do+ let+ e0 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "CREATE TABLE test (value INT NOT NULL)" (Left (0, 0))+ e1 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "DROP TABLE IF EXISTS test" (Left (0, 0))+ (((_, _, e0, _), (_, _, e1, _)), ts) <- sync conn (e0, e1)+ ts `shouldBe` Idle+ result e0 `shouldBe` ExecuteComplete CreateTableTag+ records e0 `shouldBe` ([] :: [()])+ result e1 `shouldBe` ExecuteComplete DropTableTag+ records e1 `shouldBe` ([] :: [()])++ beforeWith+ ( \conn -> do+ let+ e0 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "CREATE TABLE test (value INT NOT NULL)" (Right ([], []))+ e1 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "INSERT INTO test (value) VALUES (0), (1), (2)" (Right ([], []))+ (((_, _, e0, _), (_, _, e1, _)), ts) <- sync conn (e0, e1)+ ts `shouldBe` Idle+ result e0 `shouldBe` ExecuteComplete CreateTableTag+ records e0 `shouldBe` ([] :: [()])+ result e1 `shouldSatisfy` \(ExecuteComplete (InsertTag _ 3)) -> True+ records e1 `shouldBe` ([] :: [()])+ pure conn+ )+ $ after+ ( \conn -> do+ let+ e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "DROP TABLE IF EXISTS test" (Right ([], []))+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete DropTableTag+ records e `shouldBe` ([] :: [()])+ )+ $ do+ describe "table: test (value INT NOT NULL)" $ do+ it "DELETE FROM test WHERE value = 0" $ \conn -> do+ let+ e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "DELETE FROM test WHERE value = 0" (Right ([], []))+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete (DeleteTag 1)+ records e `shouldBe` ([] :: [()])++ it "UPDATE test SET value = 10 WHERE value = 1" $ \conn -> do+ let+ e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "UPDATE test SET value = 10 WHERE value = 1" (Right ([], []))+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete (UpdateTag 1)+ records e `shouldBe` ([] :: [()])++ it "SELECT value FROM test ORDER BY value (get all)" $ \conn -> do+ let+ e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value" (Right ([], [Oid.int4]))+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete (SelectTag 3)+ records e `shouldBe` ([Only 0, Only 1, Only 2] :: [Only Int])++ it "SELECT value FROM test ORDER BY value (get a part)" $ \conn -> do+ let+ e = execute 1 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value" (Right ([], [Oid.int4]))+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteSuspended+ records e `shouldBe` ([Only 0] :: [Only Int])++ it "SELECT value FROM test ORDER BY value (reuse portal)" $ \conn -> do+ let+ p = forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value" (Right ([], [Oid.int4]))+ e = execute 2 (pure . BSU.toString) p+ (_, p, e, _) <- flush conn e+ result e `shouldBe` ExecuteSuspended+ records e `shouldBe` ([Only 0, Only 1] :: [Only Int])+ let+ e = execute 1 (pure . BSU.toString) p+ (_, _, e, _) <- flush conn e+ result e `shouldBe` ExecuteSuspended+ records e `shouldBe` ([Only 2] :: [Only Int])+ let+ e = execute 1 (pure . BSU.toString) p+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete (SelectTag 0)+ records e `shouldBe` ([] :: [Only Int])++ it "SELECT value FROM test WHERE value = $1 (reuse prepared statement)" $ \conn -> do+ let+ ps = parse "" "SELECT value FROM test WHERE value = $1" (Right ([Oid.int4], [Oid.int4]))+ e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) (Only (0 :: Int32)) ps+ ((ps, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete (SelectTag 1)+ records e `shouldBe` [Only (0 :: Int)]+ let+ e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) (Only (2 :: Int32)) ps+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete (SelectTag 1)+ records e `shouldBe` [Only (2 :: Int)]++ it "BEGIN/ROLLBACK" $ \conn -> do+ ((_, _, e, _), ts) <- sync conn begin+ ts `shouldBe` Block+ result e `shouldBe` ExecuteComplete BeginTag+ records e `shouldBe` []+ ((_, _, e, _), ts) <- sync conn rollback+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete RollbackTag+ records e `shouldBe` []++ it "BEGIN/COMMIT" $ \conn -> do+ ((_, _, e, _), ts) <- sync conn begin+ ts `shouldBe` Block+ result e `shouldBe` ExecuteComplete BeginTag+ records e `shouldBe` []+ ((_, _, e, _), ts) <- sync conn commit+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete CommitTag+ records e `shouldBe` []++ describe "invalid SQL" $ do+ it "parse sync" $ \conn -> do+ let+ ps = parse "" "INVALID SQL" (Right ([], []))+ sync conn ps `shouldThrow` (\ErrorResponse {} -> True)++ it "parse flush" $ \conn -> do+ let+ ps = parse "" "INVALID SQL" (Right ([], []))+ flush conn ps `shouldThrow` (\ErrorResponse {} -> True)++ describe "invalid parameter type" $ do+ it "parse sync" $ \conn -> do+ let+ ps = parse "" "SELECT value FROM test WHERE value = $1" (Right ([Oid.varchar], [Oid.int4]))+ void $ sync conn ps `shouldThrow` (\ErrorResponse {} -> True)++ it "parse flush" $ \conn -> do+ let+ ps = parse "" "SELECT value FROM test WHERE value = $1" (Right ([Oid.varchar], [Oid.int4]))+ void $ flush conn ps `shouldThrow` (\ErrorResponse {} -> True)++ describe "invalid result type" $ do+ it "parse/bind sync" $ \conn -> do+ let+ p = forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value LIMIT 1" (Right ([], [Oid.varchar]))+ ((_, _), ts) <- sync conn p+ ts `shouldBe` Idle++ it "parse/bind flush" $ \conn -> do+ let+ p = forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value LIMIT 1" (Right ([], [Oid.varchar]))+ void $ flush conn p++ it "parse/bind/execute sync" $ \conn -> do+ let+ e = execute @_ @(Only Int) 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value LIMIT 1" (Right ([], [Oid.varchar]))+ sync conn e `shouldThrow` (\ResponseParsingFailed {} -> True)++ it "parse/bind/execute flush" $ \conn -> do+ let+ e = execute @_ @(Only Int) 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value LIMIT 1" (Right ([], [Oid.varchar]))+ flush conn e `shouldThrow` (\ResponseParsingFailed {} -> True)++getEnvDef :: String -> String -> IO String+getEnvDef name value = fromMaybe value <$> lookupEnv name++parseHostIPv4 :: BS.ByteString -> Either String NS.HostAddress+parseHostIPv4 =+ AP.parseOnly ipv4Parser+ where+ ipv4Parser = do+ p1 <- AP.decimal+ void $ AP.char '.'+ p2 <- AP.decimal+ void $ AP.char '.'+ p3 <- AP.decimal+ void $ AP.char '.'+ p4 <- AP.decimal+ pure $ NS.tupleToHostAddress (p1, p2, p3, p4)++fromEitherToMaybe :: Either a b -> Maybe b+fromEitherToMaybe (Left _) = Nothing+fromEitherToMaybe (Right b) = Just b++forceRight :: Either String a -> a+forceRight (Right a) = a+forceRight (Left e) = error $ "forceRight: " <> e
+ test/Database/PostgreSQL/PureSpec.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Database.PostgreSQL.PureSpec (spec) where++import Database.PostgreSQL.Pure+import qualified Database.PostgreSQL.Pure.Oid as Oid++import Test.Hspec+import Test.Hspec.Core.Hooks.Extra++import Control.Monad (void)+import qualified Data.Attoparsec.ByteString as AP+import qualified Data.Attoparsec.ByteString.Char8 as AP+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString.UTF8 as BSU+import Data.Default.Class (Default (def))+import Data.Int (Int32)+import Data.Maybe (fromMaybe)+import qualified Data.Tuple.Homotuple as T+import Data.Tuple.Homotuple.Only ()+import Data.Tuple.List.Only ()+import Data.Tuple.Only (Only (Only))+import qualified Network.Socket as NS+import System.Environment (lookupEnv)+import Text.Read (readMaybe)++{-# ANN module ("HLint: ignore Redundant do" :: String) #-}++data Env =+ Env+ { hostString :: String+ , portString :: String+ , host :: Maybe NS.HostAddress+ , port :: Maybe NS.PortNumber+ , user :: String+ , password :: String+ , database :: String+ }++spec :: Spec+spec = do+ beforeAll+ ( do+ hostString <- getEnvDef "PURE_HOST" "127.0.0.1"+ portString <- getEnvDef "PURE_PORT" "5432"+ let+ host = fromEitherToMaybe $ parseHostIPv4 $ BSC.pack hostString+ port = readMaybe portString :: Maybe NS.PortNumber+ user <- getEnvDef "PURE_USER" "postgres"+ password <- getEnvDef "PURE_PASSWORD" ""+ database <- getEnvDef "PURE_DATABASE" "postgres"+ pure Env { hostString, portString, host, port, user, password, database }+ )+ $ do+ describe "connection" $ do+ describe "connect/disconnect" $ do+ it "resolved address" $ \Env { host, port, user, password, database } -> do+ case (host, port) of+ (Just host, Just port) -> do+ let+ config =+ def+ { address = AddressResolved $ NS.SockAddrInet port host+ , user+ , password+ , database+ }+ conn <- connect config+ disconnect conn+ _ -> pendingWith "the given host and port are not resolved"++ it "not-resolved address" $ \Env { hostString, portString, user, password, database } -> do+ let+ config =+ def+ { address = AddressNotResolved hostString portString+ , user+ , password+ , database+ }+ conn <- connect config+ disconnect conn++ it "withConnection" $ \Env { hostString, portString, user, password, database } -> do+ let+ config =+ def+ { address = AddressNotResolved hostString portString+ , user+ , password+ , database+ }+ withConnection config (const $ pure ())++ beforeAllWith+ ( \Env { hostString, portString, user, password, database } -> do+ let+ config =+ def+ { address = AddressNotResolved hostString portString+ , user+ , password+ , database+ }+ connect config+ )+ $ afterAll+ disconnect+ $ do+ describe "CREATE TABLE/DROP TABLE" $ do+ it "hints, hints" $ \conn -> do+ let+ e0 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "CREATE TABLE test (value INT NOT NULL)" (Just (T.Empty, T.Empty))+ e1 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "DROP TABLE IF EXISTS test" (Just (T.Empty, T.Empty))+ (((_, _, e0, _), (_, _, e1, _)), ts) <- sync conn (e0, e1)+ ts `shouldBe` Idle+ result e0 `shouldBe` ExecuteComplete CreateTableTag+ records e0 `shouldBe` ([] :: [()])+ result e1 `shouldBe` ExecuteComplete DropTableTag+ records e1 `shouldBe` ([] :: [()])++ it "no hints, no hints" $ \conn -> do+ let+ e0 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "CREATE TABLE test (value INT NOT NULL)" Nothing+ e1 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "DROP TABLE IF EXISTS test" Nothing+ (((_, _, e0, _), (_, _, e1, _)), ts) <- sync conn (e0, e1)+ ts `shouldBe` Idle+ result e0 `shouldBe` ExecuteComplete CreateTableTag+ records e0 `shouldBe` ([] :: [()])+ result e1 `shouldBe` ExecuteComplete DropTableTag+ records e1 `shouldBe` ([] :: [()])++ beforeWith+ ( \conn -> do+ let+ e0 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "CREATE TABLE test (value INT NOT NULL)" (Just (T.Empty, T.Empty))+ e1 = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "INSERT INTO test (value) VALUES (0), (1), (2)" (Just (T.Empty, T.Empty))+ (((_, _, e0, _), (_, _, e1, _)), ts) <- sync conn (e0, e1)+ ts `shouldBe` Idle+ result e0 `shouldBe` ExecuteComplete CreateTableTag+ records e0 `shouldBe` ([] :: [()])+ result e1 `shouldSatisfy` \(ExecuteComplete (InsertTag _ 3)) -> True+ records e1 `shouldBe` ([] :: [()])+ pure conn+ )+ $ after+ ( \conn -> do+ let+ e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "DROP TABLE IF EXISTS test" (Just (T.Empty, T.Empty))+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete DropTableTag+ records e `shouldBe` ([] :: [()])+ )+ $ do+ describe "table: test (value INT NOT NULL)" $ do+ it "DELETE FROM test WHERE value = 0" $ \conn -> do+ let+ e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "DELETE FROM test WHERE value = 0" (Just (T.Empty, T.Empty))+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete (DeleteTag 1)+ records e `shouldBe` ([] :: [()])++ it "UPDATE test SET value = 10 WHERE value = 1" $ \conn -> do+ let+ e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "UPDATE test SET value = 10 WHERE value = 1" (Just (T.Empty, T.Empty))+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete (UpdateTag 1)+ records e `shouldBe` ([] :: [()])++ it "SELECT value FROM test ORDER BY value (get all)" $ \conn -> do+ let+ e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value" (Just (T.Empty, Only Oid.int4))+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete (SelectTag 3)+ records e `shouldBe` ([Only 0, Only 1, Only 2] :: [Only Int])++ it "SELECT value FROM test ORDER BY value (get a part)" $ \conn -> do+ let+ e = execute 1 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value" (Just (T.Empty, Only Oid.int4))+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteSuspended+ records e `shouldBe` ([Only 0] :: [Only Int])++ it "SELECT value FROM test ORDER BY value (reuse portal)" $ \conn -> do+ let+ p = forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value" (Just (T.Empty, Only Oid.int4))+ e = execute 2 (pure . BSU.toString) p+ (_, p, e, _) <- flush conn e+ result e `shouldBe` ExecuteSuspended+ records e `shouldBe` ([Only 0, Only 1] :: [Only Int])+ let+ e = execute 1 (pure . BSU.toString) p+ (_, _, e, _) <- flush conn e+ result e `shouldBe` ExecuteSuspended+ records e `shouldBe` ([Only 2] :: [Only Int])+ let+ e = execute 1 (pure . BSU.toString) p+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete (SelectTag 0)+ records e `shouldBe` ([] :: [Only Int])++ it "SELECT value FROM test WHERE value = $1 (reuse prepared statement)" $ \conn -> do+ let+ ps = parse "" "SELECT value FROM test WHERE value = $1" (Just (Only Oid.int4, Only Oid.int4))+ e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) (Only (0 :: Int32)) ps+ ((ps, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete (SelectTag 1)+ records e `shouldBe` [Only (0 :: Int)]+ let+ e = execute 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) (Only (2 :: Int32)) ps+ ((_, _, e, _), ts) <- sync conn e+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete (SelectTag 1)+ records e `shouldBe` [Only (2 :: Int)]++ it "BEGIN/ROLLBACK" $ \conn -> do+ ((_, _, e, _), ts) <- sync conn begin+ ts `shouldBe` Block+ result e `shouldBe` ExecuteComplete BeginTag+ records e `shouldBe` []+ ((_, _, e, _), ts) <- sync conn rollback+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete RollbackTag+ records e `shouldBe` []++ it "BEGIN/COMMIT" $ \conn -> do+ ((_, _, e, _), ts) <- sync conn begin+ ts `shouldBe` Block+ result e `shouldBe` ExecuteComplete BeginTag+ records e `shouldBe` []+ ((_, _, e, _), ts) <- sync conn commit+ ts `shouldBe` Idle+ result e `shouldBe` ExecuteComplete CommitTag+ records e `shouldBe` []++ describe "invalid SQL" $ do+ it "parse sync" $ \conn -> do+ let+ ps = parse "" "INVALID SQL" (Just (T.Empty, T.Empty))+ sync conn ps `shouldThrow` (\ErrorResponse {} -> True)++ it "parse flush" $ \conn -> do+ let+ ps = parse "" "INVALID SQL" (Just (T.Empty, T.Empty))+ flush conn ps `shouldThrow` (\ErrorResponse {} -> True)++ describe "invalid parameter type" $ do+ it "parse sync" $ \conn -> do+ let+ ps = parse "" "SELECT value FROM test WHERE value = $1" (Just (Only Oid.varchar, Only Oid.int4))+ void $ sync conn ps `shouldThrow` (\ErrorResponse {} -> True)++ it "parse flush" $ \conn -> do+ let+ ps = parse "" "SELECT value FROM test WHERE value = $1" (Just (Only Oid.varchar, Only Oid.int4))+ void $ flush conn ps `shouldThrow` (\ErrorResponse {} -> True)++ describe "invalid result type" $ do+ it "parse/bind sync" $ \conn -> do+ let+ p = forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value LIMIT 1" (Just (T.Empty, Only Oid.varchar))+ ((_, _), ts) <- sync conn p+ ts `shouldBe` Idle++ it "parse/bind flush" $ \conn -> do+ let+ p = forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value LIMIT 1" (Just (T.Empty, Only Oid.varchar))+ void $ flush conn p++ it "parse/bind/execute sync" $ \conn -> do+ let+ e = execute @_ @_ @(Only Int) 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value LIMIT 1" (Just (T.Empty, Only Oid.varchar))+ sync conn e `shouldThrow` (\ResponseParsingFailed {} -> True)++ it "parse/bind/execute flush" $ \conn -> do+ let+ e = execute @_ @_ @(Only Int) 0 (pure . BSU.toString) $ forceRight $ bind "" BinaryFormat BinaryFormat (parameters conn) (pure . BSU.fromString) () $ parse "" "SELECT value FROM test ORDER BY value LIMIT 1" (Just (T.Empty, Only Oid.varchar))+ flush conn e `shouldThrow` (\ResponseParsingFailed {} -> True)++getEnvDef :: String -> String -> IO String+getEnvDef name value = fromMaybe value <$> lookupEnv name++parseHostIPv4 :: BS.ByteString -> Either String NS.HostAddress+parseHostIPv4 =+ AP.parseOnly ipv4Parser+ where+ ipv4Parser = do+ p1 <- AP.decimal+ void $ AP.char '.'+ p2 <- AP.decimal+ void $ AP.char '.'+ p3 <- AP.decimal+ void $ AP.char '.'+ p4 <- AP.decimal+ pure $ NS.tupleToHostAddress (p1, p2, p3, p4)++fromEitherToMaybe :: Either a b -> Maybe b+fromEitherToMaybe (Left _) = Nothing+fromEitherToMaybe (Right b) = Just b++forceRight :: Either String a -> a+forceRight (Right a) = a+forceRight (Left e) = error $ "forceRight: " <> e
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Test/Hspec/Core/Hooks/Extra.hs view
@@ -0,0 +1,30 @@+module Test.Hspec.Core.Hooks.Extra+ ( beforeAllWith+ ) where++import Test.Hspec.Core.Hooks+import Test.Hspec.Core.Spec++import Control.Concurrent.MVar (MVar, modifyMVar, newMVar)+import Control.Exception (SomeException, throwIO, try)++data Memoized a =+ Empty+ | Memoized a+ | Failed SomeException++memoize :: MVar (Memoized a) -> IO a -> IO a+memoize mvar action = do+ result <- modifyMVar mvar $ \ma -> case ma of+ Empty -> do+ a <- try action+ return (either Failed Memoized a, a)+ Memoized a -> return (ma, Right a)+ Failed _ -> throwIO (Pending Nothing (Just "exception in beforeAll-hook (see previous failure)"))+ either throwIO return result++-- | Run a custom action befor the first spec item.+beforeAllWith :: (b -> IO a) -> SpecWith a -> SpecWith b+beforeAllWith action spec = do+ mver <- runIO (newMVar Empty)+ beforeWith (memoize mver . action) spec