hasbolt 0.1.6.3 → 0.1.7.0
raw patch · 7 files changed
+106/−46 lines, 7 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Database.Bolt.Serialization: fromStructure :: (FromStructure a, MonadError UnpackError m) => Structure -> m a
+ Database.Bolt.Serialization: fromStructure :: (FromStructure a, HasCallStack, MonadError UnpackError m) => Structure -> m a
Files
- hasbolt.cabal +1/−1
- src/Database/Bolt/Connection.hs +18/−10
- src/Database/Bolt/Connection/Instances.hs +14/−10
- src/Database/Bolt/Connection/Type.hs +23/−12
- src/Database/Bolt/Transaction.hs +21/−4
- src/Database/Bolt/Value/Helpers.hs +28/−8
- src/Database/Bolt/Value/Type.hs +1/−1
hasbolt.cabal view
@@ -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 view
@@ -10,6 +10,8 @@ , queryP, query , queryP', query' , queryP_, query_++ , sendRawRequest ) where import Database.Bolt.Connection.Pipe@@ -102,16 +104,22 @@ 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 view
@@ -12,6 +12,7 @@ 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 @@ 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 _ = 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 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 @@ , "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 view
@@ -122,24 +122,35 @@ 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 view
@@ -4,12 +4,17 @@ ) 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 @@ 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 view
@@ -160,27 +160,47 @@ 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 view
@@ -65,7 +65,7 @@ -- |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