diff --git a/hasbolt.cabal b/hasbolt.cabal --- a/hasbolt.cabal +++ b/hasbolt.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: hasbolt -version: 0.1.3.3 +version: 0.1.3.4 license: BSD3 license-file: LICENSE copyright: (c) 2018 Pavel Yakovlev @@ -36,6 +36,7 @@ Database.Bolt Database.Bolt.Lazy Database.Bolt.Lens + Database.Bolt.Serialization hs-source-dirs: src other-modules: Database.Bolt.Value.Type @@ -48,6 +49,7 @@ Database.Bolt.Connection.Pipe Database.Bolt.Connection Database.Bolt.Record + Database.Bolt.Transaction default-language: Haskell2010 ghc-options: -Wall build-depends: @@ -57,8 +59,8 @@ containers >=0.5.7.1 && <0.7, binary >=0.8.3.0 && <1.0, data-binary-ieee754 >=0.4.4 && <0.5, - transformers >=0.5.2.0 && <0.6, - network >=2.6.3.1 && <3.1, + mtl >=2.2.0 && <2.3, + network >=2.6.3.1 && <3.2, connection >=0.2.8 && <0.4, data-default >=0.7.1.1 && <0.8 diff --git a/src/Database/Bolt.hs b/src/Database/Bolt.hs --- a/src/Database/Bolt.hs +++ b/src/Database/Bolt.hs @@ -2,9 +2,10 @@ ( BoltActionT , connect, close, reset , run, queryP, query, queryP_, query_ + , transact , Pipe , BoltCfg (..) - , BoltValue (..), Value (..), Structure (..), Record, RecordValue (..), at + , Value (..), Structure (..), Record, RecordValue (..), at , Node (..), Relationship (..), URelationship (..), Path (..) ) where @@ -12,6 +13,7 @@ import Database.Bolt.Connection.Pipe import Database.Bolt.Connection.Type import Database.Bolt.Record +import Database.Bolt.Transaction import Database.Bolt.Value.Instances () import Database.Bolt.Value.Structure () import Database.Bolt.Value.Type diff --git a/src/Database/Bolt/Connection.hs b/src/Database/Bolt/Connection.hs --- a/src/Database/Bolt/Connection.hs +++ b/src/Database/Bolt/Connection.hs @@ -14,7 +14,7 @@ import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..), liftIO) -import Control.Monad.Trans.Reader (ReaderT (..), ask, runReaderT) +import Control.Monad.Reader (ReaderT (..), ask, runReaderT) import Data.Text (Text) import Data.Map.Strict (Map, empty) diff --git a/src/Database/Bolt/Lazy.hs b/src/Database/Bolt/Lazy.hs --- a/src/Database/Bolt/Lazy.hs +++ b/src/Database/Bolt/Lazy.hs @@ -2,9 +2,10 @@ ( BoltActionT , connect, close, reset , run, queryP, query, queryP_, query_ + , transact , Pipe , BoltCfg (..) - , BoltValue (..), Value (..), Structure (..), Record, RecordValue (..), at + , Value (..), Structure (..), Record, RecordValue (..), at , Node (..), Relationship (..), URelationship (..), Path (..) ) where diff --git a/src/Database/Bolt/Serialization.hs b/src/Database/Bolt/Serialization.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Serialization.hs @@ -0,0 +1,7 @@ +module Database.Bolt.Serialization + ( BoltValue (..) + , UnpackT + , ToStructure (..), FromStructure (..) + ) where + +import Database.Bolt.Value.Type diff --git a/src/Database/Bolt/Transaction.hs b/src/Database/Bolt/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Transaction.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +module Database.Bolt.Transaction + ( transact + ) where + +import Control.Monad ( void ) +import Control.Monad.IO.Class ( MonadIO(..) ) +import Control.Monad.Except ( MonadError(..) ) + +import Database.Bolt.Connection ( BoltActionT + , query' + ) + +-- |Runs a sequence of actions as transaction. All queries would be rolled back +-- in case of any exception inside the block. +transact :: (MonadError e m, MonadIO m) => BoltActionT m a -> BoltActionT m a +transact actions = do + txBegin + let processErrors = flip catchError $ \e -> txRollback >> throwError e + result <- processErrors actions + txCommit + pure result + +txBegin :: MonadIO m => BoltActionT m () +txBegin = void $ query' "BEGIN" + +txCommit :: MonadIO m => BoltActionT m () +txCommit = void $ query' "COMMIT" + +txRollback :: MonadIO m => BoltActionT m () +txRollback = void $ query' "ROLLBACK" diff --git a/src/Database/Bolt/Value/Instances.hs b/src/Database/Bolt/Value/Instances.hs --- a/src/Database/Bolt/Value/Instances.hs +++ b/src/Database/Bolt/Value/Instances.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} module Database.Bolt.Value.Instances where @@ -8,7 +9,7 @@ import Control.Applicative (pure) import Control.Monad (forM, replicateM) -import Control.Monad.Trans.State (gets, modify) +import Control.Monad.State (gets, modify) import Data.Binary (Binary (..), decode, encode) import Data.Binary.IEEE754 (doubleToWord, wordToDouble) import Data.ByteString (ByteString, append, cons, @@ -106,9 +107,9 @@ instance BoltValue Structure where pack (Structure sig lst) | size < size4 = (structConst + fromIntegral size) `cons` pData - | size < size8 = struct8Code `cons` fromIntegral size `cons` pData - | size < size16 = struct16Code `cons` encodeStrict size `append` pData - | otherwise = error "Cannot pack so large structure" + | size < size8 = struct8Code `cons` fromIntegral size `cons` pData + | size < size16 = struct16Code `cons` encodeStrict size `append` pData + | otherwise = error "Cannot pack so large structure" where size = fromIntegral $ length lst :: Word16 pData = sig `cons` B.concat (map pack lst) diff --git a/src/Database/Bolt/Value/Type.hs b/src/Database/Bolt/Value/Type.hs --- a/src/Database/Bolt/Value/Type.hs +++ b/src/Database/Bolt/Value/Type.hs @@ -1,6 +1,6 @@ module Database.Bolt.Value.Type where -import Control.Monad.Trans.State (StateT (..), evalStateT) +import Control.Monad.State (StateT (..), evalStateT) import Data.ByteString (ByteString) import Data.Map.Strict (Map) import Data.Text (Text) diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -12,6 +12,7 @@ import Test.QuickCheck import Database.Bolt +import Database.Bolt.Serialization main :: IO () main = hspec $ do