gistfile1.hs

performRequest' :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT ServantError IO (Int, ByteString, MediaType)
performRequest' reqMethod req isWantedStatus reqHost = do
  partialRequest <- liftIO $ reqToRequest req reqHost

  let request = partialRequest { Client.method = reqMethod
                               , checkStatus = \ _status _headers _cookies -> Nothing
                               }

  eResponse <- liftIO $ __withGlobalManager $ \ manager ->
    catchHttpException $
    Client.httpLbs request manager
  case eResponse of
    Left err ->
      left $ ConnectionError err

    Right response -> do
      liftIO $ print response
      let status = Client.responseStatus response
          body = Client.responseBody response
          status_code = statusCode status
      ct <- case lookup "Content-Type" $ Client.responseHeaders response of
                 Nothing -> pure $ "application"//"octet-stream"
                 Just t -> case parseAccept t of
                   Nothing -> left $ InvalidContentTypeHeader (cs t) body
                   Just t' -> pure t'
      unless (isWantedStatus status_code) $
        left $ FailureResponse status ct body
      return (status_code, body, ct)

performRequestCT' :: MimeUnrender ct result =>
  Proxy ct -> Method -> Req -> [Int] -> BaseUrl -> EitherT ServantError IO result
performRequestCT' ct reqMethod req wantedStatus reqHost = do
  let acceptCT = contentType ct
  (_status, respBody, respCT) <-
    performRequest reqMethod (req { reqAccept = [acceptCT] }) (`elem` wantedStatus) reqHost
  unless (matches respCT (acceptCT)) $
    left $ UnsupportedContentType respCT respBody
  either
    (left . (\s -> DecodeFailure s respCT respBody))
    return
    (fromByteString ct respBody)