diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/pqi-native.cabal b/pqi-native.cabal --- a/pqi-native.cabal +++ b/pqi-native.cabal @@ -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, diff --git a/src/library/Pqi/Native/Connection.hs b/src/library/Pqi/Native/Connection.hs --- a/src/library/Pqi/Native/Connection.hs +++ b/src/library/Pqi/Native/Connection.hs @@ -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 "" diff --git a/src/library/Pqi/Native/Query.hs b/src/library/Pqi/Native/Query.hs --- a/src/library/Pqi/Native/Query.hs +++ b/src/library/Pqi/Native/Query.hs @@ -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)