module Database.RethinkDB.Types where
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.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
class Term a where
toTerm :: a -> State Context A.Value
instance Term A.Value where
toTerm = return
class FromRSON a where
parseRSON :: A.Value -> Parser a
class ToRSON a where
toRSON :: a -> A.Value
data Context = Context
{ varCounter :: Int
}
compileTerm :: State Context A.Value -> A.Value
compileTerm e = evalState e (Context 0)
newVar :: State Context Int
newVar = do
ix <- gets varCounter
modify $ \s -> s { varCounter = ix + 1 }
return ix
data Datum
= Null
| Bool !Bool
| Number !Double
| String !Text
| Array !(Array Datum)
| Object !Object
| Time !ZonedTime
deriving (Show, Generic)
class (Term a) => IsDatum a
instance IsDatum Datum
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
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
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
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
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
type Array a = Vector a
instance (IsDatum a) => IsDatum (Array a)
instance (IsDatum a) => IsSequence (Array a)
instance (FromRSON a) => FromResponse (Array a) where
parseResponse = responseAtomParser
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)
options <- toTerm emptyOptions
return $ A.Array $ V.fromList $
[ A.Number 2
, toJSON vals
, toJSON $ options
]
type Object = HashMap Text Datum
class (Term a, IsDatum a) => IsObject a
instance IsDatum Object
instance IsObject Object
instance FromResponse Object where
parseResponse = responseAtomParser
instance FromRSON Object where
parseRSON (A.Object o) = do
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
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)
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
eqTime :: ZonedTime -> ZonedTime -> Bool
eqTime = (==) `on` zonedTimeToUTC
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
data Table = MkTable
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"
data SingleSelection = SingleSelection
deriving (Show)
instance Term SingleSelection where
toTerm = error "toTerm SingleSelection: Server-only type"
instance IsDatum SingleSelection
instance IsObject SingleSelection
data Database = MkDatabase
instance Term Database where
toTerm = error "toTerm Database: Server-only type"
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"
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]
data Sequence a
= Done !(Vector a)
| Partial !Token !(Vector 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 (FromRSON 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)
data Exp a where
Constant :: (ToRSON a) => a -> Exp a
ListDatabases :: Exp (Array Text)
CreateDatabase :: Exp Text -> Exp Object
DropDatabase :: Exp Text -> Exp Object
ListTables :: Exp Database -> Exp (Array Text)
CreateTable :: Exp Database -> Exp Text -> Exp Object
DropTable :: Exp Database -> Exp Text -> Exp Object
ListIndices :: Exp Table -> Exp (Array Text)
CreateIndex :: Exp Table -> Exp Text -> (Exp Object -> Exp Datum) -> Exp Object
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
Any :: [Exp Bool] -> Exp Bool
ObjectField :: (IsObject a, IsDatum r) => Exp a -> Exp Text -> Exp r
ExtractField :: (IsSequence a) => Exp a -> Exp Text -> Exp a
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
InsertSequence :: (IsSequence s) => Exp Table -> Exp s -> Exp Object
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
BetweenIndexed :: (IsSequence s) => Exp s -> (Bound, Bound) -> Text -> Exp s
OrderBy :: (IsSequence s) => [Order] -> Exp s -> Exp s
Keys :: (IsObject a) => Exp a -> Exp (Array Text)
Var :: Int -> Exp a
Function :: (Term a) => State Context ([Int], Exp a) -> Exp f
Call :: (Term f) => Exp f -> [SomeExp] -> Exp r
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']
instance IsString (Exp Text) where
fromString = lift . (fromString :: String -> Text)
instance Num (Exp Double) where
fromInteger = Constant . fromInteger
a + b = Add [a, b]
a * b = Multiply [a, b]
abs _ = error "Num (Exp a): abs not implemented"
signum _ = error "Num (Exp a): signum not implemented"
class Lift c e where
type Simplified 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))
call1 :: (Term a, Term r)
=> (Exp a -> Exp r)
-> Exp a
-> Exp r
call1 f a = Call (lift f) [SomeExp a]
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
data SomeExp where
SomeExp :: (Term a) => Exp a -> SomeExp
instance Term SomeExp where
toTerm (SomeExp e) = toTerm e
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 a) = Array a
type instance Result SingleSelection = Maybe Datum
type instance Result (Sequence a) = Sequence a
type Res a = Either Error (Result a)
class FromResponse a where
parseResponse :: Response -> Parser a
responseAtomParser :: (FromRSON a) => Response -> Parser a
responseAtomParser r = case (responseType r, V.toList (responseResult r)) of
(SuccessAtom, [a]) -> parseRSON a
_ -> fail $ "responseAtomParser: Not a single-element vector " ++ show (responseResult r)
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 parseRSON (responseResult r)
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)
} 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"
data Error
= ProtocolError !Text
| ClientError !Text
| CompileError !Text
| RuntimeError !Text
deriving (Eq, Show)