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.4.5 +version: 0.1.5.0 license: BSD3 license-file: LICENSE copyright: (c) 2018 Pavel Yakovlev @@ -19,11 +19,15 @@ . -Cypher queries and responses . + -Transactions and error handling + . -Authentification . -TLS/SSL connection . - The code was tested with neo4j versions 3.0 — 3.4 and GrapheneDB service + -Bolt protocol version 3 initial support + . + The code was tested with neo4j versions 3.0 — 3.5 and GrapheneDB service category: Database build-type: Simple @@ -82,7 +86,7 @@ build-depends: base >=4.8 && <5, hasbolt -any, - hspec >=2.4.1 && <2.8, + hspec >=2.4.1 && <2.9, QuickCheck >=2.9 && <2.15, text >=1.2.4.1 && <1.3, containers >=0.6.2.1 && <0.7, 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 @@ -15,6 +15,7 @@ import Database.Bolt.Connection.Pipe import Database.Bolt.Connection.Instances import Database.Bolt.Connection.Type +import Database.Bolt.Value.Helpers import Database.Bolt.Value.Type import Database.Bolt.Record @@ -58,7 +59,7 @@ -- |Runs Cypher query with parameters and ignores response queryP_ :: MonadIO m => HasCallStack => Text -> Map Text Value -> BoltActionT m () -queryP_ cypher params = do void $ sendRequest cypher params +queryP_ cypher params = do void $ sendRequest cypher params empty ask >>= liftE . discardAll -- |Runs Cypher query and ignores response @@ -68,14 +69,14 @@ -- Helper functions querySL :: MonadIO m => HasCallStack => Bool -> Text -> Map Text Value -> BoltActionT m [Record] -querySL strict cypher params = do keys <- pullKeys cypher params +querySL strict cypher params = do keys <- pullKeys cypher params empty pullRecords strict keys -pullKeys :: MonadIO m => HasCallStack => Text -> Map Text Value -> BoltActionT m [Text] -pullKeys cypher params = do pipe <- ask - status <- sendRequest cypher params - liftE $ flush pipe RequestPullAll - mkKeys status +pullKeys :: MonadIO m => HasCallStack => Text -> Map Text Value -> Map Text Value -> BoltActionT m [Text] +pullKeys cypher params ext = do pipe <- ask + status <- sendRequest cypher params ext + liftE $ flush pipe RequestPullAll + mkKeys status where mkKeys :: MonadIO m => Response -> BoltActionT m [Text] mkKeys (ResponseSuccess response) = response `at` "fields" `catchError` \(RecordHasNoKey _) -> pure [] @@ -88,7 +89,7 @@ where cases :: MonadIO m => Response -> BoltActionT m [Record] cases resp | isSuccess resp = pure [] - | isFailure resp = do ask >>= ackFailure + | isFailure resp = do ask >>= processError throwError $ ResponseError (mkFailure resp) | otherwise = parseRecord resp @@ -102,13 +103,15 @@ pure (record:rest) -- |Sends request to database and makes an action -sendRequest :: MonadIO m => HasCallStack => Text -> Map Text Value -> BoltActionT m Response -sendRequest cypher params = +sendRequest :: MonadIO m => HasCallStack => Text -> Map Text Value -> Map Text Value -> BoltActionT m Response +sendRequest cypher params ext = do pipe <- ask liftE $ do - flush pipe $ RequestRun cypher params + 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 ackFailure pipe + else do processError pipe throwError $ ResponseError (mkFailure status) diff --git a/src/Database/Bolt/Connection/Instances.hs b/src/Database/Bolt/Connection/Instances.hs --- a/src/Database/Bolt/Connection/Instances.hs +++ b/src/Database/Bolt/Connection/Instances.hs @@ -10,16 +10,19 @@ import Database.Bolt.Value.Type import Control.Monad.Except (MonadError (..)) -import Data.Map.Strict (Map, fromList, empty, (!)) +import Data.Map.Strict (Map, insert, fromList, empty, (!)) import Data.Text (Text) instance ToStructure Request where - toStructure RequestInit{..} = Structure sigInit [T agent, M $ tokenMap token] - toStructure RequestRun{..} = Structure sigRun [T statement, M parameters] + toStructure RequestInit{..} = Structure sigInit $ if isHello then [M $ helloMap agent token] + else [T agent, M $ tokenMap token] + toStructure RequestRun{..} = Structure sigRun [T statement, M parameters] + toStructure RequestRunV3{..} = Structure sigRun [T statement, M parameters, M extra] toStructure RequestReset = Structure sigReset [] toStructure RequestAckFailure = Structure sigAFail [] toStructure RequestPullAll = Structure sigPAll [] toStructure RequestDiscardAll = Structure sigDAll [] + toStructure RequestGoodbye = Structure sigGBye [] instance FromStructure Response where fromStructure Structure{..} @@ -54,19 +57,23 @@ createInit :: BoltCfg -> Request createInit BoltCfg{..} = RequestInit userAgent - AuthToken { scheme = "basic" + AuthToken { scheme = authType , principal = user , credentials = password } + (isNewVersion version) createRun :: Text -> Request createRun stmt = RequestRun stmt empty +helloMap :: Text -> AuthToken -> Map Text Value +helloMap a = insert "user_agent" (T a) . tokenMap + tokenMap :: AuthToken -> Map Text Value -tokenMap at = fromList [ ("scheme", T $ scheme at) - , ("principal", T $ principal at) - , ("credentials", T $ credentials at) +tokenMap at = fromList [ "scheme" =: scheme at + , "principal" =: principal at + , "credentials" =: credentials at ] extractMap :: MonadError UnpackError m => Value -> m (Map Text Value) diff --git a/src/Database/Bolt/Connection/Pipe.hs b/src/Database/Bolt/Connection/Pipe.hs --- a/src/Database/Bolt/Connection/Pipe.hs +++ b/src/Database/Bolt/Connection/Pipe.hs @@ -1,9 +1,11 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} module Database.Bolt.Connection.Pipe where import Database.Bolt.Connection.Instances import Database.Bolt.Connection.Type +import Database.Bolt.Value.Helpers import Database.Bolt.Value.Instances import Database.Bolt.Value.Type import qualified Database.Bolt.Connection.Connection as C (close, connect, recv, @@ -27,13 +29,15 @@ where connect' :: MonadPipe m => BoltCfg -> m Pipe connect' bcfg = do conn <- C.connect (secure bcfg) (host bcfg) (fromIntegral $ port bcfg) (socketTimeout bcfg) - let pipe = Pipe conn (maxChunkSize bcfg) + let pipe = Pipe conn (maxChunkSize bcfg) (version bcfg) handshake pipe bcfg pure pipe -- |Closes 'Pipe' close :: MonadIO m => HasCallStack => Pipe -> m () -close = C.close . connection +close pipe = do liftIO $ print "Closed" + when (isNewVersion $ pipe_version pipe) $ makeIO (`flush` RequestGoodbye) pipe + C.close $ connection pipe -- |Resets current sessions reset :: MonadIO m => HasCallStack => Pipe -> m () @@ -53,6 +57,12 @@ Left e -> liftIO $ throwIO e -- = Internal interfaces + +-- |Processes error via ackFailure or reset +processError :: MonadIO m => HasCallStack => Pipe -> m () +processError pipe@Pipe{..} = if isNewVersion pipe_version + then reset pipe + else makeIO ackFailure pipe ackFailure :: MonadPipe m => HasCallStack => Pipe -> m () ackFailure pipe = flush pipe RequestAckFailure >> void (fetch pipe) diff --git a/src/Database/Bolt/Connection/Type.hs b/src/Database/Bolt/Connection/Type.hs --- a/src/Database/Bolt/Connection/Type.hs +++ b/src/Database/Bolt/Connection/Type.hs @@ -14,7 +14,7 @@ import Data.Default (Default (..)) import Data.Map.Strict (Map) -import Data.Monoid ((<>)) +import Data.Monoid () import Data.Text (Text, unpack) import Data.Word (Word16, Word32) import GHC.Stack (HasCallStack, callStack, prettyCallStack) @@ -71,12 +71,13 @@ -- |Configuration of driver connection data BoltCfg = BoltCfg { magic :: Word32 -- ^'6060B017' value - , version :: Word32 -- ^'00000001' value + , version :: Word32 -- ^Major version number (e.g. '00000104' for 4.1) , userAgent :: Text -- ^Driver user agent , maxChunkSize :: Word16 -- ^Maximum chunk size of request , socketTimeout :: Int -- ^Driver socket timeout in seconds , host :: String -- ^Neo4j server hostname , port :: Int -- ^Neo4j server port + , authType :: Text -- ^Neo4j auth schema , user :: Text -- ^Neo4j user , password :: Text -- ^Neo4j password , secure :: Bool -- ^Use TLS or not @@ -85,12 +86,13 @@ instance Default BoltCfg where def = BoltCfg { magic = 1616949271 - , version = 1 - , userAgent = "hasbolt/1.4" + , version = 3 + , userAgent = "hasbolt/1.5" , maxChunkSize = 65535 , socketTimeout = 5 , host = "127.0.0.1" , port = 7687 + , authType = "basic" , user = "" , password = "" , secure = False @@ -103,8 +105,9 @@ -- ^ Timeout in microseconds } -data Pipe = Pipe { connection :: ConnectionWithTimeout -- ^Driver connection socket - , mcs :: Word16 -- ^Driver maximum chunk size of request +data Pipe = Pipe { connection :: ConnectionWithTimeout -- ^Driver connection socket + , mcs :: Word16 -- ^Driver maximum chunk size of request + , pipe_version :: Word32 -- ^Connection version 0000mnMJ } data AuthToken = AuthToken { scheme :: Text @@ -119,14 +122,20 @@ | ResponseFailure { failMap :: Map Text Value } deriving (Eq, Show) -data Request = RequestInit { agent :: Text - , token :: AuthToken - } - | RequestRun { statement :: Text - , parameters :: 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 deriving (Eq, Show) diff --git a/src/Database/Bolt/Value/Helpers.hs b/src/Database/Bolt/Value/Helpers.hs --- a/src/Database/Bolt/Value/Helpers.hs +++ b/src/Database/Bolt/Value/Helpers.hs @@ -2,7 +2,7 @@ import Control.Applicative (liftA2, liftA3, pure) import Data.Bits ((.&.)) -import Data.Word (Word8) +import Data.Word (Word8, Word32) -- = Checkers @@ -57,6 +57,9 @@ isStruct :: Word8 -> Bool isStruct = liftA3 (\x y z -> x || y || z) (== struct8Code) (== struct16Code) isTinyStruct +isNewVersion :: Word32 -> Bool +isNewVersion v = (v .&. 255) >= 3 + -- = Constants -- == Null @@ -175,6 +178,9 @@ sigPAll :: Word8 sigPAll = 63 + +sigGBye :: Word8 +sigGBye = 2 -- == BOLT responses signatures