diff --git a/hasbolt.cabal b/hasbolt.cabal --- a/hasbolt.cabal +++ b/hasbolt.cabal @@ -1,10 +1,10 @@ name: hasbolt -version: 0.1.2.1 +version: 0.1.3.0 cabal-version: >=1.10 build-type: Simple license: BSD3 license-file: LICENSE -copyright: Copyright: (c) 2016 Pavel Yakovlev +copyright: (c) 2016 Pavel Yakovlev maintainer: pavel@yakovlev.me homepage: https://github.com/zmactep/hasbolt#readme synopsis: Haskell driver for Neo4j 3+ (BOLT protocol) @@ -42,6 +42,7 @@ 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 @@ -51,26 +52,11 @@ Database.Bolt.Value.Helpers Database.Bolt.Value.Instances Database.Bolt.Value.Structure - Database.Bolt.Connection.Socket + Database.Bolt.Connection.Connection Database.Bolt.Connection.Type Database.Bolt.Connection.Instances Database.Bolt.Connection.Pipe Database.Bolt.Connection Database.Bolt.Record - ghc-options: -Wall -O2 + ghc-options: -Wall -test-suite hasbolt-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - build-depends: - base >=4.8 && <5, - hasbolt >=0.1.2.1 && <0.2, - hspec >=2.4.1 && <2.5, - QuickCheck >=2.9 && <2.11, - hex >=0.1.2 && <0.2, - text >=1.2.2.1 && <1.3, - containers >=0.5.7.1 && <0.6, - bytestring >=0.10.8.1 && <0.11 - default-language: Haskell2010 - hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N diff --git a/src/Database/Bolt.hs b/src/Database/Bolt.hs --- a/src/Database/Bolt.hs +++ b/src/Database/Bolt.hs @@ -4,7 +4,7 @@ , run, queryP, query, queryP_, query_ , Pipe , BoltCfg (..) - , BoltValue (..), Value (..), Record, RecordValue (..), at + , BoltValue (..), Value (..), Structure (..), Record, RecordValue (..), at , Node (..), Relationship (..), URelationship (..), Path (..) ) where diff --git a/src/Database/Bolt/Connection/Connection.hs b/src/Database/Bolt/Connection/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Connection/Connection.hs @@ -0,0 +1,37 @@ +module Database.Bolt.Connection.Connection where + +import Control.Monad (when, forM_) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString (ByteString, null) +import Data.Default (Default (..)) +import Network.Socket (PortNumber) +import Network.Connection (Connection, ConnectionParams (..), connectTo, connectionSetSecure, + initConnectionContext, connectionClose, connectionGetExact, connectionPut) +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 + pure conn + +close :: MonadIO m => Connection -> m () +close = liftIO . connectionClose + +recv :: MonadIO m => Connection -> Int -> m (Maybe ByteString) +recv conn = liftIO . (filterMaybe (not . null) <$>) . connectionGetExact conn + where + filterMaybe :: (a -> Bool) -> a -> Maybe a + filterMaybe p x | p x = Just x + | otherwise = Nothing + +send :: MonadIO m => Connection -> ByteString -> m () +send conn = liftIO . connectionPut conn + +sendMany :: MonadIO m => Connection -> [ByteString] -> m () +sendMany conn chunks = forM_ chunks $ send conn 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 @@ -4,28 +4,27 @@ import Database.Bolt.Connection.Type import Database.Bolt.Value.Instances import Database.Bolt.Value.Type - -import Database.Bolt.Connection.Socket (Socket, closeSock, - connectSock, recv, send, - sendMany) +import qualified Database.Bolt.Connection.Connection as C (close, connect, recv, + send, sendMany) -import Control.Monad (forM_, unless, void, when) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B (concat, length, null, - splitAt) -import Data.Word (Word16) +import Control.Monad (forM_, unless, void, when) +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B (concat, length, null, + splitAt) +import Data.Word (Word16) +import Network.Connection (Connection) -- |Creates new 'Pipe' instance to use all requests through connect :: MonadIO m => BoltCfg -> m Pipe -connect bcfg = do (sock, _) <- connectSock (host bcfg) (show $ port bcfg) - let pipe = Pipe sock (maxChunkSize bcfg) +connect bcfg = do conn <- C.connect (secure bcfg) (host bcfg) (fromIntegral $ port bcfg) + let pipe = Pipe conn (maxChunkSize bcfg) handshake pipe bcfg pure pipe -- |Closes 'Pipe' close :: MonadIO m => Pipe -> m () -close = closeSock . connectionSocket +close = C.close . connection -- |Resets current sessions reset :: MonadIO m => Pipe -> m () @@ -42,13 +41,13 @@ discardAll pipe = flush pipe RequestDiscardAll >> void (fetch pipe) flush :: MonadIO m => Pipe -> Request -> m () -flush pipe request = do forM_ chunks $ sendMany sock . mkChunk - send sock terminal +flush pipe request = do forM_ chunks $ C.sendMany conn . mkChunk + C.send conn terminal where bs = pack $ toStructure request chunkSize = chunkSizeFor (mcs pipe) bs chunks = split chunkSize bs terminal = encodeStrict (0 :: Word16) - sock = connectionSocket pipe + conn = connection pipe mkChunk :: ByteString -> [ByteString] mkChunk chunk = let size = fromIntegral (B.length chunk) :: Word16 @@ -57,11 +56,11 @@ fetch :: MonadIO m => Pipe -> m Response fetch pipe = do bs <- B.concat <$> chunks unpack bs >>= fromStructure - where sock = connectionSocket pipe + where conn = connection pipe chunks :: MonadIO m => m [ByteString] - chunks = do size <- decodeStrict <$> recvChunk sock 2 - chunk <- recvChunk sock size + chunks = do size <- decodeStrict <$> recvChunk conn 2 + chunk <- recvChunk conn size if B.null chunk then pure [] else do rest <- chunks @@ -70,10 +69,10 @@ -- Helper functions handshake :: MonadIO m => Pipe -> BoltCfg -> m () -handshake pipe bcfg = do let sock = connectionSocket pipe - send sock (encodeStrict $ magic bcfg) - send sock (boltVersionProposal bcfg) - serverVersion <- decodeStrict <$> recvChunk sock 4 +handshake pipe bcfg = do let conn = connection pipe + C.send conn (encodeStrict $ magic bcfg) + C.send conn (boltVersionProposal bcfg) + serverVersion <- decodeStrict <$> recvChunk conn 4 when (serverVersion /= version bcfg) $ fail "Unsupported server version" flush pipe (createInit bcfg) @@ -85,11 +84,11 @@ boltVersionProposal :: BoltCfg -> ByteString boltVersionProposal bcfg = B.concat $ encodeStrict <$> [version bcfg, 0, 0, 0] -recvChunk :: MonadIO m => Socket -> Word16 -> m ByteString -recvChunk sock size = B.concat <$> helper (fromIntegral size) +recvChunk :: MonadIO m => Connection -> Word16 -> m ByteString +recvChunk conn size = B.concat <$> helper (fromIntegral size) where helper :: MonadIO m => Int -> m [ByteString] helper 0 = pure [] - helper sz = do mbChunk <- recv sock sz + helper sz = do mbChunk <- C.recv conn sz case mbChunk of Just chunk -> (chunk:) <$> helper (sz - B.length chunk) Nothing -> fail "Cannot read chunk from sock" diff --git a/src/Database/Bolt/Connection/Socket.hs b/src/Database/Bolt/Connection/Socket.hs deleted file mode 100644 --- a/src/Database/Bolt/Connection/Socket.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Database.Bolt.Connection.Socket - ( Socket - , connectSock, closeSock - , recv, send, sendMany - ) where - -import Control.Exception (bracketOnError) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.ByteString (ByteString, null) -import Network.Socket (AddrInfoFlag (..), HostName, - ServiceName, SockAddr, Socket, - SocketType (..), addrAddress, - addrFamily, addrFlags, addrProtocol, - addrSocketType, defaultHints, - getAddrInfo, socket, close, connect) -import qualified Network.Socket.ByteString as NSB (recv, sendAll, sendMany) -import Prelude hiding (null) - -connectSock :: MonadIO m => HostName -> ServiceName -> m (Socket, SockAddr) -connectSock host port = liftIO $ bracketOnError (createSock host port) (closeSock . fst) $ - \(sock, addr) -> liftIO (connect sock addr) >> pure (sock, addr) - -createSock :: MonadIO m => HostName -> ServiceName -> m (Socket, SockAddr) -createSock host port = liftIO $ do (addr:_) <- getAddrInfo (Just hints) (Just host) (Just port) - let family' = addrFamily addr - let type' = addrSocketType addr - let protocol' = addrProtocol addr - sock <- socket family' type' protocol' - pure (sock, addrAddress addr) - where hints = defaultHints { addrFlags = [AI_ADDRCONFIG] - , addrSocketType = Stream - } - -closeSock :: MonadIO m => Socket -> m () -closeSock = liftIO . close - -recv :: MonadIO m => Socket -> Int -> m (Maybe ByteString) -recv sock nbytes = liftIO $ do bs <- NSB.recv sock nbytes - if null bs then pure Nothing - else pure (Just bs) - -send :: MonadIO m => Socket -> ByteString -> m () -send sock = liftIO . NSB.sendAll sock - -sendMany :: MonadIO m => Socket -> [ByteString] -> m () -sendMany sock = liftIO . NSB.sendMany sock 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 @@ -4,12 +4,11 @@ import Database.Bolt.Value.Type -import Database.Bolt.Connection.Socket (Socket) - import Data.Default (Default (..)) import Data.Map.Strict (Map) import Data.Text (Text) import Data.Word (Word16, Word32) +import Network.Connection (Connection) -- |Configuration of driver connection data BoltCfg = BoltCfg { magic :: Word32 -- ^'6060B017' value @@ -21,6 +20,7 @@ , port :: Int -- ^Neo4j server port , user :: Text -- ^Neo4j user , password :: Text -- ^Neo4j password + , secure :: Bool -- ^Use TLS or not } instance Default BoltCfg where @@ -33,10 +33,11 @@ , port = 7687 , user = "" , password = "" + , secure = False } -data Pipe = Pipe { connectionSocket :: Socket -- ^Driver connection socket - , mcs :: Word16 -- ^Driver maximum chunk size of request +data Pipe = Pipe { connection :: Connection -- ^Driver connection socket + , mcs :: Word16 -- ^Driver maximum chunk size of request } data AuthToken = AuthToken { scheme :: Text 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 @@ -4,7 +4,7 @@ , run, queryP, query, queryP_, query_ , Pipe , BoltCfg (..) - , BoltValue (..), Value (..), Record, RecordValue (..), at + , BoltValue (..), Value (..), Structure (..), Record, RecordValue (..), at , Node (..), Relationship (..), URelationship (..), Path (..) ) where diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# 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