hasbolt (empty) → 0.1.0.0
raw patch · 14 files changed
+1124/−0 lines, 14 filesdep +QuickCheckdep +basedep +binarysetup-changed
Dependencies added: QuickCheck, base, binary, bytestring, containers, data-binary-ieee754, data-default, hasbolt, hex, hspec, network, network-simple, text, transformers
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- hasbolt.cabal +58/−0
- src/Database/Bolt.hs +19/−0
- src/Database/Bolt/Connection.hs +46/−0
- src/Database/Bolt/Connection/Instances.hs +74/−0
- src/Database/Bolt/Connection/Pipe.hs +95/−0
- src/Database/Bolt/Connection/Type.hs +61/−0
- src/Database/Bolt/Record.hs +79/−0
- src/Database/Bolt/Value/Helpers.hs +205/−0
- src/Database/Bolt/Value/Instances.hs +206/−0
- src/Database/Bolt/Value/Structure.hs +83/−0
- src/Database/Bolt/Value/Type.hs +73/−0
- test/Spec.hs +93/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Pavel Yakovlev (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Pavel Yakovlev nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hasbolt.cabal view
@@ -0,0 +1,58 @@+name: hasbolt+version: 0.1.0.0+synopsis: Haskell driver for Neo4j 3+ (BOLT protocol)+description: Please see README.md+homepage: https://github.com/zmactep/hasbolt#readme+license: BSD3+license-file: LICENSE+author: Pavel Yakovlev+maintainer: pavel@yakovlev.me+copyright: Copyright: (c) 2016 Pavel Yakovlev+category: Database+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Database.Bolt+ other-modules: Database.Bolt.Value.Type+ , Database.Bolt.Value.Helpers+ , Database.Bolt.Value.Instances+ , Database.Bolt.Value.Structure+ , Database.Bolt.Connection.Type+ , Database.Bolt.Connection.Instances+ , Database.Bolt.Connection.Pipe+ , Database.Bolt.Connection+ , Database.Bolt.Record+ build-depends: base >= 4.7 && < 5+ , bytestring+ , text+ , containers+ , binary+ , data-binary-ieee754+ , transformers+ , network+ , network-simple+ , data-default+ , hex+ default-language: Haskell2010++test-suite hasbolt-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , hasbolt+ , hspec+ , QuickCheck+ , hex+ , text+ , containers+ , bytestring+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/zmactep/hasbolt
+ src/Database/Bolt.hs view
@@ -0,0 +1,19 @@+module Database.Bolt+ ( BoltActionT (..)+ , connect, close, reset+ , run, query, query_+ , Pipe+ , BoltCfg (..), Default (..)+ , Value (..), Record, RecordValue (..), at+ , Node (..), Relationship (..), URelationship (..), Path (..)+ ) where++import Database.Bolt.Connection+import Database.Bolt.Record+import Database.Bolt.Connection.Pipe+import Database.Bolt.Connection.Type+import Database.Bolt.Value.Instances+import Database.Bolt.Value.Structure+import Database.Bolt.Value.Type++import Data.Default (Default (..))
+ src/Database/Bolt/Connection.hs view
@@ -0,0 +1,46 @@+module Database.Bolt.Connection where++import Database.Bolt.Connection.Pipe+import Database.Bolt.Connection.Instances+import Database.Bolt.Connection.Type+import Database.Bolt.Value.Instances+import Database.Bolt.Value.Type+import Database.Bolt.Record++import Control.Monad (void, when)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Reader (ReaderT (..), ask, runReaderT)+import Data.Text (Text)+import Data.Map.Strict (empty)++-- |Monad Transformer to do all BOLT actions in+type BoltActionT = ReaderT Pipe++run :: MonadIO m => Pipe -> BoltActionT m a -> m a+run = flip runReaderT++query :: MonadIO m => Text -> BoltActionT m [Record]+query cypher = toRecords <$> pullRequests+ where pullRequests :: MonadIO m => BoltActionT m [Response]+ pullRequests = do pipe <- ask+ let request = RequestRun cypher empty+ flush pipe request+ status <- fetch pipe+ if isSuccess status then do flush pipe RequestPullAll+ (status:) <$> pullRest pipe+ else do ackFailure pipe+ return [status]++ pullRest :: MonadIO m => Pipe -> m [Response]+ pullRest pipe = do resp <- fetch pipe+ if isSuccess resp then return [resp]+ else (resp:) <$> pullRest pipe++query_ :: MonadIO m => Text -> BoltActionT m ()+query_ cypher = do pipe <- ask+ flush pipe (createRun cypher)+ status <- fetch pipe+ when (isFailure status) $+ ackFailure pipe+ when (isSuccess status) $+ discardAll pipe
+ src/Database/Bolt/Connection/Instances.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE OverloadedStrings #-}++module Database.Bolt.Connection.Instances where++import Database.Bolt.Connection.Type+import Database.Bolt.Value.Helpers+import Database.Bolt.Value.Type++import Data.Map.Strict (Map (..), fromList, empty)+import Data.Text (Text)++instance Structable Request where+ toStructure (RequestInit agent token) = Structure sigInit [T agent, M $ tokenMap token]+ toStructure (RequestRun stmt params) = Structure sigRun [T stmt, M params]+ toStructure RequestReset = Structure sigReset []+ toStructure RequestAckFailure = Structure sigAFail []+ toStructure RequestPullAll = Structure sigPAll []+ toStructure RequestDiscardAll = Structure sigDAll []++ fromStructure = undefined++instance Structable Response where+ toStructure = undefined++ fromStructure (Structure sig fields) | sig == sigSucc = ResponseSuccess <$> extractMap (head fields)+ | sig == sigRecs = return $ ResponseRecord (removeExtList fields)+ | sig == sigIgn = ResponseIgnored <$> extractMap (head fields)+ | sig == sigFail = ResponseFailure <$> extractMap (head fields)+ | otherwise = fail "Not a Response value"+ where removeExtList :: [Value] -> [Value]+ removeExtList [L x] = x+ removeExtList _ = error "Record must contain only on value list"++-- Response check functions++isSuccess :: Response -> Bool+isSuccess (ResponseSuccess _) = True+isSuccess _ = False++isFailure :: Response -> Bool+isFailure (ResponseFailure _) = True+isFailure _ = False++isIgnored :: Response -> Bool+isIgnored (ResponseIgnored _) = True+isIgnored _ = False++isRecord :: Response -> Bool+isRecord (ResponseRecord _) = True+isRecord _ = False++-- Helper functions++createInit :: BoltCfg -> Request+createInit bcfg = RequestInit (userAgent bcfg) (tokenOf bcfg)++createRun :: Text -> Request+createRun stmt = RequestRun stmt empty++tokenOf :: BoltCfg -> AuthToken+tokenOf bcfg = AuthToken { scheme = "basic"+ , principal = user bcfg+ , credentials = password bcfg+ }++tokenMap :: AuthToken -> Map Text Value+tokenMap at = fromList [ ("scheme", T $ scheme at)+ , ("principal", T $ principal at)+ , ("credentials", T $ credentials at)+ ]++extractMap :: Monad m => Value -> m (Map Text Value)+extractMap (M mp) = return mp+extractMap _ = fail "Not a Dict value"
+ src/Database/Bolt/Connection/Pipe.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Database.Bolt.Connection.Pipe where++import Database.Bolt.Connection.Instances+import Database.Bolt.Connection.Type+import Database.Bolt.Value.Instances+import Database.Bolt.Value.Type++import Control.Monad (unless, void, when)+import Control.Monad.IO.Class (MonadIO (..), liftIO)+import Data.Binary (Binary (..))+import Data.ByteString (ByteString, append)+import qualified Data.ByteString as B (concat, length, null,+ splitAt, empty)+import Data.Maybe (fromMaybe)+import Data.Word (Word16, Word32)+import Network.Simple.TCP (closeSock, connectSock,+ recv, send)+import Network.Socket (isConnected)++connect :: MonadIO m => BoltCfg -> m Pipe+connect bcfg = do (sock, _) <- connectSock (host bcfg) (show $ port bcfg)+ let pipe = Pipe sock (maxChunkSize bcfg)+ handshake pipe bcfg+ return pipe++close :: MonadIO m => Pipe -> m ()+close = closeSock . connectionSocket++reset :: MonadIO m => Pipe -> m ()+reset pipe = do flush pipe RequestReset+ response <- fetch pipe+ when (isFailure response) $+ fail "Reset failed"+ return ()++ackFailure :: MonadIO m => Pipe -> m ()+ackFailure pipe = flush pipe RequestAckFailure >> void (fetch pipe)++discardAll :: MonadIO m => Pipe -> m ()+discardAll pipe = flush pipe RequestDiscardAll >> void (fetch pipe)++flush :: MonadIO m => Pipe -> Request -> m ()+flush pipe request = do let chunkSize = fromIntegral (mcs pipe)+ let chunks = split chunkSize (pack $ toStructure request)+ let packet = B.concat $ consSize <$> chunks+ let terminal = encodeStrict (0 :: Word16)+ send (connectionSocket pipe) (packet `append` terminal)+ where split :: Int -> ByteString -> [ByteString]+ split size bs | B.null bs = []+ | otherwise = let (chunk, rest) = B.splitAt size bs+ in chunk : split size rest++ consSize :: ByteString -> ByteString+ consSize bs = let size = fromIntegral (B.length bs) :: Word16+ in encodeStrict size `append` bs++fetch :: MonadIO m => Pipe -> m Response+fetch pipe = do bs <- fetchHelper+ unpack bs >>= fromStructure+ where fetchHelper :: MonadIO m => m ByteString+ fetchHelper = do chunkSize :: Word16 <- recvWord pipe 2+ case chunkSize of+ 0 -> return B.empty+ _ -> do chunk <- recvChunk pipe chunkSize+ rest <- fetchHelper+ return $ chunk `append` rest++-- 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 :: Word32 <- recvWord pipe 4+ when (serverVersion /= version bcfg) $+ fail "Unsupported server version"+ flush pipe (createInit bcfg)+ response <- fetch pipe+ unless (isSuccess response) $+ fail "Authentification failed"+ return ()++boltVersionProposal :: BoltCfg -> ByteString+boltVersionProposal bcfg = B.concat $ encodeStrict <$> [version bcfg, 0, 0, 0]++recvWord :: (MonadIO m, Binary a, Integral a) => Pipe -> Int -> m a+recvWord pipe size = do let sock = connectionSocket pipe+ bs <- liftIO $ recv sock size+ return (fromMaybe 0 $ decodeStrict <$> bs)++recvChunk :: MonadIO m => Pipe -> Word16 -> m ByteString+recvChunk pipe size = do let sock = connectionSocket pipe+ fromMaybe B.empty <$> liftIO (recv sock (fromIntegral size))
+ src/Database/Bolt/Connection/Type.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}++module Database.Bolt.Connection.Type where++import Database.Bolt.Value.Type++import Data.Default (Default (..))+import Data.Map.Strict (Map (..))+import Data.Text (Text)+import Data.Word (Word16, Word32)+import Network.Simple.TCP (Socket)++-- |Configuration of driver connection+data BoltCfg = BoltCfg { magic :: Word32 -- ^'6060B017' value+ , version :: Word32 -- ^'00000001' value+ , userAgent :: Text -- ^Driver user agent+ , maxChunkSize :: Word16 -- ^Maximum chunk size of request+ , socketTimeout :: Int -- ^Driver socket timeout+ , host :: String -- ^Neo4j server hostname+ , port :: Int -- ^Neo4j server port+ , user :: Text -- ^Neo4j user+ , password :: Text -- ^Neo4j password+ }++instance Default BoltCfg where+ def = BoltCfg { magic = 1616949271+ , version = 1+ , userAgent = "hasbolt/1.0"+ , maxChunkSize = 65535+ , socketTimeout = 5+ , host = "127.0.0.1"+ , port = 7687+ , user = ""+ , password = ""+ }++data Pipe = Pipe { connectionSocket :: Socket -- ^Driver connection socket+ , mcs :: Word16 -- ^Driver maximum chunk size of request+ }++data AuthToken = AuthToken { scheme :: Text+ , principal :: Text+ , credentials :: Text+ }++data Response = ResponseSuccess { succMap :: Map Text Value }+ | ResponseRecord { recsList :: [Value] }+ | ResponseIgnored { ignoreMap :: Map Text Value }+ | ResponseFailure { failMap :: Map Text Value }+ deriving (Eq, Show)++data Request = RequestInit { agent :: Text+ , token :: AuthToken+ }+ | RequestRun { statement :: Text+ , parameters :: Map Text Value+ }+ | RequestAckFailure+ | RequestReset+ | RequestDiscardAll+ | RequestPullAll
+ src/Database/Bolt/Record.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.Bolt.Record where++import Database.Bolt.Connection.Instances+import Database.Bolt.Connection.Type+import Database.Bolt.Value.Structure+import Database.Bolt.Value.Type++import Data.Map.Strict (Map (..), fromList, (!), member)+import Data.Maybe (fromMaybe)+import Data.Text (Text)++-- |Result type for query requests+type Record = Map Text Value++-- |Get exact type from Value+class RecordValue a where+ exact :: Monad m => Value -> m a++instance RecordValue () where+ exact (N _) = return ()+ exact _ = fail "Not a Null value"++instance RecordValue Bool where+ exact (B b) = return b+ exact _ = fail "Not a Bool value"++instance RecordValue Int where+ exact (I i) = return i+ exact _ = fail "Not an Int value"++instance RecordValue Double where+ exact (F d) = return d+ exact _ = fail "Not a Double value"++instance RecordValue Text where+ exact (T t) = return t+ exact _ = fail "Not a Text value"++instance RecordValue a => RecordValue [a] where+ exact (L l) = traverse exact l+ exact _ = fail "Not a List value"++instance RecordValue (Map Text Value) where+ exact (M m) = return m+ exact _ = fail "Not a Map value"++instance RecordValue Node where+ exact (S s) = fromStructure s+ exact _ = fail "Not a Node value"++instance RecordValue Relationship where+ exact (S s) = fromStructure s+ exact _ = fail "Not a Node value"++instance RecordValue URelationship where+ exact (S s) = fromStructure s+ exact _ = fail "Not a Node value"++instance RecordValue Path where+ exact (S s) = fromStructure s+ exact _ = fail "Not a Node value"++at :: Monad m => Record -> Text -> m Value+at record key | member key record = return (record ! key)+ | otherwise = fail "No such key in record"++toRecords :: [Response] -> [Record]+toRecords (signature:rest) = if isSuccess signature then mkRecords rest+ else []+ where keys :: [Text]+ keys = fromMaybe [] $ exact (succMap signature ! "fields")++ mkRecords :: [Response] -> [Record]+ mkRecords [terminal] = []+ mkRecords (x:xs) = fromList (zip keys (vals x)) : mkRecords xs+ where vals (ResponseRecord xs) = xs
+ src/Database/Bolt/Value/Helpers.hs view
@@ -0,0 +1,205 @@+module Database.Bolt.Value.Helpers where++import Control.Applicative (liftA2, liftA3)+import Data.Bits ((.&.))+import Data.Word (Word8)++-- = Checkers++isTinyInt :: Integral a => a -> Bool+isTinyInt = inRange (-16, 128 - 1)++isTinyWord :: Word8 -> Bool+isTinyWord = liftA2 (||) (< textConst) (>= 240)++isTinyText :: Word8 -> Bool+isTinyText = liftA2 (&&) (>= textConst) (< listConst)++isTinyList :: Word8 -> Bool+isTinyList = liftA2 (&&) (>= listConst) (< dictConst)++isTinyDict :: Word8 -> Bool+isTinyDict = liftA2 (&&) (>= dictConst) (< structConst)++isTinyStruct :: Word8 -> Bool+isTinyStruct = liftA2 (&&) (>= structConst) (< nullCode)++isNull :: Word8 -> Bool+isNull = (== nullCode)++isBool :: Word8 -> Bool+isBool = liftA2 (||) (== trueCode) (== falseCode)++isInt :: Word8 -> Bool+isInt = do x <- liftA2 (||) (== int8Code) (== int16Code)+ y <- liftA2 (||) (== int32Code) (== int64Code)+ z <- isTinyWord+ return $ x || y || z++isDouble :: Word8 -> Bool+isDouble = (== doubleCode)++isDict :: Word8 -> Bool+isDict = do x <- liftA2 (||) (== dict8Code) (== dict16Code)+ y <- liftA2 (||) (== dict32Code) isTinyDict+ return $ x || y++isText :: Word8 -> Bool+isText = do x <- liftA2 (||) (== text8Code) (== text16Code)+ y <- liftA2 (||) (== text32Code) isTinyText+ return $ x || y++isList :: Word8 -> Bool+isList = do x <- liftA2 (||) (== list8Code) (== list16Code)+ y <- liftA2 (||) (== list32Code) isTinyList+ return $ x || y++isStruct :: Word8 -> Bool+isStruct = liftA3 (\x y z -> x || y || z) (== struct8Code) (== struct16Code) isTinyStruct++-- = Constants++-- == Null++nullCode :: Word8+nullCode = 192++-- == Bool++falseCode :: Word8+falseCode = 194++trueCode :: Word8+trueCode = 195++-- == Numbers++int8Code :: Word8+int8Code = 200++int16Code :: Word8+int16Code = 201++int32Code :: Word8+int32Code = 202++int64Code :: Word8+int64Code = 203++doubleCode :: Word8+doubleCode = 193++-- == Text++textConst :: Word8+textConst = 128++text8Code :: Word8+text8Code = 208++text16Code :: Word8+text16Code = 209++text32Code :: Word8+text32Code = 210++-- == List++listConst :: Word8+listConst = 144++list8Code :: Word8+list8Code = 212++list16Code :: Word8+list16Code = 213++list32Code :: Word8+list32Code = 214++-- == Dict++dictConst :: Word8+dictConst = 160++dict8Code :: Word8+dict8Code = 216++dict16Code :: Word8+dict16Code = 217++dict32Code :: Word8+dict32Code = 218++-- == Structure++structConst :: Word8+structConst = 176++struct8Code :: Word8+struct8Code = 220++struct16Code :: Word8+struct16Code = 221++-- == Neo4j subject signatures++sigNode :: Word8+sigNode = 78++sigRel :: Word8+sigRel = 82++sigURel :: Word8+sigURel = 114++sigPath :: Word8+sigPath = 80++-- == BOLT requests signatures++sigInit :: Word8+sigInit = 1++sigRun :: Word8+sigRun = 16++sigAFail :: Word8+sigAFail = 14++sigReset :: Word8+sigReset = 15++sigDAll :: Word8+sigDAll = 47++sigPAll :: Word8+sigPAll = 63++-- == BOLT responses signatures++sigSucc :: Word8+sigSucc = 112++sigFail :: Word8+sigFail = 127++sigRecs :: Word8+sigRecs = 113++sigIgn :: Word8+sigIgn = 126++-- = Other helpers++toInt :: Integral a => a -> Int+toInt = fromIntegral++getSize :: Word8 -> Int+getSize x = fromIntegral $ x .&. 15++inRange :: Ord a => (a, a) -> a -> Bool+inRange (low, up) x = low <= x && x < up++isIntX :: Integral x => x -> x -> Bool+isIntX p = inRange (-2^(p-1), 2^(p-1) - 1)
+ src/Database/Bolt/Value/Instances.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE FlexibleInstances #-}++module Database.Bolt.Value.Instances where++import Database.Bolt.Value.Helpers+import Database.Bolt.Value.Type++import Control.Monad (forM, replicateM)+import Control.Monad.Trans.State (gets, modify)+import Data.Binary (Binary (..), decode, encode)+import Data.Binary.IEEE754 (doubleToWord, wordToDouble)+import Data.ByteString (ByteString, append, cons, drop,+ singleton, take)+import qualified Data.ByteString as B (concat, length)+import Data.ByteString.Lazy (fromStrict, toStrict)+import Data.Int+import Data.Map.Strict (Map (..), assocs, size, fromList)+import Data.Text (Text)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Data.Word+import Prelude hiding (drop, take)++instance BoltValue () where+ pack () = singleton nullCode++ unpackT = unpackW8 >>= unpackByMarker+ where unpackByMarker m | m == nullCode = return ()+ | otherwise = fail "Not a Null value"++instance BoltValue Bool where+ pack True = singleton trueCode+ pack False = singleton falseCode++ unpackT = unpackW8 >>= unpackByMarker+ where unpackByMarker m | m == trueCode = return True+ | m == falseCode = return False+ | otherwise = fail "Not a Bool value"++instance BoltValue Int where+ pack int | isTinyInt int = encodeStrict (fromIntegral int :: Word8)+ | isIntX 8 int = cons int8Code $ encodeStrict (fromIntegral int :: Word8)+ | isIntX 16 int = cons int16Code $ encodeStrict (fromIntegral int :: Word16)+ | isIntX 32 int = cons int32Code $ encodeStrict (fromIntegral int :: Word32)+ | isIntX 64 int = cons int64Code $ encodeStrict (fromIntegral int :: Word64)++ unpackT = unpackW8 >>= unpackByMarker+ where unpackByMarker m | isTinyWord m = return . toInt $ (fromIntegral m :: Int8)+ | m == int8Code = toInt <$> unpackI8+ | m == int16Code = toInt <$> unpackI16+ | m == int32Code = toInt <$> unpackI32+ | m == int64Code = toInt <$> unpackI64+ | otherwise = fail "Not an Int value"++instance BoltValue Double where+ pack dbl = cons doubleCode $ encodeStrict (doubleToWord dbl)++ unpackT = unpackW8 >>= unpackByMarker+ where unpackByMarker m | m == doubleCode = wordToDouble <$> unpackW64+ | otherwise = fail "Not a Double value"++instance BoltValue Text where+ pack txt = mkPackedCollection (B.length pbs) pbs (textConst, text8Code, text16Code, text32Code)+ where pbs = encodeUtf8 txt++ unpackT = unpackW8 >>= unpackByMarker+ where unpackByMarker m | isTinyText m = unpackTextBySize (getSize m)+ | m == text8Code = toInt <$> unpackW8 >>= unpackTextBySize+ | m == text16Code = toInt <$> unpackW16 >>= unpackTextBySize+ | m == text32Code = toInt <$> unpackW32 >>= unpackTextBySize+ | otherwise = fail "Not a Text value"+ unpackTextBySize size = do str <- gets (take size)+ modify (drop size)+ return $ decodeUtf8 str++instance BoltValue a => BoltValue [a] where+ pack lst = mkPackedCollection (length lst) pbs (listConst, list8Code, list16Code, list32Code)+ where pbs = B.concat $ map pack lst++ unpackT = unpackW8 >>= unpackByMarker+ where unpackByMarker m | isTinyList m = unpackListBySize (getSize m)+ | m == list8Code = toInt <$> unpackW8 >>= unpackListBySize+ | m == list16Code = toInt <$> unpackW16 >>= unpackListBySize+ | m == list32Code = toInt <$> unpackW32 >>= unpackListBySize+ | otherwise = fail "Not a List value"+ unpackListBySize size = forM [1..size] $ const unpackT++instance BoltValue a => BoltValue (Map Text a) where+ pack dict = mkPackedCollection (size dict) pbs (dictConst, dict8Code, dict16Code, dict32Code)+ where pbs = B.concat $ map mkPairPack $ assocs dict+ mkPairPack (key, val) = pack key `append` pack val++ unpackT = unpackW8 >>= unpackByMarker+ where unpackByMarker m | isTinyDict m = unpackDictBySize (getSize m)+ | m == dict8Code = toInt <$> unpackW8 >>= unpackDictBySize+ | m == dict16Code = toInt <$> unpackW16 >>= unpackDictBySize+ | m == dict32Code = toInt <$> unpackW32 >>= unpackDictBySize+ | otherwise = error "Not a Dict value"+ unpackDictBySize = (fromList <$>) . unpackPairsBySize+ unpackPairsBySize size = forM [1..size] $ const $ do+ key <- unpackT+ value <- unpackT+ return (key, value)++instance BoltValue Structure where+ pack (Structure sig fields) | size < 16 = (structConst + fromIntegral size) `cons` pData+ | size < 2^8 = struct8Code `cons` fromIntegral size `cons` pData+ | size < 2^16 = struct16Code `cons` encodeStrict size `append` pData+ where size = fromIntegral $ length fields :: Word16+ pData = sig `cons` B.concat (map pack fields)++ unpackT = unpackW8 >>= unpackByMarker+ where unpackByMarker m | isTinyStruct m = unpackStructureBySize (getSize m)+ | m == struct8Code = toInt <$> unpackW8 >>= unpackStructureBySize+ | m == struct16Code = toInt <$> unpackW16 >>= unpackStructureBySize+ | otherwise = fail "Not a Structure value"+ unpackStructureBySize size = do sig <- unpackW8+ fields <- replicateM size unpackT+ return $ Structure sig fields++instance BoltValue Value where+ pack (N n) = pack n+ pack (B b) = pack b+ pack (I i) = pack i+ pack (F d) = pack d+ pack (T t) = pack t+ pack (L l) = pack l+ pack (M m) = pack m+ pack (S s) = pack s++ unpackT = observeW8 >>= unpackByMarker+ where unpackByMarker m | isNull m = N <$> unpackT+ | isBool m = B <$> unpackT+ | isInt m = I <$> unpackT+ | isDouble m = F <$> unpackT+ | isText m = T <$> unpackT+ | isList m = L <$> unpackT+ | isDict m = M <$> unpackT+ | isStruct m = S <$> unpackT+ | otherwise = fail "Not a Value value"++-- |Structure unpack function+unpackS :: (Monad m, Structable a) => ByteString -> m a+unpackS bs = unpack bs >>= fromStructure++-- = Integer values unpackers++observeW8 :: Monad m => UnpackT m Word8+observeW8 = observeNum 1++unpackW8 :: Monad m => UnpackT m Word8+unpackW8 = unpackNum 1++unpackW16 :: Monad m => UnpackT m Word16+unpackW16 = unpackNum 2++unpackW32 :: Monad m => UnpackT m Word32+unpackW32 = unpackNum 4++unpackW64 :: Monad m => UnpackT m Word64+unpackW64 = unpackNum 8++unpackI8 :: Monad m => UnpackT m Int8+unpackI8 = unpackNum 1++unpackI16 :: Monad m => UnpackT m Int16+unpackI16 = unpackNum 2++unpackI32 :: Monad m => UnpackT m Int32+unpackI32 = unpackNum 4++unpackI64 :: Monad m => UnpackT m Int64+unpackI64 = unpackNum 8++-- = Other helpers++-- |Unpacks n bytes as a numeric type+observeNum :: (Monad m, Binary a, Num a) => Int -> UnpackT m a+observeNum = (decodeStrict <$>) . topBS++unpackNum :: (Monad m, Binary a, Num a) => Int -> UnpackT m a+unpackNum = (decodeStrict <$>) . popBS++decodeStrict :: Binary a => ByteString -> a+decodeStrict = decode . fromStrict++encodeStrict :: Binary a => a -> ByteString+encodeStrict = toStrict . encode++-- |Obtain first n bytes of 'ByteString'+topBS :: Monad m => Int -> UnpackT m ByteString+topBS size = gets (take size)++-- |Obtain first n bytes of 'ByteString' and move offset by n+popBS :: Monad m => Int -> UnpackT m ByteString+popBS size = do top <- topBS size+ modify (drop size)+ return top++-- |Pack collection using it's size and set of BOLT constants+mkPackedCollection :: Int -> ByteString -> (Word8, Word8, Word8, Word8) -> ByteString+mkPackedCollection size bst (wt, w8, w16, w32) = helper size+ where helper size | size < 2^4 = cons (wt + fromIntegral size) bst+ | size < 2^8 = cons w8 $ cons (fromIntegral size) bst+ | size < 2^16 = cons w16 $ encodeStrict (fromIntegral size :: Word16) `append` bst+ | size < 2^32 = cons w32 $ encodeStrict (fromIntegral size :: Word32) `append` bst+ | otherwise = error "Cannot pack so large collection"
+ src/Database/Bolt/Value/Structure.hs view
@@ -0,0 +1,83 @@+module Database.Bolt.Value.Structure where++import Database.Bolt.Value.Type+import Database.Bolt.Value.Helpers++import Data.Text (Text)++instance Structable Node where+ toStructure = undefined++ fromStructure (Structure sig lst) | sig == sigNode = mkNode lst+ | otherwise = failNode+ where mkNode :: Monad m => [Value] -> m Node+ mkNode [I nid, L vlbls, M props] = flip (Node nid) props <$> cnvT vlbls+ mkNode _ = failNode++ failNode :: Monad m => m Node+ failNode = fail "Not a Node value"++instance Structable Relationship where+ toStructure = undefined++ fromStructure (Structure sig lst) | sig == sigRel = mkRel lst+ | otherwise = failRel+ where mkRel :: Monad m => [Value] -> m Relationship+ mkRel [I rid, I sni, I eni, T rt, M rp] = return $ Relationship rid sni eni rt rp+ mkRel _ = failRel++ failRel :: Monad m => m Relationship+ failRel = fail "Not a Relationship value"++instance Structable URelationship where+ toStructure = undefined++ fromStructure (Structure sig lst) | sig == sigURel = mkURel lst+ | otherwise = failURel+ where mkURel :: Monad m => [Value] -> m URelationship+ mkURel [I rid, T rt, M rp] = return $ URelationship rid rt rp+ mkURel _ = failURel++ failURel :: Monad m => m URelationship+ failURel = fail "Not a Unbounded Relationship value"++instance Structable Path where+ toStructure = undefined++ fromStructure (Structure sig lst) | sig == sigPath = mkPath lst+ | otherwise = failPath+ where mkPath :: Monad m => [Value] -> m Path+ mkPath [L vnp, L vrp, L vip] = do np <- cnvN vnp+ rp <- cnvR vrp+ ip <- cnvI vip+ return $ Path np rp ip+ mkPath _ = failPath++ failPath :: Monad m => m Path+ failPath = fail "Not a Path value"++-- = Helper functions++cnvT :: Monad m => [Value] -> m [Text]+cnvT [] = return []+cnvT (T x:xs) = (x:) <$> cnvT xs+cnvT _ = fail "Non-text value in text list"++cnvN :: Monad m => [Value] -> m [Node]+cnvN [] = return []+cnvN (S x:xs) = do hd <- fromStructure x+ rest <- cnvN xs+ return (hd:rest)+cnvN _ = fail "Non-node value in text list"++cnvR :: Monad m => [Value] -> m [URelationship]+cnvR [] = return []+cnvR (S x:xs) = do hd <- fromStructure x+ rest <- cnvR xs+ return (hd:rest)+cnvR _ = fail "Non-(u)relationship value in text list"++cnvI :: Monad m => [Value] -> m [Int]+cnvI [] = return []+cnvI (I x:xs) = (x:) <$> cnvI xs+cnvI _ = fail "Non-int value in text list"
+ src/Database/Bolt/Value/Type.hs view
@@ -0,0 +1,73 @@+module Database.Bolt.Value.Type where++import Control.Monad.Trans.State (StateT (..), evalStateT)+import Data.ByteString (ByteString)+import Data.Map.Strict (Map (..))+import Data.Text (Text)+import Data.Word (Word8)++-- \The 'UnpackT' transformer helps to unpack a set of values from one 'ByteString'+type UnpackT = StateT ByteString++-- |The 'Structure' datatype describes Neo4j structure for BOLT protocol+data Structure = Structure { signature :: Word8+ , fields :: [Value]+ }+ deriving (Show, Eq)++-- |Generalizes all datatypes that can be serialized (deserialized) to (from) 'Structure's.+class Structable a where+ toStructure :: a -> Structure+ fromStructure :: Monad m => Structure -> m a++-- |The 'BoltValue' class describes values, that can be packed and unpacked for BOLT protocol.+class BoltValue a where+ -- |Packs a value to 'ByteString'+ pack :: a -> ByteString+ -- |Unpacks in a State monad to get values from single 'ByteString'+ unpackT :: Monad m => UnpackT m a++ -- |Unpacks a 'ByteString' to selected value+ unpack :: Monad m => ByteString -> m a+ unpack = evalStateT unpackT++-- |The 'Value' datatype generalizes all primitive 'BoltValue's+data Value = N ()+ | B Bool+ | I Int+ | F Double+ | T Text+ | L [Value]+ | M (Map Text Value)+ | S Structure+ deriving (Show, Eq)++-- = Structure types++-- == Neo4j subjects++data Node = Node { nodeIdentity :: Int -- ^Neo4j node identifier+ , labels :: [Text] -- ^Set of node labels (types)+ , nodeProps :: Map Text Value -- ^Dict of node properties+ }+ deriving (Show, Eq)++data Relationship = Relationship { relIdentity :: Int -- ^Neo4j relationship identifier+ , startNodeId :: Int -- ^Identifier of start node+ , endNodeId :: Int -- ^Identifier of end node+ , relType :: Text -- ^Relationship type+ , relProps :: Map Text Value -- ^Dict of relationship properties+ }+ deriving (Show, Eq)++data URelationship = URelationship { urelIdentity :: Int -- ^Neo4j relationship identifier+ , urelType :: Text -- ^Relationship type+ , urelProps :: Map Text Value -- ^Dict of relationship properties+ }+ deriving (Show, Eq)++data Path = Path { pathNodes :: [Node] -- ^Chain of 'Node's in path+ , pathRelationships :: [URelationship] -- ^Chain of 'Relationship's in path+ , pathSequence :: [Int] -- ^Path sequence+ }+ deriving (Show, Eq)
+ test/Spec.hs view
@@ -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 (BoltValue (..))++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