diff --git a/hasql.cabal b/hasql.cabal --- a/hasql.cabal +++ b/hasql.cabal @@ -1,7 +1,7 @@ name: hasql version: - 0.19.14 + 0.19.15 category: Hasql, Database, PostgreSQL synopsis: @@ -46,24 +46,24 @@ default-language: Haskell2010 other-modules: - Hasql.Prelude - Hasql.PTI + Hasql.Private.Prelude + Hasql.Private.PTI Hasql.Private.IO Hasql.Private.Query Hasql.Private.Session Hasql.Private.Connection Hasql.Private.PreparedStatementRegistry - Hasql.Settings - Hasql.Commands - Hasql.Decoders.Array - Hasql.Decoders.Composite - Hasql.Decoders.Value - Hasql.Decoders.Row - Hasql.Decoders.Result - Hasql.Decoders.Results - Hasql.Encoders.Array - Hasql.Encoders.Value - Hasql.Encoders.Params + Hasql.Private.Settings + Hasql.Private.Commands + Hasql.Private.Decoders.Array + Hasql.Private.Decoders.Composite + Hasql.Private.Decoders.Value + Hasql.Private.Decoders.Row + Hasql.Private.Decoders.Result + Hasql.Private.Decoders.Results + Hasql.Private.Encoders.Array + Hasql.Private.Encoders.Value + Hasql.Private.Encoders.Params exposed-modules: Hasql.Decoders Hasql.Encoders @@ -80,7 +80,7 @@ bytestring-tree-builder >= 0.2.5 && < 0.3, -- data: dlist >= 0.7 && < 0.9, - aeson >= 0.7 && < 0.12, + aeson >= 0.7 && < 2, uuid == 1.3.*, vector >= 0.10 && < 0.12, time >= 1.4 && < 2, diff --git a/library/Hasql/Commands.hs b/library/Hasql/Commands.hs deleted file mode 100644 --- a/library/Hasql/Commands.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Hasql.Commands -( - Commands, - asBytes, - setEncodersToUTF8, - setMinClientMessagesToWarning, -) -where - -import Hasql.Prelude -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy.Builder as BB -import qualified Data.ByteString.Lazy.Builder.ASCII as BB -import qualified Data.ByteString.Lazy as BL - - -newtype Commands = - Commands (DList BB.Builder) - deriving (Monoid) - -instance Semigroup Commands - -asBytes :: Commands -> ByteString -asBytes (Commands list) = - BL.toStrict $ BB.toLazyByteString $ foldMap (<> BB.char7 ';') $ list - -setEncodersToUTF8 :: Commands -setEncodersToUTF8 = - Commands (pure "SET client_encoding = 'UTF8'") - -setMinClientMessagesToWarning :: Commands -setMinClientMessagesToWarning = - Commands (pure "SET client_min_messages TO WARNING") diff --git a/library/Hasql/Connection.hs b/library/Hasql/Connection.hs --- a/library/Hasql/Connection.hs +++ b/library/Hasql/Connection.hs @@ -13,4 +13,4 @@ where import Hasql.Private.Connection -import Hasql.Settings +import Hasql.Private.Settings diff --git a/library/Hasql/Decoders.hs b/library/Hasql/Decoders.hs --- a/library/Hasql/Decoders.hs +++ b/library/Hasql/Decoders.hs @@ -58,17 +58,17 @@ ) where -import Hasql.Prelude hiding (maybe, bool) +import Hasql.Private.Prelude hiding (maybe, bool) import qualified Data.Aeson as Aeson import qualified Data.Vector as Vector import qualified PostgreSQL.Binary.Decoder as Decoder -import qualified Hasql.Decoders.Results as Results -import qualified Hasql.Decoders.Result as Result -import qualified Hasql.Decoders.Row as Row -import qualified Hasql.Decoders.Value as Value -import qualified Hasql.Decoders.Array as Array -import qualified Hasql.Decoders.Composite as Composite -import qualified Hasql.Prelude as Prelude +import qualified Hasql.Private.Decoders.Results as Results +import qualified Hasql.Private.Decoders.Result as Result +import qualified Hasql.Private.Decoders.Row as Row +import qualified Hasql.Private.Decoders.Value as Value +import qualified Hasql.Private.Decoders.Array as Array +import qualified Hasql.Private.Decoders.Composite as Composite +import qualified Hasql.Private.Prelude as Prelude -- * Result diff --git a/library/Hasql/Decoders/Array.hs b/library/Hasql/Decoders/Array.hs deleted file mode 100644 --- a/library/Hasql/Decoders/Array.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Hasql.Decoders.Array where - -import Hasql.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Decoder as Decoder - - -newtype Array a = - Array (ReaderT Bool Decoder.ArrayDecoder a) - deriving (Functor) - -{-# INLINE run #-} -run :: Array a -> Bool -> Decoder.Decoder a -run (Array imp) env = - Decoder.array (runReaderT imp env) - -{-# INLINE dimension #-} -dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b -dimension replicateM (Array imp) = - Array $ ReaderT $ \env -> Decoder.arrayDimension replicateM (runReaderT imp env) - -{-# INLINE value #-} -value :: (Bool -> Decoder.Decoder a) -> Array (Maybe a) -value decoder' = - Array $ ReaderT $ Decoder.arrayValue . decoder' - -{-# INLINE nonNullValue #-} -nonNullValue :: (Bool -> Decoder.Decoder a) -> Array a -nonNullValue decoder' = - Array $ ReaderT $ Decoder.arrayNonNullValue . decoder' - diff --git a/library/Hasql/Decoders/Composite.hs b/library/Hasql/Decoders/Composite.hs deleted file mode 100644 --- a/library/Hasql/Decoders/Composite.hs +++ /dev/null @@ -1,26 +0,0 @@ -module Hasql.Decoders.Composite where - -import Hasql.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Decoder as Decoder - - -newtype Composite a = - Composite (ReaderT Bool Decoder.CompositeDecoder a) - deriving (Functor, Applicative, Monad) - -{-# INLINE run #-} -run :: Composite a -> Bool -> Decoder.Decoder a -run (Composite imp) env = - Decoder.composite (runReaderT imp env) - -{-# INLINE value #-} -value :: (Bool -> Decoder.Decoder a) -> Composite (Maybe a) -value decoder' = - Composite $ ReaderT $ Decoder.compositeValue . decoder' - -{-# INLINE nonNullValue #-} -nonNullValue :: (Bool -> Decoder.Decoder a) -> Composite a -nonNullValue decoder' = - Composite $ ReaderT $ Decoder.compositeNonNullValue . decoder' - diff --git a/library/Hasql/Decoders/Result.hs b/library/Hasql/Decoders/Result.hs deleted file mode 100644 --- a/library/Hasql/Decoders/Result.hs +++ /dev/null @@ -1,232 +0,0 @@ -module Hasql.Decoders.Result where - -import Hasql.Prelude hiding (maybe, many) -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Hasql.Decoders.Row as Row -import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec -import qualified Data.ByteString as ByteString -import qualified Hasql.Prelude as Prelude -import qualified Data.Vector as Vector -import qualified Data.Vector.Mutable as MutableVector - - -newtype Result a = - Result (ReaderT (Bool, LibPQ.Result) (EitherT Error IO) a) - deriving (Functor, Applicative, Monad) - -data Error = - -- | - -- An error reported by the DB. Code, message, details, hint. - -- - -- * The SQLSTATE code for the error. The SQLSTATE code identifies the type of error that has occurred; - -- it can be used by front-end applications to perform specific operations (such as error handling) - -- in response to a particular database error. - -- For a list of the possible SQLSTATE codes, see Appendix A. - -- This field is not localizable, and is always present. - -- - -- * The primary human-readable error message (typically one line). Always present. - -- - -- * Detail: an optional secondary error message carrying more detail about the problem. - -- Might run to multiple lines. - -- - -- * Hint: an optional suggestion what to do about the problem. - -- This is intended to differ from detail in that it offers advice (potentially inappropriate) - -- rather than hard facts. Might run to multiple lines. - ServerError !ByteString !ByteString !(Maybe ByteString) !(Maybe ByteString) | - -- | - -- The database returned an unexpected result. - -- Indicates an improper statement or a schema mismatch. - UnexpectedResult !Text | - -- | - -- An error of the row reader, preceded by the index of the row. - RowError !Int !Row.Error | - -- | - -- An unexpected amount of rows. - UnexpectedAmountOfRows !Int - deriving (Show) - -{-# INLINE run #-} -run :: Result a -> (Bool, LibPQ.Result) -> IO (Either Error a) -run (Result reader) env = - runEitherT (runReaderT reader env) - -{-# INLINE unit #-} -unit :: Result () -unit = - checkExecStatus $ \case - LibPQ.CommandOk -> True - LibPQ.TuplesOk -> True - _ -> False - -{-# INLINE rowsAffected #-} -rowsAffected :: Result Int64 -rowsAffected = - do - checkExecStatus $ \case - LibPQ.CommandOk -> True - _ -> False - Result $ ReaderT $ \(_, result) -> EitherT $ - LibPQ.cmdTuples result & fmap cmdTuplesReader - where - cmdTuplesReader = - notNothing >=> notEmpty >=> decimal - where - notNothing = - Prelude.maybe (Left (UnexpectedResult "No bytes")) Right - notEmpty bytes = - if ByteString.null bytes - then Left (UnexpectedResult "Empty bytes") - else Right bytes - decimal bytes = - mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $ - Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes - -{-# INLINE checkExecStatus #-} -checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result () -checkExecStatus predicate = - {-# SCC "checkExecStatus" #-} - do - status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result - unless (predicate status) $ do - case status of - LibPQ.BadResponse -> serverError - LibPQ.NonfatalError -> serverError - LibPQ.FatalError -> serverError - _ -> Result $ lift $ EitherT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status) - -{-# INLINE serverError #-} -serverError :: Result () -serverError = - Result $ ReaderT $ \(_, result) -> EitherT $ do - code <- - fmap (fromMaybe ($bug "No code")) $ - LibPQ.resultErrorField result LibPQ.DiagSqlstate - message <- - fmap (fromMaybe ($bug "No message")) $ - LibPQ.resultErrorField result LibPQ.DiagMessagePrimary - detail <- - LibPQ.resultErrorField result LibPQ.DiagMessageDetail - hint <- - LibPQ.resultErrorField result LibPQ.DiagMessageHint - pure $ Left $ ServerError code message detail hint - -{-# INLINE maybe #-} -maybe :: Row.Row a -> Result (Maybe a) -maybe rowDec = - do - checkExecStatus $ \case - LibPQ.TuplesOk -> True - _ -> False - Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do - maxRows <- LibPQ.ntuples result - case maxRows of - 0 -> return (Right Nothing) - 1 -> do - maxCols <- LibPQ.nfields result - fmap (fmap Just . mapLeft (RowError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) - _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) - where - rowToInt (LibPQ.Row n) = - fromIntegral n - intToRow = - LibPQ.Row . fromIntegral - -{-# INLINE single #-} -single :: Row.Row a -> Result a -single rowDec = - do - checkExecStatus $ \case - LibPQ.TuplesOk -> True - _ -> False - Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do - maxRows <- LibPQ.ntuples result - case maxRows of - 1 -> do - maxCols <- LibPQ.nfields result - fmap (mapLeft (RowError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) - _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) - where - rowToInt (LibPQ.Row n) = - fromIntegral n - intToRow = - LibPQ.Row . fromIntegral - -{-# INLINE vector #-} -vector :: Row.Row a -> Result (Vector a) -vector rowDec = - do - checkExecStatus $ \case - LibPQ.TuplesOk -> True - _ -> False - Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do - maxRows <- LibPQ.ntuples result - maxCols <- LibPQ.nfields result - mvector <- MutableVector.unsafeNew (rowToInt maxRows) - failureRef <- newIORef Nothing - forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do - rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) - case rowResult of - Left !x -> writeIORef failureRef (Just (RowError rowIndex x)) - Right !x -> MutableVector.unsafeWrite mvector rowIndex x - readIORef failureRef >>= \case - Nothing -> Right <$> Vector.unsafeFreeze mvector - Just x -> pure (Left x) - where - rowToInt (LibPQ.Row n) = - fromIntegral n - intToRow = - LibPQ.Row . fromIntegral - -{-# INLINE foldl #-} -foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a -foldl step init rowDec = - {-# SCC "foldl" #-} - do - checkExecStatus $ \case - LibPQ.TuplesOk -> True - _ -> False - Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ {-# SCC "traversal" #-} do - maxRows <- LibPQ.ntuples result - maxCols <- LibPQ.nfields result - accRef <- newIORef init - failureRef <- newIORef Nothing - forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do - rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) - case rowResult of - Left !x -> writeIORef failureRef (Just (RowError rowIndex x)) - Right !x -> modifyIORef accRef (\acc -> step acc x) - readIORef failureRef >>= \case - Nothing -> Right <$> readIORef accRef - Just x -> pure (Left x) - where - rowToInt (LibPQ.Row n) = - fromIntegral n - intToRow = - LibPQ.Row . fromIntegral - -{-# INLINE foldr #-} -foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a -foldr step init rowDec = - {-# SCC "foldr" #-} - do - checkExecStatus $ \case - LibPQ.TuplesOk -> True - _ -> False - Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do - maxRows <- LibPQ.ntuples result - maxCols <- LibPQ.nfields result - accRef <- newIORef init - failureRef <- newIORef Nothing - forMToZero_ (rowToInt maxRows) $ \rowIndex -> do - rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) - case rowResult of - Left !x -> writeIORef failureRef (Just (RowError rowIndex x)) - Right !x -> modifyIORef accRef (\acc -> step x acc) - readIORef failureRef >>= \case - Nothing -> Right <$> readIORef accRef - Just x -> pure (Left x) - where - rowToInt (LibPQ.Row n) = - fromIntegral n - intToRow = - LibPQ.Row . fromIntegral diff --git a/library/Hasql/Decoders/Results.hs b/library/Hasql/Decoders/Results.hs deleted file mode 100644 --- a/library/Hasql/Decoders/Results.hs +++ /dev/null @@ -1,91 +0,0 @@ --- | --- An API for retrieval of multiple results. --- Can be used to handle: --- --- * A single result, --- --- * Individual results of a multi-statement query --- with the help of "Applicative" and "Monad", --- --- * Row-by-row fetching. --- -module Hasql.Decoders.Results where - -import Hasql.Prelude hiding (maybe, many) -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Hasql.Prelude as Prelude -import qualified Hasql.Decoders.Result as Result -import qualified Hasql.Decoders.Row as Row - - -newtype Results a = - Results (ReaderT (Bool, LibPQ.Connection) (EitherT Error IO) a) - deriving (Functor, Applicative, Monad) - -data Error = - -- | - -- An error on the client-side, - -- with a message generated by the \"libpq\" library. - -- Usually indicates problems with the connection. - ClientError !(Maybe ByteString) | - ResultError !Result.Error - deriving (Show) - -{-# INLINE run #-} -run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either Error a) -run (Results stack) env = - runEitherT (runReaderT stack env) - -{-# INLINE clientError #-} -clientError :: Results a -clientError = - Results $ ReaderT $ \(_, connection) -> EitherT $ - fmap (Left . ClientError) (LibPQ.errorMessage connection) - --- | --- Parse a single result. -{-# INLINE single #-} -single :: Result.Result a -> Results a -single resultDec = - Results $ ReaderT $ \(integerDatetimes, connection) -> EitherT $ do - resultMaybe <- LibPQ.getResult connection - case resultMaybe of - Just result -> - mapLeft ResultError <$> Result.run resultDec (integerDatetimes, result) - Nothing -> - fmap (Left . ClientError) (LibPQ.errorMessage connection) - --- | --- Fetch a single result. -{-# INLINE getResult #-} -getResult :: Results LibPQ.Result -getResult = - Results $ ReaderT $ \(_, connection) -> EitherT $ do - resultMaybe <- LibPQ.getResult connection - case resultMaybe of - Just result -> pure (Right result) - Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection) - --- | --- Fetch a single result. -{-# INLINE getResultMaybe #-} -getResultMaybe :: Results (Maybe LibPQ.Result) -getResultMaybe = - Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection - -{-# INLINE dropRemainders #-} -dropRemainders :: Results () -dropRemainders = - {-# SCC "dropRemainders" #-} - Results $ ReaderT $ \(integerDatetimes, connection) -> loop integerDatetimes connection - where - loop integerDatetimes connection = - getResultMaybe >>= Prelude.maybe (pure ()) onResult - where - getResultMaybe = - lift $ LibPQ.getResult connection - onResult result = - checkErrors *> loop integerDatetimes connection - where - checkErrors = - EitherT $ fmap (mapLeft ResultError) $ Result.run Result.unit (integerDatetimes, result) diff --git a/library/Hasql/Decoders/Row.hs b/library/Hasql/Decoders/Row.hs deleted file mode 100644 --- a/library/Hasql/Decoders/Row.hs +++ /dev/null @@ -1,65 +0,0 @@ -module Hasql.Decoders.Row where - -import Hasql.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Decoder as Decoder -import qualified Hasql.Decoders.Value as Value - - -newtype Row a = - Row (ReaderT Env (EitherT Error IO) a) - deriving (Functor, Applicative, Monad) - -data Env = - Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column) - -data Error = - EndOfInput | - UnexpectedNull | - ValueError !Text - deriving (Show) - - --- * Functions -------------------------- - -{-# INLINE run #-} -run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either Error a) -run (Row impl) (result, row, columnsAmount, integerDatetimes) = - do - columnRef <- newIORef 0 - runEitherT (runReaderT impl (Env result row columnsAmount integerDatetimes columnRef)) - -{-# INLINE error #-} -error :: Error -> Row a -error x = - Row (ReaderT (const (EitherT (pure (Left x))))) - --- | --- Next value, decoded using the provided value decoder. -{-# INLINE value #-} -value :: Value.Value a -> Row (Maybe a) -value valueDec = - {-# SCC "value" #-} - Row $ ReaderT $ \(Env result row columnsAmount integerDatetimes columnRef) -> EitherT $ do - col <- readIORef columnRef - writeIORef columnRef (succ col) - if col < columnsAmount - then do - valueMaybe <- {-# SCC "getvalue'" #-} LibPQ.getvalue' result row col - pure $ - case valueMaybe of - Nothing -> - Right Nothing - Just value -> - fmap Just $ mapLeft ValueError $ - {-# SCC "decode" #-} Decoder.run (Value.run valueDec integerDatetimes) value - else pure (Left EndOfInput) - --- | --- Next value, decoded using the provided value decoder. -{-# INLINE nonNullValue #-} -nonNullValue :: Value.Value a -> Row a -nonNullValue valueDec = - {-# SCC "nonNullValue" #-} - value valueDec >>= maybe (error UnexpectedNull) pure diff --git a/library/Hasql/Decoders/Value.hs b/library/Hasql/Decoders/Value.hs deleted file mode 100644 --- a/library/Hasql/Decoders/Value.hs +++ /dev/null @@ -1,28 +0,0 @@ -module Hasql.Decoders.Value where - -import Hasql.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Decoder as Decoder - - -newtype Value a = - Value (ReaderT Bool Decoder.Decoder a) - deriving (Functor) - - -{-# INLINE run #-} -run :: Value a -> Bool -> Decoder.Decoder a -run (Value imp) integerDatetimes = - runReaderT imp integerDatetimes - -{-# INLINE decoder #-} -decoder :: (Bool -> Decoder.Decoder a) -> Value a -decoder = - {-# SCC "decoder" #-} - Value . ReaderT - -{-# INLINE decoderFn #-} -decoderFn :: (Bool -> ByteString -> Either Text a) -> Value a -decoderFn fn = - Value $ ReaderT $ \integerDatetimes -> Decoder.fn $ fn integerDatetimes - diff --git a/library/Hasql/Encoders.hs b/library/Hasql/Encoders.hs --- a/library/Hasql/Encoders.hs +++ b/library/Hasql/Encoders.hs @@ -41,14 +41,14 @@ ) where -import Hasql.Prelude hiding (bool) +import Hasql.Private.Prelude hiding (bool) import qualified PostgreSQL.Binary.Encoder as Encoder import qualified Data.Aeson as Aeson -import qualified Hasql.Encoders.Params as Params -import qualified Hasql.Encoders.Value as Value -import qualified Hasql.Encoders.Array as Array -import qualified Hasql.PTI as PTI -import qualified Hasql.Prelude as Prelude +import qualified Hasql.Private.Encoders.Params as Params +import qualified Hasql.Private.Encoders.Value as Value +import qualified Hasql.Private.Encoders.Array as Array +import qualified Hasql.Private.PTI as PTI +import qualified Hasql.Private.Prelude as Prelude -- * Parameters Product Encoder diff --git a/library/Hasql/Encoders/Array.hs b/library/Hasql/Encoders/Array.hs deleted file mode 100644 --- a/library/Hasql/Encoders/Array.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Hasql.Encoders.Array where - -import Hasql.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Encoder as Encoder -import qualified Hasql.PTI as PTI - - -data Array a = - Array PTI.OID PTI.OID (Bool -> Encoder.ArrayEncoder a) - -{-# INLINE run #-} -run :: Array a -> (PTI.OID, Bool -> Encoder.Encoder a) -run (Array valueOID arrayOID encoder') = - (arrayOID, \env -> Encoder.array (PTI.oidWord32 valueOID) (encoder' env)) - -{-# INLINE value #-} -value :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array a -value valueOID arrayOID encoder' = - Array valueOID arrayOID (Encoder.arrayValue . encoder') - -{-# INLINE nullableValue #-} -nullableValue :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array (Maybe a) -nullableValue valueOID arrayOID encoder' = - Array valueOID arrayOID (Encoder.arrayNullableValue . encoder') - -{-# INLINE dimension #-} -dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c -dimension foldl (Array valueOID arrayOID encoder') = - Array valueOID arrayOID (Encoder.arrayDimension foldl . encoder') - diff --git a/library/Hasql/Encoders/Params.hs b/library/Hasql/Encoders/Params.hs deleted file mode 100644 --- a/library/Hasql/Encoders/Params.hs +++ /dev/null @@ -1,51 +0,0 @@ -module Hasql.Encoders.Params where - -import Hasql.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Encoder as Encoder -import qualified Hasql.Encoders.Value as Value -import qualified Hasql.PTI as PTI - - --- | --- Encoder of some representation of a parameters product. -newtype Params a = - Params (Op (DList (LibPQ.Oid, Bool -> Maybe ByteString)) a) - deriving (Contravariant, Divisible, Decidable, Monoid) - -instance Semigroup (Params a) - -run :: Params a -> a -> DList (LibPQ.Oid, Bool -> Maybe ByteString) -run (Params (Op op)) params = - {-# SCC "run" #-} - op params - -run' :: Params a -> a -> Bool -> ([LibPQ.Oid], [Maybe (ByteString, LibPQ.Format)]) -run' (Params (Op op)) params integerDatetimes = - {-# SCC "run'" #-} - foldr step ([], []) (op params) - where - step (oid, bytesGetter) ~(oidList, bytesAndFormatList) = - (,) - (oid : oidList) - (fmap (\bytes -> (bytes, LibPQ.Binary)) (bytesGetter integerDatetimes) : bytesAndFormatList) - -run'' :: Params a -> a -> Bool -> [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] -run'' (Params (Op op)) params integerDatetimes = - {-# SCC "run''" #-} - foldr step [] (op params) - where - step a b = - mapping a : b - where - mapping (oid, bytesGetter) = - (,,) <$> pure oid <*> bytesGetter integerDatetimes <*> pure LibPQ.Binary - -value :: Value.Value a -> Params a -value = - contramap Just . nullableValue - -nullableValue :: Value.Value a -> Params (Maybe a) -nullableValue (Value.Value valueOID arrayOID encoder') = - Params $ Op $ \input -> - pure (PTI.oidPQ valueOID, \env -> fmap (Encoder.run (encoder' env)) input) diff --git a/library/Hasql/Encoders/Value.hs b/library/Hasql/Encoders/Value.hs deleted file mode 100644 --- a/library/Hasql/Encoders/Value.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Hasql.Encoders.Value where - -import Hasql.Prelude -import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified PostgreSQL.Binary.Encoder as Encoder -import qualified Hasql.PTI as PTI - - -data Value a = - Value PTI.OID PTI.OID (Bool -> Encoder.Encoder a) - -instance Contravariant Value where - {-# INLINE contramap #-} - contramap f (Value valueOID arrayOID encoder) = - Value valueOID arrayOID (\integerDatetimes input -> encoder integerDatetimes (f input)) - -{-# INLINE run #-} -run :: Value a -> (PTI.OID, PTI.OID, Bool -> Encoder.Encoder a) -run (Value valueOID arrayOID encoder') = - (valueOID, arrayOID, encoder') - -{-# INLINE unsafePTI #-} -unsafePTI :: PTI.PTI -> (Bool -> Encoder.Encoder a) -> Value a -unsafePTI pti encoder' = - Value (PTI.ptiOID pti) (fromMaybe ($bug "No array OID") (PTI.ptiArrayOID pti)) encoder' - - diff --git a/library/Hasql/PTI.hs b/library/Hasql/PTI.hs deleted file mode 100644 --- a/library/Hasql/PTI.hs +++ /dev/null @@ -1,94 +0,0 @@ -module Hasql.PTI where - -import Hasql.Prelude hiding (bool) -import qualified Database.PostgreSQL.LibPQ as LibPQ - - --- | A Postgresql type info -data PTI = PTI { ptiOID :: !OID, ptiArrayOID :: !(Maybe OID) } - --- | A Word32 and a LibPQ representation of an OID -data OID = OID { oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid } - -mkOID :: Word32 -> OID -mkOID x = - OID x ((LibPQ.Oid . fromIntegral) x) - -mkPTI :: Word32 -> Maybe Word32 -> PTI -mkPTI oid arrayOID = - PTI (mkOID oid) (fmap mkOID arrayOID) - - --- * Constants -------------------------- - -abstime = mkPTI 702 (Just 1023) -aclitem = mkPTI 1033 (Just 1034) -bit = mkPTI 1560 (Just 1561) -bool = mkPTI 16 (Just 1000) -box = mkPTI 603 (Just 1020) -bpchar = mkPTI 1042 (Just 1014) -bytea = mkPTI 17 (Just 1001) -char = mkPTI 18 (Just 1002) -cid = mkPTI 29 (Just 1012) -cidr = mkPTI 650 (Just 651) -circle = mkPTI 718 (Just 719) -cstring = mkPTI 2275 (Just 1263) -date = mkPTI 1082 (Just 1182) -daterange = mkPTI 3912 (Just 3913) -float4 = mkPTI 700 (Just 1021) -float8 = mkPTI 701 (Just 1022) -gtsvector = mkPTI 3642 (Just 3644) -inet = mkPTI 869 (Just 1041) -int2 = mkPTI 21 (Just 1005) -int2vector = mkPTI 22 (Just 1006) -int4 = mkPTI 23 (Just 1007) -int4range = mkPTI 3904 (Just 3905) -int8 = mkPTI 20 (Just 1016) -int8range = mkPTI 3926 (Just 3927) -interval = mkPTI 1186 (Just 1187) -json = mkPTI 114 (Just 199) -jsonb = mkPTI 3802 (Just 3807) -line = mkPTI 628 (Just 629) -lseg = mkPTI 601 (Just 1018) -macaddr = mkPTI 829 (Just 1040) -money = mkPTI 790 (Just 791) -name = mkPTI 19 (Just 1003) -numeric = mkPTI 1700 (Just 1231) -numrange = mkPTI 3906 (Just 3907) -oid = mkPTI 26 (Just 1028) -oidvector = mkPTI 30 (Just 1013) -path = mkPTI 602 (Just 1019) -point = mkPTI 600 (Just 1017) -polygon = mkPTI 604 (Just 1027) -record = mkPTI 2249 (Just 2287) -refcursor = mkPTI 1790 (Just 2201) -regclass = mkPTI 2205 (Just 2210) -regconfig = mkPTI 3734 (Just 3735) -regdictionary = mkPTI 3769 (Just 3770) -regoper = mkPTI 2203 (Just 2208) -regoperator = mkPTI 2204 (Just 2209) -regproc = mkPTI 24 (Just 1008) -regprocedure = mkPTI 2202 (Just 2207) -regtype = mkPTI 2206 (Just 2211) -reltime = mkPTI 703 (Just 1024) -text = mkPTI 25 (Just 1009) -tid = mkPTI 27 (Just 1010) -time = mkPTI 1083 (Just 1183) -timestamp = mkPTI 1114 (Just 1115) -timestamptz = mkPTI 1184 (Just 1185) -timetz = mkPTI 1266 (Just 1270) -tinterval = mkPTI 704 (Just 1025) -tsquery = mkPTI 3615 (Just 3645) -tsrange = mkPTI 3908 (Just 3909) -tstzrange = mkPTI 3910 (Just 3911) -tsvector = mkPTI 3614 (Just 3643) -txid_snapshot = mkPTI 2970 (Just 2949) -unknown = mkPTI 705 (Just 705) -uuid = mkPTI 2950 (Just 2951) -varbit = mkPTI 1562 (Just 1563) -varchar = mkPTI 1043 (Just 1015) -void = mkPTI 2278 Nothing -xid = mkPTI 28 (Just 1011) -xml = mkPTI 142 (Just 143) - diff --git a/library/Hasql/Prelude.hs b/library/Hasql/Prelude.hs deleted file mode 100644 --- a/library/Hasql/Prelude.hs +++ /dev/null @@ -1,142 +0,0 @@ -module Hasql.Prelude -( - module Exports, - LazyByteString, - ByteStringBuilder, - LazyText, - TextBuilder, - bug, - bottom, - forMToZero_, - forMFromZero_, - strictCons, -) -where - - --- base-prelude -------------------------- -import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error, (<>), First(..), Last(..)) - --- transformers -------------------------- -import Control.Monad.IO.Class as Exports -import Control.Monad.Trans.Class as Exports -import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass) -import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch) -import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) -import Data.Functor.Identity as Exports - --- mtl -------------------------- -import Control.Monad.Error.Class as Exports (MonadError (..)) - --- data-default-class -------------------------- -import Data.Default.Class as Exports - --- profunctors -------------------------- -import Data.Profunctor.Unsafe as Exports - --- contravariant -------------------------- -import Data.Functor.Contravariant as Exports -import Data.Functor.Contravariant.Divisible as Exports - --- contravariant-extras -------------------------- -import Contravariant.Extras as Exports - --- either -------------------------- -import Control.Monad.Trans.Either as Exports -import Data.Either.Combinators as Exports - --- semigroups -------------------------- -import Data.Semigroup as Exports - --- hashable -------------------------- -import Data.Hashable as Exports (Hashable(..)) - --- text -------------------------- -import Data.Text as Exports (Text) - --- bytestring -------------------------- -import Data.ByteString as Exports (ByteString) - --- scientific -------------------------- -import Data.Scientific as Exports (Scientific) - --- uuid -------------------------- -import Data.UUID as Exports (UUID) - --- time -------------------------- -import Data.Time as Exports - --- vector -------------------------- -import Data.Vector as Exports (Vector) - --- dlist -------------------------- -import Data.DList as Exports (DList) - --- placeholders -------------------------- -import Development.Placeholders as Exports - --- loch-th -------------------------- -import Debug.Trace.LocationTH as Exports - --- custom -------------------------- -import qualified Debug.Trace.LocationTH -import qualified Data.Text.Lazy -import qualified Data.Text.Lazy.Builder -import qualified Data.ByteString.Lazy -import qualified Data.ByteString.Builder - - -type LazyByteString = - Data.ByteString.Lazy.ByteString - -type ByteStringBuilder = - Data.ByteString.Builder.Builder - -type LazyText = - Data.Text.Lazy.Text - -type TextBuilder = - Data.Text.Lazy.Builder.Builder - -bug = - [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |] - where - msg = "A \"hasql\" package bug: " :: String - -bottom = - [e| $bug "Bottom evaluated" |] - -{-# INLINE forMToZero_ #-} -forMToZero_ :: Applicative m => Int -> (Int -> m a) -> m () -forMToZero_ !startN f = - ($ pred startN) $ fix $ \loop !n -> if n >= 0 then f n *> loop (pred n) else pure () - -{-# INLINE forMFromZero_ #-} -forMFromZero_ :: Applicative m => Int -> (Int -> m a) -> m () -forMFromZero_ !endN f = - ($ 0) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure () - -{-# INLINE strictCons #-} -strictCons :: a -> [a] -> [a] -strictCons !a b = - let !c = a : b in c diff --git a/library/Hasql/Private/Commands.hs b/library/Hasql/Private/Commands.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Commands.hs @@ -0,0 +1,33 @@ +module Hasql.Private.Commands +( + Commands, + asBytes, + setEncodersToUTF8, + setMinClientMessagesToWarning, +) +where + +import Hasql.Private.Prelude +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy.Builder as BB +import qualified Data.ByteString.Lazy.Builder.ASCII as BB +import qualified Data.ByteString.Lazy as BL + + +newtype Commands = + Commands (DList BB.Builder) + deriving (Monoid) + +instance Semigroup Commands + +asBytes :: Commands -> ByteString +asBytes (Commands list) = + BL.toStrict $ BB.toLazyByteString $ foldMap (<> BB.char7 ';') $ list + +setEncodersToUTF8 :: Commands +setEncodersToUTF8 = + Commands (pure "SET client_encoding = 'UTF8'") + +setMinClientMessagesToWarning :: Commands +setMinClientMessagesToWarning = + Commands (pure "SET client_min_messages TO WARNING") diff --git a/library/Hasql/Private/Connection.hs b/library/Hasql/Private/Connection.hs --- a/library/Hasql/Private/Connection.hs +++ b/library/Hasql/Private/Connection.hs @@ -3,11 +3,11 @@ module Hasql.Private.Connection where -import Hasql.Prelude +import Hasql.Private.Prelude import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry import qualified Hasql.Private.IO as IO -import qualified Hasql.Settings as Settings +import qualified Hasql.Private.Settings as Settings -- | diff --git a/library/Hasql/Private/Decoders/Array.hs b/library/Hasql/Private/Decoders/Array.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Decoders/Array.hs @@ -0,0 +1,31 @@ +module Hasql.Private.Decoders.Array where + +import Hasql.Private.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Decoder as Decoder + + +newtype Array a = + Array (ReaderT Bool Decoder.ArrayDecoder a) + deriving (Functor) + +{-# INLINE run #-} +run :: Array a -> Bool -> Decoder.Decoder a +run (Array imp) env = + Decoder.array (runReaderT imp env) + +{-# INLINE dimension #-} +dimension :: (forall m. Monad m => Int -> m a -> m b) -> Array a -> Array b +dimension replicateM (Array imp) = + Array $ ReaderT $ \env -> Decoder.arrayDimension replicateM (runReaderT imp env) + +{-# INLINE value #-} +value :: (Bool -> Decoder.Decoder a) -> Array (Maybe a) +value decoder' = + Array $ ReaderT $ Decoder.arrayValue . decoder' + +{-# INLINE nonNullValue #-} +nonNullValue :: (Bool -> Decoder.Decoder a) -> Array a +nonNullValue decoder' = + Array $ ReaderT $ Decoder.arrayNonNullValue . decoder' + diff --git a/library/Hasql/Private/Decoders/Composite.hs b/library/Hasql/Private/Decoders/Composite.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Decoders/Composite.hs @@ -0,0 +1,26 @@ +module Hasql.Private.Decoders.Composite where + +import Hasql.Private.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Decoder as Decoder + + +newtype Composite a = + Composite (ReaderT Bool Decoder.CompositeDecoder a) + deriving (Functor, Applicative, Monad) + +{-# INLINE run #-} +run :: Composite a -> Bool -> Decoder.Decoder a +run (Composite imp) env = + Decoder.composite (runReaderT imp env) + +{-# INLINE value #-} +value :: (Bool -> Decoder.Decoder a) -> Composite (Maybe a) +value decoder' = + Composite $ ReaderT $ Decoder.compositeValue . decoder' + +{-# INLINE nonNullValue #-} +nonNullValue :: (Bool -> Decoder.Decoder a) -> Composite a +nonNullValue decoder' = + Composite $ ReaderT $ Decoder.compositeNonNullValue . decoder' + diff --git a/library/Hasql/Private/Decoders/Result.hs b/library/Hasql/Private/Decoders/Result.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Decoders/Result.hs @@ -0,0 +1,232 @@ +module Hasql.Private.Decoders.Result where + +import Hasql.Private.Prelude hiding (maybe, many) +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.Private.Decoders.Row as Row +import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec +import qualified Data.ByteString as ByteString +import qualified Hasql.Private.Prelude as Prelude +import qualified Data.Vector as Vector +import qualified Data.Vector.Mutable as MutableVector + + +newtype Result a = + Result (ReaderT (Bool, LibPQ.Result) (EitherT Error IO) a) + deriving (Functor, Applicative, Monad) + +data Error = + -- | + -- An error reported by the DB. Code, message, details, hint. + -- + -- * The SQLSTATE code for the error. The SQLSTATE code identifies the type of error that has occurred; + -- it can be used by front-end applications to perform specific operations (such as error handling) + -- in response to a particular database error. + -- For a list of the possible SQLSTATE codes, see Appendix A. + -- This field is not localizable, and is always present. + -- + -- * The primary human-readable error message (typically one line). Always present. + -- + -- * Detail: an optional secondary error message carrying more detail about the problem. + -- Might run to multiple lines. + -- + -- * Hint: an optional suggestion what to do about the problem. + -- This is intended to differ from detail in that it offers advice (potentially inappropriate) + -- rather than hard facts. Might run to multiple lines. + ServerError !ByteString !ByteString !(Maybe ByteString) !(Maybe ByteString) | + -- | + -- The database returned an unexpected result. + -- Indicates an improper statement or a schema mismatch. + UnexpectedResult !Text | + -- | + -- An error of the row reader, preceded by the index of the row. + RowError !Int !Row.Error | + -- | + -- An unexpected amount of rows. + UnexpectedAmountOfRows !Int + deriving (Show) + +{-# INLINE run #-} +run :: Result a -> (Bool, LibPQ.Result) -> IO (Either Error a) +run (Result reader) env = + runEitherT (runReaderT reader env) + +{-# INLINE unit #-} +unit :: Result () +unit = + checkExecStatus $ \case + LibPQ.CommandOk -> True + LibPQ.TuplesOk -> True + _ -> False + +{-# INLINE rowsAffected #-} +rowsAffected :: Result Int64 +rowsAffected = + do + checkExecStatus $ \case + LibPQ.CommandOk -> True + _ -> False + Result $ ReaderT $ \(_, result) -> EitherT $ + LibPQ.cmdTuples result & fmap cmdTuplesReader + where + cmdTuplesReader = + notNothing >=> notEmpty >=> decimal + where + notNothing = + Prelude.maybe (Left (UnexpectedResult "No bytes")) Right + notEmpty bytes = + if ByteString.null bytes + then Left (UnexpectedResult "Empty bytes") + else Right bytes + decimal bytes = + mapLeft (\m -> UnexpectedResult ("Decimal parsing failure: " <> fromString m)) $ + Attoparsec.parseOnly (Attoparsec.decimal <* Attoparsec.endOfInput) bytes + +{-# INLINE checkExecStatus #-} +checkExecStatus :: (LibPQ.ExecStatus -> Bool) -> Result () +checkExecStatus predicate = + {-# SCC "checkExecStatus" #-} + do + status <- Result $ ReaderT $ \(_, result) -> lift $ LibPQ.resultStatus result + unless (predicate status) $ do + case status of + LibPQ.BadResponse -> serverError + LibPQ.NonfatalError -> serverError + LibPQ.FatalError -> serverError + _ -> Result $ lift $ EitherT $ pure $ Left $ UnexpectedResult $ "Unexpected result status: " <> (fromString $ show status) + +{-# INLINE serverError #-} +serverError :: Result () +serverError = + Result $ ReaderT $ \(_, result) -> EitherT $ do + code <- + fmap (fromMaybe ($bug "No code")) $ + LibPQ.resultErrorField result LibPQ.DiagSqlstate + message <- + fmap (fromMaybe ($bug "No message")) $ + LibPQ.resultErrorField result LibPQ.DiagMessagePrimary + detail <- + LibPQ.resultErrorField result LibPQ.DiagMessageDetail + hint <- + LibPQ.resultErrorField result LibPQ.DiagMessageHint + pure $ Left $ ServerError code message detail hint + +{-# INLINE maybe #-} +maybe :: Row.Row a -> Result (Maybe a) +maybe rowDec = + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do + maxRows <- LibPQ.ntuples result + case maxRows of + 0 -> return (Right Nothing) + 1 -> do + maxCols <- LibPQ.nfields result + fmap (fmap Just . mapLeft (RowError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) + _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +{-# INLINE single #-} +single :: Row.Row a -> Result a +single rowDec = + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do + maxRows <- LibPQ.ntuples result + case maxRows of + 1 -> do + maxCols <- LibPQ.nfields result + fmap (mapLeft (RowError 0)) $ Row.run rowDec (result, 0, maxCols, integerDatetimes) + _ -> return (Left (UnexpectedAmountOfRows (rowToInt maxRows))) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +{-# INLINE vector #-} +vector :: Row.Row a -> Result (Vector a) +vector rowDec = + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do + maxRows <- LibPQ.ntuples result + maxCols <- LibPQ.nfields result + mvector <- MutableVector.unsafeNew (rowToInt maxRows) + failureRef <- newIORef Nothing + forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do + rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) + case rowResult of + Left !x -> writeIORef failureRef (Just (RowError rowIndex x)) + Right !x -> MutableVector.unsafeWrite mvector rowIndex x + readIORef failureRef >>= \case + Nothing -> Right <$> Vector.unsafeFreeze mvector + Just x -> pure (Left x) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +{-# INLINE foldl #-} +foldl :: (a -> b -> a) -> a -> Row.Row b -> Result a +foldl step init rowDec = + {-# SCC "foldl" #-} + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ {-# SCC "traversal" #-} do + maxRows <- LibPQ.ntuples result + maxCols <- LibPQ.nfields result + accRef <- newIORef init + failureRef <- newIORef Nothing + forMFromZero_ (rowToInt maxRows) $ \rowIndex -> do + rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) + case rowResult of + Left !x -> writeIORef failureRef (Just (RowError rowIndex x)) + Right !x -> modifyIORef accRef (\acc -> step acc x) + readIORef failureRef >>= \case + Nothing -> Right <$> readIORef accRef + Just x -> pure (Left x) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral + +{-# INLINE foldr #-} +foldr :: (b -> a -> a) -> a -> Row.Row b -> Result a +foldr step init rowDec = + {-# SCC "foldr" #-} + do + checkExecStatus $ \case + LibPQ.TuplesOk -> True + _ -> False + Result $ ReaderT $ \(integerDatetimes, result) -> EitherT $ do + maxRows <- LibPQ.ntuples result + maxCols <- LibPQ.nfields result + accRef <- newIORef init + failureRef <- newIORef Nothing + forMToZero_ (rowToInt maxRows) $ \rowIndex -> do + rowResult <- Row.run rowDec (result, intToRow rowIndex, maxCols, integerDatetimes) + case rowResult of + Left !x -> writeIORef failureRef (Just (RowError rowIndex x)) + Right !x -> modifyIORef accRef (\acc -> step x acc) + readIORef failureRef >>= \case + Nothing -> Right <$> readIORef accRef + Just x -> pure (Left x) + where + rowToInt (LibPQ.Row n) = + fromIntegral n + intToRow = + LibPQ.Row . fromIntegral diff --git a/library/Hasql/Private/Decoders/Results.hs b/library/Hasql/Private/Decoders/Results.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Decoders/Results.hs @@ -0,0 +1,91 @@ +-- | +-- An API for retrieval of multiple results. +-- Can be used to handle: +-- +-- * A single result, +-- +-- * Individual results of a multi-statement query +-- with the help of "Applicative" and "Monad", +-- +-- * Row-by-row fetching. +-- +module Hasql.Private.Decoders.Results where + +import Hasql.Private.Prelude hiding (maybe, many) +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified Hasql.Private.Prelude as Prelude +import qualified Hasql.Private.Decoders.Result as Result +import qualified Hasql.Private.Decoders.Row as Row + + +newtype Results a = + Results (ReaderT (Bool, LibPQ.Connection) (EitherT Error IO) a) + deriving (Functor, Applicative, Monad) + +data Error = + -- | + -- An error on the client-side, + -- with a message generated by the \"libpq\" library. + -- Usually indicates problems with the connection. + ClientError !(Maybe ByteString) | + ResultError !Result.Error + deriving (Show) + +{-# INLINE run #-} +run :: Results a -> (Bool, LibPQ.Connection) -> IO (Either Error a) +run (Results stack) env = + runEitherT (runReaderT stack env) + +{-# INLINE clientError #-} +clientError :: Results a +clientError = + Results $ ReaderT $ \(_, connection) -> EitherT $ + fmap (Left . ClientError) (LibPQ.errorMessage connection) + +-- | +-- Parse a single result. +{-# INLINE single #-} +single :: Result.Result a -> Results a +single resultDec = + Results $ ReaderT $ \(integerDatetimes, connection) -> EitherT $ do + resultMaybe <- LibPQ.getResult connection + case resultMaybe of + Just result -> + mapLeft ResultError <$> Result.run resultDec (integerDatetimes, result) + Nothing -> + fmap (Left . ClientError) (LibPQ.errorMessage connection) + +-- | +-- Fetch a single result. +{-# INLINE getResult #-} +getResult :: Results LibPQ.Result +getResult = + Results $ ReaderT $ \(_, connection) -> EitherT $ do + resultMaybe <- LibPQ.getResult connection + case resultMaybe of + Just result -> pure (Right result) + Nothing -> fmap (Left . ClientError) (LibPQ.errorMessage connection) + +-- | +-- Fetch a single result. +{-# INLINE getResultMaybe #-} +getResultMaybe :: Results (Maybe LibPQ.Result) +getResultMaybe = + Results $ ReaderT $ \(_, connection) -> lift $ LibPQ.getResult connection + +{-# INLINE dropRemainders #-} +dropRemainders :: Results () +dropRemainders = + {-# SCC "dropRemainders" #-} + Results $ ReaderT $ \(integerDatetimes, connection) -> loop integerDatetimes connection + where + loop integerDatetimes connection = + getResultMaybe >>= Prelude.maybe (pure ()) onResult + where + getResultMaybe = + lift $ LibPQ.getResult connection + onResult result = + checkErrors *> loop integerDatetimes connection + where + checkErrors = + EitherT $ fmap (mapLeft ResultError) $ Result.run Result.unit (integerDatetimes, result) diff --git a/library/Hasql/Private/Decoders/Row.hs b/library/Hasql/Private/Decoders/Row.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Decoders/Row.hs @@ -0,0 +1,65 @@ +module Hasql.Private.Decoders.Row where + +import Hasql.Private.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Decoder as Decoder +import qualified Hasql.Private.Decoders.Value as Value + + +newtype Row a = + Row (ReaderT Env (EitherT Error IO) a) + deriving (Functor, Applicative, Monad) + +data Env = + Env !LibPQ.Result !LibPQ.Row !LibPQ.Column !Bool !(IORef LibPQ.Column) + +data Error = + EndOfInput | + UnexpectedNull | + ValueError !Text + deriving (Show) + + +-- * Functions +------------------------- + +{-# INLINE run #-} +run :: Row a -> (LibPQ.Result, LibPQ.Row, LibPQ.Column, Bool) -> IO (Either Error a) +run (Row impl) (result, row, columnsAmount, integerDatetimes) = + do + columnRef <- newIORef 0 + runEitherT (runReaderT impl (Env result row columnsAmount integerDatetimes columnRef)) + +{-# INLINE error #-} +error :: Error -> Row a +error x = + Row (ReaderT (const (EitherT (pure (Left x))))) + +-- | +-- Next value, decoded using the provided value decoder. +{-# INLINE value #-} +value :: Value.Value a -> Row (Maybe a) +value valueDec = + {-# SCC "value" #-} + Row $ ReaderT $ \(Env result row columnsAmount integerDatetimes columnRef) -> EitherT $ do + col <- readIORef columnRef + writeIORef columnRef (succ col) + if col < columnsAmount + then do + valueMaybe <- {-# SCC "getvalue'" #-} LibPQ.getvalue' result row col + pure $ + case valueMaybe of + Nothing -> + Right Nothing + Just value -> + fmap Just $ mapLeft ValueError $ + {-# SCC "decode" #-} Decoder.run (Value.run valueDec integerDatetimes) value + else pure (Left EndOfInput) + +-- | +-- Next value, decoded using the provided value decoder. +{-# INLINE nonNullValue #-} +nonNullValue :: Value.Value a -> Row a +nonNullValue valueDec = + {-# SCC "nonNullValue" #-} + value valueDec >>= maybe (error UnexpectedNull) pure diff --git a/library/Hasql/Private/Decoders/Value.hs b/library/Hasql/Private/Decoders/Value.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Decoders/Value.hs @@ -0,0 +1,28 @@ +module Hasql.Private.Decoders.Value where + +import Hasql.Private.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Decoder as Decoder + + +newtype Value a = + Value (ReaderT Bool Decoder.Decoder a) + deriving (Functor) + + +{-# INLINE run #-} +run :: Value a -> Bool -> Decoder.Decoder a +run (Value imp) integerDatetimes = + runReaderT imp integerDatetimes + +{-# INLINE decoder #-} +decoder :: (Bool -> Decoder.Decoder a) -> Value a +decoder = + {-# SCC "decoder" #-} + Value . ReaderT + +{-# INLINE decoderFn #-} +decoderFn :: (Bool -> ByteString -> Either Text a) -> Value a +decoderFn fn = + Value $ ReaderT $ \integerDatetimes -> Decoder.fn $ fn integerDatetimes + diff --git a/library/Hasql/Private/Encoders/Array.hs b/library/Hasql/Private/Encoders/Array.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Encoders/Array.hs @@ -0,0 +1,31 @@ +module Hasql.Private.Encoders.Array where + +import Hasql.Private.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified Hasql.Private.PTI as PTI + + +data Array a = + Array PTI.OID PTI.OID (Bool -> Encoder.ArrayEncoder a) + +{-# INLINE run #-} +run :: Array a -> (PTI.OID, Bool -> Encoder.Encoder a) +run (Array valueOID arrayOID encoder') = + (arrayOID, \env -> Encoder.array (PTI.oidWord32 valueOID) (encoder' env)) + +{-# INLINE value #-} +value :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array a +value valueOID arrayOID encoder' = + Array valueOID arrayOID (Encoder.arrayValue . encoder') + +{-# INLINE nullableValue #-} +nullableValue :: PTI.OID -> PTI.OID -> (Bool -> Encoder.Encoder a) -> Array (Maybe a) +nullableValue valueOID arrayOID encoder' = + Array valueOID arrayOID (Encoder.arrayNullableValue . encoder') + +{-# INLINE dimension #-} +dimension :: (forall a. (a -> b -> a) -> a -> c -> a) -> Array b -> Array c +dimension foldl (Array valueOID arrayOID encoder') = + Array valueOID arrayOID (Encoder.arrayDimension foldl . encoder') + diff --git a/library/Hasql/Private/Encoders/Params.hs b/library/Hasql/Private/Encoders/Params.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Encoders/Params.hs @@ -0,0 +1,51 @@ +module Hasql.Private.Encoders.Params where + +import Hasql.Private.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified Hasql.Private.Encoders.Value as Value +import qualified Hasql.Private.PTI as PTI + + +-- | +-- Encoder of some representation of a parameters product. +newtype Params a = + Params (Op (DList (LibPQ.Oid, Bool -> Maybe ByteString)) a) + deriving (Contravariant, Divisible, Decidable, Monoid) + +instance Semigroup (Params a) + +run :: Params a -> a -> DList (LibPQ.Oid, Bool -> Maybe ByteString) +run (Params (Op op)) params = + {-# SCC "run" #-} + op params + +run' :: Params a -> a -> Bool -> ([LibPQ.Oid], [Maybe (ByteString, LibPQ.Format)]) +run' (Params (Op op)) params integerDatetimes = + {-# SCC "run'" #-} + foldr step ([], []) (op params) + where + step (oid, bytesGetter) ~(oidList, bytesAndFormatList) = + (,) + (oid : oidList) + (fmap (\bytes -> (bytes, LibPQ.Binary)) (bytesGetter integerDatetimes) : bytesAndFormatList) + +run'' :: Params a -> a -> Bool -> [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] +run'' (Params (Op op)) params integerDatetimes = + {-# SCC "run''" #-} + foldr step [] (op params) + where + step a b = + mapping a : b + where + mapping (oid, bytesGetter) = + (,,) <$> pure oid <*> bytesGetter integerDatetimes <*> pure LibPQ.Binary + +value :: Value.Value a -> Params a +value = + contramap Just . nullableValue + +nullableValue :: Value.Value a -> Params (Maybe a) +nullableValue (Value.Value valueOID arrayOID encoder') = + Params $ Op $ \input -> + pure (PTI.oidPQ valueOID, \env -> fmap (Encoder.run (encoder' env)) input) diff --git a/library/Hasql/Private/Encoders/Value.hs b/library/Hasql/Private/Encoders/Value.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Encoders/Value.hs @@ -0,0 +1,27 @@ +module Hasql.Private.Encoders.Value where + +import Hasql.Private.Prelude +import qualified Database.PostgreSQL.LibPQ as LibPQ +import qualified PostgreSQL.Binary.Encoder as Encoder +import qualified Hasql.Private.PTI as PTI + + +data Value a = + Value PTI.OID PTI.OID (Bool -> Encoder.Encoder a) + +instance Contravariant Value where + {-# INLINE contramap #-} + contramap f (Value valueOID arrayOID encoder) = + Value valueOID arrayOID (\integerDatetimes input -> encoder integerDatetimes (f input)) + +{-# INLINE run #-} +run :: Value a -> (PTI.OID, PTI.OID, Bool -> Encoder.Encoder a) +run (Value valueOID arrayOID encoder') = + (valueOID, arrayOID, encoder') + +{-# INLINE unsafePTI #-} +unsafePTI :: PTI.PTI -> (Bool -> Encoder.Encoder a) -> Value a +unsafePTI pti encoder' = + Value (PTI.ptiOID pti) (fromMaybe ($bug "No array OID") (PTI.ptiArrayOID pti)) encoder' + + diff --git a/library/Hasql/Private/IO.hs b/library/Hasql/Private/IO.hs --- a/library/Hasql/Private/IO.hs +++ b/library/Hasql/Private/IO.hs @@ -3,13 +3,13 @@ module Hasql.Private.IO where -import Hasql.Prelude +import Hasql.Private.Prelude import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Hasql.Commands as Commands +import qualified Hasql.Private.Commands as Commands import qualified Hasql.Private.PreparedStatementRegistry as PreparedStatementRegistry -import qualified Hasql.Decoders.Result as ResultDecoders -import qualified Hasql.Decoders.Results as ResultsDecoders -import qualified Hasql.Encoders.Params as ParamsEncoders +import qualified Hasql.Private.Decoders.Result as ResultDecoders +import qualified Hasql.Private.Decoders.Results as ResultsDecoders +import qualified Hasql.Private.Encoders.Params as ParamsEncoders import qualified Data.DList as DList diff --git a/library/Hasql/Private/PTI.hs b/library/Hasql/Private/PTI.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/PTI.hs @@ -0,0 +1,94 @@ +module Hasql.Private.PTI where + +import Hasql.Private.Prelude hiding (bool) +import qualified Database.PostgreSQL.LibPQ as LibPQ + + +-- | A Postgresql type info +data PTI = PTI { ptiOID :: !OID, ptiArrayOID :: !(Maybe OID) } + +-- | A Word32 and a LibPQ representation of an OID +data OID = OID { oidWord32 :: !Word32, oidPQ :: !LibPQ.Oid } + +mkOID :: Word32 -> OID +mkOID x = + OID x ((LibPQ.Oid . fromIntegral) x) + +mkPTI :: Word32 -> Maybe Word32 -> PTI +mkPTI oid arrayOID = + PTI (mkOID oid) (fmap mkOID arrayOID) + + +-- * Constants +------------------------- + +abstime = mkPTI 702 (Just 1023) +aclitem = mkPTI 1033 (Just 1034) +bit = mkPTI 1560 (Just 1561) +bool = mkPTI 16 (Just 1000) +box = mkPTI 603 (Just 1020) +bpchar = mkPTI 1042 (Just 1014) +bytea = mkPTI 17 (Just 1001) +char = mkPTI 18 (Just 1002) +cid = mkPTI 29 (Just 1012) +cidr = mkPTI 650 (Just 651) +circle = mkPTI 718 (Just 719) +cstring = mkPTI 2275 (Just 1263) +date = mkPTI 1082 (Just 1182) +daterange = mkPTI 3912 (Just 3913) +float4 = mkPTI 700 (Just 1021) +float8 = mkPTI 701 (Just 1022) +gtsvector = mkPTI 3642 (Just 3644) +inet = mkPTI 869 (Just 1041) +int2 = mkPTI 21 (Just 1005) +int2vector = mkPTI 22 (Just 1006) +int4 = mkPTI 23 (Just 1007) +int4range = mkPTI 3904 (Just 3905) +int8 = mkPTI 20 (Just 1016) +int8range = mkPTI 3926 (Just 3927) +interval = mkPTI 1186 (Just 1187) +json = mkPTI 114 (Just 199) +jsonb = mkPTI 3802 (Just 3807) +line = mkPTI 628 (Just 629) +lseg = mkPTI 601 (Just 1018) +macaddr = mkPTI 829 (Just 1040) +money = mkPTI 790 (Just 791) +name = mkPTI 19 (Just 1003) +numeric = mkPTI 1700 (Just 1231) +numrange = mkPTI 3906 (Just 3907) +oid = mkPTI 26 (Just 1028) +oidvector = mkPTI 30 (Just 1013) +path = mkPTI 602 (Just 1019) +point = mkPTI 600 (Just 1017) +polygon = mkPTI 604 (Just 1027) +record = mkPTI 2249 (Just 2287) +refcursor = mkPTI 1790 (Just 2201) +regclass = mkPTI 2205 (Just 2210) +regconfig = mkPTI 3734 (Just 3735) +regdictionary = mkPTI 3769 (Just 3770) +regoper = mkPTI 2203 (Just 2208) +regoperator = mkPTI 2204 (Just 2209) +regproc = mkPTI 24 (Just 1008) +regprocedure = mkPTI 2202 (Just 2207) +regtype = mkPTI 2206 (Just 2211) +reltime = mkPTI 703 (Just 1024) +text = mkPTI 25 (Just 1009) +tid = mkPTI 27 (Just 1010) +time = mkPTI 1083 (Just 1183) +timestamp = mkPTI 1114 (Just 1115) +timestamptz = mkPTI 1184 (Just 1185) +timetz = mkPTI 1266 (Just 1270) +tinterval = mkPTI 704 (Just 1025) +tsquery = mkPTI 3615 (Just 3645) +tsrange = mkPTI 3908 (Just 3909) +tstzrange = mkPTI 3910 (Just 3911) +tsvector = mkPTI 3614 (Just 3643) +txid_snapshot = mkPTI 2970 (Just 2949) +unknown = mkPTI 705 (Just 705) +uuid = mkPTI 2950 (Just 2951) +varbit = mkPTI 1562 (Just 1563) +varchar = mkPTI 1043 (Just 1015) +void = mkPTI 2278 Nothing +xid = mkPTI 28 (Just 1011) +xml = mkPTI 142 (Just 143) + diff --git a/library/Hasql/Private/Prelude.hs b/library/Hasql/Private/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Prelude.hs @@ -0,0 +1,142 @@ +module Hasql.Private.Prelude +( + module Exports, + LazyByteString, + ByteStringBuilder, + LazyText, + TextBuilder, + bug, + bottom, + forMToZero_, + forMFromZero_, + strictCons, +) +where + + +-- base-prelude +------------------------- +import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error, (<>), First(..), Last(..)) + +-- transformers +------------------------- +import Control.Monad.IO.Class as Exports +import Control.Monad.Trans.Class as Exports +import Control.Monad.Trans.Maybe as Exports hiding (liftListen, liftPass) +import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch) +import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) +import Data.Functor.Identity as Exports + +-- mtl +------------------------- +import Control.Monad.Error.Class as Exports (MonadError (..)) + +-- data-default-class +------------------------- +import Data.Default.Class as Exports + +-- profunctors +------------------------- +import Data.Profunctor.Unsafe as Exports + +-- contravariant +------------------------- +import Data.Functor.Contravariant as Exports +import Data.Functor.Contravariant.Divisible as Exports + +-- contravariant-extras +------------------------- +import Contravariant.Extras as Exports + +-- either +------------------------- +import Control.Monad.Trans.Either as Exports +import Data.Either.Combinators as Exports + +-- semigroups +------------------------- +import Data.Semigroup as Exports + +-- hashable +------------------------- +import Data.Hashable as Exports (Hashable(..)) + +-- text +------------------------- +import Data.Text as Exports (Text) + +-- bytestring +------------------------- +import Data.ByteString as Exports (ByteString) + +-- scientific +------------------------- +import Data.Scientific as Exports (Scientific) + +-- uuid +------------------------- +import Data.UUID as Exports (UUID) + +-- time +------------------------- +import Data.Time as Exports + +-- vector +------------------------- +import Data.Vector as Exports (Vector) + +-- dlist +------------------------- +import Data.DList as Exports (DList) + +-- placeholders +------------------------- +import Development.Placeholders as Exports + +-- loch-th +------------------------- +import Debug.Trace.LocationTH as Exports + +-- custom +------------------------- +import qualified Debug.Trace.LocationTH +import qualified Data.Text.Lazy +import qualified Data.Text.Lazy.Builder +import qualified Data.ByteString.Lazy +import qualified Data.ByteString.Builder + + +type LazyByteString = + Data.ByteString.Lazy.ByteString + +type ByteStringBuilder = + Data.ByteString.Builder.Builder + +type LazyText = + Data.Text.Lazy.Text + +type TextBuilder = + Data.Text.Lazy.Builder.Builder + +bug = + [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |] + where + msg = "A \"hasql\" package bug: " :: String + +bottom = + [e| $bug "Bottom evaluated" |] + +{-# INLINE forMToZero_ #-} +forMToZero_ :: Applicative m => Int -> (Int -> m a) -> m () +forMToZero_ !startN f = + ($ pred startN) $ fix $ \loop !n -> if n >= 0 then f n *> loop (pred n) else pure () + +{-# INLINE forMFromZero_ #-} +forMFromZero_ :: Applicative m => Int -> (Int -> m a) -> m () +forMFromZero_ !endN f = + ($ 0) $ fix $ \loop !n -> if n < endN then f n *> loop (succ n) else pure () + +{-# INLINE strictCons #-} +strictCons :: a -> [a] -> [a] +strictCons !a b = + let !c = a : b in c diff --git a/library/Hasql/Private/PreparedStatementRegistry.hs b/library/Hasql/Private/PreparedStatementRegistry.hs --- a/library/Hasql/Private/PreparedStatementRegistry.hs +++ b/library/Hasql/Private/PreparedStatementRegistry.hs @@ -7,7 +7,7 @@ ) where -import Hasql.Prelude hiding (lookup) +import Hasql.Private.Prelude hiding (lookup) import qualified Data.HashTable.IO as A import qualified ByteString.TreeBuilder as B diff --git a/library/Hasql/Private/Query.hs b/library/Hasql/Private/Query.hs --- a/library/Hasql/Private/Query.hs +++ b/library/Hasql/Private/Query.hs @@ -1,12 +1,12 @@ module Hasql.Private.Query where -import Hasql.Prelude +import Hasql.Private.Prelude import qualified Database.PostgreSQL.LibPQ as LibPQ import qualified Hasql.Private.IO as IO import qualified Hasql.Private.Connection as Connection -import qualified Hasql.Decoders.Results as Decoders.Results -import qualified Hasql.Encoders.Params as Encoders.Params +import qualified Hasql.Private.Decoders.Results as Decoders.Results +import qualified Hasql.Private.Encoders.Params as Encoders.Params -- | diff --git a/library/Hasql/Private/Session.hs b/library/Hasql/Private/Session.hs --- a/library/Hasql/Private/Session.hs +++ b/library/Hasql/Private/Session.hs @@ -1,11 +1,11 @@ module Hasql.Private.Session where -import Hasql.Prelude +import Hasql.Private.Prelude import qualified Database.PostgreSQL.LibPQ as LibPQ -import qualified Hasql.Decoders.Results as Decoders.Results -import qualified Hasql.Decoders.Result as Decoders.Result -import qualified Hasql.Settings as Settings +import qualified Hasql.Private.Decoders.Results as Decoders.Results +import qualified Hasql.Private.Decoders.Result as Decoders.Result +import qualified Hasql.Private.Settings as Settings import qualified Hasql.Private.IO as IO import qualified Hasql.Private.Query as Query import qualified Hasql.Private.Connection as Connection diff --git a/library/Hasql/Private/Settings.hs b/library/Hasql/Private/Settings.hs new file mode 100644 --- /dev/null +++ b/library/Hasql/Private/Settings.hs @@ -0,0 +1,39 @@ +module Hasql.Private.Settings where + +import Hasql.Private.Prelude +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy.Builder as BB +import qualified Data.ByteString.Lazy.Builder.ASCII as BB +import qualified Data.ByteString.Lazy as BL + + + +-- | +-- All settings encoded in a single byte-string according to +-- . +type Settings = + ByteString + +-- | +-- Encode a host, a port, a user, a password and a database into the PostgreSQL settings byte-string. +{-# INLINE settings #-} +settings :: ByteString -> Word16 -> ByteString -> ByteString -> ByteString -> Settings +settings host port user password database = + BL.toStrict $ BB.toLazyByteString $ mconcat $ intersperse (BB.char7 ' ') $ catMaybes $ + [ + mappend (BB.string7 "host=") . BB.byteString <$> + mfilter (not . B.null) (pure host) + , + mappend (BB.string7 "port=") . BB.word16Dec <$> + mfilter (/= 0) (pure port) + , + mappend (BB.string7 "user=") . BB.byteString <$> + mfilter (not . B.null) (pure user) + , + mappend (BB.string7 "password=") . BB.byteString <$> + mfilter (not . B.null) (pure password) + , + mappend (BB.string7 "dbname=") . BB.byteString <$> + mfilter (not . B.null) (pure database) + ] + diff --git a/library/Hasql/Query.hs b/library/Hasql/Query.hs --- a/library/Hasql/Query.hs +++ b/library/Hasql/Query.hs @@ -5,11 +5,11 @@ ) where -import Hasql.Prelude +import Hasql.Private.Prelude import qualified Hasql.Private.Query as Query -import qualified Hasql.Decoders.Results as Decoders.Results +import qualified Hasql.Private.Decoders.Results as Decoders.Results import qualified Hasql.Decoders as Decoders -import qualified Hasql.Encoders.Params as Encoders.Params +import qualified Hasql.Private.Encoders.Params as Encoders.Params import qualified Hasql.Encoders as Encoders @@ -41,10 +41,10 @@ -- sql = -- "select ($1 + $2)" -- encoder = --- 'contramap' 'fst' (Hasql.Encoders.'Hasql.Encoders.value' Hasql.Encoders.'Hasql.Encoders.int8') '<>' --- 'contramap' 'snd' (Hasql.Encoders.'Hasql.Encoders.value' Hasql.Encoders.'Hasql.Encoders.int8') +-- 'contramap' 'fst' (Hasql.Private.Encoders.'Hasql.Private.Encoders.value' Hasql.Private.Encoders.'Hasql.Private.Encoders.int8') '<>' +-- 'contramap' 'snd' (Hasql.Private.Encoders.'Hasql.Private.Encoders.value' Hasql.Private.Encoders.'Hasql.Private.Encoders.int8') -- decoder = --- Hasql.Decoders.'Hasql.Decoders.singleRow' (Hasql.Decoders.'Hasql.Decoders.value' Hasql.Decoders.'Hasql.Decoders.int8') +-- Hasql.Private.Decoders.'Hasql.Private.Decoders.singleRow' (Hasql.Private.Decoders.'Hasql.Private.Decoders.value' Hasql.Private.Decoders.'Hasql.Private.Decoders.int8') -- @ -- -- The statement above accepts a product of two parameters of type 'Int64' diff --git a/library/Hasql/Settings.hs b/library/Hasql/Settings.hs deleted file mode 100644 --- a/library/Hasql/Settings.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Hasql.Settings where - -import Hasql.Prelude -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy.Builder as BB -import qualified Data.ByteString.Lazy.Builder.ASCII as BB -import qualified Data.ByteString.Lazy as BL - - - --- | --- All settings encoded in a single byte-string according to --- . -type Settings = - ByteString - --- | --- Encode a host, a port, a user, a password and a database into the PostgreSQL settings byte-string. -{-# INLINE settings #-} -settings :: ByteString -> Word16 -> ByteString -> ByteString -> ByteString -> Settings -settings host port user password database = - BL.toStrict $ BB.toLazyByteString $ mconcat $ intersperse (BB.char7 ' ') $ catMaybes $ - [ - mappend (BB.string7 "host=") . BB.byteString <$> - mfilter (not . B.null) (pure host) - , - mappend (BB.string7 "port=") . BB.word16Dec <$> - mfilter (/= 0) (pure port) - , - mappend (BB.string7 "user=") . BB.byteString <$> - mfilter (not . B.null) (pure user) - , - mappend (BB.string7 "password=") . BB.byteString <$> - mfilter (not . B.null) (pure password) - , - mappend (BB.string7 "dbname=") . BB.byteString <$> - mfilter (not . B.null) (pure database) - ] -