module Database.Couch.Internal where
import Control.Monad (return, (>>=))
import Control.Monad.Catch (handle)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson (FromJSON, Value (Null))
import Data.Aeson.Parser (json)
import Data.Attoparsec.ByteString (IResult (Done, Fail, Partial),
parseWith)
import Data.Either (Either (Right, Left), either)
import Data.Eq ((==))
import Data.Function (const, flip, ($), (.))
import Data.Maybe (Maybe (Just, Nothing))
import Data.Monoid (mempty)
import Data.Text (pack)
import Database.Couch.RequestBuilder (RequestBuilder, runBuilder)
import Database.Couch.ResponseParser (ResponseParser, runParse,
standardParse)
import Database.Couch.Types (Context, Error (HttpError, ParseFail, ParseIncomplete),
Result, ctxCookies, ctxManager)
import Network.HTTP.Client (CookieJar, Manager, Request,
brRead, checkStatus, method,
responseBody, responseCookieJar,
responseHeaders, responseStatus,
withResponse)
import Network.HTTP.Types (ResponseHeaders, Status,
methodHead)
rawJsonRequest :: MonadIO m
=> Manager
-> Request
-> m (Either Error (ResponseHeaders, Status, CookieJar, Value))
rawJsonRequest manager request =
liftIO (handle errorHandler $ withResponse request { checkStatus = const . const . const Nothing } manager responseHandler)
where
errorHandler =
return . Left . HttpError
responseHandler res = do
result <- if method request == methodHead
then return (Done mempty Null)
else parseParts res
return $ case result of
(Done _ ret) -> return (responseHeaders res, responseStatus res, responseCookieJar res, ret)
(Partial _) -> Left ParseIncomplete
(Fail _ _ err) -> Left $ ParseFail $ pack err
parseParts res = do
let input = brRead (responseBody res)
initial <- input
parseWith input json initial
structureRequest :: MonadIO m
=> RequestBuilder ()
-> ResponseParser a
-> Context
-> m (Result a)
structureRequest builder parse context =
rawJsonRequest manager request >>= parser
where
manager =
ctxManager context
request =
runBuilder builder context
parser =
return . either Left parseContext
parseContext (h, s, c, v) =
runParse parse (Right (h, s, v)) >>= checkContextUpdate c
checkContextUpdate c a =
Right (a, if c == ctxCookies context then Nothing else Just c)
standardRequest :: (FromJSON a, MonadIO m) => RequestBuilder () -> Context -> m (Result a)
standardRequest =
flip structureRequest standardParse