diff --git a/hasbolt.cabal b/hasbolt.cabal --- a/hasbolt.cabal +++ b/hasbolt.cabal @@ -1,11 +1,11 @@ -name: hasbolt -version: 0.1.3.0 cabal-version: >=1.10 -build-type: Simple +name: hasbolt +version: 0.1.3.1 license: BSD3 license-file: LICENSE -copyright: (c) 2016 Pavel Yakovlev +copyright: (c) 2018 Pavel Yakovlev maintainer: pavel@yakovlev.me +author: Pavel Yakovlev, Martin Heuschober homepage: https://github.com/zmactep/hasbolt#readme synopsis: Haskell driver for Neo4j 3+ (BOLT protocol) description: @@ -21,9 +21,11 @@ . -Authentification . - The code was tested with neo4j versions 3.0 and 3.1 + -TLS/SSL connection + . + The code was tested with neo4j versions 3.0 — 3.4 and GrapheneDB service category: Database -author: Pavel Yakovlev, Martin Heuschober +build-type: Simple source-repository head type: git @@ -33,19 +35,6 @@ exposed-modules: Database.Bolt Database.Bolt.Lazy - build-depends: - base >=4.7 && <5, - bytestring >=0.10.8.1 && <0.11, - text >=1.2.2.1 && <1.3, - containers >=0.5.7.1 && <0.6, - 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 && <2.7, - connection >=0.2.8 && <0.3, - data-default >=0.7.1.1 && <0.8, - hex >=0.1.2 && <0.2 - default-language: Haskell2010 hs-source-dirs: src other-modules: Database.Bolt.Value.Type @@ -58,5 +47,32 @@ Database.Bolt.Connection.Pipe Database.Bolt.Connection Database.Bolt.Record + default-language: Haskell2010 ghc-options: -Wall + build-depends: + base >=4.7 && <5, + bytestring >=0.10.8.1 && <0.11, + text >=1.2.2.1 && <1.3, + 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 && <2.9, + connection >=0.2.8 && <0.3, + data-default >=0.7.1.1 && <0.8 +test-suite hasbolt-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.8 && <5, + hasbolt -any, + hspec >=2.4.1 && <2.6, + QuickCheck >=2.9 && <2.13, + hex >=0.1.2 && <0.2, + text >=1.2.3.1 && <1.3, + containers >=0.5.11.0 && <0.6, + bytestring >=0.10.8.2 && <0.11 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 @@ -12,6 +12,7 @@ import Database.Bolt.Value.Type import Database.Bolt.Record +import Control.Monad (void) import Control.Monad.IO.Class (MonadIO (..), liftIO) import Control.Monad.Trans.Reader (ReaderT (..), ask, runReaderT) import Data.Text (Text) @@ -44,9 +45,10 @@ -- |Runs Cypher query with parameters and ignores response queryP_ :: MonadIO m => Text -> Map Text Value -> BoltActionT m () -queryP_ cypher params = - do pipe <- ask - liftIO $ sendRequest pipe cypher params $ \_ -> discardAll pipe +queryP_ cypher params = do pipe <- ask + liftIO $ do + void $ sendRequest pipe cypher params + discardAll pipe -- |Runs Cypher query and ignores response query_ :: MonadIO m => Text -> BoltActionT m () @@ -56,29 +58,37 @@ querySL :: MonadIO m => Bool -> Text -> Map Text Value -> BoltActionT m [Record] querySL strict cypher params = do pipe <- ask - keys <- liftIO $ pullKeys pipe cypher params - liftIO $ pullRecords pipe keys strict + liftIO $ do + keys <- pullKeys pipe cypher params + pullRecords strict pipe keys pullKeys :: Pipe -> Text -> Map Text Value -> IO [Text] -pullKeys pipe cypher params = sendRequest pipe cypher params $ \status -> do - flush pipe RequestPullAll - mkKeys status +pullKeys pipe cypher params = do status <- sendRequest pipe cypher params + flush pipe RequestPullAll + mkKeys status -pullRecords :: Pipe -> [Text] -> Bool -> IO [Record] -pullRecords pipe keys strict = do resp <- fetch pipe - if isSuccess resp - then pure [] - else do let record = mkRecord keys resp - let pull = pullRecords pipe keys strict - rest <- if strict then pull - else unsafeInterleaveIO pull - pure (record:rest) +pullRecords :: Bool -> Pipe -> [Text] -> IO [Record] +pullRecords strict pipe keys = fetch pipe >>= cases + where + cases :: Response -> IO [Record] + cases resp | isSuccess resp = pure [] + | isFailure resp = ackFailure pipe >> mkFailure resp + | otherwise = parseRecord resp + parseRecord :: Response -> IO [Record] + parseRecord resp = do + let record = mkRecord keys resp + let pull = pullRecords strict pipe keys + rest <- if strict then pull + else unsafeInterleaveIO pull + pure (record:rest) + -- |Sends request to database and makes an action -sendRequest :: Pipe -> Text -> Map Text Value -> (Response -> IO a) -> IO a -sendRequest pipe cypher params f = +sendRequest :: Pipe -> Text -> Map Text Value -> IO Response +sendRequest pipe cypher params = do flush pipe $ RequestRun cypher params status <- fetch pipe - if isSuccess status then f status + if isSuccess status + then pure status else do ackFailure pipe mkFailure status diff --git a/src/Database/Bolt/Connection/Connection.hs b/src/Database/Bolt/Connection/Connection.hs --- a/src/Database/Bolt/Connection/Connection.hs +++ b/src/Database/Bolt/Connection/Connection.hs @@ -1,5 +1,6 @@ module Database.Bolt.Connection.Connection where +import Control.Applicative (pure, (<$>)) import Control.Monad (when, forM_) import Control.Monad.IO.Class (MonadIO (..)) import Data.ByteString (ByteString, null) @@ -10,14 +11,14 @@ import Prelude hiding (null) connect :: MonadIO m => Bool -> String -> PortNumber -> m Connection -connect secure host port = do ctx <- liftIO $ initConnectionContext - conn <- liftIO $ connectTo ctx $ ConnectionParams { connectionHostname = host - , connectionPort = port - , connectionUseSecure = Nothing - , connectionUseSocks = Nothing - } - when secure $ - liftIO $ connectionSetSecure ctx conn def +connect secure host port = liftIO $ do + ctx <- initConnectionContext + conn <- connectTo ctx ConnectionParams { connectionHostname = host + , connectionPort = port + , connectionUseSecure = Nothing + , connectionUseSocks = Nothing + } + when secure $ connectionSetSecure ctx conn def pure conn close :: MonadIO m => Connection -> m () 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 @@ -32,7 +32,6 @@ response <- fetch pipe when (isFailure response) $ fail "Reset failed" - pure () ackFailure :: MonadIO m => Pipe -> m () ackFailure pipe = flush pipe RequestAckFailure >> void (fetch pipe) @@ -41,7 +40,12 @@ discardAll pipe = flush pipe RequestDiscardAll >> void (fetch pipe) flush :: MonadIO m => Pipe -> Request -> m () -flush pipe request = do forM_ chunks $ C.sendMany conn . mkChunk +flush pipe request = do -- USELESS LOGGING + liftIO $ do + putStr "[->]: " + print request + -- USELESS LOGGING + forM_ chunks $ C.sendMany conn . mkChunk C.send conn terminal where bs = pack $ toStructure request chunkSize = chunkSizeFor (mcs pipe) bs @@ -55,7 +59,13 @@ fetch :: MonadIO m => Pipe -> m Response fetch pipe = do bs <- B.concat <$> chunks - unpack bs >>= fromStructure + result <- unpack bs >>= fromStructure + -- USELESS LOGGING + liftIO $ do + putStr "[<-]: " + print result + -- USELESS LOGGING + pure result where conn = connection pipe chunks :: MonadIO m => m [ByteString] @@ -79,7 +89,6 @@ response <- fetch pipe unless (isSuccess response) $ fail "Authentification failed" - pure () boltVersionProposal :: BoltCfg -> ByteString boltVersionProposal bcfg = B.concat $ encodeStrict <$> [version bcfg, 0, 0, 0] 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 @@ -26,7 +26,7 @@ instance Default BoltCfg where def = BoltCfg { magic = 1616949271 , version = 1 - , userAgent = "hasbolt/1.0" + , userAgent = "hasbolt/1.3" , maxChunkSize = 65535 , socketTimeout = 5 , host = "127.0.0.1" @@ -44,7 +44,8 @@ , principal :: Text , credentials :: Text } - + deriving (Eq, Show) + data Response = ResponseSuccess { succMap :: Map Text Value } | ResponseRecord { recsList :: [Value] } | ResponseIgnored { ignoreMap :: Map Text Value } @@ -61,3 +62,4 @@ | RequestReset | RequestDiscardAll | RequestPullAll + deriving (Eq, Show) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Applicative ((<$>)) +import Data.ByteString (ByteString) +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Hex +import Data.Map (Map (..)) +import qualified Data.Map as M (empty, fromList) +import Data.Text (Text) +import qualified Data.Text as T (pack) +import Test.Hspec +import Test.QuickCheck + +import Database.Bolt + +main :: IO () +main = hspec $ do + packStreamTests + unpackStreamTests + +unpackStreamTests :: Spec +unpackStreamTests = + describe "Unpack" $ do + it "unpacks integers correct" $ do + u1 <- prepareData "01" >>= unpack :: IO Int + u1 `shouldBe` 1 + u42 <- prepareData "2A" >>= unpack :: IO Int + u42 `shouldBe` 42 + u1234 <- prepareData "C904D2" >>= unpack :: IO Int + u1234 `shouldBe` 1234 + it "unpacks doubles correct" $ do + u6d <- prepareData "C1401921FB54442D18" >>= unpack :: IO Double + u6d `shouldBe` 6.283185307179586 + um1d <- prepareData "C1BFF199999999999A" >>= unpack :: IO Double + um1d `shouldBe` (-1.1) + it "unpacks booleans correct" $ do + uF <- prepareData "C2" >>= unpack :: IO Bool + uF `shouldBe` False + uT <- prepareData "C3" >>= unpack :: IO Bool + uT `shouldBe` True + it "unpacks strings correct" $ do + usE <- prepareData "80" >>= unpack :: IO Text + usE `shouldBe` T.pack "" + usA <- prepareData "8141" >>= unpack :: IO Text + usA `shouldBe` T.pack "A" + usU <- prepareData "D0124772C3B6C39F656E6D61C39F7374C3A46265" >>= unpack :: IO Text + usU `shouldBe` T.pack "Größenmaßstäbe" + it "unpacks lists correct" $ do + ulE <- prepareData "90" >>= unpack :: IO [Int] + ulE `shouldBe` [] + ulI <- prepareData "93010203" >>= unpack :: IO [Int] + ulI `shouldBe` [1,2,3] + ulL <- prepareData "D4280102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F202122232425262728" >>= unpack :: IO [Int] + ulL `shouldBe` [1..40] + it "unpacks dicts correct" $ do + udE <- prepareData "A0" >>= unpack :: IO (Map Text ()) + udE `shouldBe` M.fromList [] + udS <- prepareData "A1836F6E658465696E73" >>= unpack :: IO (Map Text Text) + udS `shouldBe` M.fromList [(T.pack "one", T.pack "eins")] + it "unpacks () correct" $ do + uN <- prepareData "C0" >>= unpack :: IO () + uN `shouldBe` () + +packStreamTests :: Spec +packStreamTests = + describe "Pack" $ do + it "packs integers correct" $ do + hex (pack (1::Int)) `shouldBe` "01" + hex (pack (42::Int)) `shouldBe` "2A" + hex (pack (1234::Int)) `shouldBe` "C904D2" + it "packs doubles correct" $ do + hex (pack (6.283185307179586::Double)) `shouldBe` "C1401921FB54442D18" + hex (pack (-1.1::Double)) `shouldBe` "C1BFF199999999999A" + it "packs booleans correct" $ do + hex (pack False) `shouldBe` "C2" + hex (pack True) `shouldBe` "C3" + it "packs strings correct" $ do + hex (pack $ T.pack "") `shouldBe` "80" + hex (pack $ T.pack "A") `shouldBe` "8141" + hex (pack $ T.pack "Größenmaßstäbe") `shouldBe` "D0124772C3B6C39F656E6D61C39F7374C3A46265" + hex (pack $ T.pack "ABCDEFGHIJKLMNOPQRSTUVWXYZ") `shouldBe` "D01A4142434445464748494A4B4C4D4E4F505152535455565758595A" + it "packs lists correct" $ do + hex (pack ([]::[Int])) `shouldBe` "90" + hex (pack ([1,2,3]::[Int])) `shouldBe` "93010203" + hex (pack ([1..40]::[Int])) `shouldBe` "D4280102030405060708090A0B0C0D0E0F101112131415161718191A1B1C1D1E1F202122232425262728" + it "packs dicts correct" $ do + hex (pack (M.empty :: Map Text ())) `shouldBe` "A0" + hex (pack (M.fromList [(T.pack "one", T.pack "eins")])) `shouldBe` "A1836F6E658465696E73" + it "packs () correct" $ + hex (pack ()) `shouldBe` "C0" + +prepareData :: Monad m => ByteString -> m ByteString +prepareData = (toStrict <$>) . unhex . fromStrict