diff --git a/hasbolt.cabal b/hasbolt.cabal --- a/hasbolt.cabal +++ b/hasbolt.cabal @@ -1,5 +1,5 @@ name: hasbolt -version: 0.1.1.0 +version: 0.1.1.1 cabal-version: >=1.10 build-type: Simple license: BSD3 @@ -63,7 +63,7 @@ main-is: Spec.hs build-depends: base >=4.8 && <5, - hasbolt >=0.1.1.0 && <0.2, + hasbolt >=0.1.1.1 && <0.2, hspec >=2.4.1 && <2.5, QuickCheck >=2.9.2 && <2.10, hex >=0.1.2 && <0.2, 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 @@ -6,12 +6,13 @@ import Database.Bolt.Value.Type import Database.Bolt.Record -import Control.Monad (when) -import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.IO.Class (MonadIO (..), liftIO) import Control.Monad.Trans.Reader (ReaderT (..), ask, runReaderT) import Data.Text (Text) import Data.Map.Strict (Map, empty) +import System.IO.Unsafe (unsafeInterleaveIO) + -- |Monad Transformer to do all BOLT actions in type BoltActionT = ReaderT Pipe @@ -21,21 +22,23 @@ -- |Runs Cypher query with parameters and returns list of obtained 'Record's queryP :: MonadIO m => Text -> Map Text Value -> BoltActionT m [Record] -queryP cypher params = pullRequests >>= toRecords - where pullRequests :: MonadIO m => BoltActionT m [Response] - pullRequests = do pipe <- ask - let request = RequestRun cypher params - flush pipe request - status <- fetch pipe - if isSuccess status then do flush pipe RequestPullAll - (status:) <$> pullRest pipe - else do ackFailure pipe - mkFailure status - - pullRest :: MonadIO m => Pipe -> m [Response] - pullRest pipe = do resp <- fetch pipe - if isSuccess resp then return [resp] - else (resp:) <$> pullRest pipe +queryP cypher params = do keys <- pullKeys + pipe <- ask + liftIO $ pullRecords pipe keys + where + pullKeys :: MonadIO m => BoltActionT m [Text] + pullKeys = sendRequest cypher params $ \status -> do + pipe <- ask + flush pipe RequestPullAll + mkKeys status + + pullRecords :: Pipe -> [Text] -> IO [Record] + pullRecords pipe keys = do resp <- fetch pipe + if isSuccess resp + then return [] + else do let record = mkRecord keys resp + rest <- unsafeInterleaveIO $ pullRecords pipe keys + return (record:rest) -- |Runs Cypher query and returns list of obtained 'Record's query :: MonadIO m => Text -> BoltActionT m [Record] @@ -43,15 +46,19 @@ -- |Runs Cypher query with parameters and ignores response queryP_ :: MonadIO m => Text -> Map Text Value -> BoltActionT m () -queryP_ cypher params = do pipe <- ask - flush pipe $ RequestRun cypher params - status <- fetch pipe - when (isFailure status) $ do - ackFailure pipe - mkFailure status - when (isSuccess status) $ - discardAll pipe +queryP_ cypher params = sendRequest cypher params $ \_ -> do + pipe <- ask + discardAll pipe -- |Runs Cypher query and ignores response query_ :: MonadIO m => Text -> BoltActionT m () query_ cypher = queryP_ cypher empty + +-- |Sends request to database and makes an action +sendRequest :: MonadIO m => Text -> Map Text Value -> (Response -> BoltActionT m a) -> BoltActionT m a +sendRequest cypher params f = do pipe <- ask + flush pipe $ RequestRun cypher params + status <- fetch pipe + if isSuccess status then f status + else do ackFailure pipe + mkFailure status 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,5 +1,3 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module Database.Bolt.Connection.Pipe where import Database.Bolt.Connection.Instances @@ -9,12 +7,10 @@ import Control.Monad (forM_, unless, void, when) import Control.Monad.IO.Class (MonadIO (..)) -import Data.Binary (Binary (..)) import Data.ByteString (ByteString) import qualified Data.ByteString as B (concat, length, null, splitAt) -import Data.Maybe (fromMaybe) -import Data.Word (Word16, Word32) +import Data.Word (Word16) import Network.Simple.TCP (Socket, closeSock, connectSock, recv, send, sendMany) @@ -59,13 +55,16 @@ fetch :: MonadIO m => Pipe -> m Response fetch pipe = do bs <- B.concat <$> chunks - (unpack $! bs) >>= fromStructure + unpack bs >>= fromStructure where sock = connectionSocket pipe chunks :: MonadIO m => m [ByteString] - chunks = do size <- recvWord sock 2 + chunks = do size <- decodeStrict <$> recvChunk sock 2 chunk <- recvChunk sock size - if B.null chunk then return [] else (chunk:) <$> chunks + if B.null chunk + then return [] + else do rest <- chunks + return (chunk:rest) -- Helper functions @@ -73,7 +72,7 @@ handshake pipe bcfg = do let sock = connectionSocket pipe send sock (encodeStrict $ magic bcfg) send sock (boltVersionProposal bcfg) - serverVersion :: Word32 <- recvWord sock 4 + serverVersion <- decodeStrict <$> recvChunk sock 4 when (serverVersion /= version bcfg) $ fail "Unsupported server version" flush pipe (createInit bcfg) @@ -84,10 +83,6 @@ boltVersionProposal :: BoltCfg -> ByteString boltVersionProposal bcfg = B.concat $ encodeStrict <$> [version bcfg, 0, 0, 0] - -recvWord :: (MonadIO m, Binary a, Integral a) => Socket -> Int -> m a -recvWord sock size = do bs <- recv sock size - return (fromMaybe 0 $ decodeStrict <$> bs) recvChunk :: MonadIO m => Socket -> Word16 -> m ByteString recvChunk sock size = B.concat <$> helper (fromIntegral size) diff --git a/src/Database/Bolt/Record.hs b/src/Database/Bolt/Record.hs --- a/src/Database/Bolt/Record.hs +++ b/src/Database/Bolt/Record.hs @@ -73,10 +73,10 @@ Just result -> return result Nothing -> fail $ "No such key (" ++ show key ++ ") in record" -toRecords :: Monad m => [Response] -> m [Record] -toRecords (ResponseSuccess response:rest) = - let keys :: [Text] - keys = fromMaybe [] $ exact =<< ("fields" `M.lookup` response) - in return $ map (M.fromList . zip keys . recsList) $ init rest -toRecords (x:_) = mkFailure x -toRecords _ = fail "Empty response" +mkKeys :: Monad m => Response -> m [Text] +mkKeys (ResponseSuccess response) = let mbKeys = exact =<< ("fields" `M.lookup` response) + in return $ fromMaybe [] mbKeys +mkKeys x = mkFailure x + +mkRecord :: [Text] -> Response -> Record +mkRecord keys = M.fromList . zip keys . recsList