module Database.CouchDB.Conduit.Design (
couchPutView
) where
import Prelude hiding (catch)
import Control.Monad (void)
import Control.Exception.Lifted (catch)
import Data.Conduit (ResourceT)
import qualified Data.ByteString as B
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.HashMap.Lazy as M
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as AT
import Database.CouchDB.Conduit.Internal.Connection
(MonadCouch, CouchError, Path, mkPath, Revision)
import Database.CouchDB.Conduit.Internal.Doc (couchGetWith, couchPutWith')
couchPutView :: MonadCouch m =>
Path
-> Path
-> Path
-> B.ByteString
-> Maybe B.ByteString
-> ResourceT m ()
couchPutView db designName viewName mapF reduceF = do
(_, A.Object d) <- getDesignDoc path
void $ couchPutWith' A.encode path [] $ inferViews (purge_ d)
where
path = designDocPath db designName
inferViews d = A.Object $ M.insert "views" (addView d) d
addView d = A.Object $ M.insert
(TE.decodeUtf8 viewName)
(constructView mapF reduceF)
(extractViews d)
constructView :: B.ByteString -> Maybe B.ByteString -> A.Value
constructView m (Just r) = A.object ["map" A..= m, "reduce" A..= r]
constructView m Nothing = A.object ["map" A..= m]
getDesignDoc :: MonadCouch m =>
Path
-> ResourceT m (Revision, AT.Value)
getDesignDoc designName = catch
(couchGetWith A.Success designName [])
(\(_ :: CouchError) -> return (B.empty, AT.emptyObject))
designDocPath :: Path -> Path -> Path
designDocPath db dn = mkPath [db, "_design", dn]
purge_ :: AT.Object -> AT.Object
purge_ = M.filterWithKey (\k _ -> k `notElem` ["_id", "_rev"])
stripObject :: AT.Value -> AT.Object
stripObject (A.Object a) = a
stripObject _ = M.empty
extractViews :: M.HashMap T.Text AT.Value -> M.HashMap T.Text AT.Value
extractViews o = maybe M.empty stripObject $ M.lookup "views" o