Merge pull request #41 from maksbotan/maksbotan/bolt-v3-transact

version 0.1.7.0: better bolt v3 support

Author: maksbotan

hasbolt.cabal

@@ -1,5 +1,5 @@
 name:                hasbolt
-version:             0.1.6.3
+version:             0.1.7.0
 synopsis:            Haskell driver for Neo4j 3+ (BOLT protocol)
 description:
   Haskell driver for Neo4j 3+ (BOLT protocol).

src/Database/Bolt/Connection.hs

@@ -10,6 +10,8 @@ module Database.Bolt.Connection
   , queryP, query
   , queryP', query'
   , queryP_, query_
+
+  , sendRawRequest
   ) where
 
 import           Database.Bolt.Connection.Pipe
@@ -102,16 +104,22 @@ pullRecords strict keys = do pipe <- ask
                                    else unsafeInterleaveIO pull
         pure (record:rest)
 
--- |Sends request to database and makes an action
+-- | Sends any 'Request' and reads the response.
+sendRawRequest :: MonadIO m => HasCallStack => Request -> BoltActionT m Response
+sendRawRequest req = do
+  pipe <- ask
+  liftE $ do
+    flush pipe req
+    status <- fetch pipe
+    if isSuccess status
+      then pure status
+      else do processError pipe
+              throwError $ ResponseError (mkFailure status)
+
+-- | Sends a query with parameters to database and reads the response.
 sendRequest :: MonadIO m => HasCallStack => Text -> Map Text Value -> Map Text Value -> BoltActionT m Response
 sendRequest cypher params ext =
   do pipe <- ask
-     liftE $ do
-         if isNewVersion (pipe_version pipe)
-            then flush pipe $ RequestRunV3 cypher params ext
-            else flush pipe $ RequestRun cypher params
-         status <- fetch pipe
-         if isSuccess status
-           then pure status
-           else do processError pipe
-                   throwError $ ResponseError (mkFailure status)
+     if isNewVersion (pipe_version pipe)
+        then sendRawRequest $ RequestRunV3 cypher params ext
+        else sendRawRequest $ RequestRun cypher params

src/Database/Bolt/Connection/Instances.hs

@@ -12,6 +12,7 @@ import           Database.Bolt.Value.Type
 import           Control.Monad.Except           (MonadError (..))
 import           Data.Map.Strict                (Map, insert, fromList, empty, (!))
 import           Data.Text                      (Text)
+import           GHC.Stack                      (HasCallStack)
 
 instance ToStructure Request where
   toStructure RequestInit{..}           = Structure sigInit $ if isHello then [M $ helloMap agent token]
@@ -23,15 +24,18 @@ instance ToStructure Request where
   toStructure RequestPullAll            = Structure sigPAll []
   toStructure RequestDiscardAll         = Structure sigDAll []
   toStructure RequestGoodbye            = Structure sigGBye []
+  toStructure RequestBegin{..}          = Structure sigBegin [M extra]
+  toStructure RequestCommit             = Structure sigCommit []
+  toStructure RequestRollback           = Structure sigRollback []
 
 instance FromStructure Response where
   fromStructure Structure{..}
-    | signature == sigSucc = ResponseSuccess <$> extractMap (head fields)
+    | signature == sigSucc = ResponseSuccess <$> extractMap fields
     | signature == sigRecs = pure $ ResponseRecord (removeExtList fields)
-    | signature == sigIgn  = ResponseIgnored <$> extractMap (head fields)
-    | signature == sigFail = ResponseFailure <$> extractMap (head fields)
-    | otherwise            = throwError $ Not "Response" 
-    where removeExtList :: [Value] -> [Value]
+    | signature == sigIgn  = pure ResponseIgnored
+    | signature == sigFail = ResponseFailure <$> extractMap fields
+    | otherwise            = throwError $ Not "Response"
+    where removeExtList :: HasCallStack => [Value] -> [Value]
           removeExtList [L x] = x
           removeExtList _     = error "Record must contain only a singleton list"
 
@@ -46,8 +50,8 @@ isFailure (ResponseFailure _) = True
 isFailure _                   = False
 
 isIgnored :: Response -> Bool
-isIgnored (ResponseIgnored _) = True
-isIgnored _                   = False
+isIgnored ResponseIgnored = True
+isIgnored _               = False
 
 isRecord :: Response -> Bool
 isRecord (ResponseRecord _) = True
@@ -67,7 +71,7 @@ createRun :: Text -> Request
 createRun stmt = RequestRun stmt empty
 
 
-helloMap :: Text -> AuthToken  -> Map Text Value 
+helloMap :: Text -> AuthToken  -> Map Text Value
 helloMap a = insert "user_agent" (T a) . tokenMap
 
 tokenMap :: AuthToken -> Map Text Value
@@ -76,8 +80,8 @@ tokenMap at = fromList [ "scheme"     =: scheme at
                        , "credentials" =: credentials at
                        ]
 
-extractMap :: MonadError UnpackError m => Value -> m (Map Text Value)
-extractMap (M mp) = pure mp
+extractMap :: MonadError UnpackError m => [Value] -> m (Map Text Value)
+extractMap [M mp] = pure mp
 extractMap _      = throwError NotDict
 
 mkFailure :: Response -> ResponseError

src/Database/Bolt/Connection/Type.hs

@@ -122,24 +122,35 @@ data AuthToken = AuthToken { scheme      :: Text
 
 data Response = ResponseSuccess { succMap   :: Map Text Value }
               | ResponseRecord  { recsList  :: [Value] }
-              | ResponseIgnored { ignoreMap :: Map Text Value }
+              | ResponseIgnored
               | ResponseFailure { failMap   :: Map Text Value }
   deriving (Eq, Show)
 
-data Request = RequestInit  { agent   :: Text
-                            , token   :: AuthToken
-                            , isHello :: Bool
-                            }
-             | RequestRun   { statement  :: Text
-                            , parameters :: Map Text Value
-                            }
-             | RequestRunV3 { statement  :: Text
-                            , parameters :: Map Text Value
-                            , extra      :: Map Text Value
-                            }
+data Request = RequestInit
+                 { agent   :: Text
+                 , token   :: AuthToken
+                 , isHello :: Bool
+                 }
+             | RequestRun
+                 { statement  :: Text
+                 , parameters :: Map Text Value
+                 }
+             | RequestRunV3
+                 { statement  :: Text
+                 , parameters :: Map Text Value
+                 , extra      :: Map Text Value
+                 }
              | RequestAckFailure
              | RequestReset
              | RequestDiscardAll
              | RequestPullAll
              | RequestGoodbye
+               -- | Introduced in v3.
+             | RequestBegin
+                 { extra       :: Map Text Value
+                 }
+               -- | Introduced in v3.
+             | RequestCommit
+               -- | Introduced in v3.
+             | RequestRollback
   deriving (Eq, Show)

src/Database/Bolt/Transaction.hs

@@ -4,12 +4,17 @@ module Database.Bolt.Transaction
   ) where
 
 import           Control.Monad                  ( void )
+import           Control.Monad.Reader           ( ask )
 import           Control.Monad.Trans            ( MonadIO(..) )
 import           Control.Monad.Except           ( MonadError(..) )
 
 import           Database.Bolt.Connection       ( BoltActionT
-                                                , query'
+                                                , query', sendRawRequest
                                                 )
+import           Database.Bolt.Connection.Type  ( Request(..)
+                                                , pipe_version
+                                                )
+import           Database.Bolt.Value.Helpers    ( isNewVersion )
 
 -- |Runs a sequence of actions as transaction. All queries would be rolled back
 -- in case of any exception inside the block.
@@ -22,10 +27,22 @@ transact actions = do
     pure result
 
 txBegin :: MonadIO m => BoltActionT m ()
-txBegin = void $ query' "BEGIN"
+txBegin = do
+  pipe <- ask
+  if isNewVersion $ pipe_version pipe
+     then void $ sendRawRequest $ RequestBegin mempty
+     else void $ query' "BEGIN"
 
 txCommit :: MonadIO m => BoltActionT m ()
-txCommit = void $ query' "COMMIT"
+txCommit = do
+  pipe <- ask
+  if isNewVersion $ pipe_version pipe
+     then void $ sendRawRequest RequestCommit
+     else void $ query' "COMMIT"
 
 txRollback :: MonadIO m => BoltActionT m ()
-txRollback = void $ query' "ROLLBACK"
+txRollback = do
+  pipe <- ask
+  if isNewVersion $ pipe_version pipe
+     then void $ sendRawRequest RequestRollback
+     else void $ query' "ROLLBACK"

src/Database/Bolt/Value/Helpers.hs

@@ -160,27 +160,47 @@ sigPath :: Word8
 sigPath = 80
 
 -- == BOLT requests signatures
+-- https://neo4j.com/docs/bolt/current/bolt/message/
 
+-- @INIT@ in v1 & v2, @HELLO@ in v3.
 sigInit :: Word8
-sigInit = 1
+sigInit = 0x01
 
+-- @RUN@.
 sigRun :: Word8
-sigRun = 16
+sigRun = 0x10
 
+-- @ACK_FAILURE@, removed in v3.
 sigAFail :: Word8
-sigAFail = 14
+sigAFail = 0x0e
 
+-- @RESET@
 sigReset :: Word8
-sigReset = 15
+sigReset = 0x0f
 
+-- @DISCARD_ALL@ in v1 & v2, @DISCARD@ in v3.
 sigDAll :: Word8
-sigDAll = 47
+sigDAll = 0x2f
 
+-- @PULL_ALL@ in v1 & v2, @PULL@ in v3.
 sigPAll :: Word8
-sigPAll = 63
+sigPAll = 0x3f
 
-sigGBye :: Word8 
-sigGBye = 2
+-- @GOODBYE@, introduced in v3.
+sigGBye :: Word8
+sigGBye = 0x02
+
+-- @BEGIN@, introduced in v3.
+sigBegin :: Word8
+sigBegin = 0x11
+
+-- @COMMIT@, introduced in v3.
+sigCommit :: Word8
+sigCommit = 0x12
+
+-- @ROLLBACK@, introduced in v3.
+sigRollback :: Word8
+sigRollback = 0x13
 
 -- == BOLT responses signatures
 

src/Database/Bolt/Value/Type.hs

@@ -65,7 +65,7 @@ data Structure = Structure { signature :: Word8
 
 -- |Generalizes all datatypes that can be deserialized from 'Structure's.
 class FromStructure a where
-  fromStructure :: MonadError UnpackError m => Structure -> m a
+  fromStructure :: (HasCallStack, MonadError UnpackError m) => Structure -> m a
 
 -- |Generalizes all datatypes that can be serialized to 'Structure's.
 class ToStructure a where