bolt 0.1.0.2 → 0.1.0.3
raw patch · 16 files changed
+1001/−978 lines, 16 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- LICENSE +30/−30
- README.md +15/−0
- Setup.hs +2/−2
- bolt.cabal +64/−56
- src/Data/PackStream.hs +293/−293
- src/Database/Bolt/Exception.hs +39/−39
- src/Database/Bolt/Protocol/Ver1.hs +29/−29
- src/Database/Bolt/Protocol/Ver1/Graph.hs +82/−82
- src/Database/Bolt/Protocol/Ver1/Message.hs +77/−77
- src/Database/Bolt/Protocol/Ver1/Pretty.hs +30/−30
- src/Database/Bolt/Protocol/Ver1/Request.hs +74/−74
- src/Database/Bolt/Protocol/Ver1/Types.hs +20/−20
- src/Database/Bolt/Transport.hs +68/−68
- src/Database/Bolt/Transport/Chunked.hs +73/−73
- src/Database/Bolt/Transport/Message.hs +26/−26
- src/Database/Bolt/Transport/Socket.hs +79/−79
LICENSE view
@@ -1,30 +1,30 @@-Copyright Shaun Sharples (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 Author name here 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. +Copyright Shaun Sharples (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 Author name here 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.
+ README.md view
@@ -0,0 +1,15 @@+# Bolt driver for Haskell++I have started writing a basic Bolt driver to access Neo4j databases by+implementing the [Bolt Protocol, Version 1](http://boltprotocol.org/v1/).++## Join In!++I am happy to receive bug reports, fixes, documentation enhancements, and+other improvements.++Please report bugs via the [github issue tracker](https://github.com/bflyblue/bolt/issues).++## Authors++This library is written and maintained by Shaun Sharples, <shaun.sharples@gmail.com>.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
bolt.cabal view
@@ -1,56 +1,64 @@-name: bolt -version: 0.1.0.2 -synopsis: Bolt driver for Neo4j -description: Please see README.md -homepage: https://github.com/bflyblue/bolt#readme -license: BSD3 -license-file: LICENSE -author: Shaun Sharples -maintainer: shaun.sharples@gmail.com -stability: experimental -copyright: (c) 2016 Shaun Sharples -category: Database -build-type: Simple --- extra-source-files: -cabal-version: >=1.10 - -library - hs-source-dirs: src - exposed-modules: Data.PackStream - , Database.Bolt.Exception - , Database.Bolt.Protocol.Ver1 - , Database.Bolt.Protocol.Ver1.Graph - , Database.Bolt.Protocol.Ver1.Message - , Database.Bolt.Protocol.Ver1.Pretty - , Database.Bolt.Protocol.Ver1.Request - , Database.Bolt.Protocol.Ver1.Types - , Database.Bolt.Transport - , Database.Bolt.Transport.Chunked - , Database.Bolt.Transport.Message - , Database.Bolt.Transport.Socket - build-depends: base >= 4.7 && < 5 - , bifunctors - , bytestring - , cereal - , containers - , hashable - , network - , network-uri - , text - , unordered-containers - , vector - ghc-options: -Wall - default-language: Haskell2010 - --- test-suite tests --- type: exitcode-stdio-1.0 --- hs-source-dirs: test --- main-is: Spec.hs --- build-depends: base --- , bolt --- ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall --- default-language: Haskell2010 - -source-repository head - type: git - location: https://github.com/bflyblue/bolt +name: bolt+version: 0.1.0.3+synopsis: Bolt driver for Neo4j+description:+ A Bolt driver to access Neo4j databases using+ the Bolt Protocol, Version 1. <http://boltprotocol.org/v1/>+homepage: https://github.com/bflyblue/bolt#readme+license: BSD3+license-file: LICENSE+author: Shaun Sharples+maintainer: shaun.sharples@gmail.com+stability: experimental+copyright: (c) 2016 Shaun Sharples+category: Database+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ other-extensions: DeriveAnyClass+ , DeriveGeneric+ , MultiWayIf+ , OverloadedStrings+ , RecordWildCards+ , ScopedTypeVariables+ exposed-modules: Data.PackStream+ , Database.Bolt.Exception+ , Database.Bolt.Protocol.Ver1+ , Database.Bolt.Protocol.Ver1.Graph+ , Database.Bolt.Protocol.Ver1.Message+ , Database.Bolt.Protocol.Ver1.Pretty+ , Database.Bolt.Protocol.Ver1.Request+ , Database.Bolt.Protocol.Ver1.Types+ , Database.Bolt.Transport+ , Database.Bolt.Transport.Chunked+ , Database.Bolt.Transport.Message+ , Database.Bolt.Transport.Socket+ build-depends: base >= 4.8 && < 5+ , bifunctors >= 5.2 && < 5.5+ , bytestring >= 0.10.6 && < 0.11+ , cereal >= 0.5.2 && < 0.6+ , containers >= 0.5.6 && < 0.6+ , hashable >= 1.2.4 && < 1.3+ , network >= 2.6.2 && < 2.7+ , network-uri >= 2.6.1 && < 2.7+ , text >= 1.2.2 && < 1.3+ , unordered-containers >= 0.2.7 && < 0.3+ , vector >= 0.11.0 && < 0.12+ ghc-options: -Wall+ default-language: Haskell2010++-- test-suite tests+-- type: exitcode-stdio-1.0+-- hs-source-dirs: test+-- main-is: Spec.hs+-- build-depends: base+-- , bolt+-- ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+-- default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/bflyblue/bolt
src/Data/PackStream.hs view
@@ -1,293 +1,293 @@-{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} - -module Data.PackStream - ( PackStream(..) - , ToPackStream(..) - , FromPackStream(..) - , Parser - , parse - , parseEither - , parseMaybe - , pack - , unpack - , pretty - , prettyStruct - , genericStructName - , (.=) - , (.:) - , (.:?) - , (.!=) - ) -where - -import Control.Monad -import Data.Bifunctor -import Data.Bits -import Data.Hashable -import qualified Data.HashMap.Strict as HM -import Data.Int -import qualified Data.Map.Strict as M -import Data.Monoid -import Data.Serialize.Get -import Data.Serialize.IEEE754 -import Data.Serialize.Put -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Vector as V -import Data.Word -import GHC.Generics (Generic) -import Text.Printf - --- Orphan instance should go away once vector-instances 0.4 is available -instance (Hashable a) => Hashable (V.Vector a) where - hashWithSalt salt = hashWithSalt salt . V.toList - {-# INLINE hashWithSalt #-} - -data PackStream = Null - | Bool !Bool - | Int !Int64 - | Float !Double - | String !Text - | List !(V.Vector PackStream) - | Map !(HM.HashMap PackStream PackStream) - | Struct !Word8 ![PackStream] - deriving (Show, Eq, Generic, Hashable) - -type Parser = Either String - -parse :: (a -> Parser b) -> a -> Parser b -parse = parseEither - -parseEither :: (a -> Parser b) -> a -> Either String b -parseEither f = f - -parseMaybe :: (a -> Parser b) -> a -> Maybe b -parseMaybe f = either (const Nothing) Just . parseEither f - -class FromPackStream a where - parsePackStream :: PackStream -> Parser a - -instance FromPackStream PackStream where - parsePackStream = return - -instance FromPackStream Bool where - parsePackStream (Bool b) = return b - parsePackStream _ = fail "Expecting Bool" - -instance FromPackStream Int64 where - parsePackStream (Int i) = return i - parsePackStream _ = fail "Expecting Int" - -instance FromPackStream Double where - parsePackStream (Float d) = return d - parsePackStream _ = fail "Expecting Float" - -instance FromPackStream Text where - parsePackStream (String t) = return t - parsePackStream _ = fail "Expecting String" - -instance FromPackStream a => FromPackStream [a] where - parsePackStream (List l) = mapM parsePackStream (V.toList l) - parsePackStream _ = fail "Expecting List" - -instance FromPackStream a => FromPackStream (V.Vector a) where - parsePackStream (List l) = mapM parsePackStream l - parsePackStream _ = fail "Expecting List" - -instance (Eq a, Hashable a, FromPackStream a, FromPackStream b) => FromPackStream (HM.HashMap a b) where - parsePackStream (Map m) = do - kvs <- mapM parseAssoc (HM.toList m) - return $ HM.fromList kvs - where - parseAssoc (k, v) = (,) <$> parsePackStream k <*> parsePackStream v - - parsePackStream _ = fail "Expecting Map" - -instance (Ord a, FromPackStream a, FromPackStream b) => FromPackStream (M.Map a b) where - parsePackStream (Map m) = do - kvs <- mapM parseAssoc (HM.toList m) - return $ M.fromList kvs - where - parseAssoc (k, v) = (,) <$> parsePackStream k <*> parsePackStream v - - parsePackStream _ = fail "Expecting Map" - -class ToPackStream a where - toPackStream :: a -> PackStream - -instance ToPackStream PackStream where - toPackStream = id - -instance ToPackStream Bool where - toPackStream = Bool - -instance ToPackStream Int64 where - toPackStream = Int - -instance ToPackStream Double where - toPackStream = Float - -instance ToPackStream Text where - toPackStream = String - -instance ToPackStream a => ToPackStream [a] where - toPackStream = List . V.fromList . fmap toPackStream - -instance ToPackStream a => ToPackStream (V.Vector a) where - toPackStream = List . fmap toPackStream - -instance (ToPackStream a, ToPackStream b) => ToPackStream (M.Map a b) where - toPackStream = Map . HM.fromList . fmap (bimap toPackStream toPackStream) . M.toList - -instance (ToPackStream a, ToPackStream b) => ToPackStream (HM.HashMap a b) where - toPackStream = Map . HM.fromList . fmap (bimap toPackStream toPackStream) . HM.toList - -pack :: ToPackStream a => Putter a -pack = putPackStream . toPackStream - -unpack :: FromPackStream a => Get (Parser a) -unpack = parsePackStream <$> getPackStream - -getPackStream :: Get PackStream -getPackStream = do - marker <- getWord8 - if | marker == 0xc0 -> return Null - - | marker == 0xc1 -> Float <$> getFloat64be - - | marker == 0xc2 -> return $ Bool False - | marker == 0xc3 -> return $ Bool True - - | marker < 0x80 -> return $ Int (fromIntegral marker) - | marker >= 0xf0 -> return $ Int (fromIntegral marker - 0x100) - | marker == 0xc8 -> Int . fromIntegral <$> getWord8 - | marker == 0xc9 -> Int . fromIntegral <$> getWord16be - | marker == 0xca -> Int . fromIntegral <$> getWord32be - | marker == 0xcb -> Int . fromIntegral <$> getWord64be - - | 0x80 <= marker && marker < 0x90 - -> getString (fromIntegral marker .&. 0x0f) - | marker == 0xd0 -> fromIntegral <$> getWord8 >>= getString - | marker == 0xd1 -> fromIntegral <$> getWord16be >>= getString - | marker == 0xd2 -> fromIntegral <$> getWord32be >>= getString - - | 0x90 <= marker && marker < 0xa0 - -> getList (fromIntegral marker .&. 0x0f) - | marker == 0xd4 -> fromIntegral <$> getWord8 >>= getList - | marker == 0xd5 -> fromIntegral <$> getWord16be >>= getList - | marker == 0xd6 -> fromIntegral <$> getWord32be >>= getList - - | 0xa0 <= marker && marker < 0xb0 - -> getMap (fromIntegral marker .&. 0x0f) - | marker == 0xd8 -> fromIntegral <$> getWord8 >>= getMap - | marker == 0xd9 -> fromIntegral <$> getWord16be >>= getMap - | marker == 0xda -> fromIntegral <$> getWord32be >>= getMap - - | 0xb0 <= marker && marker < 0xc0 - -> getStruct (fromIntegral marker .&. 0x0f) - | marker == 0xdc -> fromIntegral <$> getWord8 >>= getStruct - | marker == 0xdd -> fromIntegral <$> getWord16be >>= getStruct - | otherwise -> fail $ "Unknown marker " ++ printf "0x%02x" marker - -getString :: Int -> Get PackStream -getString n = String . T.decodeUtf8 <$> getByteString n - -getList :: Int -> Get PackStream -getList n = List . V.fromList <$> replicateM n getPackStream - -getMap :: Int -> Get PackStream -getMap n = Map . HM.fromList <$> replicateM n getPair - where - getPair = (,) <$> getPackStream <*> getPackStream - -getStruct :: Int -> Get PackStream -getStruct n = Struct <$> getWord8 <*> replicateM n getPackStream - -putPackStream :: Putter PackStream - -putPackStream Null = putWord8 0xc0 - -putPackStream (Float d) = putWord8 0xc1 >> putFloat64be d - -putPackStream (Bool False) = putWord8 0xc2 -putPackStream (Bool True) = putWord8 0xc3 - -putPackStream (Int i) - | -0x10 <= i && i < 0x80 = putWord8 (fromIntegral i) - | -0x80 <= i && i < 0x80 = putWord8 0xc8 >> putWord8 (fromIntegral i) - | -0x8000 <= i && i < 0x8000 = putWord8 0xc9 >> putWord16be (fromIntegral i) - | -0x80000000 <= i && i < 0x80000000 = putWord8 0xca >> putWord32be (fromIntegral i) - | otherwise = putWord8 0xcb >> putWord64be (fromIntegral i) - -putPackStream (String t) = do - let size = T.length t - if | size < 0x10 -> putWord8 (0x80 + fromIntegral size) - | size < 0x100 -> putWord8 0xd0 >> putWord8 (fromIntegral size) - | size < 0x10000 -> putWord8 0xd1 >> putWord16be (fromIntegral size) - | size < 0x100000000 -> putWord8 0xd2 >> putWord16be (fromIntegral size) - | otherwise -> fail "String too long" - putByteString $ T.encodeUtf8 t - -putPackStream (List xs) = do - let size = V.length xs - if | size < 0x10 -> putWord8 (0x90 + fromIntegral size) - | size < 0x100 -> putWord8 0xd4 >> putWord8 (fromIntegral size) - | size < 0x10000 -> putWord8 0xd5 >> putWord16be (fromIntegral size) - | size < 0x100000000 -> putWord8 0xd6 >> putWord16be (fromIntegral size) - | otherwise -> fail "List too long" - mapM_ putPackStream xs - -putPackStream (Map m) = do - let size = HM.size m - if | size < 0x10 -> putWord8 (0xa0 + fromIntegral size) - | size < 0x100 -> putWord8 0xd8 >> putWord8 (fromIntegral size) - | size < 0x10000 -> putWord8 0xd9 >> putWord16be (fromIntegral size) - | size < 0x100000000 -> putWord8 0xda >> putWord16be (fromIntegral size) - | otherwise -> fail "Map too large" - mapM_ (uncurry putPair) (HM.toList m) - where - putPair k v = putPackStream k >> putPackStream v - -putPackStream (Struct sig fs) = do - let size = length fs - if | size < 0x10 -> putWord8 (0xb0 + fromIntegral size) - | size < 0x100 -> putWord8 0xdc >> putWord8 (fromIntegral size) - | size < 0x10000 -> putWord8 0xdd >> putWord16be (fromIntegral size) - | otherwise -> fail "Structure too big" - putWord8 sig - mapM_ putPackStream fs - -pretty :: PackStream -> Text -pretty = prettyStruct genericStructName - -prettyStruct :: (Word8 -> Text) -> PackStream -> Text -prettyStruct _ Null = "null" -prettyStruct _ (Bool True) = "true" -prettyStruct _ (Bool False) = "false" -prettyStruct _ (Int i) = T.pack (show i) -prettyStruct _ (Float d) = T.pack (show d) -prettyStruct _ (String t) = "\"" <> t <> "\"" -prettyStruct _ (List xs) = "[" <> T.intercalate ", " (pretty <$> V.toList xs) <> "]" -prettyStruct _ (Map ps) = "{" <> T.intercalate ", " (fmap (\(k, v) -> pretty k <> ": " <> pretty v) (HM.toList ps)) <> "}" -prettyStruct sn (Struct s fs) = sn s <> "{" <> T.intercalate ", " (pretty <$> fs) <> "}" - -genericStructName :: Word8 -> Text -genericStructName n = "Struct(signature=" <> T.pack (printf "0x%02x" n) <> ")" - -(.=) :: ToPackStream a => Text -> a -> (PackStream, PackStream) -k .= v = (String k, toPackStream v) - -(.:) :: FromPackStream a => HM.HashMap PackStream PackStream -> Text -> Parser a -m .: k = maybe (error "Expected Key missing in map") parsePackStream (HM.lookup (String k) m) - -(.:?) :: FromPackStream a => HM.HashMap PackStream PackStream -> Text -> Parser (Maybe a) -m .:? k = maybe (return Nothing) (fmap Just . parsePackStream) (HM.lookup (String k) m) - -(.!=) :: Parser (Maybe a) -> a -> Parser a -p .!= d = do - ma <- p - maybe (return d) return ma +{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.PackStream+ ( PackStream(..)+ , ToPackStream(..)+ , FromPackStream(..)+ , Parser+ , parse+ , parseEither+ , parseMaybe+ , pack+ , unpack+ , pretty+ , prettyStruct+ , genericStructName+ , (.=)+ , (.:)+ , (.:?)+ , (.!=)+ )+where++import Control.Monad+import Data.Bifunctor+import Data.Bits+import Data.Hashable+import qualified Data.HashMap.Strict as HM+import Data.Int+import qualified Data.Map.Strict as M+import Data.Monoid+import Data.Serialize.Get+import Data.Serialize.IEEE754+import Data.Serialize.Put+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.Vector as V+import Data.Word+import GHC.Generics (Generic)+import Text.Printf++-- Orphan instance should go away once vector-instances 0.4 is available+instance (Hashable a) => Hashable (V.Vector a) where+ hashWithSalt salt = hashWithSalt salt . V.toList+ {-# INLINE hashWithSalt #-}++data PackStream = Null+ | Bool !Bool+ | Int !Int64+ | Float !Double+ | String !Text+ | List !(V.Vector PackStream)+ | Map !(HM.HashMap PackStream PackStream)+ | Struct !Word8 ![PackStream]+ deriving (Show, Eq, Generic, Hashable)++type Parser = Either String++parse :: (a -> Parser b) -> a -> Parser b+parse = parseEither++parseEither :: (a -> Parser b) -> a -> Either String b+parseEither f = f++parseMaybe :: (a -> Parser b) -> a -> Maybe b+parseMaybe f = either (const Nothing) Just . parseEither f++class FromPackStream a where+ parsePackStream :: PackStream -> Parser a++instance FromPackStream PackStream where+ parsePackStream = return++instance FromPackStream Bool where+ parsePackStream (Bool b) = return b+ parsePackStream _ = fail "Expecting Bool"++instance FromPackStream Int64 where+ parsePackStream (Int i) = return i+ parsePackStream _ = fail "Expecting Int"++instance FromPackStream Double where+ parsePackStream (Float d) = return d+ parsePackStream _ = fail "Expecting Float"++instance FromPackStream Text where+ parsePackStream (String t) = return t+ parsePackStream _ = fail "Expecting String"++instance FromPackStream a => FromPackStream [a] where+ parsePackStream (List l) = mapM parsePackStream (V.toList l)+ parsePackStream _ = fail "Expecting List"++instance FromPackStream a => FromPackStream (V.Vector a) where+ parsePackStream (List l) = mapM parsePackStream l+ parsePackStream _ = fail "Expecting List"++instance (Eq a, Hashable a, FromPackStream a, FromPackStream b) => FromPackStream (HM.HashMap a b) where+ parsePackStream (Map m) = do+ kvs <- mapM parseAssoc (HM.toList m)+ return $ HM.fromList kvs+ where+ parseAssoc (k, v) = (,) <$> parsePackStream k <*> parsePackStream v++ parsePackStream _ = fail "Expecting Map"++instance (Ord a, FromPackStream a, FromPackStream b) => FromPackStream (M.Map a b) where+ parsePackStream (Map m) = do+ kvs <- mapM parseAssoc (HM.toList m)+ return $ M.fromList kvs+ where+ parseAssoc (k, v) = (,) <$> parsePackStream k <*> parsePackStream v++ parsePackStream _ = fail "Expecting Map"++class ToPackStream a where+ toPackStream :: a -> PackStream++instance ToPackStream PackStream where+ toPackStream = id++instance ToPackStream Bool where+ toPackStream = Bool++instance ToPackStream Int64 where+ toPackStream = Int++instance ToPackStream Double where+ toPackStream = Float++instance ToPackStream Text where+ toPackStream = String++instance ToPackStream a => ToPackStream [a] where+ toPackStream = List . V.fromList . fmap toPackStream++instance ToPackStream a => ToPackStream (V.Vector a) where+ toPackStream = List . fmap toPackStream++instance (ToPackStream a, ToPackStream b) => ToPackStream (M.Map a b) where+ toPackStream = Map . HM.fromList . fmap (bimap toPackStream toPackStream) . M.toList++instance (ToPackStream a, ToPackStream b) => ToPackStream (HM.HashMap a b) where+ toPackStream = Map . HM.fromList . fmap (bimap toPackStream toPackStream) . HM.toList++pack :: ToPackStream a => Putter a+pack = putPackStream . toPackStream++unpack :: FromPackStream a => Get (Parser a)+unpack = parsePackStream <$> getPackStream++getPackStream :: Get PackStream+getPackStream = do+ marker <- getWord8+ if | marker == 0xc0 -> return Null++ | marker == 0xc1 -> Float <$> getFloat64be++ | marker == 0xc2 -> return $ Bool False+ | marker == 0xc3 -> return $ Bool True++ | marker < 0x80 -> return $ Int (fromIntegral marker)+ | marker >= 0xf0 -> return $ Int (fromIntegral marker - 0x100)+ | marker == 0xc8 -> Int . fromIntegral <$> getWord8+ | marker == 0xc9 -> Int . fromIntegral <$> getWord16be+ | marker == 0xca -> Int . fromIntegral <$> getWord32be+ | marker == 0xcb -> Int . fromIntegral <$> getWord64be++ | 0x80 <= marker && marker < 0x90+ -> getString (fromIntegral marker .&. 0x0f)+ | marker == 0xd0 -> fromIntegral <$> getWord8 >>= getString+ | marker == 0xd1 -> fromIntegral <$> getWord16be >>= getString+ | marker == 0xd2 -> fromIntegral <$> getWord32be >>= getString++ | 0x90 <= marker && marker < 0xa0+ -> getList (fromIntegral marker .&. 0x0f)+ | marker == 0xd4 -> fromIntegral <$> getWord8 >>= getList+ | marker == 0xd5 -> fromIntegral <$> getWord16be >>= getList+ | marker == 0xd6 -> fromIntegral <$> getWord32be >>= getList++ | 0xa0 <= marker && marker < 0xb0+ -> getMap (fromIntegral marker .&. 0x0f)+ | marker == 0xd8 -> fromIntegral <$> getWord8 >>= getMap+ | marker == 0xd9 -> fromIntegral <$> getWord16be >>= getMap+ | marker == 0xda -> fromIntegral <$> getWord32be >>= getMap++ | 0xb0 <= marker && marker < 0xc0+ -> getStruct (fromIntegral marker .&. 0x0f)+ | marker == 0xdc -> fromIntegral <$> getWord8 >>= getStruct+ | marker == 0xdd -> fromIntegral <$> getWord16be >>= getStruct+ | otherwise -> fail $ "Unknown marker " ++ printf "0x%02x" marker++getString :: Int -> Get PackStream+getString n = String . T.decodeUtf8 <$> getByteString n++getList :: Int -> Get PackStream+getList n = List . V.fromList <$> replicateM n getPackStream++getMap :: Int -> Get PackStream+getMap n = Map . HM.fromList <$> replicateM n getPair+ where+ getPair = (,) <$> getPackStream <*> getPackStream++getStruct :: Int -> Get PackStream+getStruct n = Struct <$> getWord8 <*> replicateM n getPackStream++putPackStream :: Putter PackStream++putPackStream Null = putWord8 0xc0++putPackStream (Float d) = putWord8 0xc1 >> putFloat64be d++putPackStream (Bool False) = putWord8 0xc2+putPackStream (Bool True) = putWord8 0xc3++putPackStream (Int i)+ | -0x10 <= i && i < 0x80 = putWord8 (fromIntegral i)+ | -0x80 <= i && i < 0x80 = putWord8 0xc8 >> putWord8 (fromIntegral i)+ | -0x8000 <= i && i < 0x8000 = putWord8 0xc9 >> putWord16be (fromIntegral i)+ | -0x80000000 <= i && i < 0x80000000 = putWord8 0xca >> putWord32be (fromIntegral i)+ | otherwise = putWord8 0xcb >> putWord64be (fromIntegral i)++putPackStream (String t) = do+ let size = T.length t+ if | size < 0x10 -> putWord8 (0x80 + fromIntegral size)+ | size < 0x100 -> putWord8 0xd0 >> putWord8 (fromIntegral size)+ | size < 0x10000 -> putWord8 0xd1 >> putWord16be (fromIntegral size)+ | size < 0x100000000 -> putWord8 0xd2 >> putWord16be (fromIntegral size)+ | otherwise -> fail "String too long"+ putByteString $ T.encodeUtf8 t++putPackStream (List xs) = do+ let size = V.length xs+ if | size < 0x10 -> putWord8 (0x90 + fromIntegral size)+ | size < 0x100 -> putWord8 0xd4 >> putWord8 (fromIntegral size)+ | size < 0x10000 -> putWord8 0xd5 >> putWord16be (fromIntegral size)+ | size < 0x100000000 -> putWord8 0xd6 >> putWord16be (fromIntegral size)+ | otherwise -> fail "List too long"+ mapM_ putPackStream xs++putPackStream (Map m) = do+ let size = HM.size m+ if | size < 0x10 -> putWord8 (0xa0 + fromIntegral size)+ | size < 0x100 -> putWord8 0xd8 >> putWord8 (fromIntegral size)+ | size < 0x10000 -> putWord8 0xd9 >> putWord16be (fromIntegral size)+ | size < 0x100000000 -> putWord8 0xda >> putWord16be (fromIntegral size)+ | otherwise -> fail "Map too large"+ mapM_ (uncurry putPair) (HM.toList m)+ where+ putPair k v = putPackStream k >> putPackStream v++putPackStream (Struct sig fs) = do+ let size = length fs+ if | size < 0x10 -> putWord8 (0xb0 + fromIntegral size)+ | size < 0x100 -> putWord8 0xdc >> putWord8 (fromIntegral size)+ | size < 0x10000 -> putWord8 0xdd >> putWord16be (fromIntegral size)+ | otherwise -> fail "Structure too big"+ putWord8 sig+ mapM_ putPackStream fs++pretty :: PackStream -> Text+pretty = prettyStruct genericStructName++prettyStruct :: (Word8 -> Text) -> PackStream -> Text+prettyStruct _ Null = "null"+prettyStruct _ (Bool True) = "true"+prettyStruct _ (Bool False) = "false"+prettyStruct _ (Int i) = T.pack (show i)+prettyStruct _ (Float d) = T.pack (show d)+prettyStruct _ (String t) = "\"" <> t <> "\""+prettyStruct _ (List xs) = "[" <> T.intercalate ", " (pretty <$> V.toList xs) <> "]"+prettyStruct _ (Map ps) = "{" <> T.intercalate ", " (fmap (\(k, v) -> pretty k <> ": " <> pretty v) (HM.toList ps)) <> "}"+prettyStruct sn (Struct s fs) = sn s <> "{" <> T.intercalate ", " (pretty <$> fs) <> "}"++genericStructName :: Word8 -> Text+genericStructName n = "Struct(signature=" <> T.pack (printf "0x%02x" n) <> ")"++(.=) :: ToPackStream a => Text -> a -> (PackStream, PackStream)+k .= v = (String k, toPackStream v)++(.:) :: FromPackStream a => HM.HashMap PackStream PackStream -> Text -> Parser a+m .: k = maybe (error "Expected Key missing in map") parsePackStream (HM.lookup (String k) m)++(.:?) :: FromPackStream a => HM.HashMap PackStream PackStream -> Text -> Parser (Maybe a)+m .:? k = maybe (return Nothing) (fmap Just . parsePackStream) (HM.lookup (String k) m)++(.!=) :: Parser (Maybe a) -> a -> Parser a+p .!= d = do+ ma <- p+ maybe (return d) return ma
src/Database/Bolt/Exception.hs view
@@ -1,39 +1,39 @@-module Database.Bolt.Exception - ( internalErr - , transportErr - , protocolErr - , authFail - , reqFail - , reqIgnore - ) where - -import Control.Exception -import Data.Text (Text) - -data BoltException = AuthenticationFailure Text - | RequestFailure Text - | RequestIgnored Text - | InternalError Text - | TransportError Text - | ProtocolError Text - deriving (Show) - -instance Exception BoltException - -authFail :: Text -> IO a -authFail = throwIO . AuthenticationFailure - -reqFail :: Text -> IO a -reqFail = throwIO . RequestFailure - -reqIgnore :: Text -> IO a -reqIgnore = throwIO . RequestIgnored - -internalErr :: Text -> IO a -internalErr = throwIO . InternalError - -transportErr :: Text -> IO a -transportErr = throwIO . TransportError - -protocolErr :: Text -> IO a -protocolErr = throwIO . ProtocolError +module Database.Bolt.Exception+ ( internalErr+ , transportErr+ , protocolErr+ , authFail+ , reqFail+ , reqIgnore+ ) where++import Control.Exception+import Data.Text (Text)++data BoltException = AuthenticationFailure Text+ | RequestFailure Text+ | RequestIgnored Text+ | InternalError Text+ | TransportError Text+ | ProtocolError Text+ deriving (Show)++instance Exception BoltException++authFail :: Text -> IO a+authFail = throwIO . AuthenticationFailure++reqFail :: Text -> IO a+reqFail = throwIO . RequestFailure++reqIgnore :: Text -> IO a+reqIgnore = throwIO . RequestIgnored++internalErr :: Text -> IO a+internalErr = throwIO . InternalError++transportErr :: Text -> IO a+transportErr = throwIO . TransportError++protocolErr :: Text -> IO a+protocolErr = throwIO . ProtocolError
src/Database/Bolt/Protocol/Ver1.hs view
@@ -1,29 +1,29 @@-{-# LANGUAGE OverloadedStrings #-} - -module Database.Bolt.Protocol.Ver1 - ( init - , exec - , AuthToken(..) - , open - ) where - -import Prelude hiding (init) -import Control.Monad - -import Database.Bolt.Exception -import Database.Bolt.Protocol.Ver1.Message (AuthToken(..)) -import Database.Bolt.Protocol.Ver1.Request (init, exec) -import Database.Bolt.Protocol.Ver1.Types -import Database.Bolt.Transport - -useragent :: UserAgent -useragent = "haskell-bolt/0.0" - -open :: Transport t => (a -> IO t) -> a -> AuthToken -> IO t -open c a auth = do - conn <- c a - agreed <- handshake conn (OfferProtocols 1 noProto noProto noProto) - unless (agreed == 1) $ - protocolErr "Can't negotiate protocol version" - init conn useragent auth - return conn +{-# LANGUAGE OverloadedStrings #-}++module Database.Bolt.Protocol.Ver1+ ( init+ , exec+ , AuthToken(..)+ , open+ ) where++import Prelude hiding (init)+import Control.Monad++import Database.Bolt.Exception+import Database.Bolt.Protocol.Ver1.Message (AuthToken(..))+import Database.Bolt.Protocol.Ver1.Request (init, exec)+import Database.Bolt.Protocol.Ver1.Types+import Database.Bolt.Transport++useragent :: UserAgent+useragent = "haskell-bolt/0.0"++open :: Transport t => (a -> IO t) -> a -> AuthToken -> IO t+open c a auth = do+ conn <- c a+ agreed <- handshake conn (OfferProtocols 1 noProto noProto noProto)+ unless (agreed == 1) $+ protocolErr "Can't negotiate protocol version"+ init conn useragent auth+ return conn
src/Database/Bolt/Protocol/Ver1/Graph.hs view
@@ -1,82 +1,82 @@-{-# LANGUAGE OverloadedStrings #-} - -module Database.Bolt.Protocol.Ver1.Graph - ( Node(..) - , Relationship(..) - , Path(..) - , UnboundedRelationship(..) - ) -where - -import Data.Int -import Data.PackStream - -import Database.Bolt.Protocol.Ver1.Types - -data Node = Node - { nodeIdentity :: Identity - , nodeLabels :: [Label] - , nodeProperties :: Properties - } deriving (Show, Eq) - -data Relationship = Relationship - { relIdentity :: Identity - , startNodeIdentity :: Identity - , endNodeIdentity :: Identity - , relType :: Type - , relProperties :: Properties - } deriving (Show, Eq) - -data Path = Path - { pathNodes :: [Node] - , pathRelationships :: [UnboundedRelationship] - , pathSequence :: [Int64] - } deriving (Show, Eq) - -data UnboundedRelationship = UnboundedRelationship - { urelIdentity :: Identity - , urelType :: Type - , urelProperties :: Properties - } deriving (Show, Eq) - -instance ToPackStream Node where - toPackStream (Node nodeid labels props) = Struct 0x4e [toPackStream nodeid, toPackStream labels, toPackStream props] - -instance FromPackStream Node where - parsePackStream s = do - struct <- parsePackStream s - case struct of - (Struct 0x4e [nodeid, labels, props]) -> Node <$> parsePackStream nodeid <*> parsePackStream labels <*> parsePackStream props - _ -> error "Invalid Node" - -instance ToPackStream Relationship where - toPackStream (Relationship relid start end ty props) = Struct 0x52 [ toPackStream relid, toPackStream start, toPackStream end - , toPackStream ty, toPackStream props ] - -instance FromPackStream Relationship where - parsePackStream s = do - struct <- parsePackStream s - case struct of - (Struct 0x52 [relid, start, end, ty, props]) -> Relationship <$> parsePackStream relid <*> parsePackStream start <*> parsePackStream end - <*> parsePackStream ty <*> parsePackStream props - _ -> error "Invalid Relationship" - -instance ToPackStream Path where - toPackStream (Path nodes rels seqn) = Struct 0x50 [ toPackStream nodes, toPackStream rels, toPackStream seqn] - -instance FromPackStream Path where - parsePackStream s = do - struct <- parsePackStream s - case struct of - (Struct 0x50 [nodes, rels, seqn]) -> Path <$> parsePackStream nodes <*> parsePackStream rels <*> parsePackStream seqn - _ -> error "Invalid Path" - -instance ToPackStream UnboundedRelationship where - toPackStream (UnboundedRelationship relid ty props) = Struct 0x72 [toPackStream relid, toPackStream ty, toPackStream props] - -instance FromPackStream UnboundedRelationship where - parsePackStream s = do - struct <- parsePackStream s - case struct of - (Struct 0x72 [relid, ty, props]) -> UnboundedRelationship <$> parsePackStream relid <*> parsePackStream ty <*> parsePackStream props - _ -> error "Invalid UnboundedRelationship" +{-# LANGUAGE OverloadedStrings #-}++module Database.Bolt.Protocol.Ver1.Graph+ ( Node(..)+ , Relationship(..)+ , Path(..)+ , UnboundedRelationship(..)+ )+where++import Data.Int+import Data.PackStream++import Database.Bolt.Protocol.Ver1.Types++data Node = Node+ { nodeIdentity :: Identity+ , nodeLabels :: [Label]+ , nodeProperties :: Properties+ } deriving (Show, Eq)++data Relationship = Relationship+ { relIdentity :: Identity+ , startNodeIdentity :: Identity+ , endNodeIdentity :: Identity+ , relType :: Type+ , relProperties :: Properties+ } deriving (Show, Eq)++data Path = Path+ { pathNodes :: [Node]+ , pathRelationships :: [UnboundedRelationship]+ , pathSequence :: [Int64]+ } deriving (Show, Eq)++data UnboundedRelationship = UnboundedRelationship+ { urelIdentity :: Identity+ , urelType :: Type+ , urelProperties :: Properties+ } deriving (Show, Eq)++instance ToPackStream Node where+ toPackStream (Node nodeid labels props) = Struct 0x4e [toPackStream nodeid, toPackStream labels, toPackStream props]++instance FromPackStream Node where+ parsePackStream s = do+ struct <- parsePackStream s+ case struct of+ (Struct 0x4e [nodeid, labels, props]) -> Node <$> parsePackStream nodeid <*> parsePackStream labels <*> parsePackStream props+ _ -> error "Invalid Node"++instance ToPackStream Relationship where+ toPackStream (Relationship relid start end ty props) = Struct 0x52 [ toPackStream relid, toPackStream start, toPackStream end+ , toPackStream ty, toPackStream props ]++instance FromPackStream Relationship where+ parsePackStream s = do+ struct <- parsePackStream s+ case struct of+ (Struct 0x52 [relid, start, end, ty, props]) -> Relationship <$> parsePackStream relid <*> parsePackStream start <*> parsePackStream end+ <*> parsePackStream ty <*> parsePackStream props+ _ -> error "Invalid Relationship"++instance ToPackStream Path where+ toPackStream (Path nodes rels seqn) = Struct 0x50 [ toPackStream nodes, toPackStream rels, toPackStream seqn]++instance FromPackStream Path where+ parsePackStream s = do+ struct <- parsePackStream s+ case struct of+ (Struct 0x50 [nodes, rels, seqn]) -> Path <$> parsePackStream nodes <*> parsePackStream rels <*> parsePackStream seqn+ _ -> error "Invalid Path"++instance ToPackStream UnboundedRelationship where+ toPackStream (UnboundedRelationship relid ty props) = Struct 0x72 [toPackStream relid, toPackStream ty, toPackStream props]++instance FromPackStream UnboundedRelationship where+ parsePackStream s = do+ struct <- parsePackStream s+ case struct of+ (Struct 0x72 [relid, ty, props]) -> UnboundedRelationship <$> parsePackStream relid <*> parsePackStream ty <*> parsePackStream props+ _ -> error "Invalid UnboundedRelationship"
src/Database/Bolt/Protocol/Ver1/Message.hs view
@@ -1,77 +1,77 @@-{-# LANGUAGE OverloadedStrings #-} - -module Database.Bolt.Protocol.Ver1.Message - ( Message(..) - , AuthToken(..) - ) -where - -import qualified Data.HashMap.Strict as HM -import Data.PackStream -import Data.Text (Text) - -import Database.Bolt.Protocol.Ver1.Types - -data Message = Init UserAgent AuthToken - | AckFailure - | Reset - | Run Statement Parameters - | DiscardAll - | PullAll - | Success Metadata - | Ignored Metadata - | Failure Metadata - | Record Record - deriving (Show) - -instance ToPackStream Message where - toPackStream (Init useragent authtoken) = Struct 0x01 [toPackStream useragent, toPackStream authtoken] - toPackStream AckFailure = Struct 0x0e [] - toPackStream Reset = Struct 0x0f [] - toPackStream (Run stmt params) = Struct 0x10 [toPackStream stmt, toPackStream params] - toPackStream DiscardAll = Struct 0x2f [] - toPackStream PullAll = Struct 0x3f [] - toPackStream (Success metadata) = Struct 0x70 [toPackStream metadata] - toPackStream (Ignored metadata) = Struct 0x71 [toPackStream metadata] - toPackStream (Failure metadata) = Struct 0x7e [toPackStream metadata] - toPackStream (Record record) = Struct 0x7f record - -instance FromPackStream Message where - parsePackStream s = do - struct <- parsePackStream s - case struct of - (Struct 0x01 [useragent, authtoken]) -> Init <$> parsePackStream useragent <*> parsePackStream authtoken - (Struct 0x0e []) -> return AckFailure - (Struct 0x0f []) -> return Reset - (Struct 0x10 [stmt, params]) -> Run <$> parsePackStream stmt <*> parsePackStream params - (Struct 0x2f []) -> return DiscardAll - (Struct 0x3f []) -> return PullAll - (Struct 0x70 [metadata]) -> Success <$> parsePackStream metadata - (Struct 0x71 value) -> return $ Record value - (Struct 0x7e [metadata]) -> Ignored <$> parsePackStream metadata - (Struct 0x7f [metadata]) -> Failure <$> parsePackStream metadata - _ -> error "Invalid Message" - -data AuthToken = NoAuth - | Basic Principal Credentials - deriving (Show) - -instance ToPackStream AuthToken where - toPackStream NoAuth = Map $ HM.fromList [ "scheme" .= ("none" :: Text) ] - toPackStream (Basic user pass) = Map $ HM.fromList [ "scheme" .= ("basic" :: Text) - , "principal" .= user - , "credentials" .= pass - ] - -instance FromPackStream AuthToken where - parsePackStream (Map m) = do - scheme <- m .:? "scheme" .!= "none" - parseScheme scheme - where - parseScheme :: Text -> Parser AuthToken - parseScheme "none" = return NoAuth - parseScheme "basic" = Basic <$> m .: "principal" - <*> m .: "credentials" - parseScheme _ = error "Unknown authentication scheme" - - parsePackStream _ = error "AuthToken should be a map" +{-# LANGUAGE OverloadedStrings #-}++module Database.Bolt.Protocol.Ver1.Message+ ( Message(..)+ , AuthToken(..)+ )+where++import qualified Data.HashMap.Strict as HM+import Data.PackStream+import Data.Text (Text)++import Database.Bolt.Protocol.Ver1.Types++data Message = Init UserAgent AuthToken+ | AckFailure+ | Reset+ | Run Statement Parameters+ | DiscardAll+ | PullAll+ | Success Metadata+ | Ignored Metadata+ | Failure Metadata+ | Record Record+ deriving (Show)++instance ToPackStream Message where+ toPackStream (Init useragent authtoken) = Struct 0x01 [toPackStream useragent, toPackStream authtoken]+ toPackStream AckFailure = Struct 0x0e []+ toPackStream Reset = Struct 0x0f []+ toPackStream (Run stmt params) = Struct 0x10 [toPackStream stmt, toPackStream params]+ toPackStream DiscardAll = Struct 0x2f []+ toPackStream PullAll = Struct 0x3f []+ toPackStream (Success metadata) = Struct 0x70 [toPackStream metadata]+ toPackStream (Ignored metadata) = Struct 0x71 [toPackStream metadata]+ toPackStream (Failure metadata) = Struct 0x7e [toPackStream metadata]+ toPackStream (Record record) = Struct 0x7f record++instance FromPackStream Message where+ parsePackStream s = do+ struct <- parsePackStream s+ case struct of+ (Struct 0x01 [useragent, authtoken]) -> Init <$> parsePackStream useragent <*> parsePackStream authtoken+ (Struct 0x0e []) -> return AckFailure+ (Struct 0x0f []) -> return Reset+ (Struct 0x10 [stmt, params]) -> Run <$> parsePackStream stmt <*> parsePackStream params+ (Struct 0x2f []) -> return DiscardAll+ (Struct 0x3f []) -> return PullAll+ (Struct 0x70 [metadata]) -> Success <$> parsePackStream metadata+ (Struct 0x71 value) -> return $ Record value+ (Struct 0x7e [metadata]) -> Ignored <$> parsePackStream metadata+ (Struct 0x7f [metadata]) -> Failure <$> parsePackStream metadata+ _ -> error "Invalid Message"++data AuthToken = NoAuth+ | Basic Principal Credentials+ deriving (Show)++instance ToPackStream AuthToken where+ toPackStream NoAuth = Map $ HM.fromList [ "scheme" .= ("none" :: Text) ]+ toPackStream (Basic user pass) = Map $ HM.fromList [ "scheme" .= ("basic" :: Text)+ , "principal" .= user+ , "credentials" .= pass+ ]++instance FromPackStream AuthToken where+ parsePackStream (Map m) = do+ scheme <- m .:? "scheme" .!= "none"+ parseScheme scheme+ where+ parseScheme :: Text -> Parser AuthToken+ parseScheme "none" = return NoAuth+ parseScheme "basic" = Basic <$> m .: "principal"+ <*> m .: "credentials"+ parseScheme _ = error "Unknown authentication scheme"++ parsePackStream _ = error "AuthToken should be a map"
src/Database/Bolt/Protocol/Ver1/Pretty.hs view
@@ -1,30 +1,30 @@-{-# LANGUAGE OverloadedStrings #-} - -module Database.Bolt.Protocol.Ver1.Pretty - ( pretty - , structName - ) where - -import Data.PackStream (PackStream, genericStructName, prettyStruct) -import Data.Text -import Data.Word - -pretty :: PackStream -> Text -pretty = prettyStruct structName - -structName :: Word8 -> Text -structName 0x01 = "InitMessage" -structName 0x0e = "AckFailureMessage" -structName 0x0f = "ResetMessage" -structName 0x10 = "RunMessage" -structName 0x2f = "DiscardAllMessage" -structName 0x3f = "PullAllMessage" -structName 0x43 = "Node" -structName 0x50 = "Path" -structName 0x52 = "Relationship" -structName 0x70 = "SuccessMessage" -structName 0x71 = "RecordMessage" -structName 0x72 = "UnboundedRelationship" -structName 0x7e = "IgnoredMessage" -structName 0x7f = "FailureMessage" -structName n = genericStructName n +{-# LANGUAGE OverloadedStrings #-}++module Database.Bolt.Protocol.Ver1.Pretty+ ( pretty+ , structName+ ) where++import Data.PackStream (PackStream, genericStructName, prettyStruct)+import Data.Text+import Data.Word++pretty :: PackStream -> Text+pretty = prettyStruct structName++structName :: Word8 -> Text+structName 0x01 = "InitMessage"+structName 0x0e = "AckFailureMessage"+structName 0x0f = "ResetMessage"+structName 0x10 = "RunMessage"+structName 0x2f = "DiscardAllMessage"+structName 0x3f = "PullAllMessage"+structName 0x43 = "Node"+structName 0x50 = "Path"+structName 0x52 = "Relationship"+structName 0x70 = "SuccessMessage"+structName 0x71 = "RecordMessage"+structName 0x72 = "UnboundedRelationship"+structName 0x7e = "IgnoredMessage"+structName 0x7f = "FailureMessage"+structName n = genericStructName n
src/Database/Bolt/Protocol/Ver1/Request.hs view
@@ -1,74 +1,74 @@-{-# LANGUAGE OverloadedStrings #-} - -module Database.Bolt.Protocol.Ver1.Request - ( init - , reset - , discardAll - , pullAll - , run - , exec - ) where - -import Prelude hiding (init) - -import Database.Bolt.Exception -import Database.Bolt.Protocol.Ver1.Message (AuthToken, Message) -import qualified Database.Bolt.Protocol.Ver1.Message as Msg -import Database.Bolt.Protocol.Ver1.Types -import Database.Bolt.Transport -import Database.Bolt.Transport.Message - -data Response = Success [Record] - | Failed - | Ignored - -request :: Transport t => t -> Message -> IO Response -request conn msg = do - sendmsg conn msg - gather [] - where - gather vals = do - reply <- recvmsg conn - case reply of - Msg.Success _meta -> return $ Success (reverse vals) - Msg.Failure _meta -> return Failed - Msg.Ignored _meta -> return Ignored - Msg.Record val -> gather (val : vals) - _ -> protocolErr "Unexpected message in response" - -simple :: Transport t => t -> Message -> IO () -simple conn msg = do - resp <- request conn msg - case resp of - Success [] -> return () - Success _ -> reqFail "Request not expecting records" - Failed -> reqFail "Request failed" - Ignored -> reqIgnore "Request ignored" - -detail :: Transport t => t -> Message -> IO [Record] -detail conn msg = do - resp <- request conn msg - case resp of - Success rs -> return rs - Failed -> reqFail "Request failed" - Ignored -> reqIgnore "Request ignored" - -init :: Transport t => t -> UserAgent -> AuthToken -> IO () -init conn agent auth = simple conn $ Msg.Init agent auth - -reset :: Transport t => t -> IO () -reset conn = simple conn Msg.Reset - -discardAll :: Transport t => t -> IO () -discardAll conn = simple conn Msg.DiscardAll - -pullAll :: Transport t => t -> IO [Record] -pullAll conn = detail conn Msg.PullAll - -run :: Transport t => t -> Statement -> Parameters -> IO () -run conn stmt params = simple conn $ Msg.Run stmt params - -exec :: Transport t => t -> Statement -> Parameters -> IO [Record] -exec conn stmt params = do - run conn stmt params - pullAll conn +{-# LANGUAGE OverloadedStrings #-}++module Database.Bolt.Protocol.Ver1.Request+ ( init+ , reset+ , discardAll+ , pullAll+ , run+ , exec+ ) where++import Prelude hiding (init)++import Database.Bolt.Exception+import Database.Bolt.Protocol.Ver1.Message (AuthToken, Message)+import qualified Database.Bolt.Protocol.Ver1.Message as Msg+import Database.Bolt.Protocol.Ver1.Types+import Database.Bolt.Transport+import Database.Bolt.Transport.Message++data Response = Success [Record]+ | Failed+ | Ignored++request :: Transport t => t -> Message -> IO Response+request conn msg = do+ sendmsg conn msg+ gather []+ where+ gather vals = do+ reply <- recvmsg conn+ case reply of+ Msg.Success _meta -> return $ Success (reverse vals)+ Msg.Failure _meta -> return Failed+ Msg.Ignored _meta -> return Ignored+ Msg.Record val -> gather (val : vals)+ _ -> protocolErr "Unexpected message in response"++simple :: Transport t => t -> Message -> IO ()+simple conn msg = do+ resp <- request conn msg+ case resp of+ Success [] -> return ()+ Success _ -> reqFail "Request not expecting records"+ Failed -> reqFail "Request failed"+ Ignored -> reqIgnore "Request ignored"++detail :: Transport t => t -> Message -> IO [Record]+detail conn msg = do+ resp <- request conn msg+ case resp of+ Success rs -> return rs+ Failed -> reqFail "Request failed"+ Ignored -> reqIgnore "Request ignored"++init :: Transport t => t -> UserAgent -> AuthToken -> IO ()+init conn agent auth = simple conn $ Msg.Init agent auth++reset :: Transport t => t -> IO ()+reset conn = simple conn Msg.Reset++discardAll :: Transport t => t -> IO ()+discardAll conn = simple conn Msg.DiscardAll++pullAll :: Transport t => t -> IO [Record]+pullAll conn = detail conn Msg.PullAll++run :: Transport t => t -> Statement -> Parameters -> IO ()+run conn stmt params = simple conn $ Msg.Run stmt params++exec :: Transport t => t -> Statement -> Parameters -> IO [Record]+exec conn stmt params = do+ run conn stmt params+ pullAll conn
src/Database/Bolt/Protocol/Ver1/Types.hs view
@@ -1,20 +1,20 @@-module Database.Bolt.Protocol.Ver1.Types where - -import Data.Int -import qualified Data.HashMap.Strict as HM -import Data.PackStream -import Data.Text (Text) - -type UserAgent = Text -type Principal = Text -type Credentials = Text -type Statement = Text -type Label = Text -type Type = Text -type Identity = Int64 - -type Object = HM.HashMap Text PackStream -type Parameters = Object -type Properties = Object -type Metadata = Object -type Record = [PackStream] +module Database.Bolt.Protocol.Ver1.Types where++import Data.Int+import qualified Data.HashMap.Strict as HM+import Data.PackStream+import Data.Text (Text)++type UserAgent = Text+type Principal = Text+type Credentials = Text+type Statement = Text+type Label = Text+type Type = Text+type Identity = Int64++type Object = HM.HashMap Text PackStream+type Parameters = Object+type Properties = Object+type Metadata = Object+type Record = [PackStream]
src/Database/Bolt/Transport.hs view
@@ -1,68 +1,68 @@-{-# LANGUAGE OverloadedStrings #-} - -module Database.Bolt.Transport - ( Transport(..) - , put - , get - , getE - , handshake - , BoltProtocol - , OfferProtocols(..) - , noProto - ) where - -import qualified Data.ByteString as BS -import Data.Monoid -import Data.Serialize.Get -import Data.Serialize.Put -import Data.Text as T -import Data.Word - -import Database.Bolt.Exception - --- Transport - -class Transport t where - send :: t -> BS.ByteString -> IO () - recv :: t -> Int -> IO BS.ByteString - close :: t -> IO () - - sendMany :: t -> [BS.ByteString] -> IO () - sendMany conn = mapM_ (send conn) - -put :: Transport t => t -> Put -> IO () -put conn = send conn . runPut - -get :: Transport t => t -> Int -> Get a -> IO a -get conn n g = getE conn n g >>= either bad return - where - bad e = transportErr $ "Bad data received: " <> T.pack e - -getE :: Transport t => t -> Int -> Get a -> IO (Either String a) -getE conn n g = runGet g <$> recv conn n - --- Protocol negotiation - -type BoltProtocol = Word32 - -noProto :: BoltProtocol -noProto = 0 - -data OfferProtocols = OfferProtocols BoltProtocol BoltProtocol BoltProtocol BoltProtocol - deriving (Show, Eq, Ord) - -handshake :: Transport t => t -> OfferProtocols -> IO BoltProtocol -handshake conn offer = do - put conn (gogobolt >> offerProtocols offer) - get conn 4 agreedProtocol - -gogobolt :: Put -gogobolt = mapM_ putWord8 [0x60, 0x60, 0xb0, 0x17] - -offerProtocols :: Putter OfferProtocols -offerProtocols (OfferProtocols p1 p2 p3 p4) = mapM_ offerProtocol [p1, p2, p3, p4] - where - offerProtocol = putWord32be - -agreedProtocol :: Get BoltProtocol -agreedProtocol = getWord32be +{-# LANGUAGE OverloadedStrings #-}++module Database.Bolt.Transport+ ( Transport(..)+ , put+ , get+ , getE+ , handshake+ , BoltProtocol+ , OfferProtocols(..)+ , noProto+ ) where++import qualified Data.ByteString as BS+import Data.Monoid+import Data.Serialize.Get+import Data.Serialize.Put+import Data.Text as T+import Data.Word++import Database.Bolt.Exception++-- Transport++class Transport t where+ send :: t -> BS.ByteString -> IO ()+ recv :: t -> Int -> IO BS.ByteString+ close :: t -> IO ()++ sendMany :: t -> [BS.ByteString] -> IO ()+ sendMany conn = mapM_ (send conn)++put :: Transport t => t -> Put -> IO ()+put conn = send conn . runPut++get :: Transport t => t -> Int -> Get a -> IO a+get conn n g = getE conn n g >>= either bad return+ where+ bad e = transportErr $ "Bad data received: " <> T.pack e++getE :: Transport t => t -> Int -> Get a -> IO (Either String a)+getE conn n g = runGet g <$> recv conn n++-- Protocol negotiation++type BoltProtocol = Word32++noProto :: BoltProtocol+noProto = 0++data OfferProtocols = OfferProtocols BoltProtocol BoltProtocol BoltProtocol BoltProtocol+ deriving (Show, Eq, Ord)++handshake :: Transport t => t -> OfferProtocols -> IO BoltProtocol+handshake conn offer = do+ put conn (gogobolt >> offerProtocols offer)+ get conn 4 agreedProtocol++gogobolt :: Put+gogobolt = mapM_ putWord8 [0x60, 0x60, 0xb0, 0x17]++offerProtocols :: Putter OfferProtocols+offerProtocols (OfferProtocols p1 p2 p3 p4) = mapM_ offerProtocol [p1, p2, p3, p4]+ where+ offerProtocol = putWord32be++agreedProtocol :: Get BoltProtocol+agreedProtocol = getWord32be
src/Database/Bolt/Transport/Chunked.hs view
@@ -1,73 +1,73 @@-{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} - -module Database.Bolt.Transport.Chunked - ( send - , recv - , put - , get - ) where - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as LBS -import Data.Monoid -import Data.Serialize.Get -import Data.Serialize.Put -import qualified Data.Text as T - -import Database.Bolt.Exception -import Database.Bolt.Transport (Transport) -import qualified Database.Bolt.Transport as Trans - --------- Chunked I/O -------- - -send :: Transport t => t -> LBS.ByteString -> IO () -send conn lbs = Trans.put conn $ mapM_ putChunks (LBS.toChunks lbs) >> done - where - maxChunk = 0xffff - - done = putWord16be 0 - - putChunks bs = do - let sz = BS.length bs - if | sz == 0 -> return () - | sz > maxChunk -> split bs - | otherwise -> sendChunk bs - - split bs = do - let (bs1, bs2) = BS.splitAt maxChunk bs - sendChunk bs1 - putChunks bs2 - - sendChunk bs = do - putWord16be $ fromIntegral $ BS.length bs - putByteString bs - -recv :: Transport t => t -> IO LBS.ByteString -recv conn = LBS.fromChunks <$> getChunks - where - getChunks = do - size <- Trans.get conn 2 getWord16be - case size of - 0 -> return [] - csz -> do bs <- getChunk csz - bs' <- getChunks - return (bs ++ bs') - - getChunk n = do - bs <- Trans.recv conn (fromIntegral n) - let sz = fromIntegral $ BS.length bs - if | sz == 0 -> transportErr "Unexpected end of stream" - | sz < n -> do bs' <- getChunk (n - sz) - return (bs : bs') - | otherwise -> return [bs] - -put :: Transport t => t -> Put -> IO () -put conn = send conn . runPutLazy - -get :: Transport t => t -> Get a -> IO a -get conn g = do - lbs <- recv conn - case runGetLazy g lbs of - Left err -> transportErr $ "Unexpected data received: " <> T.pack err - Right a -> return a +{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.Bolt.Transport.Chunked+ ( send+ , recv+ , put+ , get+ ) where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.Monoid+import Data.Serialize.Get+import Data.Serialize.Put+import qualified Data.Text as T++import Database.Bolt.Exception+import Database.Bolt.Transport (Transport)+import qualified Database.Bolt.Transport as Trans++-------- Chunked I/O --------++send :: Transport t => t -> LBS.ByteString -> IO ()+send conn lbs = Trans.put conn $ mapM_ putChunks (LBS.toChunks lbs) >> done+ where+ maxChunk = 0xffff++ done = putWord16be 0++ putChunks bs = do+ let sz = BS.length bs+ if | sz == 0 -> return ()+ | sz > maxChunk -> split bs+ | otherwise -> sendChunk bs++ split bs = do+ let (bs1, bs2) = BS.splitAt maxChunk bs+ sendChunk bs1+ putChunks bs2++ sendChunk bs = do+ putWord16be $ fromIntegral $ BS.length bs+ putByteString bs++recv :: Transport t => t -> IO LBS.ByteString+recv conn = LBS.fromChunks <$> getChunks+ where+ getChunks = do+ size <- Trans.get conn 2 getWord16be+ case size of+ 0 -> return []+ csz -> do bs <- getChunk csz+ bs' <- getChunks+ return (bs ++ bs')++ getChunk n = do+ bs <- Trans.recv conn (fromIntegral n)+ let sz = fromIntegral $ BS.length bs+ if | sz == 0 -> transportErr "Unexpected end of stream"+ | sz < n -> do bs' <- getChunk (n - sz)+ return (bs : bs')+ | otherwise -> return [bs]++put :: Transport t => t -> Put -> IO ()+put conn = send conn . runPutLazy++get :: Transport t => t -> Get a -> IO a+get conn g = do+ lbs <- recv conn+ case runGetLazy g lbs of+ Left err -> transportErr $ "Unexpected data received: " <> T.pack err+ Right a -> return a
src/Database/Bolt/Transport/Message.hs view
@@ -1,26 +1,26 @@-{-# LANGUAGE OverloadedStrings #-} - -module Database.Bolt.Transport.Message - ( sendmsg - , recvmsg - ) where - -import Data.Monoid -import Data.PackStream -import qualified Data.Text as T - -import Database.Bolt.Exception -import Database.Bolt.Transport (Transport) -import qualified Database.Bolt.Transport.Chunked as Chunked - --------- Message I/O -------- - -sendmsg :: (Transport t, ToPackStream a) => t -> a -> IO () -sendmsg conn = Chunked.put conn . pack - -recvmsg :: (Transport t, FromPackStream a) => t -> IO a -recvmsg conn = do - ma <- Chunked.get conn unpack - case ma of - Left e -> transportErr $ "Couldn't unpack received data: " <> T.pack e - Right a -> return a +{-# LANGUAGE OverloadedStrings #-}++module Database.Bolt.Transport.Message+ ( sendmsg+ , recvmsg+ ) where++import Data.Monoid+import Data.PackStream+import qualified Data.Text as T++import Database.Bolt.Exception+import Database.Bolt.Transport (Transport)+import qualified Database.Bolt.Transport.Chunked as Chunked++-------- Message I/O --------++sendmsg :: (Transport t, ToPackStream a) => t -> a -> IO ()+sendmsg conn = Chunked.put conn . pack++recvmsg :: (Transport t, FromPackStream a) => t -> IO a+recvmsg conn = do+ ma <- Chunked.get conn unpack+ case ma of+ Left e -> transportErr $ "Couldn't unpack received data: " <> T.pack e+ Right a -> return a
src/Database/Bolt/Transport/Socket.hs view
@@ -1,79 +1,79 @@-{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Database.Bolt.Transport.Socket - ( ConnInfo - , hostserv - , uri - - , Connection - , connect - , close - - , send - , sendMany - , recv - , put - , get - ) where - -import Control.Exception -import Control.Monad -import Data.Monoid -import qualified Data.Text as T -import qualified Network.Socket as Net -import qualified Network.Socket.ByteString as NetBS -import Network.URI - -import Database.Bolt.Exception -import Database.Bolt.Transport - --------- Socket -------- - -newtype Connection = Connection { connSocket :: Net.Socket } - -instance Transport Connection where - send = NetBS.sendAll . connSocket - sendMany = NetBS.sendMany . connSocket - recv = NetBS.recv . connSocket - close = Net.close . connSocket - -data ConnInfo = ConnInfo - { connHost :: Net.HostName - , connService :: Net.ServiceName - } deriving (Show, Read, Eq, Ord) - --------- Connections -------- - --- Create ConnInfo from a host and service name -hostserv :: String -> String -> ConnInfo -hostserv = ConnInfo - --- Create ConnInfo from a bolt URI -uri :: String -> Maybe ConnInfo -uri uristr = do - uri' <- parseAbsoluteURI uristr - guard $ uriScheme uri' == "bolt" - auth <- uriAuthority uri' - guard $ uriUserInfo auth == "" - guard $ uriPath uri' == "" - guard $ uriQuery uri' == "" - guard $ uriFragment uri' == "" - return ConnInfo { connHost = uriRegName auth - , connService = uriPort auth } - --- Connect using ConnInfo and return a handle -connect :: ConnInfo -> IO Connection -connect ConnInfo{..} = do - let hints = Net.defaultHints { Net.addrSocketType = Net.Stream } - addrs <- Net.getAddrInfo (Just hints) (Just connHost) (Just connService) - connectAny addrs - where - connectAny [] = transportErr $ "Unable to connect to " <> T.pack connHost <> ":" <> T.pack connService - connectAny (addr:addrs) = doConnect addr `catch` (\ (_ :: IOException) -> connectAny addrs) - - doConnect addr = do - sock <- Net.socket (Net.addrFamily addr) (Net.addrSocketType addr) (Net.addrProtocol addr) - Net.connect sock (Net.addrAddress addr) `onException` Net.close sock - return $ Connection sock +{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Database.Bolt.Transport.Socket+ ( ConnInfo+ , hostserv+ , uri++ , Connection+ , connect+ , close++ , send+ , sendMany+ , recv+ , put+ , get+ ) where++import Control.Exception+import Control.Monad+import Data.Monoid+import qualified Data.Text as T+import qualified Network.Socket as Net+import qualified Network.Socket.ByteString as NetBS+import Network.URI++import Database.Bolt.Exception+import Database.Bolt.Transport++-------- Socket --------++newtype Connection = Connection { connSocket :: Net.Socket }++instance Transport Connection where+ send = NetBS.sendAll . connSocket+ sendMany = NetBS.sendMany . connSocket+ recv = NetBS.recv . connSocket+ close = Net.close . connSocket++data ConnInfo = ConnInfo+ { connHost :: Net.HostName+ , connService :: Net.ServiceName+ } deriving (Show, Read, Eq, Ord)++-------- Connections --------++-- Create ConnInfo from a host and service name+hostserv :: String -> String -> ConnInfo+hostserv = ConnInfo++-- Create ConnInfo from a bolt URI+uri :: String -> Maybe ConnInfo+uri uristr = do+ uri' <- parseAbsoluteURI uristr+ guard $ uriScheme uri' == "bolt"+ auth <- uriAuthority uri'+ guard $ uriUserInfo auth == ""+ guard $ uriPath uri' == ""+ guard $ uriQuery uri' == ""+ guard $ uriFragment uri' == ""+ return ConnInfo { connHost = uriRegName auth+ , connService = uriPort auth }++-- Connect using ConnInfo and return a handle+connect :: ConnInfo -> IO Connection+connect ConnInfo{..} = do+ let hints = Net.defaultHints { Net.addrSocketType = Net.Stream }+ addrs <- Net.getAddrInfo (Just hints) (Just connHost) (Just connService)+ connectAny addrs+ where+ connectAny [] = transportErr $ "Unable to connect to " <> T.pack connHost <> ":" <> T.pack connService+ connectAny (addr:addrs) = doConnect addr `catch` (\ (_ :: IOException) -> connectAny addrs)++ doConnect addr = do+ sock <- Net.socket (Net.addrFamily addr) (Net.addrSocketType addr) (Net.addrProtocol addr)+ Net.connect sock (Net.addrAddress addr) `onException` Net.close sock+ return $ Connection sock