module Database.CouchDB.Conduit.LowLevel (
CouchResponse,
couch,
protect,
protect'
) where
import Prelude hiding (catch)
import Control.Exception.Lifted (catch)
import Control.Exception (SomeException)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Base (liftBase)
import Data.Maybe (fromJust)
import qualified Data.ByteString as B
import qualified Data.Aeson as A
import qualified Data.ByteString.UTF8 as BU8
import qualified Data.HashMap.Lazy as M
import qualified Data.Text as T
import Data.Conduit (ResourceT, BufferedSource,
($$), resourceThrow)
import Data.Conduit.Attoparsec (sinkParser)
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
import Database.CouchDB.Conduit
type CouchResponse m = H.Response (BufferedSource m B.ByteString)
couch :: MonadCouch m =>
HT.Method
-> Path
-> HT.RequestHeaders
-> HT.Query
-> H.RequestBody m
-> (CouchResponse m -> ResourceT m (CouchResponse m))
-> ResourceT m (CouchResponse m)
couch meth path hdrs qs reqBody protectFn = do
conn <- lift couchConnection
let req = H.def
{ H.method = meth
, H.host = couchHost conn
, H.requestHeaders = hdrs
, H.port = couchPort conn
, H.path = B.intercalate "/" . filter (/="") $
[couchDB conn, path]
, H.queryString = HT.renderQuery False qs
, H.requestBody = reqBody
, H.checkStatus = const . const $ Nothing }
let req' = if couchLogin conn == B.empty then req else H.applyBasicAuth
(couchLogin conn) (couchPass conn) req
res <- H.http req' (fromJust $ couchManager conn)
protectFn res
protect :: MonadCouch m =>
[Int]
-> CouchResponse m
-> ResourceT m (CouchResponse m)
protect goodCodes ~resp@(H.Response (HT.Status sc sm) _ bsrc)
| sc `elem` goodCodes = return resp
| otherwise = do
v <- catch (bsrc $$ sinkParser A.json)
(\(_::SomeException) -> return A.Null)
liftBase $ resourceThrow $ CouchError (Just sc) $ msg v
where
msg v = BU8.toString sm ++ reason v
reason (A.Object v) = case M.lookup "reason" v of
Just (A.String t) -> ": " ++ T.unpack t
_ -> ""
reason _ = []
protect' :: MonadCouch m =>
CouchResponse m
-> ResourceT m (CouchResponse m)
protect' = protect [200, 201, 202, 304]