postgresql-pure 0.1.2.0 → 0.1.3.0
raw patch · 21 files changed
+1610/−1509 lines, 21 filesbuild-type:Customsetup-changed
Files
- ChangeLog.md +8/−0
- README.md +2/−0
- Setup.hs +168/−2
- benchmark/requests-per-second-constant.hs +15/−3
- benchmark/requests-per-second.hs +6/−0
- postgresql-pure.cabal +25/−11
- src/Database/HDBC/PostgreSQL/Pure.hs +21/−18
- src/Database/PostgreSQL/Pure.hs +6/−2
- src/Database/PostgreSQL/Pure/Internal/Builder.hs +0/−609
- src/Database/PostgreSQL/Pure/Internal/Connection.hs +2/−0
- src/Database/PostgreSQL/Pure/Internal/Data.hs +20/−14
- src/Database/PostgreSQL/Pure/Internal/Parser.hs +0/−839
- src/Database/PostgreSQL/Pure/Internal/Query.hs +6/−2
- src/Database/PostgreSQL/Pure/Internal/SocketIO.hs +8/−2
- src/Database/PostgreSQL/Pure/Parser.hs +5/−0
- src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs +5/−2
- template/Builder.hs +549/−0
- template/BuilderItem.hs +10/−0
- template/Parser.hs +748/−0
- template/ParserItem.hs +5/−0
- test-doctest/doctest.hs +1/−5
ChangeLog.md view
@@ -1,5 +1,13 @@ # Changelog for postgresql-pure +## 0.1.3.0++2020.06.15++- Expose a function for type class instance implementations.+- A new instance `FromField String`.+- New instances for `FromRecord`, `ToRecord`.+ ## 0.1.2.0 2019.10.21
README.md view
@@ -1,5 +1,7 @@ # postgresql-pure +[](http://hackage.haskell.org/package/postgresql-pure) [](https://kakkun61.visualstudio.com/postgresql-pure/_build/latest?definitionId=1&branchName=master) [](https://travis-ci.org/iij-ii/postgresql-pure)+ ## Copyright 2019 IIJ Innovation Institute Inc.
Setup.hs view
@@ -1,2 +1,168 @@-import Distribution.Simple-main = defaultMain+import Prelude hiding (head, init, last, reverse, tail)+import qualified Prelude++import Data.Char (isDigit)+import Data.Foldable (for_)+import Data.List (intercalate, intersperse, isPrefixOf, replicate, stripPrefix)+import Distribution.Simple (Args, UserHooks (preBuild), defaultMainWithHooks, simpleUserHooks)+import Distribution.Simple.Setup (BuildFlags)+import Distribution.Types.HookedBuildInfo (HookedBuildInfo, emptyHookedBuildInfo)+import System.Directory (copyFile, createDirectoryIfMissing, getTemporaryDirectory, removeFile)+import System.IO (Handle, IOMode (ReadMode), hClose, hGetLine, hIsEOF, hPutStrLn,+ hSetNewlineMode, noNewlineTranslation, openTempFile, stdin, withFile)++main :: IO ()+main =+ defaultMainWithHooks+ simpleUserHooks+ { preBuild = \_ _ -> preProcessBuilder >> preProcessParser >> pure emptyHookedBuildInfo }++preProcessBuilder :: IO ()+preProcessBuilder = do+ let+ dir = "src/Database/PostgreSQL/Pure/Internal"+ file = "Builder.hs"+ srcPath = dir ++ "/" ++ file+ templatePath = "template/Builder.hs"+ templateItemPath = "template/BuilderItem.hs"+ tempPath <-+ withFile templatePath ReadMode $ \template -> do+ tempDir <- (++ "/postgresql-pure") <$> getTemporaryDirectory+ createDirectoryIfMissing True tempDir+ (tempPath, temp) <- openTempFile tempDir file+ putStrLn $ "temporaly file: " ++ tempPath+ hSetNewlineMode template noNewlineTranslation+ hSetNewlineMode temp noNewlineTranslation+ hSetNewlineMode stdin noNewlineTranslation+ templateItem <- lines <$> readFile templateItemPath+ loop template temp templateItem+ hClose temp+ pure tempPath+ copyFile tempPath srcPath+ removeFile tempPath+ where+ loop :: Handle -> Handle -> [String] -> IO ()+ loop template temp templateItem =+ go+ where+ go = do+ eof <- hIsEOF template+ if eof+ then pure ()+ else do+ line <- hGetLine template+ for_ (preprocess line templateItem) (hPutStrLn temp)+ go++ preprocess :: String -> [String] -> [String]+ preprocess line templateItem+ | Just rest <- stripPrefix "---- embed " line+ , let n = read $ takeWhile isDigit rest+ = embed n templateItem+ | otherwise = [line]++ embed :: Word -> [String] -> [String]+ embed l templateItem+ | l >= 2 = concatMap go templateItem+ | otherwise = error "length must be larger than or equal to 2"+ where+ go "" = [""]+ go t+ | Just rest <- stripPrefix "<to-field>" t = [toField ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<type-tuple>" t = [typeTuple ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<value-tuple>" t = [valueTuple ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<format-list>" t = [formatList ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<oid-list>" t = [oidList ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<to-field-nothing-list>" t = [toFieldNothingList ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<to-field-just-list>" t = [toFieldJustList ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<length>" t = [length ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<>" t = ["<>" ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<" t = error $ "unknown tag: " ++ takeWhile (/= '>') rest+ | (s, rest) <- span (/= '<') t = [s ++ Prelude.head (go rest)]+ n = fromIntegral l+ toField = paren $ take n $ ("ToField " ++) <$> i012+ typeTuple = paren $ take n i012+ valueTuple = paren $ take n v012+ formatList = bracket $ take n f012+ oidList = bracket $ take n o012+ toFieldNothingList = bracket $ take n $ (\(f, v) -> "toField backendParams encode Nothing " ++ f ++ " " ++ v) <$> zip f012 v012+ toFieldJustList = bracket $ take n $ (\(o, f, v) -> "toField backendParams encode (Just " ++ o ++ ") " ++ f ++ " " ++ v) <$> zip3 o012 f012 v012+ length = show l+ paren xs = "(" ++ intercalate ", " xs ++ ")"+ bracket xs = "[" ++ intercalate ", " xs ++ "]"+ i012 = ('i':) . show <$> [0 ..]+ o012 = ('o':) . show <$> [0 ..]+ f012 = ('f':) . show <$> [0 ..]+ v012 = ('v':) . show <$> [0 ..]++preProcessParser :: IO ()+preProcessParser = do+ let+ dir = "src/Database/PostgreSQL/Pure/Internal"+ file = "Parser.hs"+ srcPath = dir ++ "/" ++ file+ templatePath = "template/Parser.hs"+ templateItemPath = "template/ParserItem.hs"+ tempPath <-+ withFile templatePath ReadMode $ \template -> do+ tempDir <- (++ "/postgresql-pure") <$> getTemporaryDirectory+ createDirectoryIfMissing True tempDir+ (tempPath, temp) <- openTempFile tempDir file+ putStrLn $ "temporaly file: " ++ tempPath+ hSetNewlineMode template noNewlineTranslation+ hSetNewlineMode temp noNewlineTranslation+ hSetNewlineMode stdin noNewlineTranslation+ templateItem <- lines <$> readFile templateItemPath+ loop template temp templateItem+ hClose temp+ pure tempPath+ copyFile tempPath srcPath+ removeFile tempPath+ where+ loop :: Handle -> Handle -> [String] -> IO ()+ loop template temp templateItem =+ go+ where+ go = do+ eof <- hIsEOF template+ if eof+ then pure ()+ else do+ line <- hGetLine template+ for_ (preprocess line templateItem) (hPutStrLn temp)+ go++ preprocess :: String -> [String] -> [String]+ preprocess line templateItem+ | Just rest <- stripPrefix "---- embed " line+ , let n = read $ takeWhile isDigit rest+ = embed n templateItem+ | otherwise = [line]++ embed :: Word -> [String] -> [String]+ embed l templateItem+ | l >= 2 = concatMap go templateItem+ | otherwise = error "length must be larger than or equal to 2"+ where+ go "" = [""]+ go t+ | Just rest <- stripPrefix "<from-field>" t = [fromField ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<tuple>" t = [tuple ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<list>" t = [list ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<length>" t = [length ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<tuple-cons>" t = [tupleCons ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<decode>" t = [decode ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<$>" t = ["<$>" ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<>" t = ["<>" ++ Prelude.head (go rest)]+ | Just rest <- stripPrefix "<" t = error $ "unknown tag: " ++ takeWhile (/= '>') rest+ | (s, rest) <- span (/= '<') t = [s ++ Prelude.head (go rest)]+ n = fromIntegral l+ fromField = paren $ take n $ ("FromField " ++) <$> i012+ tuple = paren $ take n i012+ list = bracket $ take n i012+ length = show l+ tupleCons = "(" ++ replicate (n - 1) ',' ++ ")"+ decode = intercalate " <*> " $ take n $ ("column decode " ++) <$> i012+ paren xs = "(" ++ intercalate ", " xs ++ ")"+ bracket xs = "[" ++ intercalate ", " xs ++ "]"+ i012 = ('i':) . show <$> [0 ..]
benchmark/requests-per-second-constant.hs view
@@ -9,6 +9,10 @@ {-# OPTIONS_GHC -Wno-orphans #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- for postgresql-typed's pgSQL quasiquotes +#if __GLASGOW_HASKELL__ >= 808+#define MIN_VERSION_postgresql_typed(a, b, c) 0+#endif+ import qualified Database.PostgreSQL.Simple as S #if !MIN_VERSION_postgresql_simple(0,6,0) import qualified Database.PostgreSQL.Simple.FromField as S@@ -18,15 +22,19 @@ import qualified Database.PostgreSQL.Pure as P import qualified Database.PostgreSQL.Pure.Oid as P +#if __GLASGOW_HASKELL__ < 808 import qualified Database.PostgreSQL.Typed as T+#endif #ifndef mingw32_HOST_OS+#if !MIN_VERSION_base(4,13,0) 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+#endif import qualified RepeatThreadPool as Pool @@ -65,7 +73,7 @@ import Time.Types (Elapsed (Elapsed), ElapsedP (ElapsedP), NanoSeconds (NanoSeconds), Seconds (Seconds)) -#if !MIN_VERSION_postgresql_typed(0,6,0)+#if __GLASGOW_HASKELL__ < 808 && !MIN_VERSION_postgresql_typed(0,6,0) import Network (PortID (PortNumber)) #endif @@ -119,9 +127,7 @@ [ ("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 }@@ -169,6 +175,9 @@ deepseq r $ pure () measureTyped :: Config -> IO Result+#if __GLASGOW_HASKELL__ >= 808+measureTyped = error "postgresql-typed is not compatible with template-haskell >= 2.15.0.0"+#else measureTyped config@Config { host } = do let postgresqlConfig =@@ -193,10 +202,13 @@ [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 ()+#endif measureWire :: Config -> IO Result #ifdef mingw32_HOST_OS measureWire = error "postgres-wire can run on only UNIX-like environments"+#elif MIN_VERSION_base(4,13,0)+measureWire = error "postgres-wire is not compatible with base >= 4.13.0" #else measureWire config@Config { host } = do let
benchmark/requests-per-second.hs view
@@ -36,6 +36,7 @@ import qualified Database.PostgreSQL.Pure.Oid as Pure #ifndef mingw32_HOST_OS+#if !MIN_VERSION_base(4,13,0) import qualified Data.ByteString.Lazy as BL import Database.PostgreSQL.Driver@@ -45,6 +46,7 @@ import qualified Database.PostgreSQL.Protocol.Store.Decode as WD import Database.PostgreSQL.Protocol.Types #endif+#endif {- CREATE TABLE _bytes_100_of_1k(b bytea);@@ -136,6 +138,8 @@ benchPw :: Config -> RowsType -> IO () #ifdef mingw32_HOST_OS benchPw = error "postgres-wire can run on only UNIX-like environments"+#elif MIN_VERSION_base(4,13,0)+benchPw = error "postgres-wire is not compatible with base >= 4.13.0" #else benchPw Config { host, database, user, password } rowsType = benchRequests createConnection $ \c ->@@ -285,6 +289,8 @@ benchLoop :: Config -> IO () #ifdef mingw32_HOST_OS benchLoop = error "postgres-wire can run on only UNIX-like environments"+#elif MIN_VERSION_base(4,13,0)+benchLoop = error "postgres-wire is not compatible with base >= 4.13.0" #else benchLoop _config = do counter <- newIORef 0 :: IO (IORef Word)
postgresql-pure.cabal view
@@ -1,13 +1,13 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.31.1.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: 14ecd5f20820aca779a23760293ec281ed09841814409b6a8a5b26824c001e6d+-- hash: f757c949d0349b8b53ec562b1d70787caeecdb570097658b6d2373dcbbfb505e name: postgresql-pure-version: 0.1.2.0+version: 0.1.3.0 synopsis: pure Haskell PostgreSQL driver description: pure Haskell PostgreSQL driver category: Database@@ -18,15 +18,25 @@ copyright: 2019 IIJ Innovation Institute Inc. license: BSD-3-Clause license-file: LICENSE-build-type: Simple+build-type: Custom extra-source-files: README.md ChangeLog.md+ template/Builder.hs+ template/BuilderItem.hs+ template/Parser.hs+ template/ParserItem.hs source-repository head type: git location: https://github.com/iij-ii/postgresql-pure +custom-setup+ setup-depends:+ Cabal+ , base+ , directory+ flag pure-md5 manual: False default: False@@ -37,21 +47,24 @@ Database.PostgreSQL.Pure Database.PostgreSQL.Pure.List Database.PostgreSQL.Pure.Oid+ Database.PostgreSQL.Pure.Parser 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+ Database.PostgreSQL.Pure.Internal.Builder+ Database.PostgreSQL.Pure.Internal.Parser Paths_postgresql_pure autogen-modules:+ Database.PostgreSQL.Pure.Internal.Builder+ Database.PostgreSQL.Pure.Internal.Parser Paths_postgresql_pure hs-source-dirs: src@@ -147,17 +160,16 @@ 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.Pure.Parser Database.PostgreSQL.Simple.Time.Internal.Parser Database.PostgreSQL.Simple.Time.Internal.Printer Paths_postgresql_pure@@ -350,7 +362,7 @@ else build-depends: cryptohash-md5- if !os(windows)+ if !os(windows) && impl(ghc < 8.8.0) build-depends: postgres-wire default-language: Haskell2010@@ -389,7 +401,6 @@ , postgresql-libpq , postgresql-pure , postgresql-simple- , postgresql-typed , pretty-hex , random-shuffle , safe-exceptions@@ -406,7 +417,10 @@ else build-depends: cryptohash-md5- if !os(windows)+ if !os(windows) && impl(ghc < 8.8.0) build-depends: postgres-wire+ if impl(ghc < 8.8.0)+ build-depends:+ postgresql-typed default-language: Haskell2010
src/Database/HDBC/PostgreSQL/Pure.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}@@ -47,7 +48,6 @@ 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@@ -69,23 +69,30 @@ import Data.Word (Word32, Word64) import qualified PostgreSQL.Binary.Encoding as BE +#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+ -- | A configuration of a connection. -- -- Default configuration is 'def', which is following. --+-- >>> address def+-- AddressResolved 127.0.0.1:5432+-- >>> user def+-- "postgres"+-- >>> password def+-- ""+-- >>> database def+-- ""+-- >>> sendingBufferSize def+-- 4096+-- >>> receptionBufferSize def+-- 4096+-- -- @--- 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--- }+-- encodeString def = \code -> case code of \"UTF8\" -> 'pure' . 'BSU.fromString'; _ -> 'const' $ 'fail' $ "unexpected character code: " <> 'show' code+-- decodeString def = \code -> case code of \"UTF8\" -> 'pure' . 'BSU.toString'; _ -> 'const' $ 'fail' $ "unexpected character code: " <> 'show' code -- @ data Config = Config@@ -411,11 +418,7 @@ 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"+ 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
src/Database/PostgreSQL/Pure.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-}@@ -163,7 +164,6 @@ 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))@@ -174,6 +174,10 @@ import GHC.Records (HasField (getField)) import GHC.TypeLits (KnownNat, Nat, natVal) +#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+ -- | 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.@@ -192,7 +196,7 @@ 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.+-- | This represents a prepared statement which is not yet processed by a server. newtype PreparedStatementProcedure (parameterLength :: Nat) (resultLength :: Nat) = PreparedStatementProcedure Data.PreparedStatementProcedure deriving newtype (Show, Message)
− src/Database/PostgreSQL/Pure/Internal/Builder.hs
@@ -1,609 +0,0 @@-{-# 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
@@ -93,7 +93,9 @@ NS.SockAddrInet {} -> NS.AF_INET NS.SockAddrInet6 {} -> NS.AF_INET6 NS.SockAddrUnix {} -> NS.AF_UNIX+#if !MIN_VERSION_network(3,0,0) _ -> NS.AF_UNSPEC+#endif } resolve :: NS.HostName -> NS.ServiceName -> IO NS.AddrInfo
src/Database/PostgreSQL/Pure/Internal/Data.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-}@@ -73,7 +74,6 @@ 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@@ -95,20 +95,26 @@ import qualified Text.Read as R import qualified Text.Read.Lex as R +#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+ -- | 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')--- }--- @+-- >>> address def+-- AddressResolved 127.0.0.1:5432+-- >>> user def+-- "postgres"+-- >>> password def+-- ""+-- >>> database def+-- ""+-- >>> sendingBufferSize def+-- 4096+-- >>> receptionBufferSize def+-- 4096 data Config = Config { address :: Address -- ^ Server address.@@ -174,7 +180,7 @@ type TypeModifier = Int32 --- | Format code of patameters of results.+-- | Format code of parameters of results. data FormatCode = TextFormat | BinaryFormat deriving (Show, Read, Eq, Enum) data BindParameterFormatCodes@@ -318,7 +324,7 @@ -- 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.+-- | To convert a type which means that it is not processed 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.@@ -335,7 +341,7 @@ 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.+-- | This represents a prepared statement which is not yet processed by a server. data PreparedStatementProcedure = PreparedStatementProcedure { name :: PreparedStatementName
− src/Database/PostgreSQL/Pure/Internal/Parser.hs
@@ -1,839 +0,0 @@-{-# 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
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DerivingStrategies #-}@@ -57,7 +58,6 @@ import Control.Applicative ((<|>)) import Control.Exception.Safe (throw, try) import Control.Monad (void, when)-import Control.Monad.Fail (MonadFail) import Control.Monad.State.Strict (put) import qualified Data.Attoparsec.ByteString as AP import qualified Data.Attoparsec.Combinator as AP@@ -67,6 +67,10 @@ import Data.List (genericLength) import GHC.OverloadedLabels (IsLabel) +#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail)+#endif+ -- | 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.@@ -196,7 +200,7 @@ instance Close Portal where close p = CloseProcedure (Builder.closePortal $ #name p) Parser.closeComplete --- | This means than @r@ is a objective of 'flush' and 'sync'.+-- | This means that @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
src/Database/PostgreSQL/Pure/Internal/SocketIO.hs view
@@ -13,8 +13,6 @@ 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)@@ -28,7 +26,15 @@ import Foreign (ForeignPtr, Ptr, withForeignPtr) import qualified Network.Socket as NS import qualified Network.Socket.ByteString as NSB++#if MIN_VERSION_base(4,13,0)+import Control.Exception.Safe (throw, try)+import Control.Monad (unless)+#else+import Control.Exception.Safe (throw, try, tryJust)+import Control.Monad (guard, unless) import System.IO.Error (isEOFError)+#endif type SocketIO = StateT Carry (ReaderT (NS.Socket, Buffer, Buffer, Config) IO)
+ src/Database/PostgreSQL/Pure/Parser.hs view
@@ -0,0 +1,5 @@+module Database.PostgreSQL.Pure.Parser+ ( column+ ) where++import Database.PostgreSQL.Pure.Internal.Parser (column)
src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}+{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables #-} -- | -- Module: Database.PostgreSQL.Simple.Time.Internal.Parser@@ -24,7 +24,6 @@ , 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)@@ -35,6 +34,10 @@ import Data.Time.Clock (UTCTime(UTCTime), DiffTime, picosecondsToDiffTime) import qualified Data.ByteString.Char8 as B8 import qualified Data.Time.LocalTime as Local++#if !MIN_VERSION_base(4,13,0)+import Control.Applicative ((<$>), (<*>), (<*), (*>))+#endif -- | Parse a date of the form @YYYY-MM-DD@. day :: Parser Day
+ template/Builder.hs view
@@ -0,0 +1,549 @@+{-# 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 [f] (Single v) = + sequence [toField backendParams encode Nothing f v] + toRecord _ _ Nothing [_] _ = + cantReachHere + toRecord backendParams encode (Just [o]) [f] (Single v) = + sequence [toField backendParams encode (Just o) f 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) + +---- embed 2 + +---- embed 3 + +---- embed 4 + +---- embed 5 + +---- embed 6 + +---- embed 7 + +---- embed 8 + +---- embed 9 + +---- embed 10 + +---- embed 11 + +---- embed 12 + +---- embed 13 + +---- embed 14 + +---- embed 15 + +---- embed 16 + +---- embed 17 + +---- embed 18 + +---- embed 19 + +---- embed 20 + +---- embed 21 + +---- embed 22 + +---- embed 23 + +---- embed 24 + +---- embed 25 + +---- embed 26 + +---- embed 27 + +---- embed 28 + +---- embed 29 + +---- embed 30 + +---- embed 31 + +---- embed 32 + +---- embed 33 + +---- embed 34 + +---- embed 35 + +---- embed 36 + +---- embed 37 + +---- embed 38 + +---- embed 39 + +---- embed 40 + +---- embed 41 + +---- embed 42 + +---- embed 43 + +---- embed 44 + +---- embed 45 + +---- embed 46 + +---- embed 47 + +---- embed 48 + +---- embed 49 + +---- embed 50 + +---- embed 51 + +---- embed 52 + +---- embed 53 + +---- embed 54 + +---- embed 55 + +---- embed 56 + +---- embed 57 + +---- embed 58 + +---- embed 59 + +---- embed 60 + +---- embed 61 + +---- embed 62 + +-- 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
+ template/BuilderItem.hs view
@@ -0,0 +1,10 @@+-- <length>-tuple +instance <to-field> => ToRecord <type-tuple> where + toRecord backendParams encode Nothing <format-list> <value-tuple> = + sequence <to-field-nothing-list> + toRecord backendParams encode (Just <oid-list>) <format-list> <value-tuple> = + sequence <to-field-just-list> + toRecord _ _ (Just os) _ _ = + fail $ "the number of OIDs must be <length>, actually " <> show (length os) + toRecord _ _ _ fs _ = + fail $ "the number of format codes must be <length>, actually " <> show (length fs)
+ template/Parser.hs view
@@ -0,0 +1,748 @@+{-# 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+ , column+ ) 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.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)++#if MIN_VERSION_base(4,13,0)+import Control.Applicative ((<|>))+#else+import Control.Applicative ((*>), (<|>))+#endif++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 String where+ fromField decode ColumnInfo { typeOid } (Just v)+ | typeOid `elem` [Oid.text, Oid.bpchar, Oid.varchar, Oid.name]+ = MonadFail.fromEither $ decode v+ fromField _ ColumnInfo { typeOid } _ = fail $ "type mismatch (FromField): OID: " <> show typeOid <> ", Haskell: String"++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)++---- embed 2++---- embed 3++---- embed 4++---- embed 5++---- embed 6++---- embed 7++---- embed 8++---- embed 9++---- embed 10++---- embed 11++---- embed 12++---- embed 13++---- embed 14++---- embed 15++---- embed 16++---- embed 17++---- embed 18++---- embed 19++---- embed 20++---- embed 21++---- embed 22++---- embed 23++---- embed 24++---- embed 25++---- embed 26++---- embed 27++---- embed 28++---- embed 29++---- embed 30++---- embed 31++---- embed 32++---- embed 33++---- embed 34++---- embed 35++---- embed 36++---- embed 37++---- embed 38++---- embed 39++---- embed 40++---- embed 41++---- embed 42++---- embed 43++---- embed 44++---- embed 45++---- embed 46++---- embed 47++---- embed 48++---- embed 49++---- embed 50++---- embed 51++---- embed 52++---- embed 53++---- embed 54++---- embed 55++---- embed 56++---- embed 57++---- embed 58++---- embed 59++---- embed 60++---- embed 61++---- embed 62++-- list+instance FromField a => FromRecord [a] where+ fromRecord decode is = sequence $ column decode <$> is++-- | For implementing 'fromRecord'.+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
+ template/ParserItem.hs view
@@ -0,0 +1,5 @@+-- <length>-tuple+instance <from-field> => FromRecord <tuple> where+ fromRecord decode <list> =+ <tuple-cons> <$> <decode>+ fromRecord _ is = fail $ "length mismatch: expected <length>: actual: " <> show (length is)
test-doctest/doctest.hs view
@@ -2,8 +2,4 @@ main :: IO () main =- doctest- [ "-isrc"- , "src/Database/PostgreSQL/Pure.hs"- , "src/Database/PostgreSQL/Pure/List.hs"- ]+ doctest ["-isrc", "src"]