module Database.Couch.ResponseParser where
import Control.Monad (return, (>>=))
import Control.Monad.Reader (Reader, asks, runReader)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Data.Aeson (FromJSON, Result (Error, Success),
Value (Object), fromJSON)
import Data.ByteString (ByteString)
import Data.Either (Either (Left, Right), either)
import Data.Eq ((==))
import Data.Foldable (find)
import Data.Function (($), (.))
import Data.Functor (fmap)
import Data.HashMap.Strict (lookup)
import Data.Maybe (Maybe, maybe)
import Data.Monoid (mempty)
import Data.Text (Text, pack)
import Data.Text.Encoding (decodeUtf8)
import Data.Text.Read (decimal)
import Data.Tuple (fst, snd)
import Database.Couch.Types (DocRev (DocRev), Error (AlreadyExists, Conflict, HttpError, ImplementationError, InvalidName, NotFound, ParseFail, Unauthorized))
import GHC.Integer (Integer)
import Network.HTTP.Client (HttpException (StatusCodeException))
import Network.HTTP.Types (HeaderName, ResponseHeaders,
Status, statusCode)
standardParse :: FromJSON a => ResponseParser a
standardParse = do
checkStatusCode
responseValue >>= toOutputType
type ResponseParser = ExceptT Error (Reader (ResponseHeaders, Status, Value))
runParse :: ResponseParser a -> Either Error (ResponseHeaders, Status, Value) -> Either Error a
runParse p (Right v) = (runReader . runExceptT) p v
runParse _ (Left v) = Left v
responseStatus :: ResponseParser Status
responseStatus =
asks status
where
status (_, s, _) = s
responseHeaders :: ResponseParser ResponseHeaders
responseHeaders =
asks headers
where
headers (h, _, _) = h
responseValue :: ResponseParser Value
responseValue =
asks value
where
value (_, _, v) = v
checkStatusCode :: ResponseParser ()
checkStatusCode = do
h <- responseHeaders
s <- responseStatus
case statusCode s of
200 -> return ()
201 -> return ()
202 -> return ()
304 -> return ()
400 -> do
error <- getKey "reason" >>= toOutputType
throwE $ InvalidName error
401 -> throwE Unauthorized
404 -> throwE NotFound
409 -> throwE Conflict
412 -> throwE AlreadyExists
415 -> throwE $ ImplementationError "The server says we sent a bad content type, which shouldn't happen. Please open an issue at https://github.com/mdorman/couch-simple/issues with a test case if possible."
_ -> throwE $ HttpError (StatusCodeException s h mempty)
maybeGetHeader :: HeaderName -> ResponseParser (Maybe ByteString)
maybeGetHeader header = do
h <- responseHeaders
return $ fmap snd (find ((== header) . fst) h)
getHeader :: HeaderName -> ResponseParser ByteString
getHeader header =
maybeGetHeader header >>= maybe (throwE NotFound) return
getContentLength :: ResponseParser Integer
getContentLength = do
h <- getHeader "Content-Length"
either (throwE . ParseFail . pack) (return . fst) $ decimal (decodeUtf8 h)
getDocRev :: ResponseParser DocRev
getDocRev = do
h <- getHeader "ETag"
return $ DocRev $ decodeUtf8 h
getKey :: Text -> ResponseParser Value
getKey key = do
v <- responseValue
case v of
Object o -> maybe (throwE NotFound) return $ lookup key o
_ -> throwE NotFound
toOutputType :: (FromJSON a) => Value -> ResponseParser a
toOutputType v =
case fromJSON v of
Error e -> throwE $ ParseFail $ pack e
Success a -> return a