diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2014 Tomas Carnecky + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 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/rethinkdb-client-driver.cabal b/rethinkdb-client-driver.cabal new file mode 100644 --- /dev/null +++ b/rethinkdb-client-driver.cabal @@ -0,0 +1,70 @@ +name: rethinkdb-client-driver +version: 0.0.0.1 +license: MIT +license-file: LICENSE +author: Tomas Carnecky +maintainer: tomas.carnecky@gmail.com +category: Database +build-type: Simple +cabal-version: >= 1.10 + +homepage: https://github.com/wereHamster/rethinkdb-client-driver +bug-reports: https://github.com/wereHamster/rethinkdb-client-driver/issues + +synopsis: Client driver for RethinkDB +description: + This is an alternative client driver for RethinkDB. It is not complete + yet, but the basic structure is in place and the driver can make + simple queries. + . + Its main focus is on type safety, which it achieves quite well. It also + uses the new JSON protocol which should give it a speed boost (and make + the driver compatible with GHC 7.8). + . + Note that the driver is neither thread-safe nor reentrant. If you have + a multi-threaded application, I recommend using 'resource-pool'. + +source-repository head + type: git + location: git://github.com/wereHamster/rethinkdb-client-driver.git + + +library + default-language : Haskell2010 + hs-source-dirs : src + + build-depends : base >= 4.6 && < 4.7 + , aeson + , binary >= 0.7.2.1 + , bytestring + , hashable + , network + , scientific + , text + , unordered-containers + , vector + + exposed-modules : Database.RethinkDB + other-modules : Database.RethinkDB.Messages + , Database.RethinkDB.Terms + , Database.RethinkDB.Types + + ghc-options : -Wall + + +test-suite spec + default-language : Haskell2010 + hs-source-dirs : test + + main-is : Test.hs + type : exitcode-stdio-1.0 + + build-depends : base >= 4.6 && < 4.7 + , hspec + , smallcheck + , hspec-smallcheck + + , rethinkdb-client-driver + , vector + , text + , unordered-containers diff --git a/src/Database/RethinkDB.hs b/src/Database/RethinkDB.hs new file mode 100644 --- /dev/null +++ b/src/Database/RethinkDB.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +module Database.RethinkDB + ( Handle + , newHandle + , run, nextChunk, collect + + , Error(..) + + , Exp + , Array, Object, Datum(..) + , Sequence + , constant + , Table, Database, SingleSelection + , Res + , emptyOptions + + , Any, IsDatum, IsObject, IsSequence + + , module Database.RethinkDB.Terms + ) where + + +import Data.Monoid ((<>)) +import qualified Data.Text as T +import qualified Data.Vector as V +import qualified Data.Aeson.Types as A + +import Network.Socket (Socket) +import Data.IORef + +import Database.RethinkDB.Types +import Database.RethinkDB.Terms +import Database.RethinkDB.Messages + + +------------------------------------------------------------------------------ +-- Handle + +data Handle = Handle + { hSocket :: !Socket + , hTokenRef :: !(IORef Token) + } + + +-- | Create a new handle to the RethinkDB server. +newHandle :: IO Handle +newHandle = do + sock <- createSocket + + -- Do the handshake dance. Note that we currently ignore the reply and + -- assume it is "SUCCESS". + sendMessage sock handshakeMessage + _reply <- recvMessage sock handshakeReplyParser + + -- RethinkDB seems to expect the token to never be null. So we start with + -- one and then count up. + ref <- newIORef 1 + + return $ Handle sock ref + + +-- | Start a new query and wait for its (first) result. If the result is an +-- single value ('Datum'), then three will be no further results. If it is +-- a sequence, then you must consume results until the sequence ends. +run :: (Any a, FromResponse (Result a)) + => Handle -> Exp a -> IO (Res a) +run handle expr = do + _token <- start handle expr + reply <- getResponse handle + + case reply of + Left e -> return $ Left e + Right response -> return $ case A.parseEither parseResponse response of + Left e -> Left $ ProtocolError $ T.pack e + Right r -> Right r + + +-- | Collect all the values in a sequence and make them available as +-- a 'Vector a'. +collect :: (FromResponse (Sequence a)) + => Handle -> Sequence a -> IO (Either Error (V.Vector a)) +collect _ (Done x) = return $ Right x +collect handle s@(Partial token x) = do + chunk <- nextChunk handle s + case chunk of + Left e -> return $ Left e + Right r -> do + vals <- collect handle r + case vals of + Left ve -> return $ Left ve + Right v -> return $ Right $ x <> v + + + +-- | Start a new query. Returns the 'Token' which can be used to track its +-- progress. +start :: (Any a) => Handle -> Exp a -> IO Token +start handle term = do + token <- atomicModifyIORef (hTokenRef handle) (\x -> (x + 1, x)) + sendMessage (hSocket handle) (queryMessage token (Start term [])) + return token + + + +singleElementArray :: Int -> A.Value +singleElementArray x = A.Array $ V.singleton $ A.Number $ fromIntegral x + +-- | Let the server know that it can send the next response corresponding to +-- the given token. +continue :: Handle -> Token -> IO () +continue handle token = sendMessage + (hSocket handle) + (queryMessage token $ singleElementArray 2) + + +-- | Stop (abort?) a query. +stop :: Handle -> Token -> IO () +stop handle token = sendMessage + (hSocket handle) + (queryMessage token $ singleElementArray 3) + + +-- | Wait until a previous query (which was started with the 'noreply' option) +-- finishes. +wait :: Handle -> Token -> IO () +wait handle token = sendMessage + (hSocket handle) + (queryMessage token $ singleElementArray 4) + + + +-- | Get the next chunk of a sequence. It is an error to request the next chunk +-- if the sequence is already 'Done', +nextChunk :: (FromResponse (Sequence a)) + => Handle -> Sequence a -> IO (Either Error (Sequence a)) +nextChunk _ (Done _) = return $ Left $ ProtocolError "" +nextChunk handle (Partial token _) = do + continue handle token + reply <- getResponse handle + case reply of + Left e -> return $ Left e + Right response -> case A.parseEither parseResponse response of + Left e -> return $ Left $ ProtocolError $ T.pack e + Right r -> return $ Right $ r + + +getResponse :: Handle -> IO (Either Error Response) +getResponse handle = do + recvMessage (hSocket handle) responseMessageParser diff --git a/src/Database/RethinkDB/Messages.hs b/src/Database/RethinkDB/Messages.hs new file mode 100644 --- /dev/null +++ b/src/Database/RethinkDB/Messages.hs @@ -0,0 +1,91 @@ + +module Database.RethinkDB.Messages where + + +import Control.Applicative + +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + +import Data.Aeson as A hiding (Result) +import Data.Aeson.Types as A hiding (Result) + +import Data.ByteString.Lazy (toStrict) +import qualified Data.ByteString.Lazy as BS + +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get as Get + +import Network.Socket (Socket, AddrInfo(..), AddrInfoFlag(..), SocketType(..)) +import Network.Socket (getAddrInfo, socket, connect, defaultHints) + +import Network.Socket.ByteString (recv) +import Network.Socket.ByteString.Lazy (sendAll) + +import Database.RethinkDB.Types + + + +createSocket :: IO Socket +createSocket = do + ai:_ <- getAddrInfo (Just hints) (Just "localhost") (Just "28015") + sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai) + connect sock (addrAddress ai) + return sock + where + hints = defaultHints { addrSocketType = Stream, addrFlags = [ AI_NUMERICSERV ] } + + + +sendMessage :: Socket -> BS.ByteString -> IO () +sendMessage sock buf = sendAll sock buf + + +-- | Receive the next message from the socket. If it fails, a (hopefully) +-- descriptive error will be returned. +recvMessage :: Socket -> Get a -> IO (Either Error a) +recvMessage sock parser = go (runGetIncremental parser) + where + go (Get.Done _ _ r) = return $ Right r + go (Get.Partial c) = recv sock (4 * 1024) >>= go . c . Just + go (Get.Fail _ _ e) = return $ Left $ ProtocolError $ T.pack e + + + +handshakeMessage :: BS.ByteString +handshakeMessage = runPut $ do + putWord32le 0x5f75e83e -- V0_3 + putWord32le 0 -- No authentication + putWord32le 0x7e6970c7 -- JSON + + +handshakeReplyParser :: Get Text +handshakeReplyParser = do + (T.decodeUtf8 . toStrict) <$> getLazyByteStringNul + + +queryMessage :: (ToJSON a) => Token -> a -> BS.ByteString +queryMessage token msg = runPut $ do + putWord64host token + putWord32le (fromIntegral $ BS.length buf) + putLazyByteString buf + where + buf = A.encode msg + + +responseMessageParser :: Get Response +responseMessageParser = do + token <- getWord64host + len <- getWord32le + buf <- getLazyByteString (fromIntegral len) + + let (Just v) = A.decode buf :: (Maybe Value) + --trace (show v) $ return () + case A.parseEither (responseParser token) v of + Left e -> do + --trace ("Response parser " ++ e) $ return () + fail $ "Response: " ++ e + Right x -> return x + diff --git a/src/Database/RethinkDB/Terms.hs b/src/Database/RethinkDB/Terms.hs new file mode 100644 --- /dev/null +++ b/src/Database/RethinkDB/Terms.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} + +module Database.RethinkDB.Terms where + + +import Data.Text (Text) +import qualified Data.HashMap.Strict as HMS +import Database.RethinkDB.Types + + + +db :: Exp Text -> Exp Database +db name = Term DB [SomeExp name] emptyOptions + + +table :: Exp Text -> Exp Table +table name = Term TABLE [SomeExp name] emptyOptions + + +getField :: (IsObject o) => Exp o -> Exp Text -> Exp Datum +getField obj k = Term GET_FIELD [SomeExp obj, SomeExp k] emptyOptions + + +extractField :: (IsSequence s, IsDatum a) => Exp s -> Exp Text -> Exp (Sequence a) +extractField s k = Term GET_FIELD [SomeExp s, SomeExp k] emptyOptions + + +get :: Exp Table -> Exp Text -> Exp SingleSelection +get tbl key = + Term GET [SomeExp tbl, SomeExp key] emptyOptions + + +coerceTo :: (Any v) => Exp v -> Exp Text => Exp Text +coerceTo value typeName = + Term COERCE_TO [SomeExp value, SomeExp typeName] emptyOptions + + +getAll :: (IsDatum a) => Exp Table -> [Exp a] -> Maybe Text -> Exp Array +getAll tbl keys mbIndex = + Term GET_ALL ([SomeExp tbl] ++ map SomeExp keys) options + where + options = case mbIndex of + Nothing -> emptyOptions + Just index -> HMS.singleton "index" (String index) + +getAllIndexed :: (IsDatum a) => Exp Table -> [Exp a] -> Text -> Exp (Sequence Datum) +getAllIndexed tbl keys index = + Term GET_ALL ([SomeExp tbl] ++ map SomeExp keys) options + where + options = HMS.singleton "index" (String index) + + +add :: [Exp Double] -> Exp Double +add xs = Term ADD (map SomeExp xs) emptyOptions + + +insert :: Exp Table -> Object -> Exp Object +insert tbl obj = Term INSERT [SomeExp tbl, SomeExp (constant obj)] emptyOptions + + +limit :: (Any a) => Exp a -> Exp Double -> Exp Table +limit s n = Term LIMIT [SomeExp s, SomeExp n] emptyOptions + + +append :: Exp Array -> Exp Datum -> Exp Array +append a d = Term APPEND [SomeExp a, SomeExp d] emptyOptions diff --git a/src/Database/RethinkDB/Types.hs b/src/Database/RethinkDB/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/RethinkDB/Types.hs @@ -0,0 +1,449 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module Database.RethinkDB.Types where + + +import Control.Applicative + +import Data.Word +import Data.String +import Data.Text (Text) + +import Data.Aeson (FromJSON(..), ToJSON(..), (.:)) +import Data.Aeson.Types (Parser, Value) +import qualified Data.Aeson as A + +import Data.Vector (Vector) +import qualified Data.Vector as V +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HMS + +import GHC.Generics + + + +------------------------------------------------------------------------------ +-- | Any value which can appear in RQL terms. +-- +-- For convenience we require that it can be converted to JSON, but that is +-- not required for all types. Only types which satisfy 'IsDatum' are +-- eventually converted to JSON. + +class (ToJSON a) => Any a + + + +------------------------------------------------------------------------------ +-- | A sumtype covering all the primitive types which can appear in queries +-- or responses. + +data Datum + = Null + | Bool !Bool + | Number !Double + | String !Text + | Array !Array + | Object !Object + deriving (Eq, Show, Generic) + + +class (Any a) => IsDatum a + + +instance Any Datum +instance IsDatum Datum + +instance ToJSON Datum where + toJSON (Null ) = A.Null + toJSON (Bool x) = toJSON x + toJSON (Number x) = toJSON x + toJSON (String x) = toJSON x + toJSON (Array x) = toJSON x + toJSON (Object x) = toJSON x + +instance FromJSON Datum where + parseJSON (A.Null ) = pure Null + parseJSON (A.Bool x) = pure $ Bool x + parseJSON (A.Number x) = pure $ Number (realToFrac x) + parseJSON (A.String x) = pure $ String x + parseJSON (A.Array x) = Array <$> V.mapM parseJSON x + parseJSON (A.Object x) = do + -- HashMap does not provide a mapM, what a shame :( + items <- mapM (\(k, v) -> (,) <$> pure k <*> parseJSON v) $ HMS.toList x + return $ Object $ HMS.fromList items + +instance FromResponse Datum where + parseResponse = responseAtomParser + + + +------------------------------------------------------------------------------ +-- | For a boolean type, we're reusing the standard Haskell 'Bool' type. + +instance Any Bool +instance IsDatum Bool + +instance FromResponse Bool where + parseResponse = responseAtomParser + + + +------------------------------------------------------------------------------ +-- | Numbers are 'Double' (unlike 'Aeson', which uses 'Scientific'). No +-- particular reason. + +instance Any Double +instance IsDatum Double + +instance FromResponse Double where + parseResponse = responseAtomParser + + + +------------------------------------------------------------------------------ +-- | For strings, we're using the Haskell 'Text' type. + +instance Any Text +instance IsDatum Text + +instance FromResponse Text where + parseResponse = responseAtomParser + + + +------------------------------------------------------------------------------ +-- | Arrays are vectors of 'Datum'. + +type Array = Vector Datum + +instance Any Array +instance IsDatum Array + +instance FromResponse Array where + parseResponse = responseAtomParser + +-- Arrays are encoded as a term MAKE_ARRAY. +instance ToJSON Array where + toJSON v = A.Array $ V.fromList $ + [ toJSON MAKE_ARRAY + , toJSON $ map toJSON (V.toList v) + , toJSON emptyOptions + ] + +instance FromJSON Array where + parseJSON (A.Array v) = V.mapM parseJSON v + parseJSON _ = fail "Array" + + + +------------------------------------------------------------------------------ +-- | Objects are maps from 'Text' to 'Datum'. Like 'Aeson', we're using +-- 'HashMap'. + +type Object = HashMap Text Datum + + +class (IsDatum a) => IsObject a + + +instance Any Object +instance IsDatum Object +instance IsObject Object + +instance FromResponse Object where + parseResponse = responseAtomParser + + + +------------------------------------------------------------------------------ +-- | Tables are something you can select objects from. +-- +-- This type is not exported, and merely serves as a sort of phantom type. On +-- the client tables are converted to a 'Sequence'. + +data Table = Table + +instance Any Table +instance IsSequence Table + +instance ToJSON Table where + toJSON = error "toJSON Table: Server-only type" + + + +------------------------------------------------------------------------------ +-- | 'SingleSelection' is essentially a 'Maybe Object', where 'Nothing' is +-- represented with 'Null' in the network protocol. + +data SingleSelection = SingleSelection + deriving (Show) + +instance ToJSON SingleSelection where + toJSON = error "toJSON SingleSelection: Server-only type" + +instance Any SingleSelection +instance IsDatum SingleSelection +instance IsObject SingleSelection + + + +------------------------------------------------------------------------------ +-- | A 'Database' is something which contains tables. It is a server-only +-- type. + +data Database = Database + +instance Any Database +instance ToJSON Database where + toJSON = error "toJSON Database: Server-only type" + + + +------------------------------------------------------------------------------ +-- | Sequences are a bounded list of items. The server may split the sequence +-- into multiple chunks when sending it to the client. When the response is +-- a partial sequence, the client may request additional chunks until it gets +-- a 'Done'. + +data Sequence a + = Done !(Vector a) + | Partial !Token !(Vector a) + + +class Any a => IsSequence a + + +instance Show (Sequence a) where + show (Done v) = "Done " ++ (show $ V.length v) + show (Partial _ v) = "Partial " ++ (show $ V.length v) + +instance (FromJSON a) => FromResponse (Sequence a) where + parseResponse = responseSequenceParser + +instance ToJSON (Sequence a) where + toJSON = error "toJSON Sequence: Server-only type" + +instance (Any a) => Any (Sequence a) +instance (Any a) => IsSequence (Sequence a) + + + +------------------------------------------------------------------------------ +-- | All types of functions which the server supports. Keep this in sync with +-- the protocol definition file, especially the ToJSON instance. + +data TermType + = ADD + | COERCE_TO + | DB + | GET + | GET_ALL + | GET_FIELD + | INSERT + | LIMIT + | MAKE_ARRAY + | APPEND + | TABLE + + +instance ToJSON TermType where + toJSON MAKE_ARRAY = A.Number 2 + toJSON DB = A.Number 14 + toJSON TABLE = A.Number 15 + toJSON GET = A.Number 16 + toJSON GET_ALL = A.Number 78 + toJSON ADD = A.Number 24 + toJSON COERCE_TO = A.Number 51 + toJSON GET_FIELD = A.Number 31 + toJSON INSERT = A.Number 56 + toJSON LIMIT = A.Number 71 + toJSON APPEND = A.Number 29 + + + +------------------------------------------------------------------------------ + +data Exp a where + Constant :: (IsDatum a) => a -> Exp a + Term :: TermType -> [SomeExp] -> Object -> Exp a + + +instance (ToJSON a) => ToJSON (Exp a) where + toJSON (Constant datum) = + toJSON datum + + toJSON (Term termType args opts) = + toJSON [toJSON termType, toJSON args, toJSON opts] + + +-- | Convenience to for automatically converting a 'Text' to a constant +-- expression. +instance IsString (Exp Text) where + fromString = constant . fromString + + +-- | Convert a 'Datum' to an 'Exp'. +constant :: (IsDatum a) => a -> Exp a +constant x = Constant x + + +emptyOptions :: Object +emptyOptions = HMS.empty + + + +------------------------------------------------------------------------------ +-- | Because the arguments to functions are polymorphic (the individual +-- arguments can, and often have, different types). + +data SomeExp where + SomeExp :: (ToJSON a, Any a) => Exp a -> SomeExp + +instance ToJSON SomeExp where + toJSON (SomeExp e) = toJSON e + + + +------------------------------------------------------------------------------ +-- Query + +data Query a + = Start (Exp a) [(Text, SomeExp)] + | Continue + | Stop + | NoreplyWait + +instance (ToJSON a) => ToJSON (Query a) where + toJSON (Start term options) = A.Array $ V.fromList + [ A.Number 1 + , toJSON term + , toJSON options + ] + toJSON Continue = A.Array $ V.singleton (A.Number 2) + toJSON Stop = A.Array $ V.singleton (A.Number 3) + toJSON NoreplyWait = A.Array $ V.singleton (A.Number 4) + + + +------------------------------------------------------------------------------ +-- | The type of result you get when executing a query of 'Exp a'. +type family Result a + +type instance Result Text = Text +type instance Result Double = Double +type instance Result Bool = Bool + +type instance Result Table = Sequence Datum +type instance Result Datum = Datum +type instance Result Object = Object +type instance Result Array = Array +type instance Result SingleSelection = Maybe Datum +type instance Result (Sequence a) = Sequence a + + + +------------------------------------------------------------------------------ +-- | The result of a query. It is either an error or a result (which depends +-- on the type of the query expression). This type is named to be symmetrical +-- to 'Exp', so we get this nice type for 'run'. +-- +-- > run :: Handle -> Exp a -> IO (Res a) + +type Res a = Either Error (Result a) + + + +------------------------------------------------------------------------------ +-- | A value which can be converted from a 'Response'. All types which are +-- defined as being a 'Result a' should have a 'FromResponse a'. Because, +-- uhm.. you really want to be able to extract the result from the response. +-- +-- There are two parsers defined here, one for atoms and the other for +-- sequences. These are the only two implementations of parseResponse which +-- should be used. + +class FromResponse a where + parseResponse :: Response -> Parser a + + +responseAtomParser :: (FromJSON a) => Response -> Parser a +responseAtomParser r = case (responseType r, V.toList (responseResult r)) of + (SuccessAtom, [a]) -> parseJSON a + _ -> fail $ "responseAtomParser: Not a single-element vector " ++ show (responseResult r) + +responseSequenceParser :: (FromJSON a) => Response -> Parser (Sequence a) +responseSequenceParser r = case responseType r of + SuccessSequence -> Done <$> values + SuccessPartial -> Partial <$> pure (responseToken r) <*> values + _ -> fail "responseSequenceParser: Unexpected type" + where + values = V.mapM parseJSON (responseResult r) + + + +------------------------------------------------------------------------------ +-- | A token is used to refer to queries and the corresponding responses. This +-- driver uses a monotonically increasing counter. + +type Token = Word64 + + + +data ResponseType + = SuccessAtom | SuccessSequence | SuccessPartial | SuccessFeed + | WaitComplete + | ClientErrorType | CompileErrorType | RuntimeErrorType + deriving (Show, Eq) + + +instance FromJSON ResponseType where + parseJSON (A.Number 1) = pure SuccessAtom + parseJSON (A.Number 2) = pure SuccessSequence + parseJSON (A.Number 3) = pure SuccessPartial + parseJSON (A.Number 4) = pure WaitComplete + parseJSON (A.Number 5) = pure SuccessFeed + parseJSON (A.Number 16) = pure ClientErrorType + parseJSON (A.Number 17) = pure CompileErrorType + parseJSON (A.Number 18) = pure RuntimeErrorType + parseJSON _ = fail "ResponseType" + + + +data Response = Response + { responseToken :: !Token + , responseType :: !ResponseType + , responseResult :: !(Vector Value) + --, responseBacktrace :: () + --, responseProfile :: () + } deriving (Show, Eq) + + + +responseParser :: Token -> Value -> Parser Response +responseParser token (A.Object o) = + Response <$> pure token <*> o .: "t" <*> o .: "r" +responseParser _ _ = + fail "Response: Unexpected JSON value" + + + + +------------------------------------------------------------------------------ +-- Errors + +data Error + = ProtocolError !Text + -- ^ An error on the protocol level. Perhaps the socket was closed + -- unexpectedly, or the server sent a message which the driver could + -- not parse. + + | ClientError + | CompileError + | RuntimeError + deriving (Eq, Show) diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main where + +import Control.Applicative + +import Test.Hspec +import Test.SmallCheck +import Test.SmallCheck.Series +import Test.Hspec.SmallCheck + +import Database.RethinkDB + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HMS +import Data.Text (Text) +import qualified Data.Text as T +import Data.Vector (Vector) +import qualified Data.Vector as V + + + +instance Monad m => Serial m Datum +instance Monad m => Serial m Text where + series = decDepth $ T.pack <$> series +instance Monad m => Serial m (HashMap Text Datum) where + series = decDepth $ HMS.fromList <$> series +instance Monad m => Serial m (Vector Datum) where + series = decDepth $ V.fromList <$> series + + + + +main :: IO () +main = do + h <- newHandle + hspec $ spec h + + +spec :: Handle -> Spec +spec h = do + + -- The roundtrips test whether the driver generates the proper terms + -- and the server responds with what the driver expects. + describe "roundtrips" $ do + describe "primitive values" $ do + it "Double" $ property $ \(x :: Double) -> + monadic $ ((Right x)==) <$> run h (constant x) + it "Text" $ property $ \(x :: Text) -> + monadic $ ((Right x)==) <$> run h (constant x) + it "Array" $ property $ \(x :: Array) -> + monadic $ ((Right x)==) <$> run h (constant x) + it "Object" $ property $ \(x :: Object) -> + monadic $ ((Right x)==) <$> run h (constant x) + it "Datum" $ property $ \(x :: Datum) -> + monadic $ ((Right x)==) <$> run h (constant x) + + describe "pure functions" $ do + it "add" $ property $ \(xs0 :: [Double]) -> monadic $ do + -- The list must not be empty, so we prepend a zero to it. + let xs = 0 : xs0 + res <- run h $ add $ map constant xs + return $ res == (Right $ sum xs)