diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,15 +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, . +# 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, . diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/bolt.cabal b/bolt.cabal --- a/bolt.cabal +++ b/bolt.cabal @@ -1,64 +1,67 @@ -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. -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 +name: bolt +version: 0.2.0.0 +synopsis: Bolt driver for Neo4j +description: + A Bolt driver to access Neo4j databases using + the Bolt Protocol, Version 1. +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.Transaction + , 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 + , scientific >= 0.3.0 && < 0.4 + , text >= 1.2.2 && < 1.3 + , transformers >= 0.5.0 && < 0.6 + , 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 diff --git a/src/Data/PackStream.hs b/src/Data/PackStream.hs --- a/src/Data/PackStream.hs +++ b/src/Data/PackStream.hs @@ -1,293 +1,309 @@ -{-# 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 + , parsefail + , 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.Scientific +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 + +parsefail :: a -> Either a b +parsefail = Left + +class FromPackStream a where + parsePackStream :: PackStream -> Parser a + +instance FromPackStream PackStream where + parsePackStream = return + +instance FromPackStream Bool where + parsePackStream (Bool b) = return b + parsePackStream _ = parsefail "Expecting Bool" + +instance FromPackStream Int64 where + parsePackStream (Int i) = return i + parsePackStream _ = parsefail "Expecting Int" + +instance FromPackStream Double where + parsePackStream (Float d) = return d + parsePackStream _ = parsefail "Expecting Float" + +instance FromPackStream Text where + parsePackStream (String t) = return t + parsePackStream _ = parsefail "Expecting String" + +instance FromPackStream a => FromPackStream [a] where + parsePackStream (List l) = mapM parsePackStream (V.toList l) + parsePackStream _ = parsefail "Expecting List" + +instance FromPackStream a => FromPackStream (V.Vector a) where + parsePackStream (List l) = mapM parsePackStream l + parsePackStream _ = parsefail "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 _ = parsefail "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 _ = parsefail "Expecting Map" + +instance FromPackStream Scientific where + parsePackStream (Int i) = return $ fromIntegral i + parsePackStream (Float f) = return $ fromFloatDigits f + parsePackStream _ = parsefail "Expecting Int or Float" + +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 + +instance ToPackStream Scientific where + toPackStream s = + case Data.Scientific.floatingOrInteger s of + Left rf -> Float rf + Right i -> Int i + +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 (parsefail "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 diff --git a/src/Database/Bolt/Exception.hs b/src/Database/Bolt/Exception.hs --- a/src/Database/Bolt/Exception.hs +++ b/src/Database/Bolt/Exception.hs @@ -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 diff --git a/src/Database/Bolt/Protocol/Ver1.hs b/src/Database/Bolt/Protocol/Ver1.hs --- a/src/Database/Bolt/Protocol/Ver1.hs +++ b/src/Database/Bolt/Protocol/Ver1.hs @@ -1,29 +1,37 @@ -{-# 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 + , Transaction + , runTransaction + , cypher + , object + , (#=) + , (#:) + , (#:?) + ) where + +import Control.Monad +import Prelude hiding (init) + +import Database.Bolt.Exception +import Database.Bolt.Protocol.Ver1.Message (AuthToken (..)) +import Database.Bolt.Protocol.Ver1.Request (exec, init) +import Database.Bolt.Protocol.Ver1.Transaction (Transaction, cypher, runTransaction) +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 diff --git a/src/Database/Bolt/Protocol/Ver1/Graph.hs b/src/Database/Bolt/Protocol/Ver1/Graph.hs --- a/src/Database/Bolt/Protocol/Ver1/Graph.hs +++ b/src/Database/Bolt/Protocol/Ver1/Graph.hs @@ -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" diff --git a/src/Database/Bolt/Protocol/Ver1/Message.hs b/src/Database/Bolt/Protocol/Ver1/Message.hs --- a/src/Database/Bolt/Protocol/Ver1/Message.hs +++ b/src/Database/Bolt/Protocol/Ver1/Message.hs @@ -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 [toPackStream 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 [record]) -> Record <$> parsePackStream record + (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" diff --git a/src/Database/Bolt/Protocol/Ver1/Pretty.hs b/src/Database/Bolt/Protocol/Ver1/Pretty.hs --- a/src/Database/Bolt/Protocol/Ver1/Pretty.hs +++ b/src/Database/Bolt/Protocol/Ver1/Pretty.hs @@ -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 0x4e = "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 diff --git a/src/Database/Bolt/Protocol/Ver1/Request.hs b/src/Database/Bolt/Protocol/Ver1/Request.hs --- a/src/Database/Bolt/Protocol/Ver1/Request.hs +++ b/src/Database/Bolt/Protocol/Ver1/Request.hs @@ -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 diff --git a/src/Database/Bolt/Protocol/Ver1/Transaction.hs b/src/Database/Bolt/Protocol/Ver1/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Protocol/Ver1/Transaction.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +module Database.Bolt.Protocol.Ver1.Transaction + ( Transaction + , runTransaction + , cypher + ) where + +import Control.Exception +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +-- import Database.Bolt.Exception +import qualified Data.HashMap.Strict as HM +import Database.Bolt.Protocol.Ver1.Request +import Database.Bolt.Protocol.Ver1.Types +import Database.Bolt.Transport + +newtype Tran t a = Tran { unTransaction :: ReaderT t IO a } + deriving (Functor, Applicative, Monad, MonadIO) + +type Transaction a = forall t. Transport t => Tran t a + +runTransaction :: Transport t => t -> Transaction a -> IO a +runTransaction conn t = do + _ <- exec conn "BEGIN" HM.empty + r <- try $ runReaderT (unTransaction t) conn + case r of + Left (SomeException ex) -> do + _ <- exec conn "ROLLBACK" HM.empty + throwIO ex + Right a -> do + _ <- exec conn "COMMIT" HM.empty + return a + +getConn :: Tran t t +getConn = Tran ask + +cypher :: Statement -> Parameters -> Transaction [Record] +cypher stmt params = do + conn <- getConn + liftIO $ exec conn stmt params diff --git a/src/Database/Bolt/Protocol/Ver1/Types.hs b/src/Database/Bolt/Protocol/Ver1/Types.hs --- a/src/Database/Bolt/Protocol/Ver1/Types.hs +++ b/src/Database/Bolt/Protocol/Ver1/Types.hs @@ -1,20 +1,33 @@ -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 Data.Hashable +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] + +object :: (Eq k, Hashable k) => [(k, v)] -> HM.HashMap k v +object = HM.fromList + +(#=) :: ToPackStream a => Text -> a -> (Text, PackStream) +k #= v = (k, toPackStream v) + +(#:) :: FromPackStream a => Object -> Text -> Parser a +m #: k = maybe (parsefail "Expected Key missing in object") parsePackStream (HM.lookup k m) + +(#:?) :: FromPackStream a => Object -> Text -> Parser (Maybe a) +m #:? k = maybe (return Nothing) (fmap Just . parsePackStream) (HM.lookup k m) diff --git a/src/Database/Bolt/Transport.hs b/src/Database/Bolt/Transport.hs --- a/src/Database/Bolt/Transport.hs +++ b/src/Database/Bolt/Transport.hs @@ -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 diff --git a/src/Database/Bolt/Transport/Chunked.hs b/src/Database/Bolt/Transport/Chunked.hs --- a/src/Database/Bolt/Transport/Chunked.hs +++ b/src/Database/Bolt/Transport/Chunked.hs @@ -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 diff --git a/src/Database/Bolt/Transport/Message.hs b/src/Database/Bolt/Transport/Message.hs --- a/src/Database/Bolt/Transport/Message.hs +++ b/src/Database/Bolt/Transport/Message.hs @@ -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 diff --git a/src/Database/Bolt/Transport/Socket.hs b/src/Database/Bolt/Transport/Socket.hs --- a/src/Database/Bolt/Transport/Socket.hs +++ b/src/Database/Bolt/Transport/Socket.hs @@ -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