module Database.Couch.RequestBuilder where
import Control.Monad (return, (>>))
import Control.Monad.Reader (Reader, ask, runReader)
import Control.Monad.State (StateT, execStateT, get, put)
import Data.Aeson (ToJSON, encode)
import Data.ByteString (ByteString, intercalate, null)
import Data.Default (def)
import Data.Eq ((==))
import Data.Function (on, ($), (.))
import Data.List (unionBy)
import Data.Maybe (Maybe (Just), maybe)
import Data.Monoid (mempty, (<>))
import Data.Tuple (fst)
import Database.Couch.Types (Context, Credentials (Basic), DocId,
DocRev, ctxCookies, ctxCred, reqDb,
reqDocId, reqDocRev, reqHost,
reqPassword, reqPort, reqUser)
import Network.HTTP.Client (Request, RequestBody (RequestBodyLBS),
applyBasicAuth, cookieJar, host, method,
path, port, requestBody, requestHeaders,
setQueryString)
import Network.HTTP.Types (RequestHeaders, hAccept, hContentType)
data BuilderState =
BuilderState {
bsRequest :: Request,
bsQueryParam :: [(ByteString, Maybe ByteString)],
bsDb :: ByteString,
bsPathSegments :: [ByteString]
}
type RequestBuilder = StateT BuilderState (Reader Context)
runBuilder :: RequestBuilder () -> Context -> Request
runBuilder builder context =
finalize (runReader (execStateT (defaultRequest >> builder) (BuilderState def [] mempty [])) context)
finalize :: BuilderState -> Request
finalize (BuilderState r q d p) =
setQueryString q r { path = calculatedPath }
where
calculatedPath = "/" <> intercalate "/" ((if null d then [] else [d]) <> p)
defaultRequest :: RequestBuilder ()
defaultRequest = do
defaultHeaders [(hAccept, "application/json"), (hContentType, "application/json")]
setAuth
setConnection
setCookieJar
setMethod "GET"
selectDb :: RequestBuilder ()
selectDb = do
c <- ask
(BuilderState r q _ p) <- get
put $ BuilderState r q (reqDb c) p
setAuth :: RequestBuilder ()
setAuth = do
c <- ask
maybe (return ()) doApply (ctxCred c)
where
doApply cred = do
(BuilderState r q d p) <- get
put $ BuilderState (applyCred cred r) q d p
applyCred (Basic u p) = applyBasicAuth (reqUser u) (reqPassword p)
setConnection :: RequestBuilder ()
setConnection = do
c <- ask
(BuilderState r q d p) <- get
put $ BuilderState r { host = reqHost c, port = reqPort c } q d p
setCookieJar :: RequestBuilder ()
setCookieJar = do
c <- ask
(BuilderState r q d p) <- get
put $ BuilderState r { cookieJar = Just $ ctxCookies c } q d p
addHeaders :: RequestHeaders -> RequestBuilder ()
addHeaders new = do
(BuilderState r q d p) <- get
let headers = requestHeaders r
put $ BuilderState r { requestHeaders = headers <> new } q d p
defaultHeaders :: RequestHeaders -> RequestBuilder ()
defaultHeaders new = do
(BuilderState r q d p) <- get
let headers = requestHeaders r
put $ BuilderState r { requestHeaders = unionBy ((==) `on` fst) headers new } q d p
setHeaders :: RequestHeaders -> RequestBuilder ()
setHeaders new = do
(BuilderState r q d p) <- get
let headers = requestHeaders r
put $ BuilderState r { requestHeaders = unionBy ((==) `on` fst) new headers } q d p
addQueryParam :: [(ByteString, Maybe ByteString)] -> RequestBuilder ()
addQueryParam new = do
(BuilderState r q d p) <- get
put $ BuilderState r (q <> new) d p
defaultQueryParam :: [(ByteString, Maybe ByteString)] -> RequestBuilder ()
defaultQueryParam new = do
(BuilderState r q d p) <- get
put $ BuilderState r (unionBy ((==) `on` fst) q new) d p
setQueryParam :: [(ByteString, Maybe ByteString)] -> RequestBuilder ()
setQueryParam new = do
(BuilderState r q d p) <- get
put $ BuilderState r (unionBy ((==) `on` fst) new q) d p
addPath :: ByteString -> RequestBuilder ()
addPath new = do
(BuilderState r q d p) <- get
put $ BuilderState r q d (p <> [new])
selectDoc :: DocId -> RequestBuilder ()
selectDoc = addPath . reqDocId
addRev :: DocRev -> RequestBuilder ()
addRev rev =
setHeaders [("ETag", reqDocRev rev)]
maybeAddRev :: Maybe DocRev -> RequestBuilder ()
maybeAddRev =
maybe (return ()) addRev
setJsonBody :: ToJSON a
=> a
-> RequestBuilder ()
setJsonBody new = do
(BuilderState r q d p) <- get
put $ BuilderState r { requestBody = RequestBodyLBS $ encode new } q d p
setMethod :: ByteString -> RequestBuilder ()
setMethod m = do
(BuilderState r q d p) <- get
put $ BuilderState r { method = m } q d p