packages feed

rethinkdb-client-driver (empty) → 0.0.0.1

raw patch · 8 files changed

+921/−0 lines, 8 filesdep +aesondep +basedep +binarysetup-changed

Dependencies added: aeson, base, binary, bytestring, hashable, hspec, hspec-smallcheck, network, rethinkdb-client-driver, scientific, smallcheck, text, unordered-containers, vector

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ rethinkdb-client-driver.cabal view
@@ -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
+ src/Database/RethinkDB.hs view
@@ -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
+ src/Database/RethinkDB/Messages.hs view
@@ -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+
+ src/Database/RethinkDB/Terms.hs view
@@ -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
+ src/Database/RethinkDB/Types.hs view
@@ -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)
+ test/Test.hs view
@@ -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)