packages feed

hasql 0.15.1.1 → 0.19.2

raw patch · 19 files changed

+491/−450 lines, 19 filesdep +mtl

Dependencies added: mtl

Files

benchmark/Main.hs view
@@ -3,10 +3,10 @@ import Main.Prelude import Criterion.Main import qualified Hasql.Connection as HC-import qualified Hasql.Settings as HS import qualified Hasql.Query as HQ import qualified Hasql.Encoders as HE import qualified Hasql.Decoders as HD+import qualified Hasql.Session import qualified Main.Queries as Q  @@ -14,7 +14,7 @@   HC.acquire settings >>= either (fail . show) use   where     settings =-      HS.settings host port user password database+      HC.settings host port user password database       where         host = "localhost"         port = 5432@@ -49,4 +49,5 @@         query :: a -> HQ.Query a b -> IO b         query params query =           {-# SCC "query" #-} -          HQ.run query params connection >>= either (fail . show) pure+          (=<<) (either (fail . show) pure) $+          flip Hasql.Session.run connection $ Hasql.Session.query params query
benchmark/Main/Queries.hs view
@@ -9,7 +9,7 @@ select1 :: Int -> HQ.Query () (Vector Int64) select1 amount =   {-# SCC "select1" #-} -  HQ.Query sql mempty decoder True+  HQ.statement sql mempty decoder True   where     !sql =       "values " <>@@ -20,7 +20,7 @@ select4 :: Int -> HQ.Query () (Vector (Int64, Int64, Int64, Int64)) select4 amount =   {-# SCC "select4" #-} -  HQ.Query sql mempty decoder True+  HQ.statement sql mempty decoder True   where     !sql =       "values " <>
hasql.cabal view
@@ -1,7 +1,7 @@ name:   hasql version:-  0.15.1.1+  0.19.2 category:   Hasql, Database, PostgreSQL synopsis:@@ -48,7 +48,12 @@   other-modules:     Hasql.Prelude     Hasql.PTI-    Hasql.IO+    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@@ -59,14 +64,12 @@     Hasql.Encoders.Array     Hasql.Encoders.Value     Hasql.Encoders.Params-    Hasql.PreparedStatementRegistry-    Hasql.Connection.Impl   exposed-modules:     Hasql.Decoders     Hasql.Encoders-    Hasql.Settings     Hasql.Connection     Hasql.Query+    Hasql.Session   build-depends:     -- parsing:     attoparsec >= 0.10 && < 0.14,@@ -90,6 +93,7 @@     contravariant-extras == 0.3.*,     contravariant >= 1.3 && < 2,     either >= 4.4.1 && < 5,+    mtl >= 2 && < 3,     transformers >= 0.3 && < 0.5,     -- errors:     loch-th == 0.2.*,
library/Hasql/Connection.hs view
@@ -6,7 +6,10 @@   ConnectionError(..),   acquire,   release,+  Settings,+  settings, ) where -import Hasql.Connection.Impl+import Hasql.Private.Connection+import Hasql.Settings
− library/Hasql/Connection/Impl.hs 
@@ -1,41 +0,0 @@-module Hasql.Connection.Impl-where--import Hasql.Prelude-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry-import qualified Hasql.IO as IO----- |--- A single connection to the database.-data Connection =-  Connection !(MVar LibPQ.Connection) !Bool !PreparedStatementRegistry.PreparedStatementRegistry---- |--- Possible details of the connection acquistion error.-type ConnectionError =-  Maybe ByteString---- |--- Acquire a connection using the provided settings encoded according to the PostgreSQL format.-acquire :: ByteString -> IO (Either ConnectionError Connection)-acquire settings =-  {-# SCC "acquire" #-}-  runEitherT $ do-    pqConnection <- lift (IO.acquireConnection settings)-    lift (IO.checkConnectionStatus pqConnection) >>= traverse left-    lift (IO.initConnection pqConnection)-    integerDatetimes <- lift (IO.getIntegerDatetimes pqConnection)-    registry <- lift (IO.acquirePreparedStatementRegistry)-    pqConnectionRef <- lift (newMVar pqConnection)-    pure (Connection pqConnectionRef integerDatetimes registry)---- |--- Release the connection.-release :: Connection -> IO ()-release (Connection pqConnectionRef _ _) =-  mask_ $ do-    nullConnection <- LibPQ.newNullConnection-    pqConnection <- swapMVar pqConnectionRef nullConnection-    IO.releaseConnection pqConnection
library/Hasql/Encoders.hs view
@@ -260,35 +260,35 @@ {-# INLINABLE timestamp #-} timestamp :: Value LocalTime timestamp =-  Value (Value.unsafePTI PTI.timestamp (Prelude.bool Encoder.timestamp_float Encoder.timestamp_int))+  Value (Value.unsafePTI PTI.timestamp (Prelude.bool Encoder.timestamp_int Encoder.timestamp_float))  -- | -- Encoder of @TIMESTAMPTZ@ values. {-# INLINABLE timestamptz #-} timestamptz :: Value UTCTime timestamptz =-  Value (Value.unsafePTI PTI.timestamptz (Prelude.bool Encoder.timestamptz_float Encoder.timestamptz_int))+  Value (Value.unsafePTI PTI.timestamptz (Prelude.bool Encoder.timestamptz_int Encoder.timestamptz_float))  -- | -- Encoder of @TIME@ values. {-# INLINABLE time #-} time :: Value TimeOfDay time =-  Value (Value.unsafePTI PTI.time (Prelude.bool Encoder.time_float Encoder.time_int))+  Value (Value.unsafePTI PTI.time (Prelude.bool Encoder.time_int Encoder.time_float))  -- | -- Encoder of @TIMETZ@ values. {-# INLINABLE timetz #-} timetz :: Value (TimeOfDay, TimeZone) timetz =-  Value (Value.unsafePTI PTI.timetz (Prelude.bool Encoder.timetz_float Encoder.timetz_int))+  Value (Value.unsafePTI PTI.timetz (Prelude.bool Encoder.timetz_int Encoder.timetz_float))  -- | -- Encoder of @INTERVAL@ values. {-# INLINABLE interval #-} interval :: Value DiffTime interval =-  Value (Value.unsafePTI PTI.interval (Prelude.bool Encoder.interval_float Encoder.interval_int))+  Value (Value.unsafePTI PTI.interval (Prelude.bool Encoder.interval_int Encoder.interval_float))  -- | -- Encoder of @UUID@ values.
− library/Hasql/IO.hs 
@@ -1,151 +0,0 @@--- |--- An API of low-level IO operations.-module Hasql.IO-where--import Hasql.Prelude-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Hasql.Commands as Commands-import qualified Hasql.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 Data.DList as DList---{-# INLINE acquireConnection #-}-acquireConnection :: ByteString -> IO LibPQ.Connection-acquireConnection =-  LibPQ.connectdb--{-# INLINE acquirePreparedStatementRegistry #-}-acquirePreparedStatementRegistry :: IO PreparedStatementRegistry.PreparedStatementRegistry-acquirePreparedStatementRegistry =-  PreparedStatementRegistry.new--{-# INLINE releaseConnection #-}-releaseConnection :: LibPQ.Connection -> IO ()-releaseConnection connection =-  LibPQ.finish connection--{-# INLINE checkConnectionStatus #-}-checkConnectionStatus :: LibPQ.Connection -> IO (Maybe (Maybe ByteString))-checkConnectionStatus c =-  do-    s <- LibPQ.status c-    case s of-      LibPQ.ConnectionOk -> return Nothing-      _ -> fmap Just (LibPQ.errorMessage c)--{-# INLINE checkServerVersion #-}-checkServerVersion :: LibPQ.Connection -> IO (Maybe Int)-checkServerVersion c =-  fmap (mfilter (< 80200) . Just) (LibPQ.serverVersion c)--{-# INLINE getIntegerDatetimes #-}-getIntegerDatetimes :: LibPQ.Connection -> IO Bool-getIntegerDatetimes c =-  fmap decodeValue $ LibPQ.parameterStatus c "integer_datetimes"-  where-    decodeValue = -      \case-        Just "on" -> True-        _ -> False--{-# INLINE initConnection #-}-initConnection :: LibPQ.Connection -> IO ()-initConnection c =-  void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodersToUTF8 <> Commands.setMinClientMessagesToWarning))--{-# INLINE getResults #-}-getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either ResultsDecoders.Error a)-getResults connection integerDatetimes des =-  {-# SCC "getResults" #-} -  ResultsDecoders.run (des <* ResultsDecoders.dropRemainders) (integerDatetimes, connection)--{-# INLINE getPreparedStatementKey #-}-getPreparedStatementKey ::-  LibPQ.Connection -> PreparedStatementRegistry.PreparedStatementRegistry ->-  ByteString -> [LibPQ.Oid] ->-  IO (Either ResultsDecoders.Error ByteString)-getPreparedStatementKey connection registry template oidList =-  {-# SCC "getPreparedStatementKey" #-} -  do-    keyMaybe <- PreparedStatementRegistry.lookup template wordOIDList registry-    case keyMaybe of-      Just key ->-        pure (pure key)-      Nothing -> -        do-          key <- PreparedStatementRegistry.register template wordOIDList registry-          sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList))-          let resultsDecoder = -                if sent-                  then ResultsDecoders.single ResultDecoders.unit-                  else ResultsDecoders.clientError-          runEitherT $ do-            EitherT $ getResults connection undefined resultsDecoder-            pure key-  where-    wordOIDList =-      map (\(LibPQ.Oid x) -> fromIntegral x) oidList--{-# INLINE checkedSend #-}-checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either ResultsDecoders.Error ())-checkedSend connection send =-  send >>= \case-    False -> fmap (Left . ResultsDecoders.ClientError) $ LibPQ.errorMessage connection-    True -> pure (Right ())--{-# INLINE sendPreparedParametricQuery #-}-sendPreparedParametricQuery ::-  LibPQ.Connection ->-  PreparedStatementRegistry.PreparedStatementRegistry ->-  ByteString ->-  [LibPQ.Oid] ->-  [Maybe (ByteString, LibPQ.Format)] ->-  IO (Either ResultsDecoders.Error ())-sendPreparedParametricQuery connection registry template oidList valueAndFormatList =-  runEitherT $ do-    key <- EitherT $ getPreparedStatementKey connection registry template oidList-    EitherT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary--{-# INLINE sendUnpreparedParametricQuery #-}-sendUnpreparedParametricQuery ::-  LibPQ.Connection ->-  ByteString ->-  [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] ->-  IO (Either ResultsDecoders.Error ())-sendUnpreparedParametricQuery connection template paramList =-  checkedSend connection $ LibPQ.sendQueryParams connection template paramList LibPQ.Binary--{-# INLINE sendParametricQuery #-}-sendParametricQuery ::-  LibPQ.Connection ->-  Bool -> -  PreparedStatementRegistry.PreparedStatementRegistry ->-  ByteString ->-  ParamsEncoders.Params a ->-  Bool ->-  a ->-  IO (Either ResultsDecoders.Error ())-sendParametricQuery connection integerDatetimes registry template encoder prepared params =-  {-# SCC "sendParametricQuery" #-} -  if prepared-    then-      let-        (oidList, valueAndFormatList) =-          ParamsEncoders.run' encoder params integerDatetimes-        in-          sendPreparedParametricQuery connection registry template oidList valueAndFormatList-    else-      let-        paramList =-          ParamsEncoders.run'' encoder params integerDatetimes-        in-          sendUnpreparedParametricQuery connection template paramList--{-# INLINE sendNonparametricQuery #-}-sendNonparametricQuery :: LibPQ.Connection -> ByteString -> IO (Either ResultsDecoders.Error ())-sendNonparametricQuery connection sql =-  checkedSend connection $ LibPQ.sendQuery connection sql
library/Hasql/Prelude.hs view
@@ -27,6 +27,10 @@ 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
− library/Hasql/PreparedStatementRegistry.hs 
@@ -1,46 +0,0 @@-module Hasql.PreparedStatementRegistry-(-  PreparedStatementRegistry,-  new,-  lookup,-  register,-)-where--import Hasql.Prelude hiding (lookup)-import qualified Data.HashTable.IO as Hashtables---data PreparedStatementRegistry =-  PreparedStatementRegistry !(Hashtables.BasicHashTable LocalKey ByteString) !(IORef Word)--{-# INLINABLE new #-}-new :: IO PreparedStatementRegistry-new =-  PreparedStatementRegistry <$> Hashtables.new <*> newIORef 0--{-# INLINABLE lookup #-}-lookup :: ByteString -> [Word32] -> PreparedStatementRegistry -> IO (Maybe ByteString)-lookup template oids (PreparedStatementRegistry table counter) =-  Hashtables.lookup table (LocalKey template oids)--{-# INLINABLE register #-}-register :: ByteString -> [Word32] -> PreparedStatementRegistry -> IO ByteString-register template oids (PreparedStatementRegistry table counter) =-  do-    n <- readIORef counter-    writeIORef counter (succ n)-    let remoteKey = fromString (show n)-    Hashtables.insert table (LocalKey template oids) remoteKey-    return remoteKey---- |--- Local statement key.-data LocalKey =-  LocalKey !ByteString ![Word32]-  deriving (Show, Eq)--instance Hashable LocalKey where-  {-# INLINE hashWithSalt #-}-  hashWithSalt salt (LocalKey template types) =-    hashWithSalt salt template
+ library/Hasql/Private/Connection.hs view
@@ -0,0 +1,44 @@+-- |+-- This module provides a low-level effectful API dealing with the connections to the database.+module Hasql.Private.Connection+where++import Hasql.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+++-- |+-- A single connection to the database.+data Connection =+  Connection !(MVar LibPQ.Connection) !Bool !PreparedStatementRegistry.PreparedStatementRegistry++-- |+-- Possible details of the connection acquistion error.+type ConnectionError =+  Maybe ByteString++-- |+-- Acquire a connection using the provided settings encoded according to the PostgreSQL format.+acquire :: Settings.Settings -> IO (Either ConnectionError Connection)+acquire settings =+  {-# SCC "acquire" #-}+  runEitherT $ do+    pqConnection <- lift (IO.acquireConnection settings)+    lift (IO.checkConnectionStatus pqConnection) >>= traverse left+    lift (IO.initConnection pqConnection)+    integerDatetimes <- lift (IO.getIntegerDatetimes pqConnection)+    registry <- lift (IO.acquirePreparedStatementRegistry)+    pqConnectionRef <- lift (newMVar pqConnection)+    pure (Connection pqConnectionRef integerDatetimes registry)++-- |+-- Release the connection.+release :: Connection -> IO ()+release (Connection pqConnectionRef _ _) =+  mask_ $ do+    nullConnection <- LibPQ.newNullConnection+    pqConnection <- swapMVar pqConnectionRef nullConnection+    IO.releaseConnection pqConnection
+ library/Hasql/Private/IO.hs view
@@ -0,0 +1,151 @@+-- |+-- An API of low-level IO operations.+module Hasql.Private.IO+where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.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 Data.DList as DList+++{-# INLINE acquireConnection #-}+acquireConnection :: ByteString -> IO LibPQ.Connection+acquireConnection =+  LibPQ.connectdb++{-# INLINE acquirePreparedStatementRegistry #-}+acquirePreparedStatementRegistry :: IO PreparedStatementRegistry.PreparedStatementRegistry+acquirePreparedStatementRegistry =+  PreparedStatementRegistry.new++{-# INLINE releaseConnection #-}+releaseConnection :: LibPQ.Connection -> IO ()+releaseConnection connection =+  LibPQ.finish connection++{-# INLINE checkConnectionStatus #-}+checkConnectionStatus :: LibPQ.Connection -> IO (Maybe (Maybe ByteString))+checkConnectionStatus c =+  do+    s <- LibPQ.status c+    case s of+      LibPQ.ConnectionOk -> return Nothing+      _ -> fmap Just (LibPQ.errorMessage c)++{-# INLINE checkServerVersion #-}+checkServerVersion :: LibPQ.Connection -> IO (Maybe Int)+checkServerVersion c =+  fmap (mfilter (< 80200) . Just) (LibPQ.serverVersion c)++{-# INLINE getIntegerDatetimes #-}+getIntegerDatetimes :: LibPQ.Connection -> IO Bool+getIntegerDatetimes c =+  fmap decodeValue $ LibPQ.parameterStatus c "integer_datetimes"+  where+    decodeValue = +      \case+        Just "on" -> True+        _ -> False++{-# INLINE initConnection #-}+initConnection :: LibPQ.Connection -> IO ()+initConnection c =+  void $ LibPQ.exec c (Commands.asBytes (Commands.setEncodersToUTF8 <> Commands.setMinClientMessagesToWarning))++{-# INLINE getResults #-}+getResults :: LibPQ.Connection -> Bool -> ResultsDecoders.Results a -> IO (Either ResultsDecoders.Error a)+getResults connection integerDatetimes des =+  {-# SCC "getResults" #-} +  ResultsDecoders.run (des <* ResultsDecoders.dropRemainders) (integerDatetimes, connection)++{-# INLINE getPreparedStatementKey #-}+getPreparedStatementKey ::+  LibPQ.Connection -> PreparedStatementRegistry.PreparedStatementRegistry ->+  ByteString -> [LibPQ.Oid] ->+  IO (Either ResultsDecoders.Error ByteString)+getPreparedStatementKey connection registry template oidList =+  {-# SCC "getPreparedStatementKey" #-} +  do+    keyMaybe <- PreparedStatementRegistry.lookup template wordOIDList registry+    case keyMaybe of+      Just key ->+        pure (pure key)+      Nothing -> +        do+          key <- PreparedStatementRegistry.register template wordOIDList registry+          sent <- LibPQ.sendPrepare connection key template (mfilter (not . null) (Just oidList))+          let resultsDecoder = +                if sent+                  then ResultsDecoders.single ResultDecoders.unit+                  else ResultsDecoders.clientError+          runEitherT $ do+            EitherT $ getResults connection undefined resultsDecoder+            pure key+  where+    wordOIDList =+      map (\(LibPQ.Oid x) -> fromIntegral x) oidList++{-# INLINE checkedSend #-}+checkedSend :: LibPQ.Connection -> IO Bool -> IO (Either ResultsDecoders.Error ())+checkedSend connection send =+  send >>= \case+    False -> fmap (Left . ResultsDecoders.ClientError) $ LibPQ.errorMessage connection+    True -> pure (Right ())++{-# INLINE sendPreparedParametricQuery #-}+sendPreparedParametricQuery ::+  LibPQ.Connection ->+  PreparedStatementRegistry.PreparedStatementRegistry ->+  ByteString ->+  [LibPQ.Oid] ->+  [Maybe (ByteString, LibPQ.Format)] ->+  IO (Either ResultsDecoders.Error ())+sendPreparedParametricQuery connection registry template oidList valueAndFormatList =+  runEitherT $ do+    key <- EitherT $ getPreparedStatementKey connection registry template oidList+    EitherT $ checkedSend connection $ LibPQ.sendQueryPrepared connection key valueAndFormatList LibPQ.Binary++{-# INLINE sendUnpreparedParametricQuery #-}+sendUnpreparedParametricQuery ::+  LibPQ.Connection ->+  ByteString ->+  [Maybe (LibPQ.Oid, ByteString, LibPQ.Format)] ->+  IO (Either ResultsDecoders.Error ())+sendUnpreparedParametricQuery connection template paramList =+  checkedSend connection $ LibPQ.sendQueryParams connection template paramList LibPQ.Binary++{-# INLINE sendParametricQuery #-}+sendParametricQuery ::+  LibPQ.Connection ->+  Bool -> +  PreparedStatementRegistry.PreparedStatementRegistry ->+  ByteString ->+  ParamsEncoders.Params a ->+  Bool ->+  a ->+  IO (Either ResultsDecoders.Error ())+sendParametricQuery connection integerDatetimes registry template encoder prepared params =+  {-# SCC "sendParametricQuery" #-} +  if prepared+    then+      let+        (oidList, valueAndFormatList) =+          ParamsEncoders.run' encoder params integerDatetimes+        in+          sendPreparedParametricQuery connection registry template oidList valueAndFormatList+    else+      let+        paramList =+          ParamsEncoders.run'' encoder params integerDatetimes+        in+          sendUnpreparedParametricQuery connection template paramList++{-# INLINE sendNonparametricQuery #-}+sendNonparametricQuery :: LibPQ.Connection -> ByteString -> IO (Either ResultsDecoders.Error ())+sendNonparametricQuery connection sql =+  checkedSend connection $ LibPQ.sendQuery connection sql
+ library/Hasql/Private/PreparedStatementRegistry.hs view
@@ -0,0 +1,46 @@+module Hasql.Private.PreparedStatementRegistry+(+  PreparedStatementRegistry,+  new,+  lookup,+  register,+)+where++import Hasql.Prelude hiding (lookup)+import qualified Data.HashTable.IO as Hashtables+++data PreparedStatementRegistry =+  PreparedStatementRegistry !(Hashtables.BasicHashTable LocalKey ByteString) !(IORef Word)++{-# INLINABLE new #-}+new :: IO PreparedStatementRegistry+new =+  PreparedStatementRegistry <$> Hashtables.new <*> newIORef 0++{-# INLINABLE lookup #-}+lookup :: ByteString -> [Word32] -> PreparedStatementRegistry -> IO (Maybe ByteString)+lookup template oids (PreparedStatementRegistry table counter) =+  Hashtables.lookup table (LocalKey template oids)++{-# INLINABLE register #-}+register :: ByteString -> [Word32] -> PreparedStatementRegistry -> IO ByteString+register template oids (PreparedStatementRegistry table counter) =+  do+    n <- readIORef counter+    writeIORef counter (succ n)+    let remoteKey = fromString (show n)+    Hashtables.insert table (LocalKey template oids) remoteKey+    return remoteKey++-- |+-- Local statement key.+data LocalKey =+  LocalKey !ByteString ![Word32]+  deriving (Show, Eq)++instance Hashable LocalKey where+  {-# INLINE hashWithSalt #-}+  hashWithSalt salt (LocalKey template types) =+    hashWithSalt salt template
+ library/Hasql/Private/Query.hs view
@@ -0,0 +1,61 @@+module Hasql.Private.Query+where++import Hasql.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+++-- |+-- An abstraction over parametric queries.+-- +-- It is composable using+-- the standard interfaces of the category theory,+-- which it has instances of.+-- E.g., here's how you can compose queries+-- using the Arrow notation:+-- +-- @+-- -- |+-- -- Given an Update query,+-- -- which uses the \@fmap (> 0) 'Decoders.Results.rowsAffected'\@ decoder+-- -- to detect, whether it had any effect,+-- -- and an Insert query,+-- -- produces a query which performs Upsert.+-- composeUpsert :: Query a Bool -> Query a () -> Query a ()+-- composeUpsert update insert =+--   proc params -> do+--     updated <- update -< params+--     if updated+--       then 'returnA' -< ()+--       else insert -< params+-- @+newtype Query a b =+  Query (Kleisli (ReaderT Connection.Connection (EitherT Decoders.Results.Error IO)) a b)+  deriving (Category, Arrow, ArrowChoice, ArrowLoop, ArrowApply)++instance Functor (Query a) where+  {-# INLINE fmap #-}+  fmap =+    (^<<)++instance Profunctor Query where+  {-# INLINE lmap #-}+  lmap =+    (^>>)+  {-# INLINE rmap #-}+  rmap =+    (^<<)++statement :: ByteString -> Encoders.Params.Params a -> Decoders.Results.Results b -> Bool -> Query a b+statement template encoder decoder preparable =+  Query $ Kleisli $ \params -> +    ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) -> +      EitherT $ withMVar pqConnectionRef $ \pqConnection ->+        runEitherT $ do+          EitherT $ IO.sendParametricQuery pqConnection integerDatetimes registry template encoder preparable params+          EitherT $ IO.getResults pqConnection integerDatetimes decoder+
+ library/Hasql/Private/Session.hs view
@@ -0,0 +1,110 @@+module Hasql.Private.Session+where++import Hasql.Prelude+import qualified Database.PostgreSQL.LibPQ as LibPQ+import qualified Hasql.Decoders.Results as Decoders.Results+import qualified Hasql.Settings as Settings+import qualified Hasql.Private.IO as IO+import qualified Hasql.Private.Query as Query+import qualified Hasql.Private.Connection as Connection+++-- |+-- A batch of actions to be executed in the context of a database connection.+newtype Session a =+  Session (ReaderT Connection.Connection (EitherT Error IO) a)+  deriving (Functor, Applicative, Monad, MonadError Error, MonadIO)++-- |+-- Executes a bunch of commands on the provided connection.+run :: Session a -> Connection.Connection -> IO (Either Error a)+run (Session impl) connection =+  runEitherT $+  runReaderT impl connection++-- |+-- Possibly a multi-statement query,+-- which however cannot be parameterized or prepared,+-- nor can any results of it be collected.+sql :: ByteString -> Session ()+sql sql =+  Session $ ReaderT $ \(Connection.Connection pqConnectionRef integerDatetimes registry) ->+    EitherT $ fmap (mapLeft unsafeCoerce) $ withMVar pqConnectionRef $ \pqConnection ->+      IO.sendNonparametricQuery pqConnection sql++-- |+-- Parameters and a specification of the parametric query to apply them to.+query :: a -> Query.Query a b -> Session b+query input (Query.Query (Kleisli impl)) =+  Session $ unsafeCoerce $ impl input+++-- * Error+-------------------------++-- |+-- An error of some command in the session.+data Error =+  -- |+  -- An error on the client-side,+  -- with a message generated by the \"libpq\" library.+  -- Usually indicates problems with connection.+  ClientError !(Maybe ByteString) |+  -- |+  -- Some error with a command result.+  ResultError !ResultError+  deriving (Show, Eq)++-- |+-- An error with a command result.+data ResultError =+  -- | +  -- An error reported by the DB.+  -- Consists of the following: Code, message, details, hint.+  -- +  -- * __Code__.+  -- The SQLSTATE code for the error.+  -- It's recommended to use+  -- <http://hackage.haskell.org/package/postgresql-error-codes the "postgresql-error-codes" package>+  -- to work with those.+  -- +  -- * __Message__.+  -- The primary human-readable error message (typically one line). Always present.+  -- +  -- * __Details__.+  -- An optional secondary error message carrying more detail about the problem. +  -- Might run to multiple lines.+  -- +  -- * __Hint__.+  -- An optional suggestion on 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 !RowError |+  -- |+  -- An unexpected amount of rows.+  UnexpectedAmountOfRows !Int+  deriving (Show, Eq)++-- |+-- An error during the decoding of a specific row.+data RowError =+  -- |+  -- Appears on the attempt to parse more columns than there are in the result.+  EndOfInput |+  -- |+  -- Appears on the attempt to parse a @NULL@ as some value.+  UnexpectedNull |+  -- |+  -- Appears when a wrong value parser is used.+  -- Comes with the error details.+  ValueError !Text+  deriving (Show, Eq)
library/Hasql/Query.hs view
@@ -1,116 +1,42 @@ module Hasql.Query (-  Query(..),-  -- * Execution-  ResultsError(..),-  ResultError(..),-  RowError(..),-  run,+  Query.Query,+  statement, ) where  import Hasql.Prelude-import qualified Database.PostgreSQL.LibPQ as LibPQ-import qualified Hasql.PreparedStatementRegistry as PreparedStatementRegistry-import qualified Hasql.Decoders.Results as ResultsDecoders+import qualified Hasql.Private.Query as Query+import qualified Hasql.Decoders.Results as Decoders.Results import qualified Hasql.Decoders as Decoders-import qualified Hasql.Encoders.Params as ParamsEncoders+import qualified Hasql.Encoders.Params as Encoders.Params import qualified Hasql.Encoders as Encoders-import qualified Hasql.Settings as Settings-import qualified Hasql.IO as IO-import qualified Hasql.Connection.Impl as Connection  --- |--- An error of the result-decoder.-data ResultsError =-  -- |-  -- An error on the client-side,-  -- with a message generated by the \"libpq\" library.-  -- Usually indicates problems with connection.-  ClientError !(Maybe ByteString) |-  -- |-  -- Decoder error details.-  ResultError !ResultError-  deriving (Show, Eq)  -- |--- Decoder error details.-data ResultError =-  -- |-  -- An error reported by the DB.-  -- Consists of the following: Code, message, details, hint.-  ---  -- * __Code__.-  -- The SQLSTATE code for the error.-  -- It's recommended to use-  -- <http://hackage.haskell.org/package/postgresql-error-codes the "postgresql-error-codes" package>-  -- to work with those.-  ---  -- * __Message__.-  -- The primary human-readable error message (typically one line). Always present.-  ---  -- * __Details__.-  -- An optional secondary error message carrying more detail about the problem.-  -- Might run to multiple lines.-  ---  -- * __Hint__.-  -- An optional suggestion on 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 !RowError |-  -- |-  -- An unexpected amount of rows.-  UnexpectedAmountOfRows !Int-  deriving (Show, Eq)---- |--- An error during the decoding of a specific row.-data RowError =-  -- |-  -- Appears on the attempt to parse more columns than there are in the result.-  EndOfInput |-  -- |-  -- Appears on the attempt to parse a @NULL@ as some value.-  UnexpectedNull |-  -- |-  -- Appears when a wrong value parser is used.-  -- Comes with the error details.-  ValueError !Text-  deriving (Show, Eq)----- | -- A specification of a strictly single-statement query, which can be parameterized and prepared.---+--  -- Consists of the following:---+--  -- * SQL template, -- * params encoder, -- * result decoder, -- * a flag, determining whether it should be prepared.---+--  -- The SQL template must be formatted according to Postgres' standard, -- with any non-ASCII characters of the template encoded using UTF-8. -- According to the format, -- parameters must be referred to using the positional notation, as in the following: -- @$1@, @$2@, @$3@ and etc. -- Those references must be used to refer to the values of the 'Encoders.Params' encoder.---+--  -- Following is an example of the declaration of a prepared statement with its associated codecs.---+--  -- @--- selectSum :: Hasql.'Hasql.Query' (Int64, Int64) Int64+-- selectSum :: Hasql.Query.'Query.Query' (Int64, Int64) Int64 -- selectSum =---   Hasql.'Hasql.Query' sql encoder decoder True+--   Hasql.Query.'statement' sql encoder decoder True --   where --     sql = --       "select ($1 + $2)"@@ -120,47 +46,12 @@ --     decoder = --       Hasql.Decoders.'Hasql.Decoders.singleRow' (Hasql.Decoders.'Hasql.Decoders.value' Hasql.Decoders.'Hasql.Decoders.int8') -- @---+--  -- The statement above accepts a product of two parameters of type 'Int64' -- and produces a single result of type 'Int64'.----data Query a b =-  Query !ByteString !(Encoders.Params a) !(Decoders.Result b) !Bool-  deriving (Functor)--instance Profunctor Query where-  {-# INLINE lmap #-}-  lmap f (Query p1 p2 p3 p4) =-    Query p1 (contramap f p2) p3 p4-  {-# INLINE rmap #-}-  rmap f (Query p1 p2 p3 p4) =-    Query p1 p2 (fmap f p3) p4-  {-# INLINE dimap #-}-  dimap f1 f2 (Query p1 p2 p3 p4) =-    Query p1 (contramap f1 p2) (fmap f2 p3) p4---- |--- Execute the query, producing either a deserialization failure or a successful result.-run :: Query a b -> a -> Connection.Connection -> IO (Either ResultsError b)-run (Query template encoder decoder preparable) params (Connection.Connection pqConnectionRef integerDatetimes registry) =-  {-# SCC "query" #-}-  withMVar pqConnectionRef $ \pqConnection ->-    fmap (mapLeft coerceResultsError) $ runEitherT $ do-      EitherT $ IO.sendParametricQuery pqConnection integerDatetimes registry template (coerceEncoder encoder) preparable params-      EitherT $ IO.getResults pqConnection integerDatetimes (coerceDecoder decoder)---- |--- WARNING: We need to take special care that the structure of--- the "ResultsDecoders.Error" type in the public API is an exact copy of--- "Error", since we're using coercion.-coerceResultsError :: ResultsDecoders.Error -> ResultsError-coerceResultsError =-  unsafeCoerce--coerceDecoder :: Decoders.Result a -> ResultsDecoders.Results a-coerceDecoder =-  unsafeCoerce+-- +{-# INLINE statement #-}+statement :: ByteString -> Encoders.Params a -> Decoders.Result b -> Bool -> Query.Query a b+statement =+  unsafeCoerce Query.statement -coerceEncoder :: Encoders.Params a -> ParamsEncoders.Params a-coerceEncoder =-  unsafeCoerce
+ library/Hasql/Session.hs view
@@ -0,0 +1,15 @@+module Hasql.Session+(+  Session.Session,+  Session.sql,+  Session.query,+  -- * Execution+  Session.Error(..),+  Session.ResultError(..),+  Session.RowError(..),+  Session.run,+)+where++import qualified Hasql.Private.Session as Session+
tasty/Main.hs view
@@ -23,78 +23,27 @@     testCase "Executing the same query twice" $     pure ()     ,-    testCase "Interval Encoding" $-    let-      actualIO =-        DSL.session $ do-          let-            query =-              Query.statement sql encoder decoder True-              where-                sql =-                  "select $1 = interval '10 seconds'"-                decoder =-                  (Decoders.singleRow (Decoders.value (Decoders.bool)))-                encoder =-                  Encoders.value (Encoders.interval)-            in DSL.query (10 :: DiffTime) query-      in actualIO >>= \x -> assertEqual (show x) (Right True) x-    ,-    testCase "Interval Decoding" $-    let-      actualIO =-        DSL.session $ do-          let-            query =-              Query.statement sql encoder decoder True-              where-                sql =-                  "select interval '10 seconds'"-                decoder =-                  (Decoders.singleRow (Decoders.value (Decoders.interval)))-                encoder =-                  Encoders.unit-            in DSL.query () query-      in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x-    ,-    testCase "Interval Encoding/Decoding" $-    let-      actualIO =-        DSL.session $ do-          let-            query =-              Query.statement sql encoder decoder True-              where-                sql =-                  "select $1"-                decoder =-                  (Decoders.singleRow (Decoders.value (Decoders.interval)))-                encoder =-                  Encoders.value (Encoders.interval)-            in DSL.query (10 :: DiffTime) query-      in actualIO >>= \x -> assertEqual (show x) (Right (10 :: DiffTime)) x-    ,     testCase "Enum" $     let       actualIO =         DSL.session $ do           let             query =-              Query.Query sql mempty Decoders.unit True+              Query.statement sql mempty Decoders.unit True               where                 sql =                   "drop type if exists mood"             in DSL.query () query           let             query =-              Query.Query sql mempty Decoders.unit True+              Query.statement sql mempty Decoders.unit True               where                 sql =                   "create type mood as enum ('sad', 'ok', 'happy')"             in DSL.query () query           let             query =-              Query.Query sql encoder decoder True+              Query.statement sql encoder decoder True               where                 sql =                   "select ($1 :: mood)"@@ -114,7 +63,7 @@               DSL.query "ok" query               where                 query =-                  Query.Query sql encoder decoder True+                  Query.statement sql encoder decoder True                   where                     sql =                       "select $1"@@ -126,7 +75,7 @@               DSL.query 1 query               where                 query =-                  Query.Query sql encoder decoder True+                  Query.statement sql encoder decoder True                   where                     sql =                       "select $1"@@ -157,7 +106,7 @@             DSL.query () $ Queries.plain $             "insert into a (name) values ('a')"             deleteRows =-            DSL.query () $ Query.Query sql def decoder False+            DSL.query () $ Query.statement sql def decoder False             where               sql =                 "delete from a"@@ -171,8 +120,8 @@         DSL.session $ do           DSL.query () $ Queries.plain $ "drop table if exists a"           DSL.query () $ Queries.plain $ "create table a (id serial not null, v char not null, primary key (id))"-          id1 <- DSL.query () $ Query.Query "insert into a (v) values ('a') returning id" def (Decoders.singleRow (Decoders.value Decoders.int4)) False-          id2 <- DSL.query () $ Query.Query "insert into a (v) values ('b') returning id" def (Decoders.singleRow (Decoders.value Decoders.int4)) False+          id1 <- DSL.query () $ Query.statement "insert into a (v) values ('a') returning id" def (Decoders.singleRow (Decoders.value Decoders.int4)) False+          id2 <- DSL.query () $ Query.statement "insert into a (v) values ('b') returning id" def (Decoders.singleRow (Decoders.value Decoders.int4)) False           DSL.query () $ Queries.plain $ "drop table if exists a"           pure (id1, id2)       in assertEqual "" (Right (1, 2)) =<< actualIO
tasty/Main/DSL.hs view
@@ -3,18 +3,18 @@ import Main.Prelude import qualified Hasql.Connection as HC import qualified Hasql.Query as HQ-import qualified Hasql.Settings as HS import qualified Hasql.Encoders as HE import qualified Hasql.Decoders as HD+import qualified Hasql.Session   newtype Session a =-  Session (ReaderT HC.Connection (EitherT HQ.ResultsError IO) a)+  Session (ReaderT HC.Connection (EitherT Hasql.Session.Error IO) a)   deriving (Functor, Applicative, Monad, MonadIO)  data SessionError =-  ConnectionError (HC.ConnectionError) |-  ResultsError (HQ.ResultsError)+  ConnectionError (Maybe ByteString) |+  SessionError (Hasql.Session.Error)   deriving (Show, Eq)  session :: Session a -> IO (Either SessionError a)@@ -25,7 +25,7 @@       EitherT $ fmap (mapLeft ConnectionError) $ HC.acquire settings       where         settings =-          HS.settings host port user password database+          HC.settings host port user password database           where             host = "localhost"             port = 5432@@ -33,11 +33,11 @@             password = ""             database = "postgres"     use connection =-      bimapEitherT ResultsError id $+      bimapEitherT SessionError id $       runReaderT impl connection     release connection =       lift $ HC.release connection  query :: a -> HQ.Query a b -> Session b query params query =-  Session $ ReaderT $ EitherT . HQ.run query params+  Session $ ReaderT $ \connection -> EitherT $ flip Hasql.Session.run connection $ Hasql.Session.query params query
tasty/Main/Queries.hs view
@@ -9,11 +9,11 @@  def :: ByteString -> HQ.Query () () def sql =-  HQ.Query sql Prelude.def Prelude.def False+  HQ.statement sql Prelude.def Prelude.def False  plain :: ByteString -> HQ.Query () () plain sql =-  HQ.Query sql mempty HD.unit False+  HQ.statement sql mempty HD.unit False  dropType :: ByteString -> HQ.Query () () dropType name =@@ -28,7 +28,7 @@  selectList :: HQ.Query () ([] (Int64, Int64)) selectList =-  HQ.Query sql mempty decoder True+  HQ.statement sql mempty decoder True   where     sql =       "values (1,2), (3,4), (5,6)"