module Database.CouchDB.Conduit.Internal.Doc (
couchRev,
couchRev',
couchDelete,
couchGetWith,
couchPutWith,
couchPutWith_,
couchPutWith'
) where
import Prelude hiding (catch)
import Control.Exception.Lifted (catch)
import Control.Monad.Trans.Class (lift)
import Data.Maybe (fromJust)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text.Encoding as TE
import qualified Data.Aeson as A
import Data.Conduit (ResourceT, resourceThrow, ($$))
import qualified Data.Conduit.Attoparsec as CA
import qualified Network.HTTP.Conduit as H
import Network.HTTP.Types as HT
import Database.CouchDB.Conduit
import Database.CouchDB.Conduit.LowLevel (couch')
import Database.CouchDB.Conduit.Internal.Parser
couchRev :: MonadCouch m =>
Path
-> ResourceT m Revision
couchRev p = do
(H.Response _ hs _) <- couch' HT.methodHead p [] []
(H.RequestBodyBS B.empty)
return $ peekRev hs
where
peekRev = B.tail . B.init . fromJust . lookup "Etag"
couchRev' :: MonadCouch m =>
Path
-> ResourceT m Revision
couchRev' p =
catch (couchRev p) handler404
where
handler404 (CouchHttpError 404 _) = return B.empty
handler404 e = lift $ resourceThrow e
couchDelete :: MonadCouch m =>
Path
-> Revision
-> ResourceT m ()
couchDelete p r = couch' HT.methodDelete p [] [("rev", Just r)]
(H.RequestBodyBS B.empty)
>> return ()
couchGetWith :: MonadCouch m =>
(A.Value -> A.Result a)
-> Path
-> Query
-> ResourceT m (Revision, a)
couchGetWith f p q = do
H.Response _ _ bsrc <- couch' HT.methodGet p [] q
(H.RequestBodyBS B.empty)
j <- bsrc $$ CA.sinkParser A.json
A.String r <- lift $ either resourceThrow return $ extractField "_rev" j
o <- lift $ jsonToTypeWith f j
return (TE.encodeUtf8 r, o)
couchPutWith :: MonadCouch m =>
(a -> BL.ByteString)
-> Path
-> Revision
-> Query
-> a
-> ResourceT m Revision
couchPutWith f p r q val = do
H.Response _ _ bsrc <- couch' HT.methodPut p (ifMatch r) q
(H.RequestBodyLBS $ f val)
j <- bsrc $$ CA.sinkParser A.json
lift $ either resourceThrow return $ extractRev j
where
ifMatch "" = []
ifMatch rv = [("If-Match", rv)]
couchPutWith_ :: MonadCouch m =>
(a -> BL.ByteString)
-> Path
-> HT.Query
-> a
-> ResourceT m Revision
couchPutWith_ f p q val = do
rev <- couchRev' p
if rev == ""
then couchPutWith f p "" q val
else return rev
couchPutWith' :: MonadCouch m =>
(a -> BL.ByteString)
-> Path
-> HT.Query
-> a
-> ResourceT m Revision
couchPutWith' f p q val = do
rev <- couchRev' p
couchPutWith f p rev q val