diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bolt.cabal b/bolt.cabal new file mode 100644 --- /dev/null +++ b/bolt.cabal @@ -0,0 +1,55 @@ +name: bolt +version: 0.1.0.1 +synopsis: Bolt driver for Neo4j +description: Please see README.md +homepage: https://github.com/bflyblue/bolt#readme +license: BSD3 +license-file: LICENSE +author: Shaun Sharples +maintainer: shaun.sharples@gmail.com +stability: experimental +copyright: (c) 2016 Shaun Sharples +category: Database +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Data.PackStream + , Database.Bolt.Exception + , Database.Bolt.Protocol.Ver1 + , Database.Bolt.Protocol.Ver1.Message + , Database.Bolt.Protocol.Ver1.Pretty + , Database.Bolt.Protocol.Ver1.Request + , Database.Bolt.Protocol.Ver1.Types + , Database.Bolt.Transport + , Database.Bolt.Transport.Chunked + , Database.Bolt.Transport.Message + , Database.Bolt.Transport.Socket + build-depends: base >= 4.7 && < 5 + , bifunctors + , bytestring + , cereal + , containers + , hashable + , network + , network-uri + , text + , unordered-containers + , vector + ghc-options: -Wall + default-language: Haskell2010 + +-- test-suite tests +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: test +-- main-is: Spec.hs +-- build-depends: base +-- , bolt +-- ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall +-- default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/bflyblue/bolt diff --git a/src/Data/PackStream.hs b/src/Data/PackStream.hs new file mode 100644 --- /dev/null +++ b/src/Data/PackStream.hs @@ -0,0 +1,293 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +module Data.PackStream + ( PackStream(..) + , ToPackStream(..) + , FromPackStream(..) + , Parser + , parse + , parseEither + , parseMaybe + , pack + , unpack + , pretty + , prettyStruct + , genericStructName + , (.=) + , (.:) + , (.:?) + , (.!=) + ) +where + +import Control.Monad +import Data.Bifunctor +import Data.Bits +import Data.Hashable +import qualified Data.HashMap.Strict as HM +import Data.Int +import qualified Data.Map.Strict as M +import Data.Monoid +import Data.Serialize.Get +import Data.Serialize.IEEE754 +import Data.Serialize.Put +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V +import Data.Word +import GHC.Generics (Generic) +import Text.Printf + +-- Orphan instance should go away once vector-instances 0.4 is available +instance (Hashable a) => Hashable (V.Vector a) where + hashWithSalt salt = hashWithSalt salt . V.toList + {-# INLINE hashWithSalt #-} + +data PackStream = Null + | Bool !Bool + | Int !Int64 + | Float !Double + | String !Text + | List !(V.Vector PackStream) + | Map !(HM.HashMap PackStream PackStream) + | Struct !Word8 ![PackStream] + deriving (Show, Eq, Generic, Hashable) + +type Parser = Either String + +parse :: (a -> Parser b) -> a -> Parser b +parse = parseEither + +parseEither :: (a -> Parser b) -> a -> Either String b +parseEither f = f + +parseMaybe :: (a -> Parser b) -> a -> Maybe b +parseMaybe f = either (const Nothing) Just . parseEither f + +class FromPackStream a where + parsePackStream :: PackStream -> Parser a + +instance FromPackStream PackStream where + parsePackStream = return + +instance FromPackStream Bool where + parsePackStream (Bool b) = return b + parsePackStream _ = fail "Expecting Bool" + +instance FromPackStream Int64 where + parsePackStream (Int i) = return i + parsePackStream _ = fail "Expecting Int" + +instance FromPackStream Double where + parsePackStream (Float d) = return d + parsePackStream _ = fail "Expecting Float" + +instance FromPackStream Text where + parsePackStream (String t) = return t + parsePackStream _ = fail "Expecting String" + +instance FromPackStream a => FromPackStream [a] where + parsePackStream (List l) = mapM parsePackStream (V.toList l) + parsePackStream _ = fail "Expecting List" + +instance FromPackStream a => FromPackStream (V.Vector a) where + parsePackStream (List l) = mapM parsePackStream l + parsePackStream _ = fail "Expecting List" + +instance (Eq a, Hashable a, FromPackStream a, FromPackStream b) => FromPackStream (HM.HashMap a b) where + parsePackStream (Map m) = do + kvs <- mapM parseAssoc (HM.toList m) + return $ HM.fromList kvs + where + parseAssoc (k, v) = (,) <$> parsePackStream k <*> parsePackStream v + + parsePackStream _ = fail "Expecting Map" + +instance (Ord a, FromPackStream a, FromPackStream b) => FromPackStream (M.Map a b) where + parsePackStream (Map m) = do + kvs <- mapM parseAssoc (HM.toList m) + return $ M.fromList kvs + where + parseAssoc (k, v) = (,) <$> parsePackStream k <*> parsePackStream v + + parsePackStream _ = fail "Expecting Map" + +class ToPackStream a where + toPackStream :: a -> PackStream + +instance ToPackStream PackStream where + toPackStream = id + +instance ToPackStream Bool where + toPackStream = Bool + +instance ToPackStream Int64 where + toPackStream = Int + +instance ToPackStream Double where + toPackStream = Float + +instance ToPackStream Text where + toPackStream = String + +instance ToPackStream a => ToPackStream [a] where + toPackStream = List . V.fromList . fmap toPackStream + +instance ToPackStream a => ToPackStream (V.Vector a) where + toPackStream = List . fmap toPackStream + +instance (ToPackStream a, ToPackStream b) => ToPackStream (M.Map a b) where + toPackStream = Map . HM.fromList . fmap (bimap toPackStream toPackStream) . M.toList + +instance (ToPackStream a, ToPackStream b) => ToPackStream (HM.HashMap a b) where + toPackStream = Map . HM.fromList . fmap (bimap toPackStream toPackStream) . HM.toList + +pack :: ToPackStream a => Putter a +pack = putPackStream . toPackStream + +unpack :: FromPackStream a => Get (Parser a) +unpack = parsePackStream <$> getPackStream + +getPackStream :: Get PackStream +getPackStream = do + marker <- getWord8 + if | marker == 0xc0 -> return Null + + | marker == 0xc1 -> Float <$> getFloat64be + + | marker == 0xc2 -> return $ Bool False + | marker == 0xc3 -> return $ Bool True + + | marker < 0x80 -> return $ Int (fromIntegral marker) + | marker >= 0xf0 -> return $ Int (fromIntegral marker - 0x100) + | marker == 0xc8 -> Int . fromIntegral <$> getWord8 + | marker == 0xc9 -> Int . fromIntegral <$> getWord16be + | marker == 0xca -> Int . fromIntegral <$> getWord32be + | marker == 0xcb -> Int . fromIntegral <$> getWord64be + + | 0x80 <= marker && marker < 0x90 + -> getString (fromIntegral marker .&. 0x0f) + | marker == 0xd0 -> fromIntegral <$> getWord8 >>= getString + | marker == 0xd1 -> fromIntegral <$> getWord16be >>= getString + | marker == 0xd2 -> fromIntegral <$> getWord32be >>= getString + + | 0x90 <= marker && marker < 0xa0 + -> getList (fromIntegral marker .&. 0x0f) + | marker == 0xd4 -> fromIntegral <$> getWord8 >>= getList + | marker == 0xd5 -> fromIntegral <$> getWord16be >>= getList + | marker == 0xd6 -> fromIntegral <$> getWord32be >>= getList + + | 0xa0 <= marker && marker < 0xb0 + -> getMap (fromIntegral marker .&. 0x0f) + | marker == 0xd8 -> fromIntegral <$> getWord8 >>= getMap + | marker == 0xd8 -> 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 0xca >> 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 diff --git a/src/Database/Bolt/Exception.hs b/src/Database/Bolt/Exception.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Exception.hs @@ -0,0 +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 diff --git a/src/Database/Bolt/Protocol/Ver1.hs b/src/Database/Bolt/Protocol/Ver1.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Protocol/Ver1.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.Bolt.Protocol.Ver1 + ( init + , exec + , AuthToken(..) + , open + ) where + +import Prelude hiding (init) +import Control.Monad + +import Database.Bolt.Exception +import Database.Bolt.Protocol.Ver1.Message (AuthToken(..)) +import Database.Bolt.Protocol.Ver1.Request (init, exec) +import Database.Bolt.Protocol.Ver1.Types +import Database.Bolt.Transport + +useragent :: UserAgent +useragent = "haskell-bolt/0.0" + +open :: Transport t => (a -> IO t) -> a -> AuthToken -> IO t +open c a auth = do + conn <- c a + agreed <- handshake conn (OfferProtocols 1 noProto noProto noProto) + unless (agreed == 1) $ + protocolErr "Can't negotiate protocol version" + init conn useragent auth + return conn diff --git a/src/Database/Bolt/Protocol/Ver1/Message.hs b/src/Database/Bolt/Protocol/Ver1/Message.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Protocol/Ver1/Message.hs @@ -0,0 +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" diff --git a/src/Database/Bolt/Protocol/Ver1/Pretty.hs b/src/Database/Bolt/Protocol/Ver1/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/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 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 diff --git a/src/Database/Bolt/Protocol/Ver1/Request.hs b/src/Database/Bolt/Protocol/Ver1/Request.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Protocol/Ver1/Request.hs @@ -0,0 +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 diff --git a/src/Database/Bolt/Protocol/Ver1/Types.hs b/src/Database/Bolt/Protocol/Ver1/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Protocol/Ver1/Types.hs @@ -0,0 +1,15 @@ +module Database.Bolt.Protocol.Ver1.Types where + +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 Object = HM.HashMap Text PackStream +type Parameters = Object +type Metadata = Object +type Record = [PackStream] diff --git a/src/Database/Bolt/Transport.hs b/src/Database/Bolt/Transport.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Transport.hs @@ -0,0 +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 diff --git a/src/Database/Bolt/Transport/Chunked.hs b/src/Database/Bolt/Transport/Chunked.hs new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Transport/Chunked.hs @@ -0,0 +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 diff --git a/src/Database/Bolt/Transport/Message.hs b/src/Database/Bolt/Transport/Message.hs new file mode 100644 --- /dev/null +++ b/src/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 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 new file mode 100644 --- /dev/null +++ b/src/Database/Bolt/Transport/Socket.hs @@ -0,0 +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