diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hasbolt.cabal b/hasbolt.cabal new file mode 100644 --- /dev/null +++ b/hasbolt.cabal @@ -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 diff --git a/src/Database/Bolt.hs b/src/Database/Bolt.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt.hs @@ -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 (..)) diff --git a/src/Database/Bolt/Connection.hs b/src/Database/Bolt/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Connection.hs @@ -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 diff --git a/src/Database/Bolt/Connection/Instances.hs b/src/Database/Bolt/Connection/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Connection/Instances.hs @@ -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" diff --git a/src/Database/Bolt/Connection/Pipe.hs b/src/Database/Bolt/Connection/Pipe.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Connection/Pipe.hs @@ -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)) diff --git a/src/Database/Bolt/Connection/Type.hs b/src/Database/Bolt/Connection/Type.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Connection/Type.hs @@ -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 diff --git a/src/Database/Bolt/Record.hs b/src/Database/Bolt/Record.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Record.hs @@ -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 diff --git a/src/Database/Bolt/Value/Helpers.hs b/src/Database/Bolt/Value/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Value/Helpers.hs @@ -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) diff --git a/src/Database/Bolt/Value/Instances.hs b/src/Database/Bolt/Value/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Value/Instances.hs @@ -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" diff --git a/src/Database/Bolt/Value/Structure.hs b/src/Database/Bolt/Value/Structure.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Value/Structure.hs @@ -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" diff --git a/src/Database/Bolt/Value/Type.hs b/src/Database/Bolt/Value/Type.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Value/Type.hs @@ -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) 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 (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