module Database.CouchDB.Conduit.Design (
couchViewPut_,
couchViewPut'
) where
import Prelude hiding (catch)
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 (MonadCouch, CouchError, Path, mkPath, Revision)
import Database.CouchDB.Conduit.Internal.Doc (couchGetWith, couchPutWith)
couchViewPut_ :: MonadCouch m =>
Path
-> Path
-> B.ByteString
-> Maybe B.ByteString
-> ResourceT m Revision
couchViewPut_ = couchViewPutInt True
couchViewPut' :: MonadCouch m =>
Path
-> Path
-> B.ByteString
-> Maybe B.ByteString
-> ResourceT m Revision
couchViewPut' = couchViewPutInt False
couchViewPutInt :: MonadCouch m =>
Bool
-> Path
-> Path
-> B.ByteString
-> Maybe B.ByteString
-> ResourceT m Revision
couchViewPutInt prot designName viewName mapF reduceF = do
(rev, A.Object d) <- getDesignDoc path
let extractedView = extractViews d
if extractedView /= M.empty && prot
then return rev
else couchPutWith A.encode path rev [] $ inferViews (purge_ d)
where
path = designDocPath 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 (designDocPath designName) [])
(\(_ :: CouchError) -> return (B.empty, AT.emptyObject))
designDocPath :: Path -> Path
designDocPath dn = mkPath ["_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