Init

.travis.yml

@@ -0,0 +1,53 @@
+env:
+  - ghc=7.6.1  cabal=1.18
+  - ghc=7.8.1  cabal=1.18
+  - ghc=7.10.1 cabal=1.22 benchmarks=1 tests=1
+
+install:
+  # Set up the Shell to treat the semicolon as &&
+  - set -o pipefail && set -e
+  # Install GHC and Cabal
+  -
+    ghc=${ghc=7.10.1}; 
+    cabal=${cabal=1.22};
+    travis_retry sudo add-apt-repository -y ppa:hvr/ghc;
+    travis_retry sudo apt-get update;
+    travis_retry sudo apt-get install cabal-install-$cabal ghc-$ghc;
+    export PATH=/opt/ghc/$ghc/bin:/opt/cabal/$cabal/bin:$PATH;
+  # Update the Cabal database
+  - cabal update
+  # Switch to the distro:
+  - 
+    export pkg_name=$(cabal info . | awk '{print $2;exit}');
+    cabal sdist;
+    cd dist;
+    tar xzvf $pkg_name.tar.gz;
+    cd $pkg_name;
+  # Install the lower bound dependencies
+  - 
+    if [ "$lower_bound_dependencies" = "1" ];
+    then
+      constraint_options=(
+      );
+    fi;
+  # Install the library dependencies
+  - cabal install --only-dependencies --reorder-goals --force-reinstalls
+      ${constraint_options[@]}
+      $([ "$tests" = "1" ] && echo "--enable-tests")
+      $([ "$benchmarks" = "1" ] && echo "--enable-benchmarks")
+  # Build the library
+  - cabal build
+  # Configure and build the remaining stuff
+  - cabal configure 
+      $([ "$tests" = "1" ] && echo "--enable-tests")
+      $([ "$benchmarks" = "1" ] && echo "--enable-benchmarks")
+      -f doctest
+  - cabal build
+
+script:
+  - |
+    if [ "$tests" = "1" ];
+    then
+      cabal clean;
+      cabal test --show-details=always;
+    fi;

LICENSE

@@ -0,0 +1,22 @@
+Copyright (c) 2015, Nikita Volkov
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the "Software"), to deal in the Software without
+restriction, including without limitation the rights to use,
+copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following
+conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.

demo/Main.hs

@@ -0,0 +1,7 @@
+module Main where
+
+import BasePrelude hiding (assert, isRight, isLeft)
+
+
+main =
+  undefined

hasql-tx.cabal

@@ -0,0 +1,93 @@
+name:
+  hasql-tx
+version:
+  1
+category:
+  Database, DSL, PostgreSQL
+synopsis:
+homepage:
+  https://github.com/nikita-volkov/hasql-tx 
+bug-reports:
+  https://github.com/nikita-volkov/hasql-tx/issues 
+author:
+  Nikita Volkov <[email protected]>
+maintainer:
+  Nikita Volkov <[email protected]>
+copyright:
+  (c) 2015, Nikita Volkov
+license:
+  MIT
+license-file:
+  LICENSE
+build-type:
+  Simple
+cabal-version:
+  >=1.10
+
+
+source-repository head
+  type:
+    git
+  location:
+    git://github.com/nikita-volkov/hasql-tx.git
+
+
+library
+  hs-source-dirs:
+    library
+  ghc-options:
+  default-extensions:
+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
+  default-language:
+    Haskell2010
+  other-modules:
+    Hasql.Tx.Prelude
+    Hasql.Tx.Queries
+  exposed-modules:
+    Hasql.Tx
+  build-depends:
+    hasql >= 1 && < 1.1,
+    -- parsing:
+    attoparsec >= 0.10 && < 0.14,
+    -- database:
+    postgresql-binary == 0.5.*,
+    postgresql-libpq == 0.9.*,
+    -- data:
+    aeson >= 0.7 && < 0.11,
+    uuid == 1.3.*,
+    vector >= 0.10 && < 0.12,
+    time >= 1.4 && < 1.6,
+    hashtables >= 1.1 && < 1.3,
+    scientific >= 0.2 && < 0.4,
+    text >= 1 && < 1.3,
+    bytestring >= 0.10 && < 0.11,
+    hashable >= 1.2 && < 1.3,
+    -- control:
+    contravariant >= 1.3 && < 2,
+    either >= 4.4.1 && < 5,
+    transformers >= 0.3 && < 0.5,
+    -- errors:
+    loch-th == 0.2.*,
+    placeholders == 0.1.*,
+    -- general:
+    base-prelude >= 0.1.19 && < 0.2
+
+
+executable demo
+  hs-source-dirs:
+    demo
+  main-is:
+    Main.hs
+  ghc-options:
+    -threaded
+    "-with-rtsopts=-N"
+  default-extensions:
+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFunctor, DeriveGeneric, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples
+  default-language:
+    Haskell2010
+  build-depends:
+    contravariant,
+    hasql-tx,
+    text,
+    bytestring,
+    base-prelude

library/Hasql/Tx.hs

@@ -0,0 +1,75 @@
+module Hasql.Tx
+where
+
+import Hasql.Tx.Prelude
+import qualified Hasql.Connection as Connection
+import qualified Hasql.Query as Query
+import qualified Hasql.ErrorCodes as ErrorCodes
+import qualified Hasql.Tx.Queries as Queries
+
+
+newtype Tx a =
+  Tx (ReaderT (Connection.Connection, IORef Int) (EitherT Connection.ResultsError IO) a)
+  deriving (Functor, Applicative, Monad)
+
+-- |
+-- 
+data Mode =
+  -- |
+  -- Read-only. No writes possible.
+  Read |
+  -- |
+  -- Write and commit.
+  Write |
+  -- |
+  -- Write without committing.
+  -- Useful for testing, 
+  -- allowing you to modify your database, 
+  -- producing some result based on your changes,
+  -- and to let Hasql roll all the changes back on the exit from the transaction.
+  WriteWithoutCommitting
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+-- |
+-- For reference see
+-- <http://www.postgresql.org/docs/current/static/transaction-iso.html the Postgres' documentation>.
+-- 
+data IsolationLevel =
+  ReadCommitted |
+  RepeatableRead |
+  Serializable
+  deriving (Show, Eq, Ord, Enum, Bounded)
+
+run :: Tx a -> Connection.Connection -> IsolationLevel -> Mode -> IO (Either Connection.ResultsError a)
+run (Tx tx) connection isolation mode =
+  runEitherT $ do
+    EitherT $ Connection.executeParametricQuery connection (Queries.beginTransaction mode') ()
+    counterRef <- lift $ newIORef 0
+    resultEither <- lift $ runEitherT $ runReaderT tx (connection, counterRef)
+    case resultEither of
+      Left (Connection.ResultError (Connection.ServerError code _ _ _))
+        | code == ErrorCodes.serialization_failure ->
+          EitherT $ run (Tx tx) connection isolation mode
+      _ -> do
+        result <- EitherT $ pure resultEither
+        let
+          query =
+            if commit
+              then Queries.commitTransaction
+              else Queries.abortTransaction
+          in
+            EitherT $ Connection.executeParametricQuery connection query ()
+        pure result
+  where
+    mode' =
+      (unsafeCoerce isolation, write)
+    (write, commit) =
+      case mode of
+        Read -> (False, True)
+        Write -> (True, True)
+        WriteWithoutCommitting -> (True, False)
+
+parametricQuery :: Query.ParametricQuery a b -> a -> Tx b
+parametricQuery query params =
+  Tx $ ReaderT $ \(connection, _) -> EitherT $
+  Connection.executeParametricQuery connection query params

library/Hasql/Tx/Prelude.hs

@@ -0,0 +1,59 @@
+module Hasql.Tx.Prelude
+( 
+  module Exports,
+  bug,
+  bottom,
+)
+where
+
+
+-- base-prelude
+-------------------------
+import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, error)
+
+-- 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)
+
+-- contravariant
+-------------------------
+import Data.Functor.Contravariant as Exports
+import Data.Functor.Contravariant.Divisible as Exports
+
+-- either
+-------------------------
+import Control.Monad.Trans.Either as Exports
+import Data.Either.Combinators as Exports
+
+-- text
+-------------------------
+import Data.Text as Exports (Text)
+
+-- bytestring
+-------------------------
+import Data.ByteString as Exports (ByteString)
+
+-- placeholders
+-------------------------
+import Development.Placeholders as Exports
+
+-- loch-th
+-------------------------
+import Debug.Trace.LocationTH as Exports
+
+-- custom
+-------------------------
+import qualified Debug.Trace.LocationTH
+
+
+bug =
+  [e| $(Debug.Trace.LocationTH.failure) . (msg <>) |]
+  where
+    msg = "A \"hasql\" package bug: " :: String
+
+bottom =
+  [e| $bug "Bottom evaluated" |]

library/Hasql/Tx/Queries.hs

@@ -0,0 +1,75 @@
+module Hasql.Tx.Queries
+where
+
+import Hasql.Tx.Prelude
+import Hasql.Query
+import qualified Hasql.Serialization as S
+import qualified Hasql.Deserialization as D
+
+
+-- * Transactions
+-------------------------
+
+data Isolation =
+  ReadCommitted |
+  RepeatableRead |
+  Serializable 
+
+type TransactionMode =
+  (Isolation, Bool)
+
+beginTransaction :: TransactionMode -> ParametricQuery () ()
+beginTransaction (isolation, write) =
+  (template, mempty, D.result D.noResult, True)
+  where
+    template =
+      mconcat
+      [
+        "BEGIN "
+        ,
+        case isolation of
+          ReadCommitted  -> "ISOLATION LEVEL READ COMMITTED"
+          RepeatableRead -> "ISOLATION LEVEL REPEATABLE READ"
+          Serializable   -> "ISOLATION LEVEL SERIALIZABLE"
+        ,
+        " "
+        ,
+        case write of
+          True  -> "READ WRITE"
+          False -> "READ ONLY"
+      ]
+
+commitTransaction :: ParametricQuery () ()
+commitTransaction =
+  ("COMMIT", mempty, D.result D.noResult, True)
+
+abortTransaction :: ParametricQuery () ()
+abortTransaction =
+  ("ABORT", mempty, D.result D.noResult, True)
+
+
+-- * Streaming
+-------------------------
+
+declareCursor :: ByteString -> ParametricQuery a b -> ParametricQuery a b
+declareCursor name (template, serializer, deserializer, preparable) =
+  (template', serializer, deserializer, False)
+  where
+    template' =
+      "DECLARE " <> name <> " NO SCROLL CURSOR FOR " <> template
+
+closeCursor :: ParametricQuery ByteString ()
+closeCursor =
+  ("CLOSE $1", S.value (S.nonNull S.bytea), D.result D.noResult, True)
+
+fetchFromCursor :: D.Results a -> ParametricQuery (Int64, ByteString) a
+fetchFromCursor deserializer =
+  (template, serializer, deserializer, True)
+  where
+    template =
+      "FETCH FORWARD $1 FROM $2"
+    serializer =
+      contramap fst (S.value (S.nonNull S.int8)) <>
+      contramap snd (S.value (S.nonNull S.bytea))
+
+