diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..633cafc --- /dev/null +++ b/.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; diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..defe17a --- /dev/null +++ b/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. diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 index 0000000..0c223f8 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import BasePrelude hiding (assert, isRight, isLeft) + + +main = + undefined diff --git a/hasql-tx.cabal b/hasql-tx.cabal new file mode 100644 index 0000000..4fdd736 --- /dev/null +++ b/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 +maintainer: + Nikita Volkov +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 diff --git a/library/Hasql/Tx.hs b/library/Hasql/Tx.hs new file mode 100644 index 0000000..b229625 --- /dev/null +++ b/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 +-- . +-- +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 diff --git a/library/Hasql/Tx/Prelude.hs b/library/Hasql/Tx/Prelude.hs new file mode 100644 index 0000000..1a3a5af --- /dev/null +++ b/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" |] diff --git a/library/Hasql/Tx/Queries.hs b/library/Hasql/Tx/Queries.hs new file mode 100644 index 0000000..f72e6bc --- /dev/null +++ b/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)) + +