{-# 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)