rethinkdb-client-driver 0.0.0.2 → 0.0.3
raw patch · 7 files changed
+501/−242 lines, 7 filesdep +criteriondep ~base
Dependencies added: criterion
Dependency ranges changed: base
Files
- benchmark/Benchmark.hs +43/−0
- rethinkdb-client-driver.cabal +22/−1
- src/Database/RethinkDB.hs +14/−11
- src/Database/RethinkDB/Messages.hs +7/−9
- src/Database/RethinkDB/Types.hs +98/−220
- src/Database/RethinkDB/Types/Datum.hs +316/−0
- test/Test.hs +1/−1
+ benchmark/Benchmark.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+++module Main where++import Control.Monad+import Criterion.Main+import Database.RethinkDB+import qualified Data.HashMap.Strict as HMS+++db :: Exp Database+db = Database "test"++table :: Exp Table+table = Table "benchmark"+++main :: IO ()+main = do+ h <- prepare++ let test name = bench name . nfIO . void . run h++ defaultMain+ [ test "roundtrip" $ lift (0 :: Double)+ , test "point-get" $ Get table "id"+ ]+++prepare :: IO Handle+prepare = do+ h <- newHandle "localhost" defaultPort Nothing++ void $ run h (CreateTable db "benchmark")+ void $ run h (InsertObject table (HMS.singleton "id" (String "id")))++ return h
rethinkdb-client-driver.cabal view
@@ -1,5 +1,5 @@ name: rethinkdb-client-driver-version: 0.0.0.2+version: 0.0.3 license: MIT license-file: LICENSE author: Tomas Carnecky@@ -50,6 +50,7 @@ exposed-modules : Database.RethinkDB other-modules : Database.RethinkDB.Messages , Database.RethinkDB.Types+ , Database.RethinkDB.Types.Datum ghc-options : -Wall @@ -71,3 +72,23 @@ , text , unordered-containers , time+++benchmark bench+ default-language : Haskell2010+ hs-source-dirs : benchmark++ main-is : Benchmark.hs+ type : exitcode-stdio-1.0++ build-depends : base < 4.8+ , criterion++ , rethinkdb-client-driver+ , vector+ , text+ , unordered-containers+ , time++ ghc-options : -Wall -O2 -threaded -rtsopts -with-rtsopts=-N+ ghc-prof-options : "-with-rtsopts=-p -s -h -i0.1 -N"
src/Database/RethinkDB.hs view
@@ -4,18 +4,21 @@ module Database.RethinkDB ( Handle , defaultPort, newHandle- , run, nextChunk, collect+ , run, nextChunk, collect, stop, wait , Error(..) - , Term, Exp(..), SomeExp(..)- , FromRSON(..), ToRSON(..)- , Array, Object, Datum(..), Bound(..), Order(..)+ -- * The Datum type+ , Datum(..), Array, Object, ToDatum(..), FromDatum(..)+ , (.=), (.:), (.:?), object++ -- The Exp type+ , Exp(..), SomeExp(..)+ , Bound(..), Order(..) , Sequence , Table, Database, SingleSelection , Res, Result, FromResponse , emptyOptions- , eqTime , lift , call1, call2 @@ -35,6 +38,7 @@ import Data.IORef import Database.RethinkDB.Types+import Database.RethinkDB.Types.Datum import Database.RethinkDB.Messages @@ -47,7 +51,7 @@ } --- | The default port where RethinkDB accepts cliend driver connections.+-- | The default port where RethinkDB accepts client driver connections. defaultPort :: Int defaultPort = 28015 @@ -72,7 +76,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 :: (Term a, FromResponse (Result a))+run :: (FromResponse (Result a)) => Handle -> Exp a -> IO (Res a) run handle expr = do _token <- start handle expr@@ -100,10 +104,9 @@ -- | Collect all the values in a sequence and make them available as -- a 'Vector a'.-collect :: (FromResponse (Sequence a))- => Handle -> Sequence a -> IO (Either Error (V.Vector a))+collect :: (FromDatum a) => Handle -> Sequence a -> IO (Either Error (V.Vector a)) collect _ (Done x) = return $ Right x-collect handle s@(Partial token x) = do+collect handle s@(Partial _ x) = do chunk <- nextChunk handle s case chunk of Left e -> return $ Left e@@ -117,7 +120,7 @@ -- | Start a new query. Returns the 'Token' which can be used to track its -- progress.-start :: (Term a) => Handle -> a -> IO Token+start :: Handle -> Exp a -> IO Token start handle term = do token <- atomicModifyIORef (hTokenRef handle) (\x -> (x + 1, x)) sendMessage (hSocket handle) (queryMessage token msg)
src/Database/RethinkDB/Messages.hs view
@@ -86,13 +86,11 @@ responseMessageParser = do token <- getWord64host len <- getWord32le- buf <- getLazyByteString (fromIntegral len)-- let (Just v) = A.decode buf :: (Maybe Value)- --trace (show v) $ return ()- case A.parseEither (responseParser token) v of- Left e -> do- --trace ("Response parser " ++ e) $ return ()- fail $ "Response: " ++ e- Right x -> return x+ buf <- getByteString (fromIntegral len) + case A.eitherDecodeStrict buf of+ Left e -> fail $ "responseMessageParser: response is not a JSON value (" ++ e ++ ")"+ Right value -> do+ case A.parseEither (responseParser token) value of+ Left e -> fail $ "responseMessageParser: could not parse response (" ++ e ++ ")"+ Right x -> return x
src/Database/RethinkDB/Types.hs view
@@ -10,27 +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.Time-import System.Locale (defaultTimeLocale) import Data.Time.Clock.POSIX -import Data.Aeson ((.:), (.=), FromJSON, parseJSON, toJSON)+import Data.Aeson (FromJSON, parseJSON, 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+import Database.RethinkDB.Types.Datum @@ -48,22 +44,6 @@ --------------------------------------------------------------------------------- | 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. @@ -86,66 +66,33 @@ ---------------------------------------------------------------------------------- | 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 Datum)- | Object !Object- | Time !ZonedTime- deriving (Show, Generic)---class (Term a) => IsDatum a-+class IsDatum a instance IsDatum Datum --- | 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 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 <*> parseRSON v) $ HMS.toList x- return $ Object $ HMS.fromList items- instance Term Datum where- toTerm = return . toRSON+ toTerm (Null ) = return $ A.Null+ toTerm (Bool x) = toTerm x+ toTerm (Number x) = toTerm x+ toTerm (String x) = toTerm x+ toTerm (Array x) = toTerm x+ toTerm (Object x) = toTerm x+ toTerm (Time x) = toTerm x instance FromResponse Datum where parseResponse = responseAtomParser +instance FromResponse (Maybe Datum) where+ parseResponse r = case (responseType r, V.toList (responseResult r)) of+ (SuccessAtom, [a]) -> do+ res0 <- parseWire a+ case res0 of+ Null -> return Nothing+ res -> return $ Just res+ _ -> fail $ "responseAtomParser: Not a single-element vector " ++ show (responseResult r) + ------------------------------------------------------------------------------ -- | For a boolean type, we're reusing the standard Haskell 'Bool' type. @@ -154,14 +101,8 @@ 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+ toTerm = return . A.Bool @@ -174,14 +115,8 @@ 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+ toTerm = return . toJSON @@ -193,40 +128,20 @@ 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+ toTerm = return . toJSON ------------------------------------------------------------------------------ -- | Arrays are vectors of 'Datum'. -type Array a = Vector a- instance (IsDatum a) => IsDatum (Array a) instance (IsDatum a) => IsSequence (Array a) -instance (FromRSON a) => FromResponse (Array a) where+instance (FromDatum a) => FromResponse (Array a) where parseResponse = responseAtomParser --- 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 (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)@@ -243,10 +158,7 @@ -- | Objects are maps from 'Text' to 'Datum'. Like 'Aeson', we're using -- 'HashMap'. -type Object = HashMap Text Datum---class (Term a, IsDatum a) => IsObject a+class (IsDatum a) => IsObject a instance IsDatum Object@@ -255,19 +167,10 @@ 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+ toTerm x = do+ items <- mapM (\(k, v) -> (,) <$> pure k <*> toTerm v) $ HMS.toList x+ return $ A.Object $ HMS.fromList $ items @@ -283,39 +186,12 @@ 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+ toTerm x = return $ A.object+ [ "$reql_type$" A..= ("TIME" :: Text)+ , "timezone" A..= (timeZoneOffsetString $ zonedTimeZone x)+ , "epoch_time" A..= (realToFrac $ utcTimeToPOSIXSeconds $ zonedTimeToUTC x :: Double)+ ] @@ -328,14 +204,8 @@ 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+ toTerm = toTerm . utcToZonedTime utc instance Lift Exp UTCTime where type Simplified UTCTime = ZonedTime@@ -353,9 +223,6 @@ instance IsSequence Table -instance ToRSON Table where- toRSON = error "toRSON Table: Server-only type"- instance Term Table where toTerm = error "toTerm Table: Server-only type" @@ -424,30 +291,31 @@ | Partial !Token !(Vector a) -class (Term a) => IsSequence a+class IsSequence a instance Show (Sequence a) where show (Done v) = "Done " ++ (show $ V.length v) show (Partial _ v) = "Partial " ++ (show $ V.length v) -instance (FromRSON a) => FromResponse (Sequence a) where+instance (FromDatum a) => FromResponse (Sequence a) where parseResponse = responseSequenceParser -instance ToRSON (Sequence a) where- toRSON = error "toRSON Sequence: Server-only type"- instance Term (Sequence a) where toTerm = error "toTerm Sequence: Server-only type" instance IsSequence (Sequence a) +instance (FromDatum a) => FromDatum (Sequence a) where+ parseDatum (Array x) = Done <$> V.mapM parseDatum x+ parseDatum _ = fail "Sequence" + ------------------------------------------------------------------------------ data Exp a where- Constant :: (ToRSON a) => a -> Exp a+ Constant :: (ToDatum 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.@@ -486,10 +354,14 @@ Database :: Exp Text -> Exp Database Table :: Exp Text -> Exp Table - Coerce :: (Term a, Term b) => Exp a -> Exp Text -> Exp b+ Coerce :: 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+ Not :: Exp Bool -> Exp Bool++ Match :: Exp Text -> Exp Text -> Exp Datum+ -- ^ First arg is the string, second a regular expression.+ 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)@@ -509,11 +381,14 @@ ExtractField :: (IsSequence a) => Exp a -> Exp Text -> Exp a -- Like 'ObjectField' but over a sequence. + HasFields :: (IsObject a) => [Text] -> Exp a -> Exp Bool+ -- True if the object has all the given fields.+ 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+ Delete :: Exp a -> Exp Object InsertObject :: Exp Table -> Object -> Exp Object -- Insert a single object into the table.@@ -521,16 +396,16 @@ 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+ Filter :: (IsSequence s) => (Exp a -> Exp Bool) -> Exp s -> Exp s+ Map :: (IsSequence s) => (Exp a -> Exp b) -> Exp s -> Exp (Sequence b) - Between :: (IsSequence s) => Exp s -> (Bound, Bound) -> Exp s+ Between :: (IsSequence s) => (Bound, Bound) -> Exp s -> Exp s -- Select all elements whose primary key is between the two bounds. - BetweenIndexed :: (IsSequence s) => Exp s -> (Bound, Bound) -> Text -> Exp s+ BetweenIndexed :: (IsSequence s) => Text -> (Bound, Bound) -> Exp s -> Exp s -- Select all elements whose secondary index is between the two bounds. - OrderBy :: (IsSequence s) => [Order] -> Exp s -> Exp s+ OrderBy :: (IsSequence s) => [Order] -> Exp s -> Exp (Array Datum) -- Order a sequence based on the given order specificiation. Keys :: (IsObject a) => Exp a -> Exp (Array Text)@@ -538,24 +413,27 @@ 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+ Function :: 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 :: Exp f -> [SomeExp] -> Exp r -- Call the given function. The function should take the same number of -- arguments as there are provided. + Limit :: (IsSequence s) => Double -> Exp s -> Exp s+ -- ^ Limit the number of items in the sequence. -instance (Term a) => Term (Exp a) where++instance Term (Exp a) where toTerm (Constant datum) =- toTerm datum+ toTerm $ toDatum datum toTerm ListDatabases =- simpleTerm 59 []+ simpleTerm 59 ([] :: [SomeExp]) toTerm (CreateDatabase name) = simpleTerm 57 [SomeExp name]@@ -602,14 +480,14 @@ toTerm (Map f s) = simpleTerm 38 [SomeExp s, SomeExp (lift f)] - toTerm (Between s (l, u)) =+ toTerm (Between (l, u) s) = 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) =+ toTerm (BetweenIndexed index (l, u) s) = termWithOptions 36 [SomeExp s, SomeExp $ lift (boundDatum l), SomeExp $ lift (boundDatum u)] $ HMS.fromList [ ("left_bound", String (boundString l))@@ -620,10 +498,10 @@ toTerm (OrderBy spec s) = do s' <- toTerm s spec' <- mapM toTerm spec- simpleTerm2 41 ([s'] ++ spec')+ simpleTerm 41 ([s'] ++ spec') - toTerm (InsertObject table object) =- termWithOptions 56 [SomeExp table, SomeExp (lift object)] emptyOptions+ toTerm (InsertObject table obj) =+ termWithOptions 56 [SomeExp table, SomeExp (lift obj)] emptyOptions toTerm (InsertSequence table s) = termWithOptions 56 [SomeExp table, SomeExp s] emptyOptions@@ -631,12 +509,15 @@ toTerm (Delete selection) = simpleTerm 54 [SomeExp selection] - toTerm (ObjectField object field) =- simpleTerm 31 [SomeExp object, SomeExp field]+ toTerm (ObjectField obj field) =+ simpleTerm 31 [SomeExp obj, SomeExp field] - toTerm (ExtractField object field) =- simpleTerm 31 [SomeExp object, SomeExp field]+ toTerm (ExtractField obj field) =+ simpleTerm 31 [SomeExp obj, SomeExp field] + toTerm (HasFields fields obj) =+ simpleTerm 32 ([SomeExp obj] ++ map (SomeExp . lift) fields)+ toTerm (Coerce value typeName) = simpleTerm 51 [SomeExp value, SomeExp typeName] @@ -658,9 +539,12 @@ toTerm (Ne a b) = simpleTerm 18 [SomeExp a, SomeExp b] - toTerm (Match a b) =- simpleTerm 97 [SomeExp a, SomeExp b]+ toTerm (Not e) =+ simpleTerm 23 [SomeExp e] + toTerm (Match str re) =+ simpleTerm 97 [SomeExp str, SomeExp re]+ toTerm (Get table key) = simpleTerm 16 [SomeExp table, SomeExp key] @@ -696,18 +580,16 @@ toTerm (Call f args) = simpleTerm 64 ([SomeExp f] ++ args) + toTerm (Limit n s) =+ simpleTerm 71 [SomeExp s, SomeExp (lift n)] -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+simpleTerm :: (Term a) => Int -> [a] -> State Context A.Value+simpleTerm 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 :: (Term a) => Int -> [a] -> Object -> State Context A.Value termWithOptions termType args options = do args' <- mapM toTerm args options' <- toTerm options@@ -729,6 +611,7 @@ abs _ = error "Num (Exp a): abs not implemented" signum _ = error "Num (Exp a): signum not implemented"+ negate _ = error "Num (Exp a): negate not implemented" @@ -774,13 +657,13 @@ type Simplified (Array Datum) = (Array Datum) lift = Constant -instance (Term r) => Lift Exp (Exp a -> Exp r) where+instance 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+instance 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@@ -794,18 +677,12 @@ -- used instead of the 'Call' constructor because they provide type safety. -- | Call an unary function with the given argument.-call1 :: (Term a, Term r)- => (Exp a -> Exp r)- -> Exp a- -> Exp r+call1 :: (Exp a -> Exp r) -> Exp a -> Exp r call1 f a = Call (lift f) [SomeExp a] -- | 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 :: (Exp a -> Exp b -> Exp r) -> Exp a -> Exp b -> Exp r call2 f a b = Call (lift f) [SomeExp a, SomeExp b] @@ -819,7 +696,7 @@ -- arguments can, and often have, different types). data SomeExp where- SomeExp :: (Term a) => Exp a -> SomeExp+ SomeExp :: Exp a -> SomeExp instance Term SomeExp where toTerm (SomeExp e) = toTerm e@@ -868,18 +745,19 @@ parseResponse :: Response -> Parser a -responseAtomParser :: (FromRSON a) => Response -> Parser a+responseAtomParser :: (FromDatum a) => Response -> Parser a responseAtomParser r = case (responseType r, V.toList (responseResult r)) of- (SuccessAtom, [a]) -> parseRSON a+ (SuccessAtom, [a]) -> parseWire a >>= parseDatum _ -> fail $ "responseAtomParser: Not a single-element vector " ++ show (responseResult r) -responseSequenceParser :: (FromRSON a) => Response -> Parser (Sequence a)+responseSequenceParser :: (FromDatum a) => Response -> Parser (Sequence a) responseSequenceParser r = case responseType r of+ SuccessAtom -> Done <$> responseAtomParser r SuccessSequence -> Done <$> values SuccessPartial -> Partial <$> pure (responseToken r) <*> values- _ -> fail "responseSequenceParser: Unexpected type"+ rt -> fail $ "responseSequenceParser: Unexpected type " ++ show rt where- values = V.mapM parseRSON (responseResult r)+ values = V.mapM (\x -> parseWire x >>= parseDatum) (responseResult r) @@ -923,7 +801,7 @@ responseParser :: Token -> Value -> Parser Response responseParser token (A.Object o) =- Response <$> pure token <*> o .: "t" <*> o .: "r"+ Response <$> pure token <*> o A..: "t" <*> o A..: "r" responseParser _ _ = fail "Response: Unexpected JSON value"
+ src/Database/RethinkDB/Types/Datum.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Database.RethinkDB.Types.Datum where+++import Control.Applicative+import Control.Monad++import Data.Text (Text)+import Data.Time+import Data.Scientific+import System.Locale (defaultTimeLocale)+import Data.Time.Clock.POSIX++import Data.Aeson (FromJSON(..), ToJSON(..))+import Data.Aeson.Types (Value, Parser)+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++++------------------------------------------------------------------------------+-- | A sumtype covering all the primitive types which can appear in queries+-- or responses.+--+-- It is similar to the aeson 'Value' type, except that RethinkDB has a few+-- more types (like 'Time'), which have a special encoding in JSON.++data Datum+ = Null+ | Bool !Bool+ | Number !Double+ | String !Text+ | Array !(Array Datum)+ | Object !Object+ | Time !ZonedTime+ deriving (Show, Generic)++++------------------------------------------------------------------------------+-- | Arrays are vectors of 'Datum'.++type Array a = Vector a++++------------------------------------------------------------------------------+-- | Objects are maps from 'Text' to 'Datum'. Like 'Aeson', we're using+-- a strict 'HashMap'.++type Object = HashMap Text Datum++++-- | 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) = (zonedTimeToUTC x) == (zonedTimeToUTC y)+ _ == _ = False+++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 (Time 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 v@(A.String x) = (Time <$> parseJSON v) <|> (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+ pure $ Object $ HMS.fromList items++++parseWire :: A.Value -> Parser Datum+parseWire (A.Null ) = pure Null+parseWire (A.Bool x) = pure $ Bool x+parseWire (A.Number x) = pure $ Number (realToFrac x)+parseWire (A.String x) = pure $ String x+parseWire (A.Array x) = Array <$> V.mapM parseWire x+parseWire (A.Object x) = (Time <$> zonedTimeParser x) <|> do+ -- HashMap does not provide a mapM, what a shame :(+ items <- mapM (\(k, v) -> (,) <$> pure k <*> parseWire v) $ HMS.toList x+ return $ Object $ HMS.fromList items+++zonedTimeParser :: HashMap Text A.Value -> Parser ZonedTime+zonedTimeParser o = do+ reqlType <- o A..: "$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 A..: "timezone" >>= \tz -> case parseTime defaultTimeLocale "%Z" tz of+ Just d -> pure d+ _ -> fail "Could not parse TimeZone"++ t <- o A..: "epoch_time" :: Parser Double+ pure $ utcToZonedTime tz $ posixSecondsToUTCTime $ realToFrac t+++++------------------------------------------------------------------------------+-- | Types which can be converted to or from a 'Datum'.++class ToDatum a where+ toDatum :: a -> Datum++class FromDatum a where+ parseDatum :: Datum -> Parser a++++(.=) :: ToDatum a => Text -> a -> (Text, Datum)+k .= v = (k, toDatum v)++(.:) :: FromDatum a => HashMap Text Datum -> Text -> Parser a+o .: k = maybe (fail $ "key " ++ show k ++ "not found") parseDatum $ HMS.lookup k o++(.:?) :: FromDatum a => HashMap Text Datum -> Text -> Parser (Maybe a)+o .:? k = maybe (return Nothing) (fmap Just . parseDatum) $ HMS.lookup k o++object :: [(Text, Datum)] -> Datum+object = Object . HMS.fromList++++------------------------------------------------------------------------------+-- Datum++instance ToDatum Datum where+ toDatum = id++instance FromDatum Datum where+ parseDatum = pure++++------------------------------------------------------------------------------+-- Bool++instance ToDatum Bool where+ toDatum = Bool++instance FromDatum Bool where+ parseDatum (Bool x) = pure x+ parseDatum _ = fail "Bool"++++------------------------------------------------------------------------------+-- Double++instance ToDatum Double where+ toDatum = Number++instance FromDatum Double where+ parseDatum (Number x) = pure x+ parseDatum _ = fail "Double"++++------------------------------------------------------------------------------+-- Int++instance ToDatum Int where+ toDatum = Number . fromIntegral++instance FromDatum Int where+ parseDatum (Number x) = pure $ floor x+ parseDatum _ = fail "Int"++++------------------------------------------------------------------------------+-- Text++instance ToDatum Text where+ toDatum = String++instance FromDatum Text where+ parseDatum (String x) = pure x+ parseDatum _ = fail "Text"++++------------------------------------------------------------------------------+-- Array (Vector)++instance (ToDatum a) => ToDatum (Array a) where+ toDatum = Array . V.map toDatum++instance (FromDatum a) => FromDatum (Array a) where+ parseDatum (Array v) = V.mapM parseDatum v+ parseDatum _ = fail "Array"++++------------------------------------------------------------------------------+-- Object (HashMap Text Datum)++instance ToDatum Object where+ toDatum = Object++instance FromDatum Object where+ parseDatum (Object o) = do+ -- HashMap does not provide a mapM, what a shame :(+ items <- mapM (\(k, v) -> (,) <$> pure k <*> parseDatum v) $ HMS.toList o+ pure $ HMS.fromList items++ parseDatum _ = fail "Object"++++------------------------------------------------------------------------------+-- ZonedTime++instance ToDatum ZonedTime where+ toDatum = Time++instance FromDatum ZonedTime where+ parseDatum (Time x) = pure x+ parseDatum _ = fail "ZonedTime"++++------------------------------------------------------------------------------+-- UTCTime++instance ToDatum UTCTime where+ toDatum = Time . utcToZonedTime utc++instance FromDatum UTCTime where+ parseDatum (Time x) = pure (zonedTimeToUTC x)+ parseDatum _ = fail "UTCTime"++++------------------------------------------------------------------------------+-- [a]++instance ToDatum a => ToDatum [a] where+ toDatum = Array . V.fromList . map toDatum++instance FromDatum a => FromDatum [a] where+ parseDatum (Array x) = V.toList <$> V.mapM parseDatum x+ parseDatum _ = fail "[a]"++++------------------------------------------------------------------------------+-- Maybe a++instance ToDatum a => ToDatum (Maybe a) where+ toDatum Nothing = Null+ toDatum (Just x) = toDatum x++instance FromDatum a => FromDatum (Maybe a) where+ parseDatum Null = pure Nothing+ parseDatum d = Just <$> parseDatum d++++------------------------------------------------------------------------------+-- Value++instance ToDatum Value where+ toDatum (A.Null ) = Null+ toDatum (A.Bool x) = Bool x+ toDatum (A.Number x) = Number $ toRealFloat x+ toDatum (A.String x) = String x+ toDatum (A.Array x) = Array $ V.map toDatum x+ toDatum (A.Object x) = Object $ fmap toDatum x++instance FromDatum Value where+ parseDatum (Null ) = pure A.Null+ parseDatum (Bool x) = pure $ A.Bool x+ parseDatum (Number x) = pure $ A.Number (realToFrac x)+ parseDatum (String x) = pure $ A.String x+ parseDatum (Array x) = A.Array <$> V.mapM parseDatum x+ parseDatum (Object x) = do+ -- HashMap does not provide a mapM, what a shame :(+ items <- mapM (\(k, v) -> (,) <$> pure k <*> parseDatum v) $ HMS.toList x+ pure $ A.Object $ HMS.fromList items+ parseDatum (Time x) = pure $ toJSON x
test/Test.hs view
@@ -60,7 +60,7 @@ expectSuccess- :: (Term a, Eq (Result a), FromResponse (Result a), Show (Result 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