module Database.CouchDB.Conduit.LowLevel (
CouchResponse,
couch,
couch',
protect
,
protect'
) where
import Prelude hiding (catch)
import Control.Exception.Lifted (catch, throw)
import Control.Exception (SomeException)
import qualified Data.ByteString as B
import qualified Data.Aeson as A
import qualified Data.HashMap.Lazy as M
import Data.String.Conversions ((<>), cs)
import Data.Conduit (ResumableSource, ($$+-))
import Data.Conduit.Attoparsec (sinkParser)
import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT
import Database.CouchDB.Conduit.Internal.Connection
type CouchResponse m = H.Response (ResumableSource m B.ByteString)
couch :: MonadCouch m =>
HT.Method
-> Path
-> HT.RequestHeaders
-> HT.Query
-> H.RequestBody m
-> (CouchResponse m -> m (CouchResponse m))
-> m (CouchResponse m)
couch meth path =
couch' meth withPrefix
where
withPrefix prx
| B.null prx = path
| otherwise = "/" <> prx <> B.tail path
couch' :: MonadCouch m =>
HT.Method
-> (Path -> Path)
-> HT.RequestHeaders
-> HT.Query
-> H.RequestBody m
-> (CouchResponse m -> m (CouchResponse m))
-> m (CouchResponse m)
couch' meth pathFn hdrs qs reqBody protectFn = do
(manager, conn) <- couchConnection
let req = H.def
{ H.method = meth
, H.host = couchHost conn
, H.requestHeaders = hdrs
, H.port = couchPort conn
, H.path = pathFn $ couchPrefix conn
, 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' manager
protectFn res
protect :: MonadCouch m =>
[Int]
-> (CouchResponse m -> m (CouchResponse m))
-> CouchResponse m
-> m (CouchResponse m)
protect goodCodes h ~resp@(H.Response (HT.Status sc sm) _ _ bsrc)
| sc == 304 = throw NotModified
| sc `elem` goodCodes = h resp
| otherwise = do
v <- catch (bsrc $$+- sinkParser A.json)
(\(_::SomeException) -> return A.Null)
throw $ CouchHttpError sc $ msg v
where
msg v = sm <> reason v
reason (A.Object v) = case M.lookup "reason" v of
Just (A.String t) -> ": " <> cs t
_ -> ""
reason _ = B.empty
protect' :: MonadCouch m =>
CouchResponse m
-> m (CouchResponse m)
protect' = protect [200, 201, 202, 304] return