pqi-native 1.0.1.0 → 1.0.1.1
raw patch · 4 files changed
+144/−45 lines, 4 filesdep +Win32dep ~pqi-conformancePVP ok
version bump matches the API change (PVP)
Dependencies added: Win32
Dependency ranges changed: pqi-conformance
API changes (from Hackage documentation)
Files
- CHANGELOG.md +8/−0
- pqi-native.cabal +8/−3
- src/library/Pqi/Native/Connection.hs +88/−32
- src/library/Pqi/Native/Query.hs +40/−10
CHANGELOG.md view
@@ -1,3 +1,11 @@+# v1.0.1.1++## Fixes++- Builds on Windows: socket I/O and signal handling now branch on the host OS, selecting `Win32` in place of `unix`.++- Fixed a pipelined `sendPrepare` stealing the preceding `sendQueryParams`' `ParseComplete`, which produced a spurious `CommandOk` and shifted every later result by one. ParseComplete messages are now charged to the command that produced them via a per-command FIFO (#3).+ # v1.0.1.0 ## Non-breaking
pqi-native.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: pqi-native-version: 1.0.1.0+version: 1.0.1.1 category: Database, PostgreSQL synopsis: Native (pure-Haskell) adapter for pqi description:@@ -143,8 +143,13 @@ pqi-native:transport, ptr-peeker ^>=0.2, ptr-poker ^>=0.1.3,- unix >=2.7 && <2.9, + if !os(windows)+ build-depends: unix >=2.7 && <2.9++ if os(windows)+ build-depends: Win32 >=2.6 && <2.15+ test-suite native-test import: test type: exitcode-stdio-1.0@@ -153,5 +158,5 @@ build-depends: base >=4.11 && <5, hspec >=2.11 && <2.12,- pqi-conformance ^>=1.0,+ pqi-conformance ^>=1.0.2.0, pqi-native,
src/library/Pqi/Native/Connection.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ -- | The native connection: its mutable state, conninfo parsing, the -- startup\/authentication handshake, and the interleave-aware receive loop that -- the higher-level query code is built on.@@ -19,6 +21,7 @@ import qualified Data.ByteString as ByteString import qualified Data.ByteString.Char8 as ByteString.Char8 import qualified Data.Map.Strict as Map+import qualified Data.Sequence as Seq import qualified Data.Set as Set import Pqi (ConnStatus (..), Notify (..), PipelineStatus (..), Verbosity (..)) import qualified Pqi.Native.Auth as Auth@@ -29,7 +32,11 @@ import Pqi.Native.Types (formatErrorFields) import qualified PtrPoker.Write as Poker import System.Environment (lookupEnv)+#if defined(mingw32_HOST_OS)+import System.Win32.Info.Computer (getUserName)+#else import System.Posix.User (getEffectiveUserName)+#endif -- | Parsed connection parameters (the @key=value@ subset we support). data ConnInfo = ConnInfo@@ -47,28 +54,56 @@ -- | Parse a conninfo string in either @key=value@ or @postgresql:\/\/@ URI -- format. Unquoted key=value values only; URI values are percent-decoded.--- @.pgpass@ is not supported. When @user@ is omitted it is resolved like libpq--- (see 'defaultUser'), which is why this lives in 'IO'.-parseConnInfo :: ByteString -> IO ConnInfo-parseConnInfo raw = do- dfltUser <- defaultUser- pure- if- | "postgresql://" `ByteString.isPrefixOf` raw -> parseUri dfltUser (ByteString.drop 13 raw)- | "postgres://" `ByteString.isPrefixOf` raw -> parseUri dfltUser (ByteString.drop 11 raw)- | otherwise -> parseKeyValue dfltUser raw+-- @.pgpass@ is not supported.+--+-- The @dfltUser@ argument is the already-resolved default user (see+-- 'resolveDefaultUser'), used whenever the conninfo omits @user@. It is passed+-- in explicitly because resolving it is the one IO effect this otherwise-pure+-- parser needs.+parseConnInfo :: ByteString -> ByteString -> ConnInfo+parseConnInfo raw dfltUser =+ if+ | "postgresql://" `ByteString.isPrefixOf` raw -> parseUri dfltUser (ByteString.drop 13 raw)+ | "postgres://" `ByteString.isPrefixOf` raw -> parseUri dfltUser (ByteString.drop 11 raw)+ | otherwise -> parseKeyValue dfltUser raw -- | Resolve the default @user@ the way libpq does (@conninfo_add_defaults@ / -- @pg_fe_getauthname@ in @fe-connect.c@): the @PGUSER@ environment variable if -- set and non-empty, otherwise the operating-system login name--- (@getpwuid(geteuid())->pw_name@ on Unix).-defaultUser :: IO ByteString-defaultUser = do+-- (@getpwuid(geteuid())->pw_name@ on Unix, @GetUserName@ on Windows).+--+-- Returns @Left msg@ if neither is available. Mirroring libpq, a lookup failure+-- must be surfaced by the caller as a 'ConnectionBad' connection (see+-- 'establish') rather than attempting to connect.+resolveDefaultUser :: IO (Either String ByteString)+resolveDefaultUser = do pguser <- lookupEnv "PGUSER" case pguser of- Just u | not (null u) -> pure (ByteString.Char8.pack u)- _ -> ByteString.Char8.pack <$> getEffectiveUserName+ Just u | not (null u) -> pure (Right (ByteString.Char8.pack u))+ _ -> do+ result <- try @SomeException (ByteString.Char8.pack <$> platformUserName)+ pure case result of+ Right name -> Right name+ Left err -> Left (platformUserNameLookupFailureMessage <> ": " <> show err) +-- | The operating-system login name, via the same call libpq uses:+-- 'getEffectiveUserName' (@getpwuid(geteuid())@) on Unix, 'getUserName'+-- (@GetUserName@) on Windows.+platformUserName :: IO String+#if defined(mingw32_HOST_OS)+platformUserName = getUserName+#else+platformUserName = getEffectiveUserName+#endif++#if defined(mingw32_HOST_OS)+platformUserNameLookupFailureMessage :: String+platformUserNameLookupFailureMessage = "user name lookup failure"+#else+platformUserNameLookupFailureMessage :: String+platformUserNameLookupFailureMessage = "could not look up local user name"+#endif+ parseKeyValue :: ByteString -> ByteString -> ConnInfo parseKeyValue dfltUser raw = ConnInfo@@ -198,10 +233,18 @@ pipelineSeparatorPending :: IORef Bool, pendingSyncs :: IORef Int, pendingCommands :: IORef Int,- -- | Count of standalone @Parse@ messages sent in pipeline mode (each from- -- 'sendPrepare'), for which only @ParseComplete@ (no @CommandComplete@) is- -- expected as a terminal response.- pendingParses :: IORef Int,+ -- | FIFO, one entry per in-flight pipeline command that sends a @Parse@+ -- ('sendQueryParams' or 'sendPrepare'), recording whether that command's+ -- @ParseComplete@ is itself the terminal result. 'sendPrepare' pushes+ -- @True@ (its @ParseComplete@ ends the command as 'CommandOk');+ -- 'sendQueryParams' pushes @False@ (its @ParseComplete@ must fold into the+ -- command's accumulating result, like every other extended-protocol+ -- message, and never terminate it early). Popping the head at the right+ -- @ParseComplete@ keeps the origins in order even when several commands are+ -- pipelined together - a plain counter cannot, which is what let a+ -- pipelined 'sendPrepare' steal the 'ParseComplete' of an earlier+ -- 'sendQueryParams' and shift every later result by one.+ pendingParseOrigins :: IORef (Seq.Seq Bool), errorVerbosity :: IORef Verbosity, -- | The SQL text of the most recently sent query (set by sendQuery / -- sendQueryParams). Used when formatting error messages for async results@@ -255,28 +298,41 @@ -- message, and run the authentication\/startup handshake. Like libpq, a failed -- connection (whether due to a network error or a rejected handshake) yields a -- 'ConnectionBad' connection rather than throwing.+-- | Open a connection: resolve the default user, resolve and connect the+-- socket, send the startup message, and run the authentication\/startup+-- handshake. Like libpq, a failed connection - whether due to a user-name+-- lookup failure, a network error or a rejected handshake - yields a+-- 'ConnectionBad' connection rather than throwing. establish :: ByteString -> IO Connection establish conninfo = do- info <- parseConnInfo conninfo- transportResult <- try @IOException (Transport.connect (host info) (port info))- case transportResult of- Left err -> do+ userResult <- resolveDefaultUser+ case userResult of+ Left message -> do transport <- Transport.unconnected- connection <- newConnection False transport info- setError connection ("could not connect to server: " <> ByteString.Char8.pack (show err))- pure connection- Right transport -> do- connection <- newConnection False transport info- sendMessage connection (startupMessage (startupParams info))- handshake connection+ connection <- newConnection False transport (parseConnInfo conninfo "")+ setError connection (ByteString.Char8.pack message) pure connection+ Right dfltUser -> do+ let info = parseConnInfo conninfo dfltUser+ transportResult <- try @IOException (Transport.connect (host info) (port info))+ case transportResult of+ Left err -> do+ transport <- Transport.unconnected+ connection <- newConnection False transport info+ setError connection ("could not connect to server: " <> ByteString.Char8.pack (show err))+ pure connection+ Right transport -> do+ connection <- newConnection False transport info+ sendMessage connection (startupMessage (startupParams info))+ handshake connection+ pure connection -- | A \"null\" sentinel connection (the analogue of @PQnewNullConnection@): no -- live socket, permanently in the 'ConnectionBad' state. nullConnection :: IO Connection nullConnection = do transport <- Transport.unconnected- info <- parseConnInfo ""+ let info = parseConnInfo "" "" conn <- newConnection True transport info writeIORef (lastError conn) (Just "connection pointer is NULL\n") pure conn@@ -323,7 +379,7 @@ <*> newIORef False <*> newIORef 0 <*> newIORef 0- <*> newIORef 0+ <*> newIORef Seq.empty <*> newIORef ErrorsDefault <*> newIORef ""
src/library/Pqi/Native/Query.hs view
@@ -18,6 +18,7 @@ where import qualified Data.Map.Strict as Map+import qualified Data.Sequence as Seq import Pqi (ConnStatus (..), ExecStatus (..), Format (..), PipelineStatus (..)) import Pqi.Native.Connection import Pqi.Native.Prelude@@ -112,10 +113,17 @@ sendQueryParams :: Connection -> ByteString -> [Maybe (Word32, ByteString, Format)] -> Format -> IO Bool sendQueryParams connection sql params resultFormat = do pipeline <- inPipeline connection- sendAsync connection sql- $ if pipeline- then asyncParamsWrite sql params resultFormat- else paramsWrite sql params resultFormat+ ok <-+ sendAsync connection sql+ $ if pipeline+ then asyncParamsWrite sql params resultFormat+ else paramsWrite sql params resultFormat+ -- 'sendQueryParams' drives the extended protocol and so always sends an+ -- unnamed @Parse@, whose @ParseComplete@ must fold into this command's own+ -- result (like 'sendQueryPrepared'). Record its origin so it is not mistaken+ -- for the terminal @ParseComplete@ of a pipelined 'sendPrepare'.+ when (ok && pipeline) $ modifyIORef' (pendingParseOrigins connection) (Seq.|> False)+ pure ok sendPrepare :: Connection -> ByteString -> ByteString -> Maybe [Word32] -> IO Bool sendPrepare connection name sql parameterTypes = do@@ -125,7 +133,7 @@ $ if pipeline then parseMessage name sql (fromMaybe [] parameterTypes) else prepareWrite name sql parameterTypes- when (ok && pipeline) $ modifyIORef' (pendingParses connection) (+ 1)+ when (ok && pipeline) $ modifyIORef' (pendingParseOrigins connection) (Seq.|> True) pure ok sendQueryPrepared :: Connection -> ByteString -> [Maybe (ByteString, Format)] -> Format -> IO Bool@@ -217,13 +225,21 @@ pure (Just (NativeResult SingleTuple (accFields builder) [values] Nothing Map.empty [] "")) else go singleRow builder {accRevRows = values : (accRevRows builder)} ParseComplete -> do- parses <- readIORef (pendingParses connection)- if parses > 0 && pipeStatus /= PipelineOff- then do- modifyIORef' (pendingParses connection) (subtract 1)+ -- Charge the @ParseComplete@ to the command that produced it by+ -- popping the oldest recorded origin. Only a 'sendPrepare' origin+ -- (@True@) terminates the command as 'CommandOk'; a 'sendQueryParams'+ -- origin (@False@) folds into the accumulating result, and so does a+ -- @ParseComplete@ seen outside pipeline mode (e.g. a non-pipelined+ -- async 'sendQueryParams', whose result is collected by 'collectExtended').+ origin <-+ if pipeStatus /= PipelineOff+ then popPendingParseOrigin connection+ else pure Nothing+ case origin of+ Just True -> do finishCommand pipeStatus pure (Just (NativeResult CommandOk [] [] Nothing Map.empty [] ""))- else go singleRow builder {accHadResponse = True}+ _ -> go singleRow builder {accHadResponse = True} BindComplete -> go singleRow builder {accHadResponse = True} CloseComplete ->@@ -281,6 +297,20 @@ when (remaining == 0) $ writeIORef (asyncPending connection) False pure (Just (NativeResult PipelineSync [] [] Nothing Map.empty [] "")) _ -> go singleRow builder++-- | Pop the origin of the next in-flight @ParseComplete@ in pipeline mode:+-- @True@ if it is the terminal @ParseComplete@ of a 'sendPrepare' (to be+-- materialized as 'CommandOk'), @False@ if it belongs to a 'sendQueryParams'+-- and must fold into that command's accumulating result. @Nothing@ when no+-- @Parse@ is pending (defensive: the @ParseComplete@ is then folded).+popPendingParseOrigin :: Connection -> IO (Maybe Bool)+popPendingParseOrigin connection =+ atomicModifyIORef'+ (pendingParseOrigins connection)+ ( \queue -> case Seq.viewl queue of+ origin Seq.:< rest -> (rest, Just origin)+ Seq.EmptyL -> (queue, Nothing)+ ) -- | Describe a prepared statement. describePrepared :: Connection -> ByteString -> IO (Maybe NativeResult)