{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} module Avers.Views where import Control.Monad import Data.Text (Text) import Data.Aeson as Aeson import Data.Monoid import qualified Data.HashMap.Strict as HMS import qualified Database.RethinkDB as R import Avers.Types import Avers.Storage.Backend viewTableName :: View obj a -> Text viewTableName View{..} = "view_" <> viewName -- | Construct the table name for the given view. The table names look -- something like this: "view_openGames" viewTable :: View obj a -> R.Exp R.Table viewTable view = R.Table Nothing $ R.lift $ viewTableName view data Record a = Record { recId :: ObjId , recContent :: a } instance Pk (Record a) where toPk = toPk . recId instance (ToJSON a) => ToJSON (Record a) where toJSON Record{..} = Aeson.Object $ HMS.insert "id" (Aeson.String $ toPk recId) hms where (Aeson.Object hms) = toJSON recContent instance (R.ToDatum a) => R.ToDatum (Record a) where toDatum Record{..} = R.Object $ HMS.insert "id" (R.String $ toPk recId) $ HMS.fromList $ map (\(k,v) -> (k, R.toDatum v)) $ HMS.toList hms where (R.Object hms) = R.toDatum recContent updateObjectViews :: ObjectType a -> ObjId -> Maybe a -> Avers () updateObjectViews ObjectType{..} objId mbObj = do forM_ otViews $ \(SomeView view) -> do updateView view objId mbObj updateView :: (R.ToDatum a) => View obj a -> ObjId -> Maybe obj -> Avers () updateView view@View{..} objId mbObj = do case mbObj of Nothing -> deleteDocument (viewTable view) objId Just obj -> do mbRecord <- viewObjectTransformer obj case mbRecord of Nothing -> deleteDocument (viewTable view) objId Just rec -> upsertDocument (viewTable view) (Record objId rec)