diff --git a/Changelog.md b/Changelog.md new file mode 100644 --- /dev/null +++ b/Changelog.md @@ -0,0 +1,5 @@ +2025-07-18 + +- Update upper bounds for all dependencies. +- Tested with GHC 9.10.2. +- Use nix flake for development. 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,75 +1,87 @@ -name: bolt -version: 0.3.1.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 - , Database.Bolt.Types - build-depends: base >= 4.8 && < 5 - , bifunctors >= 5.2 && < 5.5 - , bytestring >= 0.10.6 && < 0.11 - , cereal >= 0.5.4 && < 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 - , bytestring >= 0.10.6 && < 0.11 - , cereal >= 0.5.4 && < 0.6 - , text >= 1.2.2 && < 1.3 - , unordered-containers >= 0.2.7 && < 0.3 - , vector >= 0.11.0 && < 0.12 - , tasty - , tasty-quickcheck - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall - default-language: Haskell2010 - -source-repository head - type: git - location: https://github.com/bflyblue/bolt +cabal-version: 3.8 +name: bolt +version: 0.3.2.0 +synopsis: Bolt driver for Neo4j +description: A Bolt driver to access Neo4j databases using the Bolt Protocol. +homepage: https://github.com/bflyblue/bolt#readme +license: BSD-3-Clause +license-file: LICENSE +author: Shaun Sharples +maintainer: shaun.sharples@gmail.com +stability: experimental +copyright: (c) 2025 Shaun Sharples +category: Database +build-type: Simple +extra-source-files: README.md +extra-doc-files: Changelog.md + +common common + ghc-options: -Wall + default-language: GHC2021 + +library + import: common + hs-source-dirs: lib + other-extensions: + DeriveAnyClass + DeriveGeneric + MultiWayIf + OverloadedStrings + RecordWildCards + + -- cabal-gild: discover lib/ + 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 + Database.Bolt.Types + + build-depends: + base >=4.8 && <5, + bifunctors >=5.2 && <5.7, + bytestring >=0.10.6 && <0.13, + cereal >=0.5.4 && <0.6, + containers >=0.5.6 && <0.8, + hashable >=1.2.4 && <1.5, + network >=2.6.2 && <3.3, + network-uri >=2.6.1 && <2.7, + scientific >=0.3.0 && <0.4, + text >=1.2.2 && <1.3, + transformers >=0.5.0 && <0.7, + unordered-containers >=0.2.7 && <0.3, + vector >=0.11.0 && <0.14, + +test-suite test-bolt + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: + base, + bolt, + bytestring >=0.10.6 && <0.13, + cereal >=0.5.4 && <0.6, + tasty, + tasty-quickcheck, + text >=1.2.2 && <1.3, + unordered-containers >=0.2.7 && <0.3, + vector >=0.11.0 && <0.14, + + ghc-options: + -threaded + -rtsopts + -with-rtsopts=-N + +source-repository head + type: git + location: https://github.com/bflyblue/bolt diff --git a/lib/Data/PackStream.hs b/lib/Data/PackStream.hs new file mode 100644 --- /dev/null +++ b/lib/Data/PackStream.hs @@ -0,0 +1,300 @@ +{-# 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.ByteString qualified as BS +import Data.HashMap.Strict qualified as HM +import Data.Hashable +import Data.Int +import Data.Map.Strict qualified 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 Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Vector qualified 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 <$> getInt8 + | marker == 0xc9 -> Int . fromIntegral <$> getInt16be + | marker == 0xca -> Int . fromIntegral <$> getInt32be + | marker == 0xcb -> Int . fromIntegral <$> getInt64be + | 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 = putInt8 (fromIntegral i) + | -0x80 <= i && i < 0x80 = putWord8 0xc8 >> putInt8 (fromIntegral i) + | -0x8000 <= i && i < 0x8000 = putWord8 0xc9 >> putInt16be (fromIntegral i) + | -0x80000000 <= i && i < 0x80000000 = putWord8 0xca >> putInt32be (fromIntegral i) + | otherwise = putWord8 0xcb >> putInt64be (fromIntegral i) +putPackStream (String t) = do + let bstr = T.encodeUtf8 t + size = BS.length bstr + 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 -> error "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 -> error "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 -> error "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 -> error "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/lib/Database/Bolt/Exception.hs b/lib/Database/Bolt/Exception.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Exception.hs @@ -0,0 +1,41 @@ +module Database.Bolt.Exception ( + internalErr, + transportErr, + protocolErr, + authFail, + reqFail, + reqIgnore, +) where + +import Control.Exception +import Data.Text (Text) +import Database.Bolt.Types + +data BoltException + = AuthenticationFailure Text + | RequestFailure Object Text + | RequestIgnored Object Text + | InternalError Text + | TransportError Text + | ProtocolError Text + deriving (Show) + +instance Exception BoltException + +authFail :: Text -> IO a +authFail = throwIO . AuthenticationFailure + +reqFail :: Object -> Text -> IO a +reqFail meta = throwIO . RequestFailure meta + +reqIgnore :: Object -> Text -> IO a +reqIgnore meta = throwIO . RequestIgnored meta + +internalErr :: Text -> IO a +internalErr = throwIO . InternalError + +transportErr :: Text -> IO a +transportErr = throwIO . TransportError + +protocolErr :: Text -> IO a +protocolErr = throwIO . ProtocolError diff --git a/lib/Database/Bolt/Protocol/Ver1.hs b/lib/Database/Bolt/Protocol/Ver1.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Protocol/Ver1.hs @@ -0,0 +1,37 @@ +{-# 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/lib/Database/Bolt/Protocol/Ver1/Graph.hs b/lib/Database/Bolt/Protocol/Ver1/Graph.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Protocol/Ver1/Graph.hs @@ -0,0 +1,98 @@ +{-# 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/lib/Database/Bolt/Protocol/Ver1/Message.hs b/lib/Database/Bolt/Protocol/Ver1/Message.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Protocol/Ver1/Message.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Bolt.Protocol.Ver1.Message ( + Message (..), + AuthToken (..), +) +where + +import Data.HashMap.Strict qualified as HM +import Data.PackStream +import Data.Text (Text) +import Data.Text qualified as T + +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 0x7e []) -> return $ Ignored mempty + (Struct 0x7f [metadata]) -> Failure <$> parsePackStream metadata + (Struct 0x7f []) -> return $ Failure mempty + (Struct sn xs) -> error $ "Invalid Message: " ++ T.unpack (pretty (Struct sn xs)) + _ -> error "Invalid Message (not a struct)" + +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/lib/Database/Bolt/Protocol/Ver1/Pretty.hs b/lib/Database/Bolt/Protocol/Ver1/Pretty.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Protocol/Ver1/Pretty.hs @@ -0,0 +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 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/lib/Database/Bolt/Protocol/Ver1/Request.hs b/lib/Database/Bolt/Protocol/Ver1/Request.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Protocol/Ver1/Request.hs @@ -0,0 +1,77 @@ +{-# 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 Database.Bolt.Protocol.Ver1.Message qualified as Msg +import Database.Bolt.Protocol.Ver1.Types +import Database.Bolt.Transport +import Database.Bolt.Transport.Message + +data Response + = Success Metadata [Record] + | Failed Metadata + | Ignored Metadata + +request :: (Transport t) => t -> Message -> IO Response +request conn msg = do + -- print ("send", msg) + sendmsg conn msg + gather [] + where + gather vals = do + reply <- recvmsg conn + -- print ("recv", reply) + case reply of + Msg.Success meta -> return $ Success meta (reverse vals) + Msg.Failure meta -> return $ Failed meta + Msg.Ignored meta -> return $ Ignored meta + 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 meta _ -> reqFail meta "Request not expecting records" + Failed meta -> reqFail meta "Request failed" + Ignored meta -> reqIgnore meta "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 meta -> reqFail meta "Request failed" + Ignored meta -> reqIgnore meta "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/lib/Database/Bolt/Protocol/Ver1/Transaction.hs b/lib/Database/Bolt/Protocol/Ver1/Transaction.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Protocol/Ver1/Transaction.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} + +module Database.Bolt.Protocol.Ver1.Transaction ( + Transaction, + Tran (..), + runTransaction, + cypher, +) where + +import Control.Exception +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Data.HashMap.Strict qualified as HM +import Database.Bolt.Protocol.Ver1.Request +import Database.Bolt.Protocol.Ver1.Types +import Database.Bolt.Transport + +newtype Tran t a = Tran {unTran :: 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 (unTran t) conn + case r of + Left (SomeException ex) -> do + reset conn + 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/lib/Database/Bolt/Protocol/Ver1/Types.hs b/lib/Database/Bolt/Protocol/Ver1/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Protocol/Ver1/Types.hs @@ -0,0 +1,46 @@ +module Database.Bolt.Protocol.Ver1.Types ( + Object, + object, + UserAgent, + Principal, + Credentials, + Statement, + Label, + Type, + Identity, + Parameters, + Properties, + Metadata, + Record, + (#=), + (#:), + (#:?), +) where + +import Data.HashMap.Strict qualified as HM +import Data.Int +import Data.PackStream +import Data.Text (Text) +import Database.Bolt.Types (Object, object) + +type UserAgent = Text +type Principal = Text +type Credentials = Text +type Statement = Text +type Label = Text +type Type = Text +type Identity = Int64 + +type Parameters = Object +type Properties = Object +type Metadata = Object +type Record = [PackStream] + +(#=) :: (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/lib/Database/Bolt/Transport.hs b/lib/Database/Bolt/Transport.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Transport.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Bolt.Transport ( + Transport (..), + put, + get, + getE, + handshake, + BoltProtocol, + OfferProtocols (..), + noProto, +) where + +import Data.ByteString qualified 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/lib/Database/Bolt/Transport/Chunked.hs b/lib/Database/Bolt/Transport/Chunked.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Transport/Chunked.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +module Database.Bolt.Transport.Chunked ( + send, + recv, + put, + get, +) where + +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.Monoid +import Data.Serialize.Get +import Data.Serialize.Put +import Data.Text qualified as T + +import Database.Bolt.Exception +import Database.Bolt.Transport (Transport) +import Database.Bolt.Transport qualified 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/lib/Database/Bolt/Transport/Message.hs b/lib/Database/Bolt/Transport/Message.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Transport/Message.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Bolt.Transport.Message ( + sendmsg, + recvmsg, +) where + +import Data.Monoid +import Data.PackStream +import Data.Text qualified as T + +import Database.Bolt.Exception +import Database.Bolt.Transport (Transport) +import Database.Bolt.Transport.Chunked qualified 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/lib/Database/Bolt/Transport/Socket.hs b/lib/Database/Bolt/Transport/Socket.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Transport/Socket.hs @@ -0,0 +1,81 @@ +{-# 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 Data.Text qualified as T +import Network.Socket qualified as Net +import Network.Socket.ByteString qualified 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 diff --git a/lib/Database/Bolt/Types.hs b/lib/Database/Bolt/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Database/Bolt/Types.hs @@ -0,0 +1,14 @@ +module Database.Bolt.Types ( + Object, + object, +) where + +import Data.HashMap.Strict qualified as HM +import Data.Hashable +import Data.PackStream +import Data.Text (Text) + +type Object = HM.HashMap Text PackStream + +object :: (Eq k, Hashable k) => [(k, v)] -> HM.HashMap k v +object = HM.fromList diff --git a/src/Data/PackStream.hs b/src/Data/PackStream.hs deleted file mode 100644 --- a/src/Data/PackStream.hs +++ /dev/null @@ -1,311 +0,0 @@ -{-# 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 qualified Data.ByteString as BS -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 <$> getInt8 - | marker == 0xc9 -> Int . fromIntegral <$> getInt16be - | marker == 0xca -> Int . fromIntegral <$> getInt32be - | marker == 0xcb -> Int . fromIntegral <$> getInt64be - - | 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 = putInt8 (fromIntegral i) - | -0x80 <= i && i < 0x80 = putWord8 0xc8 >> putInt8 (fromIntegral i) - | -0x8000 <= i && i < 0x8000 = putWord8 0xc9 >> putInt16be (fromIntegral i) - | -0x80000000 <= i && i < 0x80000000 = putWord8 0xca >> putInt32be (fromIntegral i) - | otherwise = putWord8 0xcb >> putInt64be (fromIntegral i) - -putPackStream (String t) = do - let bstr = T.encodeUtf8 t - size = BS.length bstr - 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 deleted file mode 100644 --- a/src/Database/Bolt/Exception.hs +++ /dev/null @@ -1,40 +0,0 @@ -module Database.Bolt.Exception - ( internalErr - , transportErr - , protocolErr - , authFail - , reqFail - , reqIgnore - ) where - -import Control.Exception -import Data.Text (Text) -import Database.Bolt.Types - -data BoltException = AuthenticationFailure Text - | RequestFailure Object Text - | RequestIgnored Object Text - | InternalError Text - | TransportError Text - | ProtocolError Text - deriving (Show) - -instance Exception BoltException - -authFail :: Text -> IO a -authFail = throwIO . AuthenticationFailure - -reqFail :: Object -> Text -> IO a -reqFail meta = throwIO . RequestFailure meta - -reqIgnore :: Object -> Text -> IO a -reqIgnore meta = throwIO . RequestIgnored meta - -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 deleted file mode 100644 --- a/src/Database/Bolt/Protocol/Ver1.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Database/Bolt/Protocol/Ver1/Graph.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Database/Bolt/Protocol/Ver1/Message.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# 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 qualified Data.Text as T - -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 0x7e []) -> return $ Ignored mempty - (Struct 0x7f [metadata]) -> Failure <$> parsePackStream metadata - (Struct 0x7f []) -> return $ Failure mempty - (Struct sn xs) -> error $ "Invalid Message: " ++ T.unpack (pretty (Struct sn xs)) - _ -> error "Invalid Message (not a struct)" - -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 deleted file mode 100644 --- a/src/Database/Bolt/Protocol/Ver1/Pretty.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Database/Bolt/Protocol/Ver1/Request.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# 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 Metadata [Record] - | Failed Metadata - | Ignored Metadata - -request :: Transport t => t -> Message -> IO Response -request conn msg = do - -- print ("send", msg) - sendmsg conn msg - gather [] - where - gather vals = do - reply <- recvmsg conn - -- print ("recv", reply) - case reply of - Msg.Success meta -> return $ Success meta (reverse vals) - Msg.Failure meta -> return $ Failed meta - Msg.Ignored meta -> return $ Ignored meta - 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 meta _ -> reqFail meta "Request not expecting records" - Failed meta -> reqFail meta "Request failed" - Ignored meta -> reqIgnore meta "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 meta -> reqFail meta "Request failed" - Ignored meta -> reqIgnore meta "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 deleted file mode 100644 --- a/src/Database/Bolt/Protocol/Ver1/Transaction.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} - -module Database.Bolt.Protocol.Ver1.Transaction - ( Transaction - , Tran(..) - , runTransaction - , cypher - ) where - -import Control.Exception -import Control.Monad.IO.Class -import Control.Monad.Trans.Reader -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 { unTran :: 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 (unTran t) conn - case r of - Left (SomeException ex) -> do - reset conn - 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 deleted file mode 100644 --- a/src/Database/Bolt/Protocol/Ver1/Types.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Database.Bolt.Protocol.Ver1.Types - ( Object - , object - , UserAgent - , Principal - , Credentials - , Statement - , Label - , Type - , Identity - , Parameters - , Properties - , Metadata - , Record - , (#=) - , (#:) - , (#:?) - ) where - -import qualified Data.HashMap.Strict as HM -import Data.Int -import Data.PackStream -import Data.Text (Text) -import Database.Bolt.Types (Object, object) - -type UserAgent = Text -type Principal = Text -type Credentials = Text -type Statement = Text -type Label = Text -type Type = Text -type Identity = Int64 - -type Parameters = Object -type Properties = Object -type Metadata = Object -type Record = [PackStream] - -(#=) :: 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 deleted file mode 100644 --- a/src/Database/Bolt/Transport.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Database/Bolt/Transport/Chunked.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Database/Bolt/Transport/Message.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/src/Database/Bolt/Transport/Socket.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# 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 diff --git a/src/Database/Bolt/Types.hs b/src/Database/Bolt/Types.hs deleted file mode 100644 --- a/src/Database/Bolt/Types.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Database.Bolt.Types - ( Object - , object - ) where - -import Data.Hashable -import qualified Data.HashMap.Strict as HM -import Data.PackStream -import Data.Text (Text) - -type Object = HM.HashMap Text PackStream - -object :: (Eq k, Hashable k) => [(k, v)] -> HM.HashMap k v -object = HM.fromList diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,61 +1,64 @@ -module Main where - -import Data.ByteString (ByteString) -import Data.PackStream -import qualified Data.HashMap.Strict as HM -import qualified Data.Text as Text -import qualified Data.Vector as Vec -import Data.Serialize.Get -import Data.Serialize.Put - -import Test.Tasty -import Test.Tasty.QuickCheck - -instance Arbitrary PackStream where - arbitrary = - oneof [ return Null - , Bool <$> arbitrary - , Int <$> arbitrary - , Float <$> arbitrary - , String <$> (Text.pack <$> arbitrary) - , List <$> (Vec.fromList <$> scale' (listOf arbitrary)) - , Map <$> (HM.fromList <$> scale' (listOf arbitrary)) - , Struct <$> arbitrary <*> scale' (listOf arbitrary) - ] - where - scale' = scale (`div` 2) - - shrink Null = [] - shrink (Bool _) = [Null] - shrink (Int _) = [Null] - shrink (Float _) = [Null] - shrink (String s) = Null : ((String . Text.pack) <$> shrink (Text.unpack s)) - shrink (List xs) - | Vec.length xs == 0 = [Null] - | Vec.length xs == 1 = [Vec.head xs] - | otherwise = Null : ((List . Vec.fromList) <$> shrink (Vec.toList xs)) - shrink (Map xs) - | HM.size xs == 0 = [Null] - | HM.size xs == 1 = let [(k, v)] = HM.toList xs in [k, v] - | otherwise = Null : ((Map . HM.fromList) <$> shrink (HM.toList xs)) - shrink (Struct s xs) = Null : List (Vec.fromList xs) : (Struct s <$> shrink xs) - -prop_decode_encode :: PackStream -> Property -prop_decode_encode a = (decode . encode) a === a - where - encode :: PackStream -> ByteString - encode = runPut . pack - decode :: ByteString -> PackStream - decode x = case runGet unpack x of - Left err -> error err - Right (Left err) -> error err - Right (Right ps) -> ps - - -main :: IO () -main = defaultMain $ - testGroup "Tests" - [ testGroup "(checked by QuickCheck)" - [ testProperty "id == decode . encode" prop_decode_encode - ] - ] +module Main where + +import Data.ByteString (ByteString) +import qualified Data.HashMap.Strict as HM +import Data.PackStream +import Data.Serialize.Get +import Data.Serialize.Put +import qualified Data.Text as Text +import qualified Data.Vector as Vec + +import Test.Tasty +import Test.Tasty.QuickCheck + +instance Arbitrary PackStream where + arbitrary = + oneof + [ return Null + , Bool <$> arbitrary + , Int <$> arbitrary + , Float <$> arbitrary + , String <$> (Text.pack <$> arbitrary) + , List <$> (Vec.fromList <$> scale' (listOf arbitrary)) + , Map <$> (HM.fromList <$> scale' (listOf arbitrary)) + , Struct <$> arbitrary <*> scale' (listOf arbitrary) + ] + where + scale' = scale (`div` 2) + + shrink Null = [] + shrink (Bool _) = [Null] + shrink (Int _) = [Null] + shrink (Float _) = [Null] + shrink (String s) = Null : ((String . Text.pack) <$> shrink (Text.unpack s)) + shrink (List xs) + | Vec.length xs == 0 = [Null] + | Vec.length xs == 1 = [Vec.head xs] + | otherwise = Null : ((List . Vec.fromList) <$> shrink (Vec.toList xs)) + shrink (Map xs) + | HM.size xs == 0 = [Null] + | HM.size xs == 1 = let [(k, v)] = HM.toList xs in [k, v] + | otherwise = Null : ((Map . HM.fromList) <$> shrink (HM.toList xs)) + shrink (Struct s xs) = Null : List (Vec.fromList xs) : (Struct s <$> shrink xs) + +prop_decode_encode :: PackStream -> Property +prop_decode_encode a = (decode . encode) a === a + where + encode :: PackStream -> ByteString + encode = runPut . pack + decode :: ByteString -> PackStream + decode x = case runGet unpack x of + Left err -> error err + Right (Left err) -> error err + Right (Right ps) -> ps + +main :: IO () +main = + defaultMain $ + testGroup + "Tests" + [ testGroup + "(checked by QuickCheck)" + [ testProperty "id == decode . encode" prop_decode_encode + ] + ]