hpgsql 0.2.0.1 → 0.3.0
raw patch · 18 files changed
+1171/−287 lines, 18 filesdep +ghc-lib-parserdep −cerealdep −haskell-src-metadep −transformersdep ~basedep ~template-haskelldep ~timePVP ok
version bump matches the API change (PVP)
Dependencies added: ghc-lib-parser
Dependencies removed: cereal, haskell-src-meta, transformers
Dependency ranges changed: base, template-haskell, time
API changes (from Hackage documentation)
- Hpgsql.InternalTypes: [rowColumnData] :: DataRow -> ByteString
+ Hpgsql.Connection: ConnectOpts :: !Int -> !Int -> !Bool -> !Int -> ConnectOpts
+ Hpgsql.Connection: [cancellationRequestResendIntervalMs] :: ConnectOpts -> !Int
+ Hpgsql.Connection: [fillTypeInfoCache] :: ConnectOpts -> !Bool
+ Hpgsql.Connection: [killedThreadPollIntervalMs] :: ConnectOpts -> !Int
+ Hpgsql.Connection: [recvChunkSize] :: ConnectOpts -> !Int
+ Hpgsql.Connection: data ConnectOpts
+ Hpgsql.InternalTypes: [fullDataRow] :: DataRow -> ByteString
+ Hpgsql.InternalTypes: [recvChunkSize] :: ConnectOpts -> !Int
- Hpgsql.Builder: LengthAwareBuilder :: !Int32 -> !Builder -> LengthAwareBuilder
+ Hpgsql.Builder: LengthAwareBuilder :: !Int32 -> Builder -> LengthAwareBuilder
- Hpgsql.InternalTypes: ConnectOpts :: Int -> Int -> Bool -> ConnectOpts
+ Hpgsql.InternalTypes: ConnectOpts :: !Int -> !Int -> !Bool -> !Int -> ConnectOpts
- Hpgsql.InternalTypes: [cancellationRequestResendIntervalMs] :: ConnectOpts -> Int
+ Hpgsql.InternalTypes: [cancellationRequestResendIntervalMs] :: ConnectOpts -> !Int
- Hpgsql.InternalTypes: [fillTypeInfoCache] :: ConnectOpts -> Bool
+ Hpgsql.InternalTypes: [fillTypeInfoCache] :: ConnectOpts -> !Bool
- Hpgsql.InternalTypes: [killedThreadPollIntervalMs] :: ConnectOpts -> Int
+ Hpgsql.InternalTypes: [killedThreadPollIntervalMs] :: ConnectOpts -> !Int
- Hpgsql.ParsingInternal: AcceptQuasiQuoterExpressions :: ParsingOpts
+ Hpgsql.ParsingInternal: AcceptQuasiQuoterExpressions :: [Extension] -> ParsingOpts
Files
- CHANGELOG.md +28/−0
- hpgsql.cabal +11/−7
- src/Hpgsql/Builder.hs +5/−5
- src/Hpgsql/Connection.hs +13/−14
- src/Hpgsql/Encoding.hs +85/−92
- src/Hpgsql/Encoding/BinarySerializer.hs +175/−0
- src/Hpgsql/Encoding/RowDecoderMonadic.hs +16/−10
- src/Hpgsql/Internal.hs +61/−60
- src/Hpgsql/InternalTypes.hs +11/−4
- src/Hpgsql/LanguageHaskell/FromThExtension.hs +173/−0
- src/Hpgsql/LanguageHaskell/GhcParserOpts.hs +21/−0
- src/Hpgsql/LanguageHaskell/ParseHaskellExpression.hs +399/−0
- src/Hpgsql/Msgs.hs +23/−29
- src/Hpgsql/Networking.hs +3/−3
- src/Hpgsql/ParsingInternal.hs +15/−11
- src/Hpgsql/QueryInternal.hs +19/−10
- src/Hpgsql/SimpleParser.hs +110/−40
- src/Hpgsql/Types.hs +3/−2
+ CHANGELOG.md view
@@ -0,0 +1,28 @@+## v0.3.0+- Support GHC 9.12+- Support OverloadedRecordDot inside the `sql` quasiquoter+- Fix the lack of type-checking query fields when using RowDecoderMonadic+- Also when using RowDecoderMonadic, a previously cryptic error message has been improved+- Performance materializing query results improved by ~23% in some benchmarks+- Binary COPY made ~4.3% faster+- Users can supply non-default connection options, including the minimum socket recv size+- Dropped dependencies cereal and transformers+- Replaced dependency haskell-src-meta with ghc-lib-parser++To support OverloadedRecordDot in the `sql` quasiquoter, we have a brand new implementation of a Haskell expression parser instead of using haskell-src-meta's. Parts of the Haskell language might no longer be supported as parameters in the quasiquoter, but the more commonly used ones should be there, and error messages should be helpful to guide you in case you run into an unsupported case.++Thank you Brandon Chinn and Nick Ivanych for your contributions.++## v0.2.0.1++- Major fix: connecting via TCP on MacOS could fail completely. Thanks @luntain for the contribution.+- Performance materializing query results improved by ~17%+- Future-proofing for a future protocol change: accepting longer backend secret keys.++## v0.2.0.0++- Fixed a bug where an asynchronous exception thrown at the right time could hide an `IrrecoverableHpgsqlError` when using `withTransaction`. Thank you Yuras for the report.+- SCRAM-SHA-256 authentication implemented.+- Added `connectionIsClosed` function.+- `resetConnectionState` made much more thorough, to the image of the `DISCARD ALL` statement.+- `pipelineMay` and `pipelineMayWith` publicly exported.
hpgsql.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 name: hpgsql-version: 0.2.0.1+version: 0.3.0 synopsis: Pure Haskell PostgreSQL driver (no libpq) description: hpgsql is a pure Haskell implementation of a PostgreSQL driver category: Database@@ -12,11 +12,13 @@ copyright: 2026 Marcelo Zabani license: BSD3 license-file: LICENSE+extra-doc-files: CHANGELOG.md build-type: Simple tested-with: GHC ==9.6.7 || ==9.8.4 || ==9.10.3+ || ==9.12.2 source-repository head type: git@@ -42,7 +44,11 @@ Hpgsql.Types other-modules: Hpgsql.Base+ Hpgsql.Encoding.BinarySerializer Hpgsql.Internal+ Hpgsql.LanguageHaskell.FromThExtension+ Hpgsql.LanguageHaskell.GhcParserOpts+ Hpgsql.LanguageHaskell.ParseHaskellExpression Hpgsql.Locking Hpgsql.Msgs Hpgsql.Networking@@ -95,25 +101,23 @@ Only >= 0.1 && < 0.2, aeson >= 2.2 && < 2.3, attoparsec >= 0.14 && < 0.15,- base >= 4.18 && < 4.21,+ base >= 4.18 && < 4.22, bytestring >= 0.11 && < 0.13, case-insensitive >= 1.2 && < 1.3,- cereal >= 0.5 && < 0.6, containers >= 0.6 && < 0.8, crypton >= 1.0.0 && < 1.1, memory >= 0.18.0 && < 0.19, hashable >= 1.5 && < 1.6,- haskell-src-meta >= 0.8 && < 0.9,+ ghc-lib-parser >= 9.6 && < 9.14, network >= 3.2 && < 3.3, network-uri >= 2.6 && < 2.7, safe-exceptions >= 0.1 && < 0.2, scientific >= 0.3 && < 0.4, stm >= 2.5 && < 2.6, streaming >= 0.2 && < 0.3,- template-haskell >= 2.20 && < 2.23,+ template-haskell >= 2.20 && < 2.24, text >= 2.0 && < 2.2,- time >= 1.12 && < 1.13,- transformers >= 0.6 && < 0.7,+ time >= 1.12 && < 1.15, uuid-types >= 1.0 && < 1.1, vector >= 0.13 && < 0.14 default-language: Haskell2010
src/Hpgsql/Builder.hs view
@@ -1,12 +1,10 @@-module Hpgsql.Builder where---- \| This module replicates parts of the API of Data.ByteString.Builder but its own+-- | This module replicates parts of the API of Data.ByteString.Builder but its own -- builder is length-aware, which makes other parts of the code a little bit nicer. -- In COPY benchmarks, this module was introduced in a commit (together with other -- changes, like replacing `Maybe` with `BinaryField` in `ToPgField`) that barely -- changed memory usage and runtime. -- The benefits are exclusively for code readability, then.--- \|+module Hpgsql.Builder where import Data.ByteString (ByteString) import qualified Data.ByteString as BS@@ -23,7 +21,9 @@ show SqlNull = "NULL" show (NotNull bs) = show bs -data LengthAwareBuilder = LengthAwareBuilder !Int32 !Builder.Builder+-- | The lazy (instead of strict/with a bang) Builder (second arg) makes+-- our copyFromS benchmark run ~4.3% faster and allocate ~3.8% less total memory.+data LengthAwareBuilder = LengthAwareBuilder !Int32 Builder.Builder type Builder = LengthAwareBuilder
src/Hpgsql/Connection.hs view
@@ -8,6 +8,7 @@ closeForcefully, connectionIsClosed, ConnectionString (..),+ ConnectOpts (..), parseLibpqConnectionString, ResetConnectionOpts (..), resetConnectionState,@@ -27,7 +28,6 @@ void, when, )-import Control.Monad.Trans.Except (runExceptT, throwE) import Data.Attoparsec.Text ( Parser, char,@@ -41,7 +41,6 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.Char as Char-import Data.Functor.Identity (Identity (..)) import Data.List ( sortOn, )@@ -50,7 +49,7 @@ import qualified Data.Text as Text import Data.Text.Encoding (encodeUtf8) import Hpgsql.Internal (closeForcefully, closeGracefully, connect, connectOpts, connectionIsClosed, defaultConnectOpts, getBackendPid, getParameterStatus, refreshTypeInfoCache, resetConnectionState, resetTypeInfoCache, withConnection, withConnectionOpts)-import Hpgsql.InternalTypes (ConnectionString (..), ResetConnectionOpts (..))+import Hpgsql.InternalTypes (ConnectOpts (..), ConnectionString (..), ResetConnectionOpts (..)) import Network.URI ( URI (..), URIAuth (..),@@ -115,17 +114,17 @@ -- | Parses a URI with scheme 'postgres' or 'postgresql', as per https://www.postgresql.org/docs/current/libpq-connect.html#LIBPQ-CONNSTRING. -- The difference here is that URIs with a query string or with a fragment are not allowed. uriConnParser :: Text -> Either String ConnectionString-uriConnParser line = runIdentity $ runExceptT @String @_ @ConnectionString $ do+uriConnParser line = case parseURI (Text.unpack line) of- Nothing -> throwE "Connection string is not a URI"+ Nothing -> Left "Connection string is not a URI" Just URI {..} -> do unless (Text.toLower (Text.pack uriScheme) `elem` ["postgres:", "postgresql:"])- $ throwE+ $ Left "Connection string's URI scheme must be 'postgres' or 'postgresql'" case uriAuthority of Nothing ->- throwE+ Left "Connection string must contain at least user and host" Just URIAuth {..} -> do let database =@@ -133,10 +132,10 @@ hasQueryString = not $ null uriQuery hasFragment = not $ null uriFragment when (Text.null database) $- throwE+ Left "Connection string must contain a database name" when (hasQueryString || hasFragment) $- throwE+ Left "Custom parameters are not supported in connection strings. Make sure your connection URI does not have a query string or query fragment" -- Ports are not mandatory and are defaulted to 5432 when not present@@ -148,7 +147,7 @@ (Text.pack $ trimFirst ':' uriPort) ) of Nothing ->- throwE "Invalid port in connection string"+ Left "Invalid port in connection string" Just parsedPort -> do let (Text.pack . unEscapeString . trimLast '@' -> user, Text.pack . unEscapeString . trimLast '@' . trimFirst ':' -> password) = break (== ':') uriUserInfo@@ -178,7 +177,7 @@ Just (t, lastChar) -> if lastChar == c then Text.unpack t else s keywordValueConnParser :: Text -> Either String ConnectionString-keywordValueConnParser line = runIdentity $ runExceptT $ do+keywordValueConnParser line = do kvs <- sortOn fst <$> parseOrFail@@ -196,7 +195,7 @@ getVal key def parser pairs = case (map snd $ filter ((== key) . fst) pairs, def) of ([], Nothing) ->- throwE $+ Left $ "Connection string must contain a value for '" <> Text.unpack key <> "'"@@ -207,7 +206,7 @@ <> Text.unpack key <> "' is in an unrecognizable format" _ ->- throwE $+ Left $ "Duplicate key '" <> Text.unpack key <> "' found in connection string."@@ -215,7 +214,7 @@ txtToString = Parsec.takeText parseOrFail parser txt errorMsg = case parseOnly (parser <* endOfInput) txt of- Left _ -> throwE errorMsg+ Left _ -> Left errorMsg Right v -> pure v singleKeyVal = do
src/Hpgsql/Encoding.hs view
@@ -16,7 +16,7 @@ -- > persons :: [Person] <- query conn "SELECT * FROM persons" -- -- Note that Hpgsql's `RowDecoder` does not have a `Monad` instance because that allows it to--- type check query results and field counts even when queries return zero rows. If you need+-- type check query results and field counts only once per query. If you need -- to write a row decoder that is monadic (because decoding can change depending on the values -- of fields), check "Hpgsql.Encoding.RowDecoderMonadic". module Hpgsql.Encoding@@ -76,6 +76,7 @@ import qualified Data.ByteString.Lazy as LBS import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI+import Data.Coerce (coerce) import Data.Fixed (divMod') import Data.Functor.Contravariant (Contravariant (..)) import Data.Int (Int16, Int32, Int64)@@ -87,7 +88,6 @@ import Data.Proxy (Proxy (..)) import Data.Ratio (Ratio) import Data.Scientific (Scientific (..), floatingOrInteger, scientific)-import qualified Data.Serialize as Cereal import Data.Text (Text) import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8)@@ -100,13 +100,13 @@ import qualified Data.UUID.Types as UUID import Data.Vector (Vector) import qualified Data.Vector as Vector-import Data.Word (Word32, Word64)-import GHC.Float (castDoubleToWord64, castFloatToWord32, castWord32ToFloat, castWord64ToDouble, expt, float2Double)+import GHC.Float (castWord32ToFloat, castWord64ToDouble, expt, float2Double) import GHC.Generics (C, D, Generic (..), K1 (..), M1 (..), Meta (MetaCons), U1 (..), (:*:) (..), (:+:) (..)) import GHC.TypeLits (KnownSymbol, TypeError, symbolVal) import qualified GHC.TypeLits as TypeLits import Hpgsql.Builder (BinaryField (..)) import qualified Hpgsql.Builder as Builder+import qualified Hpgsql.Encoding.BinarySerializer as BinSer import qualified Hpgsql.SimpleParser as Parser import Hpgsql.Time (Unbounded (..)) import Hpgsql.TypeInfo (EncodingContext (..), Oid (..), TypeDetails (..), TypeInfo (..), boolOid, byteaOid, charOid, dateOid, float4Oid, float8Oid, int2Oid, int4Oid, int8Oid, intervalOid, jsonOid, jsonbOid, lookupTypeByName, lookupTypeByOid, nameOid, numericOid, oidOid, textOid, timeOid, timestampOid, timestamptzOid, uuidOid, varcharOid, voidOid)@@ -151,6 +151,7 @@ instance Applicative RowDecoder where pure v = RowDecoder (const $ pure v) (map (,True)) 0+ {-# INLINE (<*>) #-} -- This is crucial for performance. It makes our CPS Parser truly compile to CPS row decoders. RowDecoder p1 tc1 nc1 <*> RowDecoder p2 tc2 nc2 = RowDecoder (\colTypes -> let (cols1, cols2) = List.splitAt nc1 colTypes in p1 cols1 <*> p2 cols2) (\colTypes -> let (cols1, cols2) = List.splitAt nc1 colTypes in tc1 cols1 ++ tc2 cols2) (nc1 + nc2) instance (TypeError (TypeLits.Text "RowDecoder does not have a Monad instance in Hpgsql because Hpgsql type-checks the result types of queries before having access to even the first data row. Use the Applicative class to write your instances or use the Monadic decoding variants.")) => Monad RowDecoder where@@ -163,7 +164,7 @@ [singleColInfo] -> let decode = fieldValueDecoder singleColInfo in do- lenNextCol <- fromIntegral <$> int32Parser+ lenNextCol <- fromIntegral <$> Parser.takeInt32BE nextColBs <- if lenNextCol >= 0 then@@ -179,9 +180,6 @@ numExpectedColumns = 1 } -int32Parser :: Parser.Parser Int32-int32Parser = either fail pure . Cereal.decode @Int32 =<< Parser.take 4- class FromPgField a where fieldDecoder :: FieldDecoder a @@ -216,12 +214,12 @@ parserForRecord encodingContext = do -- From https://github.com/postgres/postgres/blob/50ba65e73325cf55fedb3e1f14673d816726923b/src/backend/utils/adt/rowtypes.c#L687 -- we can see a composite type's binary representation consists of: number of columns (Int32) + for_each_column { OID (Int32) + size_or_minus_1 (Int32) + Bytes }- numCols <- fromIntegral <$> int32Parser+ numCols <- fromIntegral <$> Parser.takeInt32BE unless (numCols == numExpectedColumns) $ fail $ "Composite type has " ++ show numCols ++ " attributes but parser expected " ++ show numExpectedColumns let mkColInfo oid = FieldInfo oid Nothing encodingContext cols <- replicateM numCols $ do- !oid <- Oid . fromIntegral <$> int32Parser- (sizeBs, !size) <- Parser.match $ fromIntegral <$> int32Parser+ !oid <- Oid . fromIntegral <$> Parser.takeInt32BE+ (sizeBs, !size) <- Parser.match $ fromIntegral <$> Parser.takeInt32BE !bs <- Parser.take (max 0 size) pure (oid, sizeBs <> bs) let typecheckedCols = rowColumnsTypeCheck (map (mkColInfo . fst) cols)@@ -337,21 +335,21 @@ fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just int2Oid,- toPgField = \_ -> \n -> NotNull $ Cereal.encode n+ toPgField = \_ -> \n -> NotNull $ BinSer.encodeInt16BE n } instance ToPgField Int32 where fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just int4Oid,- toPgField = \_ -> \n -> NotNull $ Cereal.encode n+ toPgField = \_ -> \n -> NotNull $ BinSer.encodeInt32BE n } instance ToPgField Int64 where fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just int8Oid,- toPgField = \_ -> \n -> NotNull $ Cereal.encode n+ toPgField = \_ -> \n -> NotNull $ BinSer.encodeInt64BE n } instance ToPgField Integer where@@ -374,7 +372,7 @@ fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just oidOid,- toPgField = \_ -> \n -> NotNull $ Cereal.encode @Int32 $ fromIntegral n+ toPgField = \_ -> \n -> NotNull $ BinSer.encodeInt32BE $ fromIntegral n } instance ToPgField Scientific where@@ -382,7 +380,7 @@ FieldEncoder { toTypeOid = \_ -> Just numericOid, toPgField = \_ -> \n ->- let sign = Cereal.encode @Int16 $ if n >= 0 then 0 else 0x4000+ let sign = BinSer.encodeInt16BE $ if n >= 0 then 0 else 0x4000 -- The number is coeff * 10^exp, but we want it in base-10000 so we convert it to -- new_coeff * 10^new_exp with new_exp a multiple of 4 base10000Expon = 4 * (base10Exponent n `div` 4)@@ -390,40 +388,39 @@ ndigits, weight :: Int16 digits :: ByteString (ndigits, weight, digits) = calculateDigits 0 0 (abs base10000Coeff) ""- dscale = Cereal.encode @Int16 (abs $ fromIntegral base10000Expon) -- More than necessary, but safe?- in NotNull $ Cereal.encode ndigits <> Cereal.encode (weight - 1 + fromIntegral (base10000Expon `div` 4)) <> sign <> dscale <> digits+ dscale = BinSer.encodeInt16BE (abs $ fromIntegral base10000Expon) -- More than necessary, but safe?+ in NotNull $ BinSer.encodeInt16BE ndigits <> BinSer.encodeInt16BE (weight - 1 + fromIntegral (base10000Expon `div` 4)) <> sign <> dscale <> digits } where calculateDigits :: Int16 -> Int16 -> Integer -> BS.ByteString -> (Int16, Int16, BS.ByteString) calculateDigits !ndigitsSoFar !weightSoFar 0 !encodedDigits = (ndigitsSoFar, weightSoFar, encodedDigits) calculateDigits !ndigitsSoFar !weightSoFar !val !encodedDigits =- let (quotient, fromIntegral -> rest :: Int16) = val `divMod` 10000+ let (quotient, fromIntegral -> (rest :: Int16)) = val `divMod` 10000 in calculateDigits (ndigitsSoFar + 1) (weightSoFar + 1) quotient- (Cereal.encode @Int16 rest <> encodedDigits)+ (BinSer.encodeInt16BE rest <> encodedDigits) instance ToPgField Float where fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just float4Oid,- toPgField = \_ -> \n -> NotNull $ Cereal.encode @Word32 $ castFloatToWord32 n+ toPgField = \_ -> \n -> NotNull $ BinSer.encodeFloat n } instance ToPgField Double where fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just float8Oid,- toPgField = \_ -> \n -> NotNull $ Cereal.encode @Word64 $ castDoubleToWord64 n+ toPgField = \_ -> \n -> NotNull $ BinSer.encodeDouble n } instance ToPgField Bool where- -- TODO: Cereal.encode seems to work, but reference the documentation that shows how bools are encoded fieldEncoder = FieldEncoder { toTypeOid = \_ -> Just boolOid,- toPgField = \_ n -> NotNull $ Cereal.encode @Bool $ n+ toPgField = \_ n -> NotNull $ BinSer.encodePgBoolean n } instance ToPgField Day where@@ -433,7 +430,7 @@ FieldEncoder { toTypeOid = \_ -> Just dateOid, -- TODO: Catch integer overflow and do what?- toPgField = \_ d -> NotNull $ Cereal.encode @Int32 $ fromIntegral $ diffDays d (fromGregorian 2000 1 1)+ toPgField = \_ d -> NotNull $ BinSer.encodeInt32BE $ fromIntegral $ diffDays d (fromGregorian 2000 1 1) } instance ToPgField (Unbounded Day) where@@ -442,9 +439,9 @@ in FieldEncoder { toTypeOid = fe.toTypeOid, toPgField = \encCtx -> \case- NegInfinity -> NotNull $ Cereal.encode @Int32 minBound+ NegInfinity -> NotNull $ BinSer.encodeInt32BE minBound Finite v -> fe.toPgField encCtx v- PosInfinity -> NotNull $ Cereal.encode @Int32 maxBound+ PosInfinity -> NotNull $ BinSer.encodeInt32BE maxBound } instance ToPgField CalendarDiffTime where@@ -453,7 +450,7 @@ { toTypeOid = \_ -> Just intervalOid, toPgField = \_ CalendarDiffTime {..} -> let (days :: Int32, timeUnderOneDay) = ctTime `divMod'` 86_400- in NotNull $ Cereal.encode @(Int64, Int32, Int32) (round $ timeUnderOneDay * 1_000_000, days, fromIntegral ctMonths)+ in NotNull $ BinSer.encodeInt64BE (round $ timeUnderOneDay * 1_000_000) <> BinSer.encodeInt32BE days <> BinSer.encodeInt32BE (fromIntegral ctMonths) } instance ToPgField NominalDiffTime where@@ -461,7 +458,7 @@ FieldEncoder { toTypeOid = \_ -> Just intervalOid, toPgField = \_ ndt ->- NotNull $ Cereal.encode @(Int64, Int32, Int32) (round $ ndt * 1_000_000, 0, 0)+ NotNull $ BinSer.encodeInt64BE (round $ ndt * 1_000_000) <> BinSer.encodeInt32BE 0 <> BinSer.encodeInt32BE 0 } instance ToPgField UTCTime where@@ -472,7 +469,7 @@ toPgField = \_ (UTCTime parsedDate timeinday) -> let day :: Int64 = fromInteger $ parsedDate `diffDays` fromJulian 1999 12 19 totalusecs :: Int64 = 86_400_000_000 * day + fromInteger (diffTimeToPicoseconds timeinday `div` 1_000_000)- in NotNull $ Cereal.encode @Int64 totalusecs+ in NotNull $ BinSer.encodeInt64BE totalusecs } instance ToPgField (Unbounded UTCTime) where@@ -481,9 +478,9 @@ in FieldEncoder { toTypeOid = fe.toTypeOid, toPgField = \encCtx -> \case- NegInfinity -> NotNull $ Cereal.encode @Int64 minBound+ NegInfinity -> NotNull $ BinSer.encodeInt64BE minBound Finite v -> fe.toPgField encCtx v- PosInfinity -> NotNull $ Cereal.encode @Int64 maxBound+ PosInfinity -> NotNull $ BinSer.encodeInt64BE maxBound } instance ToPgField ZonedTime where@@ -500,9 +497,9 @@ in FieldEncoder { toTypeOid = fe.toTypeOid, toPgField = \encCtx -> \case- NegInfinity -> NotNull $ Cereal.encode @Int64 minBound+ NegInfinity -> NotNull $ BinSer.encodeInt64BE minBound Finite v -> fe.toPgField encCtx v- PosInfinity -> NotNull $ Cereal.encode @Int64 maxBound+ PosInfinity -> NotNull $ BinSer.encodeInt64BE maxBound } instance ToPgField LocalTime where@@ -512,7 +509,7 @@ toPgField = \_ (LocalTime localDay localTimeOfDay) -> let day :: Int64 = fromInteger $ localDay `diffDays` fromJulian 1999 12 19 totalusecs :: Int64 = 86_400_000_000 * day + fromInteger (diffTimeToPicoseconds (timeOfDayToTime localTimeOfDay) `div` 1_000_000)- in NotNull $ Cereal.encode @Int64 totalusecs+ in NotNull $ BinSer.encodeInt64BE totalusecs } instance ToPgField TimeOfDay where@@ -521,7 +518,7 @@ { toTypeOid = \_ -> Just timeOid, toPgField = \_ tod -> let usecs :: Int64 = fromInteger $ diffTimeToPicoseconds (timeOfDayToTime tod) `div` 1_000_000- in NotNull $ Cereal.encode @Int64 usecs+ in NotNull $ BinSer.encodeInt64BE usecs } instance ToPgField Char where@@ -684,15 +681,6 @@ instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d) => ToPgRow (a, b, c, d) where rowEncoder = divide (\(a, b, c, d) -> ((a, b), (c, d))) rowEncoder rowEncoder --- This instance implements toBinaryCopyBytes as well because we did this--- to test if this method can help improve performance of COPY in our--- benchmarks. We found that it can, but we didn't bother yet implementing--- this for other types.--- toBinaryCopyBytes encCtx = \(a, b, c, d) -> Builder.int16BE 4 <> toPgFieldWithSize a <> toPgFieldWithSize b <> toPgFieldWithSize c <> toPgFieldWithSize d--- where--- toPgFieldWithSize :: (ToPgField x) => x -> Builder.Builder--- toPgFieldWithSize v = Builder.binaryField $ toPgField encCtx v- instance (ToPgField a, ToPgField b, ToPgField c, ToPgField d, ToPgField e) => ToPgRow (a, b, c, d, e) where rowEncoder = divide (\(a, b, c, d, e) -> ((a, b, c), (d, e))) rowEncoder rowEncoder @@ -733,9 +721,9 @@ -- | Big-Endian binary encoder for Haskell's `Data.Int`, which is machine-dependent. binaryIntEncoder :: Int -> BinaryField binaryIntEncoder- | haskellIntOid == int8Oid = NotNull . Cereal.encode @Int64 . fromIntegral- | haskellIntOid == int4Oid = NotNull . Cereal.encode @Int32 . fromIntegral- | otherwise = NotNull . Cereal.encode @Int16 . fromIntegral+ | haskellIntOid == int8Oid = NotNull . BinSer.encodeInt64BE . fromIntegral+ | haskellIntOid == int4Oid = NotNull . BinSer.encodeInt32BE . fromIntegral+ | otherwise = NotNull . BinSer.encodeInt16BE . fromIntegral -- | Big-Endian binary decoder for Haskell's various IntXX types. binaryIntDecoder :: forall a. (Integral a, Bounded a) => Oid -> ByteString -> Either String a@@ -747,17 +735,17 @@ maxBoundPgType :: Integer intDecoder :: ByteString -> Either String a (maxBoundPgType, intDecoder)- | typOid == int8Oid = (fromIntegral $ maxBound @Int64, fmap fromIntegral . Cereal.decode @Int64)- | typOid == int4Oid = (fromIntegral $ maxBound @Int32, fmap fromIntegral . Cereal.decode @Int32)- | typOid == int2Oid = (fromIntegral $ maxBound @Int16, fmap fromIntegral . Cereal.decode @Int16)+ | typOid == int8Oid = (fromIntegral $ maxBound @Int64, fmap fromIntegral . BinSer.decodeInt64BE 0)+ | typOid == int4Oid = (fromIntegral $ maxBound @Int32, fmap fromIntegral . BinSer.decodeInt32BE 0)+ | typOid == int2Oid = (fromIntegral $ maxBound @Int16, fmap fromIntegral . BinSer.decodeInt16BE 0) | otherwise = error "Bug in Hpgsql. Decoding binary integral type not an int2, int4 or int8" doesFit = maxBoundPgType <= fromIntegral (maxBound @a) binaryFloat4Decoder :: ByteString -> Float-binaryFloat4Decoder = castWord32ToFloat . either error id . Cereal.decode @Word32+binaryFloat4Decoder = castWord32ToFloat . either error id . BinSer.decodeWord32BE binaryFloat8Decoder :: ByteString -> Double-binaryFloat8Decoder = castWord64ToDouble . either error id . Cereal.decode @Word64+binaryFloat8Decoder = castWord64ToDouble . either error id . BinSer.decodeWord64BE parsePgType :: [Oid] -> (Maybe ByteString -> Either String a) -> FieldDecoder a parsePgType !requiredTypeOids !fieldValueDecoder =@@ -890,11 +878,11 @@ scientificDecoder :: Bool -> Parser.Parser Scientific scientificDecoder mustBeInteger = do- ndigits <- int16Parser- weight <- int16Parser- sign <- int16Parser -- 0x0000 is positive, 0x4000 is negative, 0xC000 is NAN, 0xD000 is Positive Infinity, 0xF000 is Negative Infinity+ ndigits <- Parser.takeInt16BE+ weight <- Parser.takeInt16BE+ sign <- Parser.takeInt16BE -- 0x0000 is positive, 0x4000 is negative, 0xC000 is NAN, 0xD000 is Positive Infinity, 0xF000 is Negative Infinity unless (sign == 0x0000 || sign == 0x4000) $ fail "NaN, positive or negative infinities cannot be decoded into Integer or Scientific"- !dscale <- int16Parser+ !dscale <- Parser.takeInt16BE when (mustBeInteger && dscale /= 0) $ fail "Decoding into `Integer` requires explicit casting with `numeric(X,0)` to force integral values" valueAbs <- parseAndMult ndigits (fromIntegral weight * 4) 0 pure $ (if sign == 0x0000 then 1 else (-1)) * valueAbs@@ -902,7 +890,7 @@ parseAndMult :: Int16 -> Int -> Scientific -> Parser.Parser Scientific parseAndMult 0 _ !val = pure val parseAndMult !ndigitsLeft !currexpon !val = do- !digit <- fromIntegral <$> int16Parser+ !digit <- fromIntegral <$> Parser.takeInt16BE parseAndMult (ndigitsLeft - 1) (currexpon - 4) (val + scientific digit currexpon) instance FromPgField Scientific where@@ -928,7 +916,7 @@ fieldDecoder = toRational <$> fieldDecoder @Scientific binaryTrue :: ByteString-binaryTrue = Cereal.encode True+binaryTrue = BinSer.encodePgBoolean True instance FromPgField Bool where fieldDecoder = parsePgType [boolOid] $ \case@@ -1003,7 +991,7 @@ fieldDecoder = parsePgType [timestamptzOid] $ \case Just bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909- totalusecs <- Cereal.decode @Int64 bs+ totalusecs <- BinSer.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000)@@ -1013,7 +1001,7 @@ fieldDecoder = parsePgType [timestamptzOid] $ \case Just bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909- totalusecs <- Cereal.decode @Int64 bs+ totalusecs <- BinSer.decodeInt64BE 0 bs Right $ if totalusecs == minBound then NegInfinity@@ -1030,7 +1018,7 @@ fieldDecoder = parsePgType [timestamptzOid] $ \case Just bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909- totalusecs <- Cereal.decode @Int64 bs+ totalusecs <- BinSer.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ utcToZonedTime utc $ UTCTime parsedDate (picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000)@@ -1040,7 +1028,7 @@ fieldDecoder = parsePgType [timestamptzOid] $ \case Just bs -> do -- See https://github.com/postgres/postgres/blob/50cb7505b3010736b9a7922e903931534785f3aa/src/backend/utils/adt/timestamp.c#L1909- totalusecs <- Cereal.decode @Int64 bs+ totalusecs <- BinSer.decodeInt64BE 0 bs Right $ if totalusecs == minBound then NegInfinity@@ -1056,7 +1044,7 @@ instance FromPgField LocalTime where fieldDecoder = parsePgType [timestampOid] $ \case Just bs -> do- totalusecs <- Cereal.decode @Int64 bs+ totalusecs <- BinSer.decodeInt64BE 0 bs let (day, timeusecs) = totalusecs `divMod` 86_400_000_000 -- USECS per day parsedDate = addJulianDurationClip (CalendarDiffDays 0 (fromIntegral day)) $ fromJulian 1999 12 19 Right $ LocalTime parsedDate (timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral timeusecs * 1_000_000)@@ -1065,7 +1053,7 @@ instance FromPgField TimeOfDay where fieldDecoder = parsePgType [timeOid] $ \case Just bs -> do- usecs <- Cereal.decode @Int64 bs+ usecs <- BinSer.decodeInt64BE 0 bs Right $ timeToTimeOfDay $ picosecondsToDiffTime $ fromIntegral usecs * 1_000_000 Nothing -> Left "Cannot decode SQL null as the Haskell TimeOfDay type. Use a `Maybe TimeOfDay`" @@ -1075,7 +1063,7 @@ -- There is a very specific conversion function for these, which I poorly translated to Haskell -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 -- But I found a simpler way to do this. Let's see if it works in our property based tests- jd <- Cereal.decode @Int32 bs+ jd <- BinSer.decodeInt32BE 0 bs Right $ addJulianDurationClip (CalendarDiffDays 0 (fromIntegral jd - 13)) $ fromJulian 2000 01 01 Nothing -> Left "Cannot decode SQL null as the Haskell Day type. Use a `Maybe Day`" @@ -1085,7 +1073,7 @@ -- There is a very specific conversion function for these, which I poorly translated to Haskell -- https://github.com/postgres/postgres/blob/799959dc7cf0e2462601bea8d07b6edec3fa0c4f/src/backend/utils/adt/datetime.c#L321 -- But I found a simpler way to do this. Let's see if it works in our property based tests- jd <- Cereal.decode @Int32 bs+ jd <- BinSer.decodeInt32BE 0 bs Right $ if jd == minBound then NegInfinity@@ -1099,7 +1087,9 @@ instance FromPgField CalendarDiffTime where fieldDecoder = parsePgType [intervalOid] $ \case Just bs -> do- (nMicrosecs :: Int64, nDays :: Int32, nMonths :: Int32) <- Cereal.decode bs+ nMicrosecs <- BinSer.decodeInt64BE 0 bs+ nDays <- BinSer.decodeInt32BE 8 bs+ nMonths <- BinSer.decodeInt32BE 12 bs Right $ CalendarDiffTime {ctMonths = fromIntegral nMonths, ctTime = secondsToNominalDiffTime (fromIntegral nDays * 86400) + realToFrac (picosecondsToDiffTime (fromIntegral nMicrosecs * 1_000_000))} Nothing -> Left "Cannot decode SQL null as the Haskell CalendarDiffTime type. Use a `Maybe CalendarDiffTime`" @@ -1171,33 +1161,30 @@ !elementParser = fieldDecoder @a arrayParser :: EncodingContext -> Parser.Parser (Vector (Vector a)) arrayParser encodingContext = do- !ndim <- int32Parser- !_hasNull <- int32Parser- !elementTypeOid :: Oid <- Oid . fromIntegral <$> int32Parser+ !ndim <- Parser.takeInt32BE+ !_hasNull <- Parser.takeInt32BE+ !elementTypeOid :: Oid <- Oid . fromIntegral <$> Parser.takeInt32BE let !elementColInfo = FieldInfo elementTypeOid Nothing encodingContext when (ndim /= 2) $ fail $ "TODO: No support for " ++ show ndim ++ "-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" numRows <- do- !dim_i :: Int <- fromIntegral <$> int32Parser- !_lb_i <- int32Parser+ !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE+ !_lb_i <- Parser.takeInt32BE pure dim_i lengthEachRow <- do- !dim_i :: Int <- fromIntegral <$> int32Parser- !_lb_i <- int32Parser+ !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE+ !_lb_i <- Parser.takeInt32BE pure dim_i Vector.replicateM numRows $ do Vector.replicateM lengthEachRow $ do- size :: Int <- fromIntegral <$> int32Parser+ size :: Int <- fromIntegral <$> Parser.takeInt32BE elementBs <- if size == (-1) then pure Nothing else Just <$> Parser.take size case elementParser.fieldValueDecoder elementColInfo elementBs of Left err -> fail $ "Error parsing array element: " ++ show err Right el -> pure el -int16Parser :: Parser.Parser Int16-int16Parser = either fail pure . Cereal.decode @Int16 =<< Parser.take 2- -- | Derives `FromPgRow` generically. genericFromPgRow :: forall a. (Generic a, ProductTypeDecoder (Rep a)) => RowDecoder a genericFromPgRow = to <$> genRowDecoder @(Rep a)@@ -1206,13 +1193,19 @@ genRowDecoder :: RowDecoder (f a) instance (ProductTypeDecoder a, ProductTypeDecoder b) => ProductTypeDecoder (a :*: b) where+ {-# INLINE genRowDecoder #-} genRowDecoder = (:*:) <$> genRowDecoder <*> genRowDecoder instance (ProductTypeDecoder f) => ProductTypeDecoder (M1 a c f) where+ {-# INLINE genRowDecoder #-} genRowDecoder = M1 <$> genRowDecoder instance (FromPgField a) => ProductTypeDecoder (K1 r a) where- genRowDecoder = fmap K1 $ singleField $ fieldDecoder @a+ {-# INLINE genRowDecoder #-}+ -- coercing instead of fmap reduces memory usage, apparently+ -- by reducing (unnecessary) closures in the final row decoder,+ -- as per looking at GHC Core+ genRowDecoder = coerce $ singleField $ fieldDecoder @a genericToPgRow :: forall a. (Generic a, ProductTypeEncoder (Rep a)) => RowEncoder a genericToPgRow = contramap from genRowEncoder@@ -1333,14 +1326,14 @@ encodeElement el = Builder.binaryField $ fe.toPgField encCtx el Oid elemOid = fromMaybe (Oid 0) (fe.toTypeOid encCtx) in \vec ->- let ndim = Builder.byteString $ Cereal.encode @Int32 1+ let ndim = Builder.int32BE 1 -- Postgres seems to build the "has_nulls" flag itself in the ReadArrayBinary function at https://github.com/postgres/postgres/blob/aa7f9493a02f5981c09b924323f0e7a58a32f2ed/src/backend/utils/adt/arrayfuncs.c#L1429, so we can just set it to 0- hasNull = Builder.byteString $ Cereal.encode @Int32 0- -- hasNull = Builder.byteString $ Cereal.encode @Int32 (if Vector.any (\e -> toPgField e == Nothing) vec then 1 else 0)- elemOidBs = Builder.byteString $ Cereal.encode @Int32 elemOid- lb1 = Builder.byteString $ Cereal.encode @Int32 1+ hasNull = Builder.byteString $ BinSer.encodeInt32BE 0+ -- hasNull = Builder.byteString $ BinSer.encodeInt32BE (if Vector.any (\e -> toPgField e == Nothing) vec then 1 else 0)+ elemOidBs = Builder.byteString $ BinSer.encodeInt32BE elemOid+ lb1 = Builder.byteString $ BinSer.encodeInt32BE 1 (Sum len, encodedElements) = foldMap (\el -> (Sum 1, encodeElement el)) vec- dim1 = Builder.byteString $ Cereal.encode @Int32 len+ dim1 = Builder.byteString $ BinSer.encodeInt32BE len fullBs = ndim <> hasNull <> elemOidBs <> dim1 <> lb1 <> encodedElements in NotNull (Builder.toStrictByteString fullBs) @@ -1361,19 +1354,19 @@ where arrayParser :: EncodingContext -> Parser.Parser (f a) arrayParser encodingContext = do- !ndim <- int32Parser- !_hasNull <- int32Parser- !elementTypeOid :: Oid <- Oid . fromIntegral <$> int32Parser+ !ndim <- Parser.takeInt32BE+ !_hasNull <- Parser.takeInt32BE+ !elementTypeOid :: Oid <- Oid . fromIntegral <$> Parser.takeInt32BE let !elementColInfo = FieldInfo elementTypeOid Nothing encodingContext when (ndim > 1) $ fail $ "TODO: No support for multi-dimensional arrays in Hpgsql. Got array with ndim=" ++ show ndim if ndim == 0 then pure mempty else do- !dim_i :: Int <- fromIntegral <$> int32Parser- !_lb_i <- int32Parser+ !dim_i :: Int <- fromIntegral <$> Parser.takeInt32BE+ !_lb_i <- Parser.takeInt32BE unless (elementParser.allowedPgTypes elementColInfo) $ fail $ "Array contains elements of type OID " ++ show elementTypeOid ++ " but decoder does not handle that type" replicateFunction dim_i $ do- size :: Int <- fromIntegral <$> int32Parser+ size :: Int <- fromIntegral <$> Parser.takeInt32BE elementBs <- if size == (-1) then pure Nothing else Just <$> Parser.take size case elementParser.fieldValueDecoder elementColInfo elementBs of Left err -> fail $ "Error parsing array element: " ++ show err
+ src/Hpgsql/Encoding/BinarySerializer.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE CPP #-}++-- |+-- A replacement for libraries like cereal or binary.+-- In our tests, this is ~6.0% faster than cereal, and it also+-- (or by virtue of) allocates ~13% less memory in some of our benchmarks.+-- And it also means one fewer dependency.+-- The caveat is that this module makes unaligned memory access. For the target+-- CPU architectures of this library, this should be fine.+module Hpgsql.Encoding.BinarySerializer+ ( ByteStringIdx (..),+ decodeInt16BE,+ decodeInt32BE,+ decodeInt64BE,+ decodeWord32BE,+ decodeWord64BE,+ encodeInt32BE,+ encodeDouble,+ encodeFloat,+ encodeInt64BE,+ encodeInt16BE,+ encodePgBoolean,+ decodeDataRow,+ )+where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Internal as InternalBS+import Data.Int (Int16, Int32, Int64)+import Prelude hiding (encodeFloat)+#if WORDS_BIGENDIAN+import Data.Word (Word16, Word32, Word64)+#else+import Data.Word (Word16, Word32, Word64, byteSwap16, byteSwap32, byteSwap64, Word8)+#endif+import Data.Bits (Bits (unsafeShiftR))+import Data.Coerce (coerce)+import Foreign (Storable (..), (.&.))+import Foreign.ForeignPtr (withForeignPtr)+import GHC.Float (castDoubleToWord64, castFloatToWord32)+import System.IO.Unsafe (unsafeDupablePerformIO)++fromBigEndian32 :: Word32 -> Word32+#if WORDS_BIGENDIAN+fromBigEndian32 = Prelude.id+#else+fromBigEndian32 = byteSwap32+#endif++fromBigEndian64 :: Word64 -> Word64+#if WORDS_BIGENDIAN+fromBigEndian64 = Prelude.id+#else+fromBigEndian64 = byteSwap64+#endif++fromBigEndian16 :: Word16 -> Word16+#if WORDS_BIGENDIAN+fromBigEndian16 = Prelude.id+#else+fromBigEndian16 = byteSwap16+#endif++data CoolWordDec a where+ CWord8 :: CoolWordDec Word8+ CWord16 :: CoolWordDec Word16+ CWord32 :: CoolWordDec Word32+ CWord64 :: CoolWordDec Word64++{-# INLINE decodeWord #-}+decodeWord :: CoolWordDec a -> ByteStringIdx -> ByteString -> (a -> a) -> Either String a+decodeWord wdec idx (InternalBS.BS bytesPtr len) endianConvert =+ case wdec of+ CWord8 -> if len < 1 + idx.idx then Left "Less than enough bytes to decode" else Right $ endianConvert $ unsafeDupablePerformIO $ withForeignPtr bytesPtr $ \ptr -> peekByteOff (coerce ptr) idx.idx+ CWord16 -> if len < 2 + idx.idx then Left "Less than enough bytes to decode" else Right $ endianConvert $ unsafeDupablePerformIO $ withForeignPtr bytesPtr $ \ptr -> peekByteOff (coerce ptr) idx.idx+ CWord32 -> if len < 4 + idx.idx then Left "Less than enough bytes to decode" else Right $ endianConvert $ unsafeDupablePerformIO $ withForeignPtr bytesPtr $ \ptr -> peekByteOff (coerce ptr) idx.idx+ CWord64 -> if len < 8 + idx.idx then Left "Less than enough bytes to decode" else Right $ endianConvert $ unsafeDupablePerformIO $ withForeignPtr bytesPtr $ \ptr -> peekByteOff (coerce ptr) idx.idx++{-# INLINE unsafeEncodeWord #-}+unsafeEncodeWord :: (Storable a) => a -> (a -> a) -> Int -> ByteString+unsafeEncodeWord n endianConvert len =+ InternalBS.unsafeCreate len $ \bufferPtr ->+ poke (coerce bufferPtr) $ endianConvert n++newtype ByteStringIdx = ByteStringIdx {idx :: Int}+ deriving newtype (Num)++{-# INLINE decodeInt16BE #-}+decodeInt16BE :: ByteStringIdx -> ByteString -> Either String Int16+decodeInt16BE idx bs = fromIntegral <$> decodeWord CWord16 idx bs fromBigEndian16++{-# INLINE encodeInt16BE #-}+encodeInt16BE :: Int16 -> ByteString+encodeInt16BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian16 2++{-# INLINE decodeWord8 #-}+decodeWord8 :: ByteStringIdx -> ByteString -> Either String Word8+decodeWord8 idx bs = decodeWord CWord8 idx bs Prelude.id++{-# INLINE decodeWord32BE #-}+decodeWord32BE :: ByteString -> Either String Word32+decodeWord32BE bs = decodeWord CWord32 0 bs fromBigEndian32++{-# INLINE decodeWord64BE #-}+decodeWord64BE :: ByteString -> Either String Word64+decodeWord64BE bs = decodeWord CWord64 0 bs fromBigEndian64++{-# INLINE decodeInt32BE #-}+decodeInt32BE :: ByteStringIdx -> ByteString -> Either String Int32+decodeInt32BE idx bs = fromIntegral <$> decodeWord CWord32 idx bs fromBigEndian32++{-# INLINE encodeInt32BE #-}+encodeInt32BE :: Int32 -> ByteString+encodeInt32BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian32 4++{-# INLINE decodeInt64BE #-}+decodeInt64BE :: ByteStringIdx -> ByteString -> Either String Int64+decodeInt64BE idx bs = fromIntegral <$> decodeWord CWord64 idx bs fromBigEndian64++{-# INLINE encodeInt64BE #-}+encodeInt64BE :: Int64 -> ByteString+encodeInt64BE n = unsafeEncodeWord (fromIntegral n) fromBigEndian64 8++{-# INLINE encodeFloat #-}+encodeFloat :: Float -> ByteString+encodeFloat n = unsafeEncodeWord (castFloatToWord32 n) fromBigEndian32 4++{-# INLINE encodeDouble #-}+encodeDouble :: Double -> ByteString+encodeDouble n = unsafeEncodeWord (castDoubleToWord64 n) fromBigEndian64 8++{-# INLINE encodePgBoolean #-}+encodePgBoolean :: Bool -> ByteString+encodePgBoolean v = if v then "\SOH" else "\NUL"++{-# INLINE decodeDataRow #-}++-- | A super specialized decoder to decode a postgres DataRow message+-- more quickly than a naive implementation.+-- Returns the index into the left-unparsed contents of the supplied bytestring.+decodeDataRow :: ByteStringIdx -> ByteString -> Either String ByteStringIdx+decodeDataRow idx bs@(InternalBS.BS _bytesPtr len) =+ -- We have a fast path when rows are at least 8 bytes long (should be the case+ -- for all but 0-column query results or bytestring chunks "cut in the middle of the message")+ -- by playing with bitwise operations.+ -- Whether this is worth keeping is sort of questionable. It's complex+ -- (even if I think it's safe and well tested) and reduces runtime of one of+ -- our benchmarks by 2% compared to not having it.+ case decodeWord CWord64 idx bs fromBigEndian64 of+ Right (w64 :: Word64) ->+ -- After fromBigEndian64, the Word64 has bytes in big-endian order:+ -- byte 0 (msg type) in MSB, bytes 1-4 (length) next, bytes 5-6 (col count), byte 7 in LSB.+ let msgIdentByte64 = w64 .&. 0b11111111_00000000_00000000_00000000_00000000_00000000_00000000_00000000+ lenFullMsg = flip unsafeShiftR 24 $ w64 .&. 0b00000000_11111111_11111111_11111111_11111111_00000000_00000000_00000000+ letterD :: Word64 = 0b01000100_00000000_00000000_00000000_00000000_00000000_00000000_00000000+ in if msgIdentByte64 == letterD+ then+ toResult (fromIntegral lenFullMsg)+ else Left "Not a DataRow (Word64 bits decoding path)"+ Left _ ->+ -- It is possible the DataRow has length less than 8 bytes, so+ -- we still have to try to parse that.+ if len >= 5 + idx.idx+ then do+ msgIdentChar <- decodeWord8 idx bs+ lenFullMsg <- decodeInt32BE (1 + idx) bs+ if msgIdentChar == 68 -- Letter 'D'+ then toResult (fromIntegral lenFullMsg)+ else Left "Not a DataRow"+ else Left "Less than enough bytes to decode a DataRow"+ where+ toResult lenFullMsg+ | len >= 1 + lenFullMsg + idx.idx = Right $ ByteStringIdx $ 1 + lenFullMsg + idx.idx+ | otherwise = Left "Less than enough bytes to decode a full DataRow"
src/Hpgsql/Encoding/RowDecoderMonadic.hs view
@@ -5,6 +5,7 @@ ) where +import Control.Monad (unless) import Data.Bifunctor (first) import qualified Data.List as List import Hpgsql.Encoding (FieldInfo, RowDecoder (..))@@ -14,8 +15,9 @@ -- You should prefer to use @Hpgsql.Encoding.RowDecoder@ (through @FromPgRow@ instances) -- instead of this, and use this only if your row decoder is complex enough that -- decoded fields can change the behaviour of other decoded fields.--- The regular @RowDecoder@ can even type-check queries that return no results, while--- this can't.+-- The regular @RowDecoder@ pays the price of type-checking only once per query and can+-- even type-check queries that return no results, while this pays the price of type-checking+-- for every field of every row, and won't type-check zero-rows results. -- Look for the 'query' and 'pipeline' functions with an 'M' in them for ways to query -- with this kind of row decoder. newtype RowDecoderMonadic a = RowDecoderMonadic@@ -41,15 +43,19 @@ RowDecoderMonadic {fullRowDecoder} >>= f = RowDecoderMonadic $ \cs0 -> do (row, numColsParsed) <- fullRowDecoder cs0 let RowDecoderMonadic {fullRowDecoder = parserOfRemainder} = f row- parserOfRemainder cs0 {colsLeftToParse = List.drop numColsParsed cs0.colsLeftToParse}+ (finalRow, numColsParsedByRemainder) <- parserOfRemainder cs0 {colsLeftToParse = List.drop numColsParsed cs0.colsLeftToParse}+ pure (finalRow, numColsParsed + numColsParsedByRemainder) --- | Takes an Applicative row parser (which can type-check result rows before even fetching--- any rows from the response) and transforms it into a Monadic row parser, which has no such--- type-checking.+-- | Takes an Applicative row parser (which type-checks result rows only once per query)+-- and transforms it into a Monadic row parser, which is more flexible, but pays the+-- price of type-checking every field in every row returned in queries. toMonadicRowDecoder :: RowDecoder a -> RowDecoderMonadic a-toMonadicRowDecoder RowDecoder {fullRowDecoder, numExpectedColumns} = RowDecoderMonadic $ \cs -> do+toMonadicRowDecoder RowDecoder {fullRowDecoder, numExpectedColumns, rowColumnsTypeCheck} = RowDecoderMonadic $ \cs -> do let numActualCols = length cs.colsLeftToParse case compare numActualCols numExpectedColumns of- EQ -> (,numExpectedColumns) <$> fullRowDecoder cs.colsLeftToParse- GT -> (,numExpectedColumns) <$> fullRowDecoder (List.take numExpectedColumns cs.colsLeftToParse)- LT -> fail $ "More number of columns expected by the row parser than found in query results. Expected " ++ show numExpectedColumns ++ " but got " ++ show numActualCols+ LT -> fail $ "More columns expected by the row parser than found in query results. Expected " ++ show numExpectedColumns ++ " but got " ++ show numActualCols+ _ -> do+ let colsForNow = List.take numExpectedColumns cs.colsLeftToParse+ let typecheckedCols = rowColumnsTypeCheck colsForNow+ unless (all snd typecheckedCols) $ fail "Query result column types do not match expected column types"+ (,numExpectedColumns) <$> fullRowDecoder colsForNow
src/Hpgsql/Internal.hs view
@@ -113,7 +113,7 @@ import Control.Concurrent.STM (STM, TVar) import qualified Control.Concurrent.STM as STM import Control.Exception.Safe (Exception (..), MonadThrow, SomeException, bracket, bracketOnError, finally, handleJust, mask, mask_, onException, throw, toException, tryJust)-import Control.Monad (forM, forM_, join, unless, void, when)+import Control.Monad (forM, forM_, join, replicateM, unless, void, when) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Internal (w2c)@@ -127,7 +127,6 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, isNothing, mapMaybe)-import qualified Data.Serialize as Cereal import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text@@ -138,6 +137,7 @@ import Hpgsql.Base import qualified Hpgsql.Builder as Builder import Hpgsql.Encoding (FieldInfo (..), FromPgRow (..), RowDecoder (..), RowEncoder (..), ToPgRow (..))+import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Hpgsql.Encoding.RowDecoderMonadic (ConversionState (..), RowDecoderMonadic (..)) import Hpgsql.InternalTypes (BindComplete (..), CommandComplete (..), ConnectOpts (..), ConnectionString (..), CopyInResponse (..), CopyQueryState (..), DataRow (..), Either3 (..), EncodingContext (..), ErrorDetail (..), ErrorResponse (..), HPgConnection (..), InternalConnectionState (..), IrrecoverableHpgsqlError (..), NoData (..), NotificationResponse (..), ParseComplete (..), Pipeline (..), PostgresError (..), Query (..), QueryId (..), QueryProtocol (..), QueryState (..), ReadyForQuery (..), ResetConnectionOpts (..), ResponseMsg (..), ResponseMsgsReceived (..), RowDescription (..), SingleQuery (..), TransactionStatus (..), WeakThreadId (..), mkMutex, queryToByteString, throwIrrecoverableError) import Hpgsql.Locking (getMyWeakThreadId, withMutex)@@ -228,7 +228,8 @@ ConnectOpts { killedThreadPollIntervalMs = 500, cancellationRequestResendIntervalMs = 500,- fillTypeInfoCache = True+ fillTypeInfoCache = True,+ recvChunkSize = 16000 } data InternalConnectOrCancelRequest a where@@ -506,7 +507,7 @@ Left (msgIdentChar, mPgError) -> throw IrrecoverableHpgsqlError {hpgsqlDetails = "Could not parse postgres message with ident char " <> Text.pack (show msgIdentChar) <> ". This is an internal error in Hpgsql. Please report it.", innerException = toException <$> mPgError, relatedStatement = Nothing} data ReceiveWhat a b where- ReceiveDataRows :: ReceiveWhat DataRow [DataRow]+ ReceiveDataRows :: ReceiveWhat DataRow (ByteString, Int) ReceiveArbitraryMsg :: PgMsgParser a -> (Either (Char, Maybe PostgresError) a -> STM b) -> ReceiveWhat a b -- | Masks asynchronous exceptions in between the moment the message is extracted from@@ -534,11 +535,11 @@ (initialBuf, initialBufLen) <- receiveUntilBufferHasAtLeast 5 let charAndLength = LBS.take 5 initialBuf let (w2c -> msgIdentChar, lenbs) = fromMaybe (error "impossible") $ LBS.uncons charAndLength- lenLeftToFetch :: Int64 = fromIntegral $ either error id (Cereal.decodeLazy @Int32 lenbs) - 4+ lenLeftToFetch :: Int64 = fromIntegral $ either error id (BinSer.decodeInt32BE 0 $ LBS.toStrict lenbs) - 4 fullMessageLen = 5 + lenLeftToFetch (nowBuf, _nowBufLen) <- if initialBufLen >= fullMessageLen then pure (initialBuf, initialBufLen) else receiveUntilBufferHasAtLeast fullMessageLen- let restOfMsg = LBS.drop 5 $ LBS.take fullMessageLen nowBuf- receivedNoticeOrParameterSoTryAgain <- go msgIdentChar restOfMsg fullMessageLen nowBuf+ let fullMsg = LBS.take fullMessageLen nowBuf+ receivedNoticeOrParameterSoTryAgain <- go msgIdentChar fullMsg fullMessageLen nowBuf case receivedNoticeOrParameterSoTryAgain of Nothing -> receiveNextMsgGeneric conn receiveWhat Just res -> pure res@@ -551,12 +552,12 @@ -- the recvBuffer, then we _must_ remove that message from recvBuffer. -- Ideally we'd have non-retriable STM at the type-level here. Maybe later. -- Make sure to do very little work inside `go`!- go msgIdentChar restOfMsg fullMessageLen nowBuf = mask_ $ modifyIORefIO recvBuffer $ do+ go msgIdentChar fullMsg fullMessageLen nowBuf = mask_ $ modifyIORefIO recvBuffer $ do let bufferWithoutMsg = LBS.drop fullMessageLen nowBuf handleUnexpectedMsg onNotAnyReasonableMsg = -- This could be a Notification, NOTICE or a ParameterStatus message, since these -- can be received _at any time_ according to the docs.- case parsePgMessage msgIdentChar restOfMsg (Left3 <$> msgParser @NotificationResponse <|> Middle3 <$> msgParser @NoticeResponse <|> Right3 <$> msgParser @ParameterStatus) of+ case parsePgMessage msgIdentChar fullMsg (Left3 <$> msgParser @NotificationResponse <|> Middle3 <$> msgParser @NoticeResponse <|> Right3 <$> msgParser @ParameterStatus) of Just (Left3 notifResponse) -> do debugPrint "Received notification. Will add it to internal queue." STM.atomically $ do@@ -578,36 +579,25 @@ Nothing -> do -- Just in case this is a postgres error, it might include useful information, -- so we spit that out- let mPgError = mkPostgresError "" <$> parsePgMessage msgIdentChar restOfMsg (msgParser @ErrorResponse)+ let mPgError = mkPostgresError "" <$> parsePgMessage msgIdentChar fullMsg (msgParser @ErrorResponse) fmap (nowBuf,) $ Just <$> STM.atomically (onNotAnyReasonableMsg (msgIdentChar, mPgError)) case receiveWhat of ReceiveDataRows -> -- Parse as many DataRows as we can to do as much work as we can per buffer "churn"- case Parser.parseOnly (Parser.matchLeftUnconsumed (Parser.parseMany customDataRowParser)) (LBS.toStrict nowBuf) of- Parser.ParseOk (unconsumedBuffer, msgs@(_ : _)) -> do- debugPrint $ "Received " ++ show msgs- pure (LBS.fromStrict unconsumedBuffer, Just msgs)- _ -> handleUnexpectedMsg $ const $ pure [] -- No error when we stop receiving DataRows, only emptiness+ let fullBuf = LBS.toStrict nowBuf+ in case Parser.parseOnly Parser.parseManyRows fullBuf of+ Parser.ParseOk (unconsumedBufferBegin, nRowsParsed) | nRowsParsed > 0 -> do+ let (msgs, unconsumedBuffer) = BS.splitAt unconsumedBufferBegin.idx fullBuf+ debugPrint $ "Received " ++ show nRowsParsed ++ " messages with total length " ++ show (BS.length msgs)+ pure (LBS.fromStrict unconsumedBuffer, Just (msgs, nRowsParsed))+ _ -> handleUnexpectedMsg $ const $ pure ("", 0) -- No error when we stop receiving DataRows, only emptiness ReceiveArbitraryMsg parser f ->- case parsePgMessage msgIdentChar restOfMsg parser of+ case parsePgMessage msgIdentChar fullMsg parser of Just msg -> do debugPrint $ "Received " ++ show msg fmap (bufferWithoutMsg,) $ Just <$> STM.atomically (f (Right msg)) Nothing -> handleUnexpectedMsg (f . Left) - -- Sadly we have to repeat the parsing of a DataRow message here, when it already- -- exists in the FromPgMessage instance and in the body of this function. Maybe- -- we can improve this later.- customDataRowParser = do- charAndLength <- Parser.take 5- let (w2c -> msgIdentChar, lenbs) = fromMaybe (error "impossible") $ BS.uncons charAndLength- lenLeftToFetch :: Int = fromIntegral $ either error id (Cereal.decode @Int32 lenbs) - 4- if msgIdentChar == 'D'- then do- rowColumnData <- BS.drop 2 <$> Parser.take lenLeftToFetch- pure $ DataRow rowColumnData- else fail "Not a DataRow"- -- \| Appends into the internal buffer by reading from the socket -- until the buffer has at least N bytes. -- Returns the current buffer and its length.@@ -622,7 +612,7 @@ -- or an exception is thrown when receiving. mask $ \restore -> rethrowAsIrrecoverable $ do restore $ socketWaitRead socket- someBytes <- timeDebugNonBlockingOperation "recv" $ recvNonBlocking socket (max 16000 $ fromIntegral $ minBytesNecessary - nBytesInBuffer)+ someBytes <- timeDebugNonBlockingOperation "recv" $ recvNonBlocking socket (max conn.connOpts.recvChunkSize $ fromIntegral $ minBytesNecessary - nBytesInBuffer) atomicWriteIORef recvBuffer (currentBuffer <> LBS.fromStrict someBytes) receiveUntilBufferHasAtLeast minBytesNecessary @@ -854,6 +844,10 @@ } pure (Just respMsg, newState) +-- | A sequence of all the bytes of one or more DataRow messages and the total+-- number of DataRow messages.+newtype DataRows = DataRows (ByteString, Int)+ -- | After sending one or more queries to the backend, run this function for each query to fetch that query's results. -- You must call the returned IO function and consume the returned Stream completely until you get to the -- `Either ErrorResponse CommandComplete` object.@@ -866,7 +860,7 @@ consumeResults :: HPgConnection -> QueryId ->- IO (Maybe (Either3 NoData RowDescription CopyInResponse), Stream (Of DataRow) IO (Either ErrorResponse CommandComplete))+ IO (Maybe (Either3 NoData RowDescription CopyInResponse), Stream (Of DataRows) IO (Either ErrorResponse CommandComplete)) consumeResults conn qryId = do -- debugPrint "++++ Inside consumeResults" -- We assume it's possible to receive a DataRow here even in the first call because `consumeResults`@@ -897,29 +891,28 @@ pure (mERowDesc, pure $ Right cmd) (mERowDesc, Middle3 mDataRow) -> do let allOtherRows =- S.concat $- S.unfold- ( \() -> do- mRow <- receiveNextMsgGeneric conn ReceiveDataRows- case mRow of- rows@(_ : _) -> pure $ Right (rows :> ())- [] -> do- stateAfterNextMsg <- snd <$> receiveOutstandingResponseMsgsAtomically thisThreadId conn qryId- case stateAfterNextMsg of- ErrorResponseReceived _ err -> do- receiveReadyForQueryIfNecessary thisThreadId- pure $ Left $ Left err- CommandCompleteReceived _ cmd -> do- receiveReadyForQueryIfNecessary thisThreadId- pure $ Left $ Right cmd- ReadyForQueryReceived errOrCmd _ -> pure $ Left errOrCmd- st -> throwIrrecoverableError $ "Internal error in Hpgsql. After the last DataRow we should get either an ErrorResponse or a CommandComplete message. State: " <> Text.pack (show st)- )- ()+ S.unfold+ ( \() -> do+ mRow@(_, nRows) <- receiveNextMsgGeneric conn ReceiveDataRows+ if nRows > 0+ then pure $ Right (DataRows mRow :> ())+ else do+ stateAfterNextMsg <- snd <$> receiveOutstandingResponseMsgsAtomically thisThreadId conn qryId+ case stateAfterNextMsg of+ ErrorResponseReceived _ err -> do+ receiveReadyForQueryIfNecessary thisThreadId+ pure $ Left $ Left err+ CommandCompleteReceived _ cmd -> do+ receiveReadyForQueryIfNecessary thisThreadId+ pure $ Left $ Right cmd+ ReadyForQueryReceived errOrCmd _ -> pure $ Left errOrCmd+ st -> throwIrrecoverableError $ "Internal error in Hpgsql. After the last DataRow we should get either an ErrorResponse or a CommandComplete message. State: " <> Text.pack (show st)+ )+ () finalStream = case mDataRow of Nothing -> allOtherRows Just dr ->- dr `S.cons` allOtherRows+ DataRows (dr.fullDataRow, 1) `S.cons` allOtherRows pure (mERowDesc, finalStream) where receiveReadyForQueryIfNecessary :: WeakThreadId -> IO ()@@ -1420,17 +1413,25 @@ let typecheckedColInfos = rtypecheck colInfos unless (numResultColumns == expectedNumCols) $ throwIrrecoverableErrorWithStatement qText $ "Query result contains " <> Text.pack (show numResultColumns) <> " columns but row parser expected " <> Text.pack (show expectedNumCols) unless (all snd typecheckedColInfos) $ throwIrrecoverableErrorWithStatement qText "Query result column types do not match expected column types"- pure $ rparser colInfos <* Parser.endOfInput- MonadicRowDecoder (RowDecoderMonadic rparser) -> pure $ fmap fst $ rparser ConversionState {colsLeftToParse = colInfos} <* Parser.endOfInput+ pure $ Parser.skip 7 *> rparser colInfos -- Skip msg ident., length, number of columns, then parse fields+ MonadicRowDecoder (RowDecoderMonadic rparser) ->+ pure $+ Parser.skip 7 *> do+ (row, numColsParsed) <- rparser ConversionState {colsLeftToParse = colInfos}+ unless (numColsParsed == numResultColumns) $+ fail $+ "Query result contains " ++ show numResultColumns ++ " columns but the row parser only consumed " ++ show numColsParsed+ pure row pure $ do errOrCmdComplete <-- S.mapM- ( \(DataRow rowColumnData) ->- case Parser.parseOnly rowparser rowColumnData of- Parser.ParseOk row -> pure row- Parser.ParseFail err -> throwIrrecoverableErrorWithStatement qText $ "Failed parsing a row: " <> Text.pack (show err)- )- rowsStream+ S.concat $+ S.mapM+ ( \(DataRows (rowColumnData, nRows)) ->+ case Parser.parseOnly (replicateM nRows rowparser <* Parser.endOfInput) rowColumnData of+ Parser.ParseOk rows -> pure rows+ Parser.ParseFail err -> throwIrrecoverableErrorWithStatement qText $ "Failed parsing a row: " <> Text.pack (show err)+ )+ rowsStream S.effect $ case errOrCmdComplete of Left err -> throwPostgresError qText err Right _cmdComplete -> pure mempty
src/Hpgsql/InternalTypes.hs view
@@ -259,7 +259,7 @@ -- and you want resume using the connection and cannot wait ~500ms until Hpgsql realizes -- it's fine to do so. -- You probably don't need to worry about this or tune it.- killedThreadPollIntervalMs :: Int,+ killedThreadPollIntervalMs :: !Int, -- | How long in ms Hpgsql will wait before re-sending a cancellation request -- while draining orphaned queries (queries from dead threads). The default is 500ms, -- and this is only relevant if you plan on interrupting your queries with@@ -268,14 +268,19 @@ -- It is not recommend setting this below 100ms, because orphaned query draining -- alternates with resending cancellation requests, so if this is too low it is possible -- that draining never finishes, leading to a form of livelock.- cancellationRequestResendIntervalMs :: Int,+ cancellationRequestResendIntervalMs :: !Int, -- | Immediately after connecting, run a query to fetch all types -- from the `pg_type` table. This makes them available in FromPgField -- instances. -- The default is True. You should only set it to False if you really -- know what you're doing, because class instances of custom types -- can stop working.- fillTypeInfoCache :: Bool+ fillTypeInfoCache :: !Bool,+ -- | The minimum amount of bytes to ask for when receiving from the socket.+ -- Note that Hpgsql's internal buffer may grow beyond this to accommodate+ -- larger result rows.+ -- The default is 16000.+ recvChunkSize :: !Int } data ErrorDetail@@ -363,7 +368,9 @@ newtype CommandComplete = CommandComplete {numRows :: Int64} deriving stock (Show) -newtype DataRow = DataRow {rowColumnData :: ByteString}+-- | A DataRow with its leading identifying character ('D'), the 32bits self-length,+-- the 2 bytes for the number of fields and the fields' lengths and values themselves.+newtype DataRow = DataRow {fullDataRow :: ByteString} instance Show DataRow where show _ = "DataRow"
+ src/Hpgsql/LanguageHaskell/FromThExtension.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}+{-# OPTIONS_GHC -Wno-overlapping-patterns #-}++module Hpgsql.LanguageHaskell.FromThExtension where++import Data.Map (Map)+import qualified Data.Map as Map+import GHC.LanguageExtensions.Type (Extension (..))+import qualified "template-haskell" Language.Haskell.TH as TH++fromThToGhcLibExtension :: TH.Extension -> Maybe Extension+fromThToGhcLibExtension = \case+ TH.AllowAmbiguousTypes -> Just AllowAmbiguousTypes+ TH.AlternativeLayoutRule -> Just AlternativeLayoutRule+ TH.AlternativeLayoutRuleTransitional -> Just AlternativeLayoutRuleTransitional+ TH.ApplicativeDo -> Just ApplicativeDo+ TH.Arrows -> Just Arrows+ TH.AutoDeriveTypeable -> Just AutoDeriveTypeable+ TH.BangPatterns -> Just BangPatterns+ TH.BinaryLiterals -> Just BinaryLiterals+ TH.BlockArguments -> Just BlockArguments+ TH.CApiFFI -> Just CApiFFI+ TH.CUSKs -> Just CUSKs+ TH.ConstrainedClassMethods -> Just ConstrainedClassMethods+ TH.ConstraintKinds -> Just ConstraintKinds+ TH.Cpp -> Just Cpp+ TH.DataKinds -> Just DataKinds+ TH.DatatypeContexts -> Just DatatypeContexts+ TH.DeepSubsumption -> Just DeepSubsumption+ TH.DefaultSignatures -> Just DefaultSignatures+ TH.DeriveAnyClass -> Just DeriveAnyClass+ TH.DeriveDataTypeable -> Just DeriveDataTypeable+ TH.DeriveFoldable -> Just DeriveFoldable+ TH.DeriveFunctor -> Just DeriveFunctor+ TH.DeriveGeneric -> Just DeriveGeneric+ TH.DeriveLift -> Just DeriveLift+ TH.DeriveTraversable -> Just DeriveTraversable+ TH.DerivingStrategies -> Just DerivingStrategies+ TH.DerivingVia -> Just DerivingVia+ TH.DisambiguateRecordFields -> Just DisambiguateRecordFields+ TH.DoAndIfThenElse -> Just DoAndIfThenElse+ TH.DuplicateRecordFields -> Just DuplicateRecordFields+ TH.EmptyCase -> Just EmptyCase+ TH.EmptyDataDecls -> Just EmptyDataDecls+ TH.EmptyDataDeriving -> Just EmptyDataDeriving+ TH.ExistentialQuantification -> Just ExistentialQuantification+ TH.ExplicitForAll -> Just ExplicitForAll+ TH.ExplicitNamespaces -> Just ExplicitNamespaces+ TH.ExtendedDefaultRules -> Just ExtendedDefaultRules+ TH.FieldSelectors -> Just FieldSelectors+ TH.FlexibleContexts -> Just FlexibleContexts+ TH.FlexibleInstances -> Just FlexibleInstances+ TH.ForeignFunctionInterface -> Just ForeignFunctionInterface+ TH.FunctionalDependencies -> Just FunctionalDependencies+ TH.GADTSyntax -> Just GADTSyntax+ TH.GADTs -> Just GADTs+ TH.GHCForeignImportPrim -> Just GHCForeignImportPrim+ TH.GeneralizedNewtypeDeriving -> Just GeneralizedNewtypeDeriving+ TH.HexFloatLiterals -> Just HexFloatLiterals+ TH.ImplicitParams -> Just ImplicitParams+ TH.ImplicitPrelude -> Just ImplicitPrelude+ TH.ImportQualifiedPost -> Just ImportQualifiedPost+ TH.ImpredicativeTypes -> Just ImpredicativeTypes+ TH.IncoherentInstances -> Just IncoherentInstances+ TH.InstanceSigs -> Just InstanceSigs+ TH.InterruptibleFFI -> Just InterruptibleFFI+ TH.JavaScriptFFI -> Just JavaScriptFFI+ TH.KindSignatures -> Just KindSignatures+ TH.LambdaCase -> Just LambdaCase+ TH.LexicalNegation -> Just LexicalNegation+ TH.LiberalTypeSynonyms -> Just LiberalTypeSynonyms+ TH.LinearTypes -> Just LinearTypes+ TH.MagicHash -> Just MagicHash+ TH.MonadComprehensions -> Just MonadComprehensions+ TH.MonoLocalBinds -> Just MonoLocalBinds+ TH.MonomorphismRestriction -> Just MonomorphismRestriction+ TH.MultiParamTypeClasses -> Just MultiParamTypeClasses+ TH.MultiWayIf -> Just MultiWayIf+ TH.NPlusKPatterns -> Just NPlusKPatterns+ TH.NamedFieldPuns -> Just NamedFieldPuns+ TH.NamedWildCards -> Just NamedWildCards+ TH.NegativeLiterals -> Just NegativeLiterals+ TH.NondecreasingIndentation -> Just NondecreasingIndentation+ TH.NullaryTypeClasses -> Just NullaryTypeClasses+ TH.NumDecimals -> Just NumDecimals+ TH.NumericUnderscores -> Just NumericUnderscores+ TH.OverlappingInstances -> Just OverlappingInstances+ TH.OverloadedLabels -> Just OverloadedLabels+ TH.OverloadedLists -> Just OverloadedLists+ TH.OverloadedRecordDot -> Just OverloadedRecordDot+ TH.OverloadedRecordUpdate -> Just OverloadedRecordUpdate+ TH.OverloadedStrings -> Just OverloadedStrings+ TH.PackageImports -> Just PackageImports+ TH.ParallelArrays -> Just ParallelArrays+ TH.ParallelListComp -> Just ParallelListComp+ TH.PartialTypeSignatures -> Just PartialTypeSignatures+ TH.PatternGuards -> Just PatternGuards+ TH.PatternSynonyms -> Just PatternSynonyms+ TH.PolyKinds -> Just PolyKinds+ TH.PostfixOperators -> Just PostfixOperators+ TH.QualifiedDo -> Just QualifiedDo+ TH.QuantifiedConstraints -> Just QuantifiedConstraints+ TH.QuasiQuotes -> Just QuasiQuotes+ TH.RankNTypes -> Just RankNTypes+ TH.RebindableSyntax -> Just RebindableSyntax+ TH.RecordWildCards -> Just RecordWildCards+ TH.RecursiveDo -> Just RecursiveDo+ TH.RelaxedLayout -> Just RelaxedLayout+ TH.RelaxedPolyRec -> Just RelaxedPolyRec+ TH.RoleAnnotations -> Just RoleAnnotations+ TH.ScopedTypeVariables -> Just ScopedTypeVariables+ TH.StandaloneDeriving -> Just StandaloneDeriving+ TH.StandaloneKindSignatures -> Just StandaloneKindSignatures+ TH.StarIsType -> Just StarIsType+ TH.StaticPointers -> Just StaticPointers+ TH.Strict -> Just Strict+ TH.StrictData -> Just StrictData+ TH.TemplateHaskell -> Just TemplateHaskell+ TH.TemplateHaskellQuotes -> Just TemplateHaskellQuotes+ TH.TraditionalRecordSyntax -> Just TraditionalRecordSyntax+ TH.TransformListComp -> Just TransformListComp+ TH.TupleSections -> Just TupleSections+ TH.TypeApplications -> Just TypeApplications+ TH.TypeData -> Just TypeData+ TH.TypeFamilies -> Just TypeFamilies+ TH.TypeFamilyDependencies -> Just TypeFamilyDependencies+ TH.TypeInType -> Just TypeInType+ TH.TypeOperators -> Just TypeOperators+ TH.TypeSynonymInstances -> Just TypeSynonymInstances+ TH.UnboxedSums -> Just UnboxedSums+ TH.UnboxedTuples -> Just UnboxedTuples+ TH.UndecidableInstances -> Just UndecidableInstances+ TH.UndecidableSuperClasses -> Just UndecidableSuperClasses+ TH.UnicodeSyntax -> Just UnicodeSyntax+ TH.UnliftedDatatypes -> Just UnliftedDatatypes+ TH.UnliftedFFITypes -> Just UnliftedFFITypes+ TH.UnliftedNewtypes -> Just UnliftedNewtypes+ TH.ViewPatterns -> Just ViewPatterns+#if MIN_VERSION_template_haskell(2,21,0)+ TH.ExtendedLiterals -> Just ExtendedLiterals+ TH.TypeAbstractions -> Just TypeAbstractions+#endif+#if MIN_VERSION_template_haskell(2,22,0)+ TH.ListTuplePuns -> Just ListTuplePuns+ TH.RequiredTypeArguments -> Just RequiredTypeArguments+#endif+#if MIN_VERSION_template_haskell(2,23,0)+ TH.MultilineStrings -> Just MultilineStrings+ TH.NamedDefaults -> Just NamedDefaults+ TH.OrPatterns -> Just OrPatterns+#endif+ -- Why a catch-all here after going through all the work of listing+ -- extensions above? Because of two conflicting goals:+ -- 1 - Not allocate and parse strings, plus run a Map search during compilation (see algo below)+ -- 2 - Support users compiling hpgsql with newer GHC versions+ --+ -- Goal 1 is arguably excessive over-refinement, and goal 2 is arguably+ -- pointless since it seems like (from my extremely limited experience)+ -- template-haskell and ghc-lib-parser will change with new releases+ -- anyway, but not being the annoying library that fails to compile or run+ -- with some user trying out a new GHC (after bumping version bounds themselves)+ -- feels important.+ -- So we achieve a little bit of both goals like this. This is also the reason+ -- why we have -Wno-overlapping-patterns in this file.+{- FOURMOLU_DISABLE -}+ someNewThExtension -> Map.lookup (show someNewThExtension) allGhcLibParserExtensions+{- FOURMOLU_ENABLE -}++-- | This Map is only useful by assuming the `Show` representations of language extensions in both+-- ghc-lib-parser and template-haskell match. That feels like a reasonable assumption.+allGhcLibParserExtensions :: Map String Extension+allGhcLibParserExtensions = Map.fromList $ map (\ex -> (show ex, ex)) [minBound .. maxBound]
+ src/Hpgsql/LanguageHaskell/GhcParserOpts.hs view
@@ -0,0 +1,21 @@+{-# OPTIONS_GHC -Wno-missing-fields #-}++module Hpgsql.LanguageHaskell.GhcParserOpts (fakeSettings) where++import GHC.Platform (genericPlatform)+import GHC.Settings+import GHC.Settings.Config (cProjectVersion)+import GHC.Utils.Fingerprint (fingerprint0)++-- | Fake GHC 'Settings' with only the fields the parser needs.+-- All other fields are left undefined; this is why we suppress+-- the missing-fields warning for this module only.+fakeSettings :: Settings+fakeSettings =+ Settings+ { sGhcNameVersion = GhcNameVersion "ghc" cProjectVersion,+ sFileSettings = FileSettings {},+ sTargetPlatform = genericPlatform,+ sPlatformMisc = PlatformMisc {},+ sToolSettings = ToolSettings {toolSettings_opt_P_fingerprint = fingerprint0}+ }
+ src/Hpgsql/LanguageHaskell/ParseHaskellExpression.hs view
@@ -0,0 +1,399 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE PackageImports #-}+{- FOURMOLU_DISABLE -} -- CPP macros make fourmolu fail++module Hpgsql.LanguageHaskell.ParseHaskellExpression (parseHaskellExpression, isValidHaskellExpression) where++import Data.Char (isUpper)+import Data.Either (isRight)+import qualified Data.List as List+import Data.Foldable (toList)+import Data.Maybe (mapMaybe)+import GHC.Data.FastString (mkFastString, unpackFS)+import GHC.Data.StringBuffer (stringToStringBuffer)+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Session (DynFlags, defaultDynFlags, xopt_set)+import GHC.Hs (GhcPs)+import GHC.Parser (parseExpression)+import GHC.Parser.Lexer (P (..), ParseResult (..), initParserState)+import GHC.Parser.PostProcess (ECP (..), runPV)+import GHC.Types.Basic (Boxity (..))+import GHC.Types.Name (nameOccName)+import GHC.Types.Name.Occurrence (occNameString)+import GHC.Types.Name.Reader (RdrName (..))+import GHC.Types.SourceText (IntegralLit (..), rationalFromFractionalLit)+import GHC.Types.SrcLoc (GenLocated (..), mkRealSrcLoc)+import Hpgsql.LanguageHaskell.GhcParserOpts (fakeSettings)+import Hpgsql.LanguageHaskell.FromThExtension (fromThToGhcLibExtension)+import Language.Haskell.Syntax (FieldOcc (..), GRHS (..), GRHSs (..), HsBindLR (..), HsConDetails (..), HsConPatDetails, HsFieldBind (..), HsLit (..), HsLocalBinds, HsLocalBindsLR (..), HsOverLit (..), HsRecFields (..), HsSigType (..), HsTupArg (..), HsType (..), HsValBindsLR (..), HsWildCardBndrs (..), LHsExpr, LHsRecField, LHsSigWcType, LMatch, LPat, Match (..), MatchGroup (..), OverLitVal (..), Pat (..), PromotionFlag (..))+import Language.Haskell.Syntax.Basic (FieldLabelString (..))+import Language.Haskell.Syntax.Expr (DotFieldOcc (..), HsExpr (..))+import Language.Haskell.Syntax.Module.Name (moduleNameString)+import qualified "template-haskell" Language.Haskell.TH as TH++-- | Parse a Haskell expression string into a Template Haskell Exp.+parseHaskellExpression :: [TH.Extension] -> String -> Either String TH.Exp+parseHaskellExpression callerExtensions str = do+ hsExpr <- ghcParse callerExtensions str+ convertExpr hsExpr++-- | Check if a string can be parsed as a Haskell expression.+isValidHaskellExpression :: [TH.Extension] -> String -> Bool+-- NOTE: This uses `ghcParse` instead of `parseHaskellExpression` on purpose.+-- The reasoning is if we find a valid Haskell expression inside+-- a quasiquoter, we want to parse it as a Haskell expression.+-- If later on we don't support converting that to template-haskell,+-- that's hpgsql's limitation and we want a good error to be thrown+-- to the user, which `parseHaskellExpression` will do.+-- And we don't want to mislead our quasiquoter parser into skipping+-- a valid Haskell expression inside #{} or ^{} just because hpgsql+-- can't convert it to TH: best to fail loud and clear.+isValidHaskellExpression callerExtensions = isRight . ghcParse callerExtensions++ghcParse :: [TH.Extension] -> String -> Either String (HsExpr GhcPs)+ghcParse callerExtensions str =+ let buf = stringToStringBuffer str+ loc = mkRealSrcLoc (mkFastString "<hpgsql>") 1 1+ opts = initParserOpts parserDynFlags+ parseExprP = parseExpression >>= \ecp -> runPV (unECP ecp)+ in case unP parseExprP (initParserState opts buf loc) of+ POk _ (L _ expr) -> Right expr+ PFailed _ -> Left "Failed to parse Haskell expression"+ where+ parserDynFlags :: DynFlags+ parserDynFlags =+ List.foldl'+ xopt_set+ (defaultDynFlags fakeSettings)+ (mapMaybe fromThToGhcLibExtension callerExtensions)++--+-- GHC HsExpr to TH Exp conversion++convertExpr :: HsExpr GhcPs -> Either String TH.Exp+convertExpr (HsVar _ (L _ rdr)) = Right (rdrToExp rdr)+convertExpr (HsApp _ (L _ f) (L _ x)) = TH.AppE <$> convertExpr f <*> convertExpr x+convertExpr (OpApp _ (L _ l) (L _ op) (L _ r)) = do+ l' <- convertExpr l+ op' <- convertExpr op+ r' <- convertExpr r+ Right (TH.UInfixE l' op' r')+convertExpr (NegApp _ (L _ e) _) = do+ e' <- convertExpr e+ Right $ TH.AppE (TH.VarE 'negate) e'++#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertExpr (HsPar _ (L _ e)) = TH.ParensE <$> convertExpr e+#elif MIN_VERSION_ghc_lib_parser(9,8,0)+convertExpr (HsPar _ _ (L _ e) _) = TH.ParensE <$> convertExpr e+#endif+convertExpr (ExplicitList _ es) = TH.ListE <$> traverse (\(L _ e) -> convertExpr e) es+convertExpr (ExplicitTuple _ args boxity) = do+ args' <- traverse convertTupArg args+ Right+ ( case boxity of+ Boxed -> TH.TupE args'+ Unboxed -> TH.UnboxedTupE args'+ )+convertExpr (SectionL _ (L _ e) (L _ op)) = do+ e' <- convertExpr e+ op' <- convertExpr op+ Right (TH.InfixE (Just e') op' Nothing)+convertExpr (SectionR _ (L _ op) (L _ e)) = do+ op' <- convertExpr op+ e' <- convertExpr e+ Right (TH.InfixE Nothing op' (Just e'))+convertExpr (HsIf _ (L _ c) (L _ t) (L _ f)) = do+ c' <- convertExpr c+ t' <- convertExpr t+ f' <- convertExpr f+ Right (TH.CondE c' t' f')+convertExpr (HsLit _ lit) = TH.LitE <$> convertHsLit lit+convertExpr (HsOverLit _ ol) = TH.LitE <$> convertOverLit ol+convertExpr (ExprWithTySig _ (L _ e) sigWcTy) = do+ e' <- convertExpr e+ ty' <- convertSigWcType sigWcTy+ Right (TH.SigE e' ty')+convertExpr (HsGetField _ (L _ e) (L _ (DotFieldOcc _ (L _ fld)))) = do+ e' <- convertExpr e+ Right (TH.GetFieldE e' (fieldLabelToString fld))+#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertExpr (HsProjection _ flds) =+ Right (TH.ProjectionE (fmap (\(DotFieldOcc _ (L _ fld)) -> fieldLabelToString fld) flds))+#elif MIN_VERSION_ghc_lib_parser(9,8,0)+convertExpr (HsProjection _ flds) =+ Right (TH.ProjectionE (fmap (\(L _ (DotFieldOcc _ (L _ fld))) -> fieldLabelToString fld) flds))+#endif+#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertExpr (HsAppType _ (L _ e) (HsWC _ (L _ ty))) = TH.AppTypeE <$> convertExpr e <*> convertType ty+#else+convertExpr (HsAppType _ (L _ e) _ (HsWC _ (L _ ty))) = TH.AppTypeE <$> convertExpr e <*> convertType ty+#endif+#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertExpr (RecordCon _ (L _ conName) (HsRecFields _ flds _)) = do+ flds' <- traverse convertRecField flds+ Right $ TH.RecConE (rdrToName conName) flds'+#elif MIN_VERSION_ghc_lib_parser(9,8,0)+convertExpr (RecordCon _ (L _ conName) (HsRecFields flds _)) = do+ flds' <- traverse convertRecField flds+ Right $ TH.RecConE (rdrToName conName) flds'+#endif+convertExpr (HsCase _ (L _ caseExpr) mg) = TH.CaseE <$> convertExpr caseExpr <*> convertMatchGroup mg+#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertExpr (HsLet _ localBinds (L _ body)) = do+#else+convertExpr (HsLet _ _ localBinds _ (L _ body)) = do+#endif+ decs <- convertLocalBinds localBinds+ body' <- convertExpr body+ Right (TH.LetE decs body')++-- Now come our list of unsupported language features+#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertExpr (HsEmbTy {}) = unsupportedLanguageFeatureMsg "Embedded type"+convertExpr (HsForAll {}) = unsupportedLanguageFeatureMsg "Forall-types"+convertExpr (HsFunArr {}) = unsupportedLanguageFeatureMsg "Function types"+convertExpr (HsQual {}) = unsupportedLanguageFeatureMsg "HsQual"+#else+convertExpr (HsLamCase {}) = unsupportedLanguageFeatureMsg "LambdaCase"+convertExpr (HsRecSel {}) = unsupportedLanguageFeatureMsg "Record field selectors"+#endif+convertExpr (HsUnboundVar {}) = unsupportedLanguageFeatureMsg "Unbound variables/holes"+convertExpr (HsOverLabel {}) = unsupportedLanguageFeatureMsg "Overloaded labels"+convertExpr (HsIPVar {}) = unsupportedLanguageFeatureMsg "Implicit parameters"+convertExpr (HsLam {}) = unsupportedLanguageFeatureMsg "Lambda"+convertExpr (ExplicitSum {}) = unsupportedLanguageFeatureMsg "Unboxed sums"+convertExpr (HsMultiIf {}) = unsupportedLanguageFeatureMsg "Multi-way if"+convertExpr (HsDo {}) = unsupportedLanguageFeatureMsg "Do notation"+convertExpr (RecordUpd {}) = unsupportedLanguageFeatureMsg "Record updates"+convertExpr (ArithSeq {}) = unsupportedLanguageFeatureMsg "Arithmetic sequences"+convertExpr (HsTypedBracket {}) = unsupportedLanguageFeatureMsg "Typed Template Haskell brackets"+convertExpr (HsUntypedBracket {}) = unsupportedLanguageFeatureMsg "Untyped Template Haskell brackets"+convertExpr (HsTypedSplice {}) = unsupportedLanguageFeatureMsg "Typed Template Haskell splices"+convertExpr (HsUntypedSplice {}) = unsupportedLanguageFeatureMsg "Untyped Template Haskell splices"+convertExpr (HsProc {}) = unsupportedLanguageFeatureMsg "Arrow proc notation"+convertExpr (HsStatic {}) = unsupportedLanguageFeatureMsg "Static pointers"+convertExpr (HsPragE {}) = unsupportedLanguageFeatureMsg "Pragma"++unsupportedLanguageFeatureMsg :: String -> Either String a+unsupportedLanguageFeatureMsg feat = Left $ feat ++ " expressions are unsupported in hpgsql's SQL quasi-quoter. You can usually assign your expression to a binding outside the quasi-quoter and keep only that binding inside, but do raise an issue at https://github.com/mzabani/hpgsql/issues if you want this to be supported."++convertMatchGroup :: MatchGroup GhcPs (LHsExpr GhcPs) -> Either String [TH.Match]+convertMatchGroup (MG _ (L _ matches)) = traverse convertMatch matches++convertMatch :: LMatch GhcPs (LHsExpr GhcPs) -> Either String TH.Match+#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertMatch (L _ (Match _ _ (L _ pats) grhss)) = do+#else+convertMatch (L _ (Match _ _ pats grhss)) = do+#endif+ pats' <- traverse (\(L _ p) -> convertPat p) pats+ (body, decs) <- convertGRHSs grhss+ case pats' of+ [pat] -> Right (TH.Match pat body decs)+ _ -> unsupportedLanguageFeatureMsg "Multi-pattern matches"++convertGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> Either String (TH.Body, [TH.Dec])+convertGRHSs (GRHSs _ grhss localBinds) = do+ decs <- convertLocalBinds localBinds+ body <- case grhss of+ [L _ (GRHS _ [] (L _ e))] -> TH.NormalB <$> convertExpr e+ _ -> unsupportedLanguageFeatureMsg "Guarded case alternative"+ Right (body, decs)++convertLocalBinds :: HsLocalBinds GhcPs -> Either String [TH.Dec]+convertLocalBinds (EmptyLocalBinds _) = Right []+convertLocalBinds (HsValBinds _ (ValBinds _ binds _sigs)) =+ traverse (\(L _ b) -> convertBind b) (toList binds)+convertLocalBinds (HsValBinds _ (XValBindsLR {})) =+ unsupportedLanguageFeatureMsg "XValBindsLR"+convertLocalBinds (HsIPBinds {}) = unsupportedLanguageFeatureMsg "HsIPBinds"++convertBind :: HsBindLR GhcPs GhcPs -> Either String TH.Dec+convertBind FunBind { fun_id = L _ name, fun_matches = MG _ (L _ matches) } = do+ clauses <- traverse convertClause matches+ Right (TH.FunD (rdrToName name) clauses)+convertBind PatBind { pat_lhs = L _ pat, pat_rhs = grhss } = do+ pat' <- convertPat pat+ (body, decs) <- convertGRHSs grhss+ Right (TH.ValD pat' body decs)+convertBind (VarBind{}) = unsupportedLanguageFeatureMsg "VarBind"+convertBind (PatSynBind{}) = unsupportedLanguageFeatureMsg "Pattern Synonyms bindings"++convertClause :: LMatch GhcPs (LHsExpr GhcPs) -> Either String TH.Clause+#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertClause (L _ (Match _ _ (L _ pats) grhss)) = do+#else+convertClause (L _ (Match _ _ pats grhss)) = do+#endif+ pats' <- traverse (\(L _ p) -> convertPat p) pats+ (body, decs) <- convertGRHSs grhss+ Right (TH.Clause pats' body decs)++-- Pattern conversion (GHC Pat to TH Pat)++convertPat :: Pat GhcPs -> Either String TH.Pat+convertPat (WildPat _) = Right TH.WildP+convertPat (VarPat _ (L _ rdr)) = Right (TH.VarP (rdrToName rdr))+convertPat (LitPat _ lit) = TH.LitP <$> convertHsLit lit+convertPat (NPat _ (L _ ol) _ _) = TH.LitP <$> convertOverLit ol+#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertPat (ConPat _ (L _ con) details) = convertConPatDetails con details+#elif MIN_VERSION_ghc_lib_parser(9,8,0)+convertPat (ConPat _ (L _ con) details) = convertConPatDetails con details+#endif+convertPat (TuplePat _ pats boxity) = do+ pats' <- traverse (\(L _ p) -> convertPat p) pats+ Right $ case boxity of+ Boxed -> TH.TupP pats'+ Unboxed -> TH.UnboxedTupP pats'+convertPat (ListPat _ pats) = TH.ListP <$> traverse (\(L _ p) -> convertPat p) pats+#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertPat (ParPat _ (L _ p)) = TH.ParensP <$> convertPat p+convertPat (AsPat _ (L _ rdr) (L _ p)) = TH.AsP (rdrToName rdr) <$> convertPat p+#elif MIN_VERSION_ghc_lib_parser(9,8,0)+convertPat (ParPat _ _ (L _ p) _) = TH.ParensP <$> convertPat p+convertPat (AsPat _ (L _ rdr) _ (L _ p)) = TH.AsP (rdrToName rdr) <$> convertPat p+#endif+convertPat (BangPat _ (L _ p)) = TH.BangP <$> convertPat p+-- Unsupported pattern matching expressions+convertPat (LazyPat{}) = unsupportedLanguageFeatureMsg "LazyPat in pattern matching"+convertPat (ViewPat{}) = unsupportedLanguageFeatureMsg "ViewPat in pattern matching"+convertPat (SumPat{}) = unsupportedLanguageFeatureMsg "SumPat in pattern matching"+convertPat (SplicePat{}) = unsupportedLanguageFeatureMsg "SplicePat in pattern matching"+convertPat (SigPat{}) = unsupportedLanguageFeatureMsg "SigPat in pattern matching"+convertPat (NPlusKPat{}) = unsupportedLanguageFeatureMsg "NPlusKPat in pattern matching"+#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertPat (EmbTyPat{}) = unsupportedLanguageFeatureMsg "EmbTyPat in pattern matching"+convertPat (InvisPat{}) = unsupportedLanguageFeatureMsg "InvisPat in pattern matching"+convertPat (OrPat{}) = unsupportedLanguageFeatureMsg "OrPat in pattern matching"+#endif++convertConPatDetails :: RdrName -> HsConPatDetails GhcPs -> Either String TH.Pat+convertConPatDetails con (PrefixCon tyArgs args) = do+ args' <- traverse (\(L _ p) -> convertPat p) args+ if null tyArgs+ then Right (TH.ConP (rdrToName con) [] args')+ else unsupportedLanguageFeatureMsg "Type applications in constructor patterns"+convertConPatDetails con (InfixCon (L _ l) (L _ r)) = do+ l' <- convertPat l+ r' <- convertPat r+ Right (TH.InfixP l' (rdrToName con) r')+#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertConPatDetails con (RecCon (HsRecFields _ flds _)) = do+ flds' <- traverse convertPatRecField flds+ Right (TH.RecP (rdrToName con) flds')+#elif MIN_VERSION_ghc_lib_parser(9,8,0)+convertConPatDetails con (RecCon (HsRecFields flds _)) = do+ flds' <- traverse convertPatRecField flds+ Right (TH.RecP (rdrToName con) flds')+#endif++convertPatRecField :: LHsRecField GhcPs (LPat GhcPs) -> Either String TH.FieldPat+convertPatRecField (L _ (HsFieldBind _ (L _ (FieldOcc _ (L _ rdr))) (L _ pat) _)) = do+ pat' <- convertPat pat+ Right (rdrToName rdr, pat')++-- Helper functions++rdrToExp :: RdrName -> TH.Exp+rdrToExp rdr =+ let name = rdrToName rdr+ in if isConstructorName name then TH.ConE name else TH.VarE name++rdrToName :: RdrName -> TH.Name+rdrToName (Unqual occ) = TH.mkName (occNameString occ)+rdrToName (Qual modN occ) = TH.mkName (moduleNameString modN ++ "." ++ occNameString occ)+rdrToName (Orig _ occ) = TH.mkName (occNameString occ)+rdrToName (Exact name) = TH.mkName (occNameString (nameOccName name))++isConstructorName :: TH.Name -> Bool+isConstructorName n = case TH.nameBase n of+ (c : _) -> isUpper c || c == ':'+ _ -> False++fieldLabelToString :: FieldLabelString -> String+fieldLabelToString (FieldLabelString fs) = unpackFS fs++convertRecField :: LHsRecField GhcPs (LHsExpr GhcPs) -> Either String (TH.Name, TH.Exp)+convertRecField (L _ (HsFieldBind _ (L _ (FieldOcc _ (L _ rdr))) (L _ expr) _)) = do+ expr' <- convertExpr expr+ Right (rdrToName rdr, expr')++convertTupArg :: HsTupArg GhcPs -> Either String (Maybe TH.Exp)+convertTupArg (Present _ (L _ e)) = Just <$> convertExpr e+convertTupArg (Missing _) = Right Nothing++convertHsLit :: HsLit GhcPs -> Either String TH.Lit+convertHsLit (HsChar _ c) = Right (TH.CharL c)+convertHsLit (HsString _ fs) = Right (TH.StringL (unpackFS fs))+convertHsLit (HsInt _ il) = Right (TH.IntegerL (il_value il))+convertHsLit (HsIntPrim _ i) = Right (TH.IntPrimL i)+convertHsLit (HsWordPrim _ w) = Right (TH.WordPrimL w)+convertHsLit (HsFloatPrim _ fl) = Right (TH.FloatPrimL (rationalFromFractionalLit fl))+convertHsLit (HsDoublePrim _ fl) = Right (TH.DoublePrimL (rationalFromFractionalLit fl))+#if MIN_VERSION_ghc_lib_parser(9,10,0)+convertHsLit (HsMultilineString _ fs) = Right (TH.StringL (unpackFS fs))+#endif+convertHsLit (HsCharPrim {}) = unsupportedLanguageFeatureMsg "HsCharPrim literal"+convertHsLit (HsStringPrim {}) = unsupportedLanguageFeatureMsg "HsStringPrim literal"+convertHsLit (HsInt8Prim {}) = unsupportedLanguageFeatureMsg "HsInt8Prim literal"+convertHsLit (HsInt16Prim {}) = unsupportedLanguageFeatureMsg "HsInt16Prim literal"+convertHsLit (HsInt32Prim {}) = unsupportedLanguageFeatureMsg "HsInt32Prim literal"+convertHsLit (HsInt64Prim {}) = unsupportedLanguageFeatureMsg "HsInt64Prim literal"+convertHsLit (HsWord8Prim {}) = unsupportedLanguageFeatureMsg "HsWord8Prim literal"+convertHsLit (HsWord16Prim {}) = unsupportedLanguageFeatureMsg "HsWord16Prim literal"+convertHsLit (HsWord32Prim {}) = unsupportedLanguageFeatureMsg "HsWord32Prim literal"+convertHsLit (HsWord64Prim {}) = unsupportedLanguageFeatureMsg "HsWord64Prim literal"+convertHsLit (HsInteger {}) = unsupportedLanguageFeatureMsg "HsInteger literal"+convertHsLit (HsRat {}) = unsupportedLanguageFeatureMsg "HsRat literal"++convertOverLit :: HsOverLit GhcPs -> Either String TH.Lit+convertOverLit ol = case ol_val ol of+ HsIntegral il -> Right (TH.IntegerL (il_value il))+ HsFractional fl -> Right (TH.RationalL (rationalFromFractionalLit fl))+ HsIsString _ fs -> Right (TH.StringL (unpackFS fs))++-- Type conversion (GHC HsType to TH Type)++convertSigWcType :: LHsSigWcType GhcPs -> Either String TH.Type+convertSigWcType (HsWC _ (L _ (HsSig _ _ (L _ ty)))) = convertType ty++convertType :: HsType GhcPs -> Either String TH.Type+convertType (HsTyVar _ promo (L _ rdr)) =+ let name = rdrToName rdr+ in Right $ case promo of+ IsPromoted -> TH.PromotedT name+ NotPromoted+ | isConstructorName name -> TH.ConT name+ | otherwise -> TH.VarT name+convertType (HsAppTy _ (L _ t1) (L _ t2)) =+ TH.AppT <$> convertType t1 <*> convertType t2+convertType (HsListTy _ (L _ t)) =+ TH.AppT TH.ListT <$> convertType t+convertType (HsTupleTy _ _ ts) = do+ ts' <- traverse (\(L _ t) -> convertType t) ts+ let n = length ts'+ Right (foldl TH.AppT (TH.TupleT n) ts')+convertType (HsFunTy _ _ (L _ t1) (L _ t2)) =+ TH.AppT . TH.AppT TH.ArrowT <$> convertType t1 <*> convertType t2+convertType (HsParTy _ (L _ t)) =+ convertType t+convertType (HsQualTy _ _ (L _ t)) =+ convertType t+convertType (HsForAllTy{}) = unsupportedLanguageFeatureMsg "HsForAllTy in a type"+convertType (HsAppKindTy{}) = unsupportedLanguageFeatureMsg "HsAppKindTy in a type"+convertType (HsOpTy{}) = unsupportedLanguageFeatureMsg "HsOpTy in a type"+convertType (HsSumTy{}) = unsupportedLanguageFeatureMsg "HsSumTy in a type"+convertType (HsIParamTy{}) = unsupportedLanguageFeatureMsg "HsIParamTy in a type"+convertType (HsStarTy{}) = unsupportedLanguageFeatureMsg "HsStarTy in a type"+convertType (HsKindSig{}) = unsupportedLanguageFeatureMsg "HsKindSig in a type"+convertType (HsSpliceTy{}) = unsupportedLanguageFeatureMsg "HsSpliceTy in a type"+convertType (HsDocTy{}) = unsupportedLanguageFeatureMsg "HsDocTy in a type"+convertType (HsBangTy{}) = unsupportedLanguageFeatureMsg "HsBangTy in a type"+convertType (HsRecTy{}) = unsupportedLanguageFeatureMsg "HsRecTy in a type"+convertType (HsExplicitListTy{}) = unsupportedLanguageFeatureMsg "HsExplicitListTy in a type"+convertType (HsExplicitTupleTy{}) = unsupportedLanguageFeatureMsg "HsExplicitTupleTy in a type"+convertType (HsTyLit{}) = unsupportedLanguageFeatureMsg "HsTyLit in a type"+convertType (HsWildCardTy{}) = unsupportedLanguageFeatureMsg "HsWildCardTy in a type"+convertType (XHsType{}) = unsupportedLanguageFeatureMsg "XHsType in a type"
src/Hpgsql/Msgs.hs view
@@ -1,6 +1,7 @@ module Hpgsql.Msgs (AuthenticationResponse (..), AuthenticationMethod (..), BackendKeyData (..), Bind (..), BindComplete (..), CancelRequest (..), CommandComplete (..), CopyData (..), CopyDone (..), CopyFail (..), CopyInResponse (..), DataRow (..), Describe (..), ErrorDetail (..), ErrorResponse (..), Execute (..), Flush (..), NoData (..), ParameterStatus (..), Query (..), ReadyForQuery (..), RowDescription (..), SASLInitialResponse (..), SASLResponse (..), StartupMessage (..), ToPgMessage (..), FromPgMessage (..), PgMsgParser (..), Terminate (..), TransactionStatus (..), NoticeResponse (..), NotificationResponse (..), Parse (..), ParseComplete (..), PasswordMessage (..), Sync (..), parsePgMessage, nulTermCString) where import Control.Applicative (Alternative (..))+import Control.Arrow (Kleisli (..)) import Control.Monad (replicateM) import qualified Crypto.Hash as Crypto import qualified Data.Attoparsec.ByteString as Parsec@@ -17,12 +18,12 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromMaybe, mapMaybe)-import qualified Data.Serialize as Cereal import Data.Text (Text) import Data.Text.Encoding (decodeASCII, decodeUtf8, encodeUtf8) import Data.Word (Word8) import Hpgsql.Builder (BinaryField, Builder, builderLength) import qualified Hpgsql.Builder as Builder+import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Hpgsql.InternalTypes (BindComplete (..), CommandComplete (..), CopyInResponse (..), DataRow (..), ErrorDetail (..), ErrorResponse (..), NoData (..), NotificationResponse (..), ParseComplete (..), ReadyForQuery (..), RowDescription (..), TransactionStatus (..)) import Hpgsql.ScramSHA256 (ScramClientFinalMessage (..), ScramServerFirstMessage (..)) import Hpgsql.TypeInfo (Oid (..))@@ -33,21 +34,14 @@ newtype PgMsgParser a = PgMsgParser ( Char ->- -- \| Message contents after the Int32 length attribute+ -- \| Full PG message contents, including the message identifier byte, the rest-of-message length and the message contents. LBS.ByteString -> Maybe a ) deriving stock (Functor)--instance Applicative PgMsgParser where- pure a = PgMsgParser $ \_ _ -> Just a-- -- TODO: Is this Applicative correct? Double-check laws- PgMsgParser f <*> PgMsgParser p = PgMsgParser $ \c r -> f c r <*> p c r--instance Alternative PgMsgParser where- empty = PgMsgParser $ \_ _ -> Nothing- PgMsgParser p1 <|> PgMsgParser p2 = PgMsgParser $ \c restOfMsg -> p1 c restOfMsg <|> p2 c restOfMsg+ -- Kleisli m a is a newtype over 'a -> m b', so two nested Kleislis are exactly+ -- this parser's shape, and both instances lift pointwise into Maybe.+ deriving (Applicative, Alternative) via (Kleisli (Kleisli Maybe LBS.ByteString) Char) class FromPgMessage a where msgParser :: PgMsgParser a@@ -60,7 +54,7 @@ colName <- nulTerminatedCStringParser -- Column name as C string void $ Parsec.take (4 + 2) -- TODO: OIDs are unsigned integers! Try `select (-1)::oid` to see. Change to UInt32 somehow- typOid <- either fail pure . Cereal.decode @Int32 =<< Parsec.take 4+ typOid <- either fail pure . BinSer.decodeInt32BE 0 =<< Parsec.take 4 void $ Parsec.take (2 + 4 + 2) pure (colName, Oid (fromIntegral typOid)) @@ -143,8 +137,8 @@ deriving stock (Show) instance FromPgMessage AuthenticationResponse where- msgParser = PgMsgParser $ \c restOfMsg -> case c of- 'R' -> case first (Cereal.decodeLazy @Int32) $ LBS.splitAt 4 restOfMsg of+ msgParser = PgMsgParser $ \c (LBS.drop 5 -> restOfMsg) -> case c of+ 'R' -> case first (BinSer.decodeInt32BE 0 . LBS.toStrict) $ LBS.splitAt 4 restOfMsg of (Right 0, _) -> Just $ AuthenticationResponse AuthOk (Right 2, _) -> Just $ AuthenticationResponse AuthKerberosV5 (Right 3, _) -> Just $ AuthenticationResponse AuthCleartextPassword@@ -160,19 +154,19 @@ _ -> Nothing instance FromPgMessage BackendKeyData where- msgParser = PgMsgParser $ \c (LBS.splitAt 4 -> (pidBS, backendSecretKey)) -> case c of- 'K' -> case Cereal.decodeLazy @Int32 pidBS of+ msgParser = PgMsgParser $ \c (LBS.splitAt 4 . LBS.drop 5 -> (pidBS, backendSecretKey)) -> case c of+ 'K' -> case BinSer.decodeInt32BE 0 $ LBS.toStrict pidBS of Right pid -> Just $ BackendKeyData {backendPid = pid, backendSecretKey = LBS.toStrict backendSecretKey} Left _ -> Nothing _ -> Nothing instance FromPgMessage BindComplete where- msgParser = PgMsgParser $ \c _restOfMsg -> case c of+ msgParser = PgMsgParser $ \c _ -> case c of '2' -> Just BindComplete _ -> Nothing instance FromPgMessage CommandComplete where- msgParser = PgMsgParser $ \c restOfMsg -> case c of+ msgParser = PgMsgParser $ \c (LBS.drop 5 -> restOfMsg) -> case c of 'C' -> let astext = decodeASCII $ LBS.toStrict $ LBS.dropEnd 1 restOfMsg in case TextParsec.parseOnly ((ins <|> del <|> upd <|> merge <|> sel <|> move <|> fetch <|> copy) <* TextParsec.endOfInput) astext of@@ -230,8 +224,8 @@ _ -> Nothing instance FromPgMessage DataRow where- msgParser = PgMsgParser $ \c !restOfMsg -> case c of- 'D' -> Just $ DataRow {rowColumnData = LBS.toStrict $ LBS.drop 2 restOfMsg}+ msgParser = PgMsgParser $ \c !fullDataRow -> case c of+ 'D' -> Just $ DataRow {fullDataRow = LBS.toStrict fullDataRow} _ -> Nothing instance FromPgMessage NoData where@@ -240,7 +234,7 @@ _ -> Nothing instance FromPgMessage ParameterStatus where- msgParser = PgMsgParser $ \c !restOfMsg -> case c of+ msgParser = PgMsgParser $ \c !(LBS.drop 5 -> restOfMsg) -> case c of 'S' -> case LazyParsec.parseOnly (((,) <$> nulTerminatedCStringParser <*> nulTerminatedCStringParser) <* Parsec.endOfInput) restOfMsg of Left _ -> error "Failed parsing ParameterStatus" Right (parameterName, parameterValue) -> Just $ ParameterStatus {..}@@ -354,18 +348,18 @@ Builder.int32BE (4 + contentsLen) <> contents instance FromPgMessage ReadyForQuery where- msgParser = PgMsgParser $ \c restOfMsg -> case (c, restOfMsg) of+ msgParser = PgMsgParser $ \c (LBS.drop 5 -> restOfMsg) -> case (c, restOfMsg) of ('Z', "I") -> Just $ ReadyForQuery TransIdle ('Z', "T") -> Just $ ReadyForQuery TransInTrans ('Z', "E") -> Just $ ReadyForQuery TransInError _ -> Nothing instance FromPgMessage RowDescription where- msgParser = PgMsgParser $ \c restOfMsg ->+ msgParser = PgMsgParser $ \c (LBS.drop 5 -> restOfMsg) -> if c == 'T' then let (numColsBS, colContents) = LBS.splitAt 2 restOfMsg- numCols = either error id $ Cereal.decodeLazy @Int16 numColsBS+ numCols = either error id $ BinSer.decodeInt16BE 0 $ LBS.toStrict numColsBS allColOidsParser :: Parsec.Parser [(Text, Oid)] allColOidsParser = replicateM (fromIntegral numCols) colParser in case LazyParsec.parseOnly (allColOidsParser <* Parsec.endOfInput) colContents of@@ -374,7 +368,7 @@ else Nothing instance FromPgMessage ErrorResponse where- msgParser = PgMsgParser $ \c restOfMsg ->+ msgParser = PgMsgParser $ \c (LBS.drop 5 -> restOfMsg) -> if c /= 'E' then Nothing else@@ -390,7 +384,7 @@ in Just $ ErrorResponse $ Map.fromList $ mapMaybe parseSingleErrorField errorFields instance FromPgMessage NoticeResponse where- msgParser = PgMsgParser $ \c restOfMsg ->+ msgParser = PgMsgParser $ \c (LBS.drop 5 -> restOfMsg) -> if c /= 'N' then Nothing else@@ -407,12 +401,12 @@ in Just $ NoticeResponse $ Map.fromList $ mapMaybe parseSingleErrorField errorFields instance FromPgMessage NotificationResponse where- msgParser = PgMsgParser $ \c restOfMsg ->+ msgParser = PgMsgParser $ \c (LBS.drop 5 -> restOfMsg) -> if c /= 'A' then Nothing else let (notifierPidBs, channelNameAndPayload) = LBS.splitAt 4 restOfMsg- notifierPid = either error id $ Cereal.decodeLazy @Int32 notifierPidBs+ notifierPid = either error id $ BinSer.decodeInt32BE 0 $ LBS.toStrict notifierPidBs in case LazyParsec.parseOnly ((NotificationResponse notifierPid <$> nulTerminatedCStringParser <*> nulTerminatedCStringParser) <* Parsec.endOfInput) channelNameAndPayload of
src/Hpgsql/Networking.hs view
@@ -34,11 +34,11 @@ socketWaitWrite :: Socket -> IO () socketWaitWrite socket = withFdSocket socket (threadWaitWrite . fromIntegral) -recvNonBlocking :: Socket -> CSize -> IO ByteString-recvNonBlocking s nbytes = withFdSocket s $ \fd -> createAndTrim (fromIntegral nbytes) $ \buffer -> do+recvNonBlocking :: Socket -> Int -> IO ByteString+recvNonBlocking s nbytes = withFdSocket s $ \fd -> createAndTrim nbytes $ \buffer -> do -- Largely copied from https://hackage-content.haskell.org/package/network-3.2.8.0/docs/src/Network.Socket.Buffer.html#recvBufNoWait and other functions from the network library, -- but then modified to our needs.- r <- c_recv fd (castPtr buffer) nbytes 0 {-flags-}+ r <- c_recv fd (castPtr buffer) (fromIntegral nbytes) 0 {-flags-} if r >= 0 then do -- putStrLn $ "Asked for " ++ show nbytes ++ ", got " ++ show r
src/Hpgsql/ParsingInternal.hs view
@@ -1,6 +1,9 @@+{-# LANGUAGE PackageImports #-}+ -- | -- -- This module contains parsers that are helpful to separate SQL statements from each other by finding query boundaries: semi-colons, but not when inside a string or a parenthesised expression, for example.+-- It also parses SQL inside quasi-quoters with the typical #{} and ^{} Haskell expressions. module Hpgsql.ParsingInternal ( parseSql, BlockOrNotBlock (..),@@ -36,7 +39,8 @@ import qualified Data.List.NonEmpty as NE import Data.Text (Text) import qualified Data.Text as Text-import Language.Haskell.Meta.Parse (parseExp)+import Hpgsql.LanguageHaskell.ParseHaskellExpression (isValidHaskellExpression)+import "template-haskell" Language.Haskell.TH (Extension) import Prelude hiding (takeWhile) data BlockOrNotBlock = StaticSql !Text | DollarNumberedArg !Int | QuestionMarkArg | QuasiQuoterExpression !QQExprKind !Text | SemiColon | CommentsOrWhitespace !Text@@ -45,7 +49,7 @@ data QQExprKind = QQInterpolation | QQEmbeddedQuery deriving stock (Eq, Show) -data ParsingOpts = AcceptQuestionMarksAsQueryArgs | AcceptOnlyDollarNumberedArgs | AcceptQuasiQuoterExpressions+data ParsingOpts = AcceptQuestionMarksAsQueryArgs | AcceptOnlyDollarNumberedArgs | AcceptQuasiQuoterExpressions [Extension] deriving stock (Show) -- | Parses one or more SQL statements (separated by semi-colons).@@ -106,7 +110,7 @@ -- This seems fragile, but our tests will error out if changes make this unsupported. (: []) <$> ( case popts of- AcceptQuasiQuoterExpressions -> quasiQuoterExpressionParser+ AcceptQuasiQuoterExpressions callerExtensions -> quasiQuoterExpressionParser callerExtensions _ -> fail "No quasiquoter expressions" ) <|> (: []) <$> parseStdConformingString@@ -148,26 +152,26 @@ || c == '?' || ( case popts of- AcceptQuasiQuoterExpressions -> c == '#' || c == '^'+ AcceptQuasiQuoterExpressions _ -> c == '#' || c == '^' _ -> False ) -quasiQuoterExpressionParser :: Parser BlockOrNotBlock-quasiQuoterExpressionParser = do+quasiQuoterExpressionParser :: [Extension] -> Parser BlockOrNotBlock+quasiQuoterExpressionParser callerExtensions = do prefix <- string "#{" <|> string "^{" let kind = if prefix == "#{" then QQInterpolation else QQEmbeddedQuery expr <- findExpressionEnd "" pure $ QuasiQuoterExpression kind expr where- -- Scan for '}' left-to-right, trying parseExp at each one.- -- The first '}' where parseExp succeeds is the expression boundary.+ -- Scan for '}' left-to-right, trying isValidHaskellExpression at each one.+ -- The first '}' where isValidHaskellExpression succeeds is the expression boundary. findExpressionEnd acc = do chunk <- takeWhile (/= '}') void $ char '}' let candidate = acc <> chunk- case parseExp (Text.unpack candidate) of- Right _ -> pure candidate- Left _ -> findExpressionEnd (candidate <> "}")+ if isValidHaskellExpression callerExtensions (Text.unpack candidate)+ then pure candidate+ else findExpressionEnd (candidate <> "}") dollarNumberedQueryArgParser :: Parser BlockOrNotBlock dollarNumberedQueryArgParser = do
src/Hpgsql/QueryInternal.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE PackageImports #-}+ module Hpgsql.QueryInternal ( Query (..), SingleQuery (..),@@ -20,11 +22,11 @@ import Hpgsql.Builder (BinaryField) import Hpgsql.Encoding (FieldEncoder (..), RowEncoder (..), ToPgField (..), ToPgRow (..)) import Hpgsql.InternalTypes (Query (..), SingleQuery (..), SingleQueryFragment (..), breakQueryIntoStatements, renumberParamsFrom)+import Hpgsql.LanguageHaskell.ParseHaskellExpression (parseHaskellExpression) import Hpgsql.ParsingInternal (BlockOrNotBlock (..), ParsingOpts (..), QQExprKind (..), blockText, flattenBlocks, parseSql) import Hpgsql.TypeInfo (EncodingContext, Oid)-import Language.Haskell.Meta.Parse (parseExp)-import Language.Haskell.TH import Language.Haskell.TH.Quote+import "template-haskell" Language.Haskell.TH (Exp (..), Q, extsEnabled, integerL, litE, stringL) -- | A useful representation for our quasiquoter parsing. data SqlFragment@@ -128,7 +130,9 @@ sql :: QuasiQuoter sql = QuasiQuoter- { quoteExp = liftQuery False . parseSql AcceptQuasiQuoterExpressions . Text.pack,+ { quoteExp = \qqSqlString -> do+ exts <- extsEnabled+ liftQuery False $ parseSql (AcceptQuasiQuoterExpressions exts) $ Text.pack qqSqlString, quotePat = error "Hpgsql's sql quasiquoter does not implement quotePat", quoteType = error "Hpgsql's sql quasiquoter does not implement quoteType", quoteDec = error "Hpgsql's sql quasiquoter does not implement quoteDec"@@ -139,7 +143,9 @@ sqlPrep :: QuasiQuoter sqlPrep = QuasiQuoter- { quoteExp = liftQuery True . parseSql AcceptQuasiQuoterExpressions . Text.pack,+ { quoteExp = \qqSqlString -> do+ exts <- extsEnabled+ liftQuery True $ parseSql (AcceptQuasiQuoterExpressions exts) $ Text.pack qqSqlString, quotePat = error "Hpgsql's sql quasiquoter does not implement quotePat", quoteType = error "Hpgsql's sql quasiquoter does not implement quoteType", quoteDec = error "Hpgsql's sql quasiquoter does not implement quoteDec"@@ -174,16 +180,18 @@ fragmentToPartExp :: SqlFragment -> Q Exp fragmentToPartExp (NonInterpolatedSqlFragment t) = [|StaticSqlPart $(litE (stringL (Text.unpack t)))|]-fragmentToPartExp (InterpolatedHaskellExpr haskellExpr) =- case parseExp (Text.unpack haskellExpr) of+fragmentToPartExp (InterpolatedHaskellExpr haskellExpr) = do+ exts <- extsEnabled+ case parseHaskellExpression exts (Text.unpack haskellExpr) of Left err -> error $ "Could not parse Haskell expression '" ++ Text.unpack haskellExpr ++ "': " ++ err Right expr -> [|ParamPart (encodeParam $(pure expr))|] fragmentToPartExp SemiColonFragment = [|SemiColonPart|] fragmentToPartExp (WhitespaceOrCommentsFragment t) = [|WhitespaceOrCommenstPart $(litE (stringL (Text.unpack t)))|]-fragmentToPartExp (EmbeddedQueryExpr haskellExpr) =- case parseExp (Text.unpack haskellExpr) of+fragmentToPartExp (EmbeddedQueryExpr haskellExpr) = do+ exts <- extsEnabled+ case parseHaskellExpression exts (Text.unpack haskellExpr) of Left err -> error $ "Could not parse Haskell expression '" ++ Text.unpack haskellExpr ++ "': " ++ err Right expr -> [|EmbeddedQueryPart $(pure expr)|] @@ -249,8 +257,9 @@ -- | Generate a parameter expression for a captured variable generateParamExp :: Text -> Q Exp-generateParamExp (Text.unpack -> haskellExpr) =- case parseExp haskellExpr of+generateParamExp (Text.unpack -> haskellExpr) = do+ exts <- extsEnabled+ case parseHaskellExpression exts haskellExpr of Left err -> error $ "Could not parse Haskell expression '" ++ haskellExpr ++ "': " ++ err Right expr -> [|encodeParam $(pure expr)|]
src/Hpgsql/SimpleParser.hs view
@@ -3,8 +3,12 @@ -- and perform better than attoparsec, at least the way we use it in -- hpgsql. ----- In benchmarks, this can improve performance by 12-15% materializing--- query results.+-- In benchmarks, this improved performance by 12-15% materializing+-- query results when it was introduced.+-- With the INLINE pragma in RowDecoder's Applicative's (<*>), GHC's+-- inliner was finally able to make full use of continuation passing,+-- and performance was improved by another ~14.3%, with total memory+-- allocations reduced by ~6%. module Hpgsql.SimpleParser ( Parser (..), ParseResult (..),@@ -14,11 +18,20 @@ match, parseMany, matchLeftUnconsumed,+ takeInt16BE,+ takeInt32BE,+ takeInt64BE,+ takeDataRow,+ parseManyRows,+ skip, ) where import Data.ByteString (ByteString) import qualified Data.ByteString as BS+import Data.Int (Int16, Int32, Int64)+import Hpgsql.Encoding.BinarySerializer (ByteStringIdx (..))+import qualified Hpgsql.Encoding.BinarySerializer as BinSer import Prelude hiding (take) data ParseResult a@@ -30,98 +43,155 @@ newtype Parser a = Parser { unParser :: forall r.+ ByteStringIdx -> ByteString -> (String -> r) -> -- \^ failure continuation- (a -> ByteString -> r) ->- -- \^ success continuation, taking left-unparsed ByteString and parsed value+ (a -> ByteStringIdx -> ByteString -> r) ->+ -- \^ success continuation, taking original or new ByteString, the index into the original/new bytestring of the first yet-unparsed byte, and parsed value r } instance Functor Parser where- fmap f (Parser p) = Parser $ \bs kf ks ->- p bs kf (\a bs' -> ks (f a) bs')+ fmap f (Parser p) = Parser $ \idx bs kf ks ->+ p idx bs kf (\a bs' -> ks (f a) bs') {-# INLINE fmap #-} instance Applicative Parser where- pure a = Parser $ \bs _ ks -> ks a bs+ pure a = Parser $ \idx bs _ ks -> ks a idx bs {-# INLINE pure #-} - Parser pf <*> Parser pa = Parser $ \bs kf ks ->- pf bs kf (\f bs' -> pa bs' kf (\a bs'' -> ks (f a) bs''))+ Parser pf <*> Parser pa = Parser $ \idx bs kf ks ->+ pf idx bs kf (\f bs' idx' -> pa bs' idx' kf (\a bs'' idx'' -> ks (f a) bs'' idx'')) {-# INLINE (<*>) #-} instance Monad Parser where return = pure {-# INLINE return #-} - Parser p >>= k = Parser $ \bs kf ks ->- p bs kf (\a bs' -> unParser (k a) bs' kf ks)+ Parser p >>= k = Parser $ \idx bs kf ks ->+ p idx bs kf (\a bs' idx' -> unParser (k a) bs' idx' kf ks) {-# INLINE (>>=) #-} instance MonadFail Parser where- fail msg = Parser $ \_ kf _ -> kf msg+ fail msg = Parser $ \_ _ kf _ -> kf msg {-# INLINE fail #-} -- | Run a parser and return either an error message or the parsed value, -- using the strict 'ParseResult' type. Any unconsumed trailing input is -- discarded. parseOnly :: Parser a -> ByteString -> ParseResult a-parseOnly (Parser p) bs = p bs ParseFail (\a _ -> ParseOk a)+parseOnly p = parseOnlyOffset p 0 {-# INLINE parseOnly #-} +-- | Run a parser and return either an error message or the parsed value,+-- using the strict 'ParseResult' type. Any unconsumed trailing input is+-- discarded.+parseOnlyOffset :: Parser a -> ByteStringIdx -> ByteString -> ParseResult a+parseOnlyOffset (Parser p) idx bs = p idx bs ParseFail (\a _ _ -> ParseOk a)+{-# INLINE parseOnlyOffset #-}+ -- | Consume exactly @n@ bytes of input, failing if fewer than @n@ bytes -- remain. take :: Int -> Parser ByteString-take n = Parser $ \bs kf ks ->- -- Special-casing n>0 helps reduce memory usage- -- by ~1.5% in our benchmarks without a measurable- -- difference in run time- if n > 0- then- if BS.length bs >= n- then case BS.splitAt n bs of- (!h, !t) -> ks h t- else kf ("take: wanted " <> show n <> " bytes but only " <> show (BS.length bs) <> " remain")- else- ks mempty bs+take n = Parser $ \idx bs kf ks ->+ let skip' = n + idx.idx+ in if BS.length bs >= skip'+ then case BS.take n $ BS.drop idx.idx bs of+ -- Strict on the bytestring because we're pretty sure+ -- the field decoder will need to evaluate this anyway,+ -- so no need for an extra thunk+ !h -> ks h (ByteStringIdx skip') bs+ else kf "take: insufficient bytes" {-# INLINE take #-} +-- | Consume exactly @n@ bytes of input, failing if fewer than @n@ bytes+-- remain.+skip :: Int -> Parser ()+skip n = Parser $ \idx bs _ ks ->+ ks () (ByteStringIdx $ idx.idx + n) bs+{-# INLINE skip #-}++{-# INLINE takeInt16BE #-}+takeInt16BE :: Parser Int16+takeInt16BE = Parser $ \idx bs kf ks ->+ case BinSer.decodeInt16BE idx bs of+ Left err -> kf err+ Right v -> ks v (idx + 2) bs++{-# INLINE takeInt32BE #-}+takeInt32BE :: Parser Int32+takeInt32BE = Parser $ \idx bs kf ks ->+ case BinSer.decodeInt32BE idx bs of+ Left err -> kf err+ Right v -> ks v (idx + 4) bs++{-# INLINE takeInt64BE #-}+takeInt64BE :: Parser Int64+takeInt64BE = Parser $ \idx bs kf ks ->+ case BinSer.decodeInt64BE idx bs of+ Left err -> kf err+ Right v -> ks v (idx + 8) bs++{-# INLINE takeDataRow #-}++-- | A specialized parser to parse a postgres DataRow,+-- returning the index of the byte after this DataRow's last.+takeDataRow :: Parser ByteStringIdx+takeDataRow = Parser $ \idx bs kf ks ->+ case BinSer.decodeDataRow idx bs of+ Left err -> kf err+ Right idxRest -> ks idxRest idxRest bs+ parseMany :: Parser a -> Parser [a]-parseMany p = Parser $ \bs' _kf ks -> let (vs, rest) = go bs' in ks vs rest+parseMany p = Parser $ \idx' bs' _kf ks -> let (vs, restIdx) = go idx' bs' in ks vs restIdx bs' where- go bs = case parseOnly (matchLeftUnconsumed p) bs of- ParseOk (unconsumed, v) -> let (vs, rest) = go unconsumed in (v : vs, rest)- ParseFail _ -> ([], bs)+ go idx bs = case parseOnlyOffset (matchLeftUnconsumed p) idx bs of+ ParseOk (unconsumedIdx, v) -> let (vs, rest) = go unconsumedIdx bs in (v : vs, rest)+ ParseFail _ -> ([], idx) {-# INLINE parseMany #-} +-- | Parses as many PG rows as there are available, returns+-- the index/offset of the first left-unparsed byte and the+-- number of rows parsed.+parseManyRows :: Parser (ByteStringIdx, Int)+parseManyRows = Parser $ \idx' bs' _kf ks -> let (restIdx, nParsed) = go idx' bs' 0 in ks (restIdx, nParsed) restIdx bs'+ where+ go idx bs !nParsedSoFar = case parseOnlyOffset takeDataRow idx bs of+ ParseOk unconsumedIdx -> go unconsumedIdx bs (nParsedSoFar + 1)+ ParseFail _ -> (idx, nParsedSoFar)+{-# INLINE parseManyRows #-}+ -- | Succeeds only when the input has been fully consumed. endOfInput :: Parser ()-endOfInput = Parser $ \bs kf ks ->- if BS.null bs then ks () bs else kf "endOfInput: input remaining"+endOfInput = Parser $ \idx bs kf ks ->+ if BS.length bs <= idx.idx then ks () idx bs else kf "endOfInput: input remaining" {-# INLINE endOfInput #-} -- | Run a parser and additionally return the slice of input it consumed. -- Because the input is a strict 'ByteString', the returned slice is a view -- over the original buffer and allocates no extra memory. match :: Parser a -> Parser (ByteString, a)-match (Parser p) = Parser $ \bs kf ks ->+match (Parser p) = Parser $ \idx bs kf ks -> p+ idx bs kf- ( \a bs' ->- let !consumed = BS.take (BS.length bs - BS.length bs') bs- in ks (consumed, a) bs'+ ( \a idx' bs' ->+ let !consumed = BS.take (idx'.idx - idx.idx) $ BS.drop idx.idx bs+ in ks (consumed, a) idx' bs' ) {-# INLINE match #-} --- | Run a parser and additionally return the unconsumed/unparsed ByteString.-matchLeftUnconsumed :: Parser a -> Parser (ByteString, a)-matchLeftUnconsumed (Parser p) = Parser $ \bs kf ks ->+-- | Run a parser and additionally return the index to the first unconsumed/unparsed byte+-- in the supplied ByteString.+matchLeftUnconsumed :: Parser a -> Parser (ByteStringIdx, a)+matchLeftUnconsumed (Parser p) = Parser $ \idx bs kf ks -> p+ idx bs kf- ( \a bs' ->- ks (bs', a) bs'+ ( \a idx' bs' ->+ ks (idx', a) idx' bs' ) {-# INLINE matchLeftUnconsumed #-}
src/Hpgsql/Types.hs view
@@ -17,7 +17,7 @@ import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Lazy as LBS import Data.Tuple.Only (Only (..))-import Data.Typeable (Proxy (..), Typeable)+import Data.Typeable (Proxy (..)) import Hpgsql.Builder (BinaryField (..)) import Hpgsql.Encoding (FieldDecoder (..), FieldEncoder (..), FieldInfo (..), FromPgField (..), FromPgRow (..), RowEncoder (..), ToPgField (..), ToPgRow (..), arrayField, toPgVectorField) import Hpgsql.TypeInfo (EncodingContext (..), TypeInfo (..), jsonOid, jsonbOid, lookupTypeByOid)@@ -101,7 +101,8 @@ -- into your type (from either json or jsonb), and to encode -- to jsonb. newtype Aeson a = Aeson {getAeson :: a}- deriving (Eq, Show, Read, Typeable, Functor)+ deriving stock (Functor, Read, Show)+ deriving newtype (Eq) instance (FromJSON a) => FromPgField (Aeson a) where fieldDecoder =