diff --git a/rethinkdb-client-driver.cabal b/rethinkdb-client-driver.cabal --- a/rethinkdb-client-driver.cabal +++ b/rethinkdb-client-driver.cabal @@ -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 diff --git a/src/Database/RethinkDB.hs b/src/Database/RethinkDB.hs --- a/src/Database/RethinkDB.hs +++ b/src/Database/RethinkDB.hs @@ -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) diff --git a/src/Database/RethinkDB/Messages.hs b/src/Database/RethinkDB/Messages.hs --- a/src/Database/RethinkDB/Messages.hs +++ b/src/Database/RethinkDB/Messages.hs @@ -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) diff --git a/src/Database/RethinkDB/Terms.hs b/src/Database/RethinkDB/Terms.hs deleted file mode 100644 --- a/src/Database/RethinkDB/Terms.hs +++ /dev/null @@ -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 diff --git a/src/Database/RethinkDB/Types.hs b/src/Database/RethinkDB/Types.hs --- a/src/Database/RethinkDB/Types.hs +++ b/src/Database/RethinkDB/Types.hs @@ -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) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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)