rethinkdb-client-driver 0.0.0.1 → 0.0.0.2

raw patch · 6 files changed

+810/−260 lines, 6 filesdep +mtldep +old-localedep +timedep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: mtl, old-locale, time

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• rethinkdb-client-driver.cabal +7/−4
• src/Database/RethinkDB.hs +50/−22
• src/Database/RethinkDB/Messages.hs +18/−11
• src/Database/RethinkDB/Terms.hs +0/−70
• src/Database/RethinkDB/Types.hs +648/−139
• test/Test.hs +87/−14

@@ -1,5 +1,5 @@ name:                   rethinkdb-client-driver-version:                0.0.0.1+version:                0.0.0.2 license:                MIT license-file:           LICENSE author:                 Tomas Carnecky@@ -33,20 +33,22 @@     default-language  : Haskell2010     hs-source-dirs    : src -    build-depends     : base       >= 4.6 && < 4.7+    build-depends     : base < 4.8                       , aeson                       , binary     >= 0.7.2.1                       , bytestring                       , hashable+                      , mtl                       , network+                      , old-locale                       , scientific                       , text+                      , time                       , unordered-containers                       , vector      exposed-modules   : Database.RethinkDB     other-modules     : Database.RethinkDB.Messages-                      , Database.RethinkDB.Terms                       , Database.RethinkDB.Types      ghc-options       : -Wall@@ -59,7 +61,7 @@     main-is           : Test.hs     type              : exitcode-stdio-1.0 -    build-depends     : base       >= 4.6 && < 4.7+    build-depends     : base < 4.8                       , hspec                       , smallcheck                       , hspec-smallcheck@@ -68,3 +70,4 @@                       , vector                       , text                       , unordered-containers+                      , time

@@ -3,27 +3,31 @@  module Database.RethinkDB     ( Handle-    , newHandle+    , defaultPort, newHandle     , run, nextChunk, collect      , Error(..) -    , Exp-    , Array, Object, Datum(..)+    , Term, Exp(..), SomeExp(..)+    , FromRSON(..), ToRSON(..)+    , Array, Object, Datum(..), Bound(..), Order(..)     , Sequence-    , constant     , Table, Database, SingleSelection-    , Res+    , Res, Result, FromResponse     , emptyOptions--    , Any, IsDatum, IsObject, IsSequence+    , eqTime+    , lift+    , call1, call2 -    , module Database.RethinkDB.Terms+    , IsDatum, IsObject, IsSequence     ) where   import           Data.Monoid      ((<>))++import           Data.Text        (Text) import qualified Data.Text        as T+ import qualified Data.Vector      as V import qualified Data.Aeson.Types as A @@ -31,7 +35,6 @@ import           Data.IORef  import           Database.RethinkDB.Types-import           Database.RethinkDB.Terms import           Database.RethinkDB.Messages  @@ -44,14 +47,19 @@     }  +-- | The default port where RethinkDB accepts cliend driver connections.+defaultPort :: Int+defaultPort = 28015++ -- | Create a new handle to the RethinkDB server.-newHandle :: IO Handle-newHandle = do-    sock <- createSocket+newHandle :: Text -> Int -> Maybe Text -> IO Handle+newHandle host port mbAuth = do+    sock <- createSocket host port      -- Do the handshake dance. Note that we currently ignore the reply and     -- assume it is "SUCCESS".-    sendMessage sock handshakeMessage+    sendMessage sock (handshakeMessage mbAuth)     _reply <- recvMessage sock handshakeReplyParser      -- RethinkDB seems to expect the token to never be null. So we start with@@ -64,7 +72,7 @@ -- | 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))+run :: (Term a, FromResponse (Result a))     => Handle -> Exp a -> IO (Res a) run handle expr = do     _token <- start handle expr@@ -72,11 +80,24 @@      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+        Right response -> case responseType response of+            ClientErrorType  -> mkError response ClientError+            CompileErrorType -> mkError response CompileError+            RuntimeErrorType -> mkError response RuntimeError+            _                -> return $ parseMessage parseResponse response Right +parseMessage :: (a -> A.Parser b) -> a -> (b -> Either Error c) -> Either Error c+parseMessage parser value f = case A.parseEither parser value of+    Left  e -> Left $ ProtocolError $ T.pack e+    Right v -> f v +mkError :: Response -> (T.Text -> Error) -> IO (Either Error a)+mkError r e = return $ case V.toList (responseResult r) of+    [a] -> parseMessage A.parseJSON a (Left . e)+    _   -> Left $ ProtocolError $ "mkError: Could not parse error" <> T.pack (show (responseResult r))+++ -- | Collect all the values in a sequence and make them available as -- a 'Vector a'. collect :: (FromResponse (Sequence a))@@ -96,12 +117,21 @@  -- | Start a new query. Returns the 'Token' which can be used to track its -- progress.-start :: (Any a) => Handle -> Exp a -> IO Token+start :: (Term a) => Handle -> a -> IO Token start handle term = do     token <- atomicModifyIORef (hTokenRef handle) (\x -> (x + 1, x))-    sendMessage (hSocket handle) (queryMessage token (Start term []))+    sendMessage (hSocket handle) (queryMessage token msg)     return token +  where+    msg = compileTerm $ do+        term'    <- toTerm term+        options' <- toTerm emptyOptions+        return $ A.Array $ V.fromList+            [ A.Number 1+            , term'+            , A.toJSON $ options'+            ]   singleElementArray :: Int -> A.Value@@ -141,9 +171,7 @@     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+        Right response -> return $ parseMessage parseResponse response Right   getResponse :: Handle -> IO (Either Error Response)

@@ -8,8 +8,8 @@ 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.Aeson           as A hiding (Result, Object)+import           Data.Aeson.Types     as A hiding (Result, Object)  import           Data.ByteString.Lazy (toStrict) import qualified Data.ByteString.Lazy as BS@@ -28,9 +28,9 @@   -createSocket :: IO Socket-createSocket = do-    ai:_ <- getAddrInfo (Just hints) (Just "localhost") (Just "28015")+createSocket :: Text -> Int -> IO Socket+createSocket host port = do+    ai:_ <- getAddrInfo (Just hints) (Just $ T.unpack host) (Just $ show port)     sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai)     connect sock (addrAddress ai)     return sock@@ -54,19 +54,26 @@   -handshakeMessage :: BS.ByteString-handshakeMessage = runPut $ do-    putWord32le 0x5f75e83e -- V0_3-    putWord32le 0          -- No authentication-    putWord32le 0x7e6970c7 -- JSON+handshakeMessage :: Maybe Text -> BS.ByteString+handshakeMessage mbAuth = runPut $ do+    -- Protocol version: V0_3+    putWord32le 0x5f75e83e +    -- Authentication+    flip (maybe (putWord32le 0)) mbAuth $ \auth -> do+        putWord32le   $ fromIntegral $ T.length auth+        putByteString $ T.encodeUtf8 auth +    -- Protocol type: JSON+    putWord32le 0x7e6970c7++ handshakeReplyParser :: Get Text handshakeReplyParser = do     (T.decodeUtf8 . toStrict) <$> getLazyByteStringNul  -queryMessage :: (ToJSON a) => Token -> a -> BS.ByteString+queryMessage :: Token -> A.Value -> BS.ByteString queryMessage token msg = runPut $ do     putWord64host     token     putWord32le       (fromIntegral $ BS.length buf)

@@ -1,70 +0,0 @@-{-# 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

@@ -10,17 +10,23 @@   import           Control.Applicative+import           Control.Monad+import           Control.Monad.State (State, gets, modify, evalState) +import           Data.Function import           Data.Word import           Data.String-import           Data.Text (Text)+import           Data.Text           (Text)+import           Data.Time+import           System.Locale       (defaultTimeLocale)+import           Data.Time.Clock.POSIX -import           Data.Aeson          (FromJSON(..), ToJSON(..), (.:))+import           Data.Aeson          ((.:), (.=), FromJSON, parseJSON, toJSON) import           Data.Aeson.Types    (Parser, Value)-import qualified Data.Aeson       as A+import qualified Data.Aeson          as A -import           Data.Vector (Vector)-import qualified Data.Vector as V+import           Data.Vector         (Vector)+import qualified Data.Vector         as V import           Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HMS @@ -29,17 +35,58 @@   --------------------------------------------------------------------------------- | 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.+-- | A Term is a JSON expression which can be sent to the server. Building a+-- term is a stateful operation, so the whole process happens inside a 'State'+-- monad. -class (ToJSON a) => Any a+class Term a where+    toTerm :: a -> State Context A.Value +instance Term A.Value where+    toTerm = return  + ------------------------------------------------------------------------------+-- | A class describing a type which can be converted to the RethinkDB-specific+-- wire protocol. It is based on JSON, but certain types use a presumably more+-- efficient encoding.++class FromRSON a where+    parseRSON :: A.Value -> Parser a++------------------------------------------------------------------------------+-- | See 'FromRSON'.++class ToRSON a where+    toRSON :: a -> A.Value++++------------------------------------------------------------------------------+-- | Building a RethinkDB query from an expression is a stateful process, and+-- is done using this as the context.++data Context = Context+    { varCounter :: Int+      -- ^ How many 'Var's have been allocated. See 'newVar'.+    }+++compileTerm :: State Context A.Value -> A.Value+compileTerm e = evalState e (Context 0)+++-- | Allocate a new var index from the context.+newVar :: State Context Int+newVar = do+    ix <- gets varCounter+    modify $ \s -> s { varCounter = ix + 1 }+    return ix++++------------------------------------------------------------------------------ -- | A sumtype covering all the primitive types which can appear in queries -- or responses. @@ -48,36 +95,52 @@     | Bool   !Bool     | Number !Double     | String !Text-    | Array  !Array+    | Array  !(Array Datum)     | Object !Object-    deriving (Eq, Show, Generic)+    | Time   !ZonedTime+    deriving (Show, Generic)  -class (Any a) => IsDatum a+class (Term 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+-- | We can't automatically derive 'Eq' because 'ZonedTime' does not have an+-- instance of 'Eq'. See the 'eqTime' function for why we can compare times.+instance Eq Datum where+    (Null    ) == (Null    ) = True+    (Bool   x) == (Bool   y) = x == y+    (Number x) == (Number y) = x == y+    (String x) == (String y) = x == y+    (Array  x) == (Array  y) = x == y+    (Object x) == (Object y) = x == y+    (Time   x) == (Time   y) = x `eqTime` y+    _          == _          = False -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+instance ToRSON Datum where+    toRSON (Null    ) = A.Null+    toRSON (Bool   x) = toRSON x+    toRSON (Number x) = toRSON x+    toRSON (String x) = toRSON x+    toRSON (Array  x) = toRSON x+    toRSON (Object x) = toRSON x+    toRSON (Time   x) = toRSON x++instance FromRSON Datum where+    parseRSON   (A.Null    ) = pure Null+    parseRSON   (A.Bool   x) = pure $ Bool x+    parseRSON   (A.Number x) = pure $ Number (realToFrac x)+    parseRSON   (A.String x) = pure $ String x+    parseRSON   (A.Array  x) = Array <$> V.mapM parseRSON x+    parseRSON a@(A.Object x) = (Time <$> parseRSON a) <|> do         -- HashMap does not provide a mapM, what a shame :(-        items <- mapM (\(k, v) -> (,) <$> pure k <*> parseJSON v) $ HMS.toList x+        items <- mapM (\(k, v) -> (,) <$> pure k <*> parseRSON v) $ HMS.toList x         return $ Object $ HMS.fromList items +instance Term Datum where+    toTerm = return . toRSON+ instance FromResponse Datum where     parseResponse = responseAtomParser @@ -86,62 +149,96 @@ ------------------------------------------------------------------------------ -- | For a boolean type, we're reusing the standard Haskell 'Bool' type. -instance Any     Bool instance IsDatum Bool  instance FromResponse Bool where     parseResponse = responseAtomParser +instance FromRSON Bool where+    parseRSON = parseJSON +instance ToRSON Bool where+    toRSON = toJSON +instance Term Bool where+    toTerm = return . toRSON+++ ------------------------------------------------------------------------------ -- | Numbers are 'Double' (unlike 'Aeson', which uses 'Scientific'). No -- particular reason. -instance Any     Double instance IsDatum Double  instance FromResponse Double where     parseResponse = responseAtomParser +instance FromRSON Double where+    parseRSON = parseJSON +instance ToRSON Double where+    toRSON = toJSON +instance Term Double where+    toTerm = return . toRSON+++ ------------------------------------------------------------------------------ -- | For strings, we're using the Haskell 'Text' type. -instance Any     Text instance IsDatum Text  instance FromResponse Text where     parseResponse = responseAtomParser +instance FromRSON Text where+    parseRSON = parseJSON +instance ToRSON Text where+    toRSON = toJSON +instance Term Text where+    toTerm = return . toRSON+++ ------------------------------------------------------------------------------ -- | Arrays are vectors of 'Datum'. -type Array = Vector Datum+type Array a = Vector a -instance Any     Array-instance IsDatum Array+instance (IsDatum a) => IsDatum    (Array a)+instance (IsDatum a) => IsSequence (Array a) -instance FromResponse Array where+instance (FromRSON a) => FromResponse (Array a) 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+-- Arrays are encoded as a term MAKE_ARRAY (2).+instance (ToRSON a) => ToRSON (Array a) where+    toRSON v = A.Array $ V.fromList $+        [ A.Number 2+        , toJSON $ map toRSON (V.toList v)+        , toJSON $ toRSON emptyOptions         ] -instance FromJSON Array where-    parseJSON (A.Array v) = V.mapM parseJSON v-    parseJSON _           = fail "Array"+instance (FromRSON a) => FromRSON (Array a) where+    parseRSON (A.Array v) = V.mapM parseRSON v+    parseRSON _           = fail "Array" +instance (Term a) => Term (Array a) where+    toTerm v = do+        vals    <- mapM toTerm (V.toList v)+        options <- toTerm emptyOptions+        return $ A.Array $ V.fromList $+            [ A.Number 2+            , toJSON vals+            , toJSON $ options+            ]  + ------------------------------------------------------------------------------ -- | Objects are maps from 'Text' to 'Datum'. Like 'Aeson', we're using -- 'HashMap'.@@ -149,34 +246,121 @@ type Object = HashMap Text Datum  -class (IsDatum a) => IsObject a+class (Term a, IsDatum a) => IsObject a  -instance Any      Object instance IsDatum  Object instance IsObject Object  instance FromResponse Object where     parseResponse = responseAtomParser +instance FromRSON Object where+    parseRSON (A.Object o) = do+        -- HashMap does not provide a mapM, what a shame :(+        items <- mapM (\(k, v) -> (,) <$> pure k <*> parseRSON v) $ HMS.toList o+        return $ HMS.fromList items +    parseRSON _            = fail "Object" +instance ToRSON Object where+    toRSON = A.Object . HMS.map toRSON++instance Term Object where+    toTerm = return . toRSON+++ ------------------------------------------------------------------------------+-- | Time in RethinkDB is represented similar to the 'ZonedTime' type. Except+-- that the JSON representation on the wire looks different from the default+-- used by 'Aeson'. Therefore we have a custom 'FromRSON' and 'ToRSON'+-- instances.++instance IsDatum  ZonedTime+instance IsObject ZonedTime++instance FromResponse ZonedTime where+    parseResponse = responseAtomParser++instance ToRSON ZonedTime where+    toRSON t = A.object+        [ "$reql_type$" .= ("TIME" :: Text)+        , "timezone"    .= (timeZoneOffsetString $ zonedTimeZone t)+        , "epoch_time"  .= (realToFrac $ utcTimeToPOSIXSeconds $ zonedTimeToUTC t :: Double)+        ]++instance FromRSON ZonedTime where+    parseRSON (A.Object o) = do+        reqlType <- o .: "$reql_type$"+        guard $ reqlType == ("TIME" :: Text)++        -- Parse the timezone using 'parseTime'. This overapproximates the+        -- possible responses from the server, but better than rolling our+        -- own timezone parser.+        tz <- o .: "timezone" >>= \tz -> case parseTime defaultTimeLocale "%Z" tz of+            Just d -> pure d+            _      -> fail "Could not parse TimeZone"++        t <- o .: "epoch_time" :: Parser Double+        return $ utcToZonedTime tz $ posixSecondsToUTCTime $ realToFrac t++    parseRSON _           = fail "Time"++instance Term ZonedTime where+    toTerm = return . toRSON++++-- | Comparing two times is done on the local time, regardless of the timezone.+-- This is exactly how the RethinkDB server does it.+eqTime :: ZonedTime -> ZonedTime -> Bool+eqTime = (==) `on` zonedTimeToUTC++++------------------------------------------------------------------------------+-- UTCTime++instance IsDatum  UTCTime+instance IsObject UTCTime++instance FromResponse UTCTime where+    parseResponse = responseAtomParser++instance ToRSON UTCTime where+    toRSON = toRSON . utcToZonedTime utc++instance FromRSON UTCTime where+    parseRSON v = zonedTimeToUTC <$> parseRSON v++instance Term UTCTime where+    toTerm = return . toRSON++instance Lift Exp UTCTime where+    type Simplified UTCTime = ZonedTime+    lift = Constant . utcToZonedTime utc++++------------------------------------------------------------------------------ -- | 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+data Table = MkTable -instance Any        Table instance IsSequence Table -instance ToJSON Table where-    toJSON = error "toJSON Table: Server-only type"+instance ToRSON Table where+    toRSON = error "toRSON Table: Server-only type" +instance Term Table where+    toTerm = error "toTerm Table: Server-only type"  + ------------------------------------------------------------------------------ -- | 'SingleSelection' is essentially a 'Maybe Object', where 'Nothing' is -- represented with 'Null' in the network protocol.@@ -184,10 +368,9 @@ data SingleSelection = SingleSelection     deriving (Show) -instance ToJSON SingleSelection where-    toJSON = error "toJSON SingleSelection: Server-only type"+instance Term SingleSelection where+    toTerm = error "toTerm SingleSelection: Server-only type" -instance Any      SingleSelection instance IsDatum  SingleSelection instance IsObject SingleSelection @@ -197,15 +380,40 @@ -- | A 'Database' is something which contains tables. It is a server-only -- type. -data Database = Database+data Database = MkDatabase -instance Any Database-instance ToJSON Database where-    toJSON = error "toJSON Database: Server-only type"+instance Term Database where+    toTerm = error "toTerm Database: Server-only type"    ------------------------------------------------------------------------------+-- | Bounds are used in 'Between'.++data Bound = Open !Datum | Closed !Datum++boundDatum :: Bound -> Datum+boundDatum (Open   x) = x+boundDatum (Closed x) = x++boundString :: Bound -> Text+boundString (Open   _) = "open"+boundString (Closed _) = "closed"++++------------------------------------------------------------------------------+-- | Used in 'OrderBy'.++data Order = Ascending !Text | Descending !Text++instance Term Order where+    toTerm (Ascending  key) = simpleTerm 73 [SomeExp $ Constant $ String key]+    toTerm (Descending key) = simpleTerm 74 [SomeExp $ Constant $ String key]++++------------------------------------------------------------------------------ -- | 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@@ -216,133 +424,421 @@     | Partial !Token !(Vector a)  -class Any a => IsSequence a+class (Term 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+instance (FromRSON a) => FromResponse (Sequence a) where     parseResponse = responseSequenceParser -instance ToJSON (Sequence a) where-    toJSON = error "toJSON Sequence: Server-only type"+instance ToRSON (Sequence a) where+    toRSON = error "toRSON Sequence: Server-only type" -instance (Any a) => Any (Sequence a)-instance (Any a) => IsSequence (Sequence a)+instance Term (Sequence a) where+    toTerm = error "toTerm Sequence: Server-only type" +instance 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+data Exp a where+    Constant :: (ToRSON a) => a -> Exp a+    -- Any object which can be converted to RSON can be treated as a constant.+    -- Furthermore, many basic Haskell types have a 'Lift' instance which turns+    -- their values into constants.  -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+    --------------------------------------------------------------------------+    -- Database administration +    ListDatabases  :: Exp (Array Text)+    CreateDatabase :: Exp Text -> Exp Object+    DropDatabase   :: Exp Text -> Exp Object  -------------------------------------------------------------------------------+    --------------------------------------------------------------------------+    -- Table administration -data Exp a where-    Constant :: (IsDatum a) => a -> Exp a-    Term     :: TermType -> [SomeExp] -> Object -> Exp a+    ListTables     :: Exp Database -> Exp (Array Text)+    CreateTable    :: Exp Database -> Exp Text -> Exp Object+    DropTable      :: Exp Database -> Exp Text -> Exp Object  -instance (ToJSON a) => ToJSON (Exp a) where-    toJSON (Constant datum) =-        toJSON datum+    --------------------------------------------------------------------------+    -- Index administration -    toJSON (Term termType args opts) =-        toJSON [toJSON termType, toJSON args, toJSON opts]+    ListIndices    :: Exp Table -> Exp (Array Text) +    CreateIndex    :: Exp Table -> Exp Text -> (Exp Object -> Exp Datum) -> Exp Object+    -- Create a new secondary index on the table. The index has a name and a+    -- projection function which is applied to every object which is added to the table. +    DropIndex      :: Exp Table -> Exp Text -> Exp Object+    IndexStatus    :: Exp Table -> [Exp Text] -> Exp (Array Object)+    WaitIndex      :: Exp Table -> [Exp Text] -> Exp Object+++    Database       :: Exp Text -> Exp Database+    Table          :: Exp Text -> Exp Table++    Coerce         :: (Term a, Term b) => Exp a -> Exp Text -> Exp b+    Eq             :: (IsDatum a, IsDatum b) => Exp a -> Exp b -> Exp Bool+    Ne             :: (IsDatum a, IsDatum b) => Exp a -> Exp b -> Exp Bool+    Match          :: Exp Text -> Exp Text -> Exp Datum+    Get            :: Exp Table -> Exp Text -> Exp SingleSelection+    GetAll         :: (IsDatum a) => Exp Table -> [Exp a] -> Exp (Array Datum)+    GetAllIndexed  :: (IsDatum a) => Exp Table -> [Exp a] -> Text -> Exp (Sequence Datum)++    Add            :: (Num a) => [Exp a] -> Exp a+    Multiply       :: (Num a) => [Exp a] -> Exp a++    All :: [Exp Bool] -> Exp Bool+    -- True if all the elements in the input are True.++    Any :: [Exp Bool] -> Exp Bool+    -- True if any element in the input is True.++    ObjectField :: (IsObject a, IsDatum r) => Exp a -> Exp Text -> Exp r+    -- Get a particular field from an object (or SingleSelection).++    ExtractField :: (IsSequence a) => Exp a -> Exp Text -> Exp a+    -- Like 'ObjectField' but over a sequence.++    Take           :: (IsSequence s) => Exp Double -> Exp s -> Exp s+    Append         :: (IsDatum a) => Exp (Array a) -> Exp a -> Exp (Array a)+    Prepend        :: (IsDatum a) => Exp (Array a) -> Exp a -> Exp (Array a)+    IsEmpty        :: (IsSequence a) => Exp a -> Exp Bool+    Delete         :: (Term a) => Exp a -> Exp Object++    InsertObject   :: Exp Table -> Object -> Exp Object+    -- Insert a single object into the table.++    InsertSequence :: (IsSequence s) => Exp Table -> Exp s -> Exp Object+    -- Insert a sequence into the table.++    Filter :: (IsSequence s, Term a) => (Exp a -> Exp Bool) -> Exp s -> Exp s+    Map :: (IsSequence s, Term a, Term b) => (Exp a -> Exp b) -> Exp s -> Exp s++    Between :: (IsSequence s) => Exp s -> (Bound, Bound) -> Exp s+    -- Select all elements whose primary key is between the two bounds.++    BetweenIndexed :: (IsSequence s) => Exp s -> (Bound, Bound) -> Text -> Exp s+    -- Select all elements whose secondary index is between the two bounds.++    OrderBy :: (IsSequence s) => [Order] -> Exp s -> Exp s+    -- Order a sequence based on the given order specificiation.++    Keys :: (IsObject a) => Exp a -> Exp (Array Text)++    Var :: Int -> Exp a+    -- A 'Var' is used as a placeholder in input to functions.++    Function :: (Term a) => State Context ([Int], Exp a) -> Exp f+    -- Creates a function. The action should take care of allocating an+    -- appropriate number of variables from the context. Note that you should+    -- not use this constructor directly. There are 'Lift' instances for all+    -- commonly used functions.++    Call :: (Term f) => Exp f -> [SomeExp] -> Exp r+    -- Call the given function. The function should take the same number of+    -- arguments as there are provided.+++instance (Term a) => Term (Exp a) where+    toTerm (Constant datum) =+        toTerm datum+++    toTerm ListDatabases =+        simpleTerm 59 []++    toTerm (CreateDatabase name) =+        simpleTerm 57 [SomeExp name]++    toTerm (DropDatabase name) =+        simpleTerm 58 [SomeExp name]+++    toTerm (ListTables db) =+        simpleTerm 62 [SomeExp db]++    toTerm (CreateTable db name) =+        simpleTerm 60 [SomeExp db, SomeExp name]++    toTerm (DropTable db name) =+        simpleTerm 61 [SomeExp db, SomeExp name]+++    toTerm (ListIndices table) =+        simpleTerm 77 [SomeExp table]++    toTerm (CreateIndex table name f) =+        simpleTerm 75 [SomeExp table, SomeExp name, SomeExp (lift f)]++    toTerm (DropIndex table name) =+        simpleTerm 76 [SomeExp table, SomeExp name]++    toTerm (IndexStatus table indices) =+        simpleTerm 139 ([SomeExp table] ++ map SomeExp indices)++    toTerm (WaitIndex table indices) =+        simpleTerm 140 ([SomeExp table] ++ map SomeExp indices)+++    toTerm (Database name) =+        simpleTerm 14 [SomeExp name]++    toTerm (Table name) =+        simpleTerm 15 [SomeExp name]++    toTerm (Filter f s) =+        simpleTerm 39 [SomeExp s, SomeExp (lift f)]++    toTerm (Map f s) =+        simpleTerm 38 [SomeExp s, SomeExp (lift f)]++    toTerm (Between s (l, u)) =+        termWithOptions 36 [SomeExp s, SomeExp $ lift (boundDatum l), SomeExp $ lift (boundDatum u)] $+            HMS.fromList+                [ ("left_bound",  String (boundString l))+                , ("right_bound", String (boundString u))+                ]++    toTerm (BetweenIndexed s (l, u) index) =+        termWithOptions 36 [SomeExp s, SomeExp $ lift (boundDatum l), SomeExp $ lift (boundDatum u)] $+            HMS.fromList+                [ ("left_bound",  String (boundString l))+                , ("right_bound", String (boundString u))+                , ("index",       String index)+                ]++    toTerm (OrderBy spec s) = do+        s'    <- toTerm s+        spec' <- mapM toTerm spec+        simpleTerm2 41 ([s'] ++ spec')++    toTerm (InsertObject table object) =+        termWithOptions 56 [SomeExp table, SomeExp (lift object)] emptyOptions++    toTerm (InsertSequence table s) =+        termWithOptions 56 [SomeExp table, SomeExp s] emptyOptions++    toTerm (Delete selection) =+        simpleTerm 54 [SomeExp selection]++    toTerm (ObjectField object field) =+        simpleTerm 31 [SomeExp object, SomeExp field]++    toTerm (ExtractField object field) =+        simpleTerm 31 [SomeExp object, SomeExp field]++    toTerm (Coerce value typeName) =+        simpleTerm 51 [SomeExp value, SomeExp typeName]++    toTerm (Add values) =+        simpleTerm 24 (map SomeExp values)++    toTerm (Multiply values) =+        simpleTerm 26 (map SomeExp values)++    toTerm (All values) =+        simpleTerm 67 (map SomeExp values)++    toTerm (Any values) =+        simpleTerm 66 (map SomeExp values)++    toTerm (Eq a b) =+        simpleTerm 17 [SomeExp a, SomeExp b]++    toTerm (Ne a b) =+        simpleTerm 18 [SomeExp a, SomeExp b]++    toTerm (Match a b) =+        simpleTerm 97 [SomeExp a, SomeExp b]++    toTerm (Get table key) =+        simpleTerm 16 [SomeExp table, SomeExp key]++    toTerm (GetAll table keys) =+        simpleTerm 78 ([SomeExp table] ++ map SomeExp keys)++    toTerm (GetAllIndexed table keys index) =+        termWithOptions 78 ([SomeExp table] ++ map SomeExp keys)+            (HMS.singleton "index" (String index))++    toTerm (Take n s) =+        simpleTerm 71 [SomeExp s, SomeExp n]++    toTerm (Append array value) =+        simpleTerm 29 [SomeExp array, SomeExp value]++    toTerm (Prepend array value) =+        simpleTerm 80 [SomeExp array, SomeExp value]++    toTerm (IsEmpty s) =+        simpleTerm 86 [SomeExp s]++    toTerm (Keys a) =+        simpleTerm 94 [SomeExp a]++    toTerm (Var a) =+        simpleTerm 10 [SomeExp $ lift $ (fromIntegral a :: Double)]++    toTerm (Function a) = do+        (vars, f) <- a+        simpleTerm 69 [SomeExp $ Constant $ V.fromList $ map (Number . fromIntegral) vars, SomeExp f]++    toTerm (Call f args) =+        simpleTerm 64 ([SomeExp f] ++ args)+++simpleTerm :: Int -> [SomeExp] -> State Context A.Value+simpleTerm termType args = do+    args' <- mapM toTerm args+    return $ A.Array $ V.fromList [toJSON termType, toJSON args']++simpleTerm2 :: (Term a) => Int -> [a] -> State Context A.Value+simpleTerm2 termType args = do+    args' <- mapM toTerm args+    return $ A.Array $ V.fromList [toJSON termType, toJSON args']++termWithOptions :: Int -> [SomeExp] -> Object -> State Context A.Value+termWithOptions termType args options = do+    args'    <- mapM toTerm args+    options' <- toTerm options++    return $ A.Array $ V.fromList [toJSON termType, toJSON args', toJSON options']++ -- | Convenience to for automatically converting a 'Text' to a constant -- expression. instance IsString (Exp Text) where-   fromString = constant . fromString+    fromString = lift . (fromString :: String -> Text)  --- | Convert a 'Datum' to an 'Exp'.-constant :: (IsDatum a) => a -> Exp a-constant x = Constant x+instance Num (Exp Double) where+    fromInteger = Constant . fromInteger +    a + b = Add [a, b]+    a * b = Multiply [a, b] -emptyOptions :: Object-emptyOptions = HMS.empty+    abs _    = error "Num (Exp a): abs not implemented"+    signum _ = error "Num (Exp a): signum not implemented"    --------------------------------------------------------------------------------- | Because the arguments to functions are polymorphic (the individual--- arguments can, and often have, different types).+-- | The class of types e which can be lifted into c. All basic Haskell types+-- which can be represented as 'Exp' are instances of this, as well as certain+-- types of functions (unary and binary). -data SomeExp where-     SomeExp :: (ToJSON a, Any a) => Exp a -> SomeExp+class Lift c e where+    -- | Type-level function which simplifies the type of @e@ once it is lifted+    -- into @c@. This is used for functions where we strip the signature so+    -- that we don't have to define dummy 'Term' instances for those.+    type Simplified e -instance ToJSON SomeExp where-    toJSON (SomeExp e) = toJSON e+    lift :: e -> c (Simplified e)  +instance Lift Exp Bool where+    type Simplified Bool = Bool+    lift = Constant +instance Lift Exp Double where+    type Simplified Double = Double+    lift = Constant++instance Lift Exp Text where+    type Simplified Text = Text+    lift = Constant++instance Lift Exp Object where+    type Simplified Object = Object+    lift = Constant++instance Lift Exp Datum where+    type Simplified Datum = Datum+    lift = Constant++instance Lift Exp ZonedTime where+    type Simplified ZonedTime = ZonedTime+    lift = Constant++instance Lift Exp (Array Datum) where+    type Simplified (Array Datum) = (Array Datum)+    lift = Constant++instance (Term r) => Lift Exp (Exp a -> Exp r) where+    type Simplified (Exp a -> Exp r) = Exp r+    lift f = Function $ do+        v1 <- newVar+        return $ ([v1], f (Var v1))++instance (Term r) => Lift Exp (Exp a -> Exp b -> Exp r) where+    type Simplified (Exp a -> Exp b -> Exp r) = Exp r+    lift f = Function $ do+        v1 <- newVar+        v2 <- newVar+        return $ ([v1, v2], f (Var v1) (Var v2))+++ --------------------------------------------------------------------------------- Query+-- 'call1', 'call2' etc generate a function call expression. These should be+-- used instead of the 'Call' constructor because they provide type safety. -data Query a-    = Start (Exp a) [(Text, SomeExp)]-    | Continue-    | Stop-    | NoreplyWait+-- | Call an unary function with the given argument.+call1 :: (Term a, Term r)+      => (Exp a -> Exp r)+      -> Exp a+      -> Exp r+call1 f a = Call (lift f) [SomeExp a] -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) +-- | Call an binary function with the given arguments.+call2 :: (Term a, Term b, Term r)+      => (Exp a -> Exp b -> Exp r)+      -> Exp a -> Exp b+      -> Exp r+call2 f a b = Call (lift f) [SomeExp a, SomeExp b]  +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 :: (Term a) => Exp a -> SomeExp++instance Term SomeExp where+    toTerm (SomeExp e) = toTerm e++++------------------------------------------------------------------------------ -- | 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 ZonedTime       = ZonedTime  type instance Result Table           = Sequence Datum type instance Result Datum           = Datum type instance Result Object          = Object-type instance Result Array           = Array+type instance Result (Array a)       = Array a type instance Result SingleSelection = Maybe Datum type instance Result (Sequence a)    = Sequence a @@ -372,18 +868,18 @@     parseResponse :: Response -> Parser a  -responseAtomParser :: (FromJSON a) => Response -> Parser a+responseAtomParser :: (FromRSON a) => Response -> Parser a responseAtomParser r = case (responseType r, V.toList (responseResult r)) of-    (SuccessAtom, [a]) -> parseJSON a+    (SuccessAtom, [a]) -> parseRSON a     _                  -> fail $ "responseAtomParser: Not a single-element vector " ++ show (responseResult r) -responseSequenceParser :: (FromJSON a) => Response -> Parser (Sequence a)+responseSequenceParser :: (FromRSON 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)+    values = V.mapM parseRSON (responseResult r)   @@ -433,17 +929,30 @@   - --------------------------------------------------------------------------------- Errors+-- | Errors include a plain-text description which includes further details.+-- The RethinkDB protocol also includes a backtrace which we currently don't+-- parse.  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.+      -- unexpectedly, or the server sent a message which the driver could not+      -- parse. -    | ClientError-    | CompileError-    | RuntimeError+    | ClientError !Text+      -- ^ Means the client is buggy. An example is if the client sends+      -- a malformed protobuf, or tries to send [CONTINUE] for an unknown+      -- token.++    | CompileError !Text+      -- ^ Means the query failed during parsing or type checking. For example,+      -- if you pass too many arguments to a function.++    | RuntimeError !Text+      -- ^ Means the query failed at runtime. An example is if you add+      -- together two values from a table, but they turn out at runtime to be+      -- booleans rather than numbers.+     deriving (Eq, Show)

@@ -16,21 +16,38 @@  import           Database.RethinkDB +import           Data.Monoid         ((<>))+import           Data.Function+import           Data.List 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+import           Data.Time+import           Data.Time.Clock.POSIX    instance Monad m => Serial m Datum++instance Monad m => Serial m UTCTime where+    series = decDepth $ fromInt <$> series+      where+        fromInt :: Int -> UTCTime+        fromInt = posixSecondsToUTCTime . fromIntegral++instance Monad m => Serial m ZonedTime where+    series = decDepth $ utcToZonedTime utc <$> series+ 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++instance (Monad m, Serial m a) => Serial m (Vector a) where     series = decDepth $ V.fromList <$> series  @@ -38,10 +55,18 @@  main :: IO () main = do-    h <- newHandle+    h <- newHandle "localhost" defaultPort Nothing     hspec $ spec h  +expectSuccess+    :: (Term a, Eq (Result a), FromResponse (Result a), Show (Result a))+    => Handle -> Exp a -> Result a -> IO Bool+expectSuccess h query value = do+    res <- run h query+    return $ res == Right value++ spec :: Handle -> Spec spec h = do @@ -50,19 +75,67 @@     describe "roundtrips" $ do         describe "primitive values" $ do             it "Double" $ property $ \(x :: Double) ->-                monadic $ ((Right x)==) <$> run h (constant x)+                monadic $ ((Right x)==) <$> run h (lift 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)+                monadic $ ((Right x)==) <$> run h (lift x)+            it "Array" $ property $ \(x :: Array Datum) ->+                monadic $ ((Right x)==) <$> run h (lift x)             it "Object" $ property $ \(x :: Object) ->-                monadic $ ((Right x)==) <$> run h (constant x)+                monadic $ ((Right x)==) <$> run h (lift x)             it "Datum" $ property $ \(x :: Datum) ->-                monadic $ ((Right x)==) <$> run h (constant x)+                monadic $ ((Right x)==) <$> run h (lift x)+            it "ZonedTime" $ property $ \(x :: ZonedTime) ->+                monadic $ (on (==) (fmap zonedTimeToUTC) (Right x)) <$> run h (lift 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)+    describe "function expressions" $ 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+            expectSuccess h (Add $ map lift xs) (sum xs)++        it "All" $ property $ \(xs0 :: [Bool]) -> monadic $ do+            let xs = True : xs0+            expectSuccess h (All $ map lift xs) (and xs)++        it "Any" $ property $ \(xs0 :: [Bool]) -> monadic $ do+            let xs = True : xs0+            expectSuccess h (Any $ map lift xs) (or xs)++        it "Eq" $ property $ \(a :: Datum, b :: Datum) -> monadic $ do+            expectSuccess h (Eq (lift a) (lift b)) (a == b)++        it "Ne" $ property $ \(a :: Datum, b :: Datum) -> monadic $ do+            expectSuccess h (Ne (lift a) (lift b)) (a /= b)++        it "Match" $ property $ \() -> monadic $ do+            expectSuccess h (Match "foobar" "^f(.)$") Null++        it "Append" $ property $ \(xs :: Array Datum, v :: Datum) -> monadic $ do+            expectSuccess h (Append (lift xs) (lift v)) (V.snoc xs v)++        it "Prepend" $ property $ \(xs :: Array Datum, v :: Datum) -> monadic $ do+            expectSuccess h (Prepend (lift xs) (lift v)) (V.cons v xs)++        it "IsEmpty" $ property $ \(xs :: Array Datum) -> monadic $ do+            expectSuccess h (IsEmpty (lift xs)) (V.null xs)++        it "Keys" $ property $ \(xs :: Array Text) -> monadic $ do+            let obj = HMS.fromList $ map (\x -> (x, String x)) $ V.toList xs+            res0 <- run h $ Keys (lift obj)+            let res = fmap (sort . V.toList) res0+            return $ res == (Right $ nub $ sort $ V.toList xs)++    describe "function calls" $ do+        it "Add" $ property $ \(a :: Double, b :: Double) -> monadic $ do+            res <- run h $ call2 (+) (lift a) (lift b)+            return $ res == (Right $ a + b)++            res <- run h $ call1 (1+) (lift a)+            return $ res == (Right $ a + 1)++        it "Multiply" $ property $ \(a :: Double, b :: Double) -> monadic $ do+            res <- run h $ call2 (*) (lift a) (lift b)+            return $ res == (Right $ a * b)++            res <- run h $ call1 (3*) (lift a)+            return $ res == (Right $ a * 3)