Http.hs

{-|
Module      : Control.Monad.Freer.Http
Description : http requests with freer-simple
Copyright   : (c) Ben Weitzman 2018
License     : MIT
Maintainer  : ben@costarastrolgoy.com
Stability   : experimental
Portability : POSIX
-}

module Control.Monad.Freer.Http
  ( Http
  , get
  , getJSON
  , post
  , postJSON
  , doRequest
  , request
  , requestJSON
  , HttpException
  , JSONParseError(..)
  , runHttp
  , mockHttp
  , staticHttpMock
  )
where

import Control.Exception

import Control.Monad

import Control.Monad.Freer
import Control.Monad.Freer.Error

import Data.Aeson

import qualified Data.ByteString as BS
import Data.ByteString.Lazy (ByteString)

import Data.Map (Map)
import qualified Data.Map as M

import Data.Maybe (fromMaybe)

import Data.Functor ((<&>))

import Network.HTTP.Client (Request, Response, Manager, httpLbs
                           ,HttpException(HttpExceptionRequest), parseRequest, requestHeaders
                           ,method, path, HttpExceptionContent(StatusCodeException)
                           ,RequestBody(..), requestBody)
import Network.HTTP.Client.Internal (Response(..), CookieJar(CJ), ResponseClose(..))
import Network.HTTP.Types.Header (RequestHeaders)
import Network.HTTP.Types.Method (Method, methodGet, methodPost)
import Network.HTTP.Types.Status (Status, status404, statusCode)
import Network.HTTP.Types.Version (http11)

-- | The 'Http' effect is for making http requests
data Http v where
    DoRequest :: Request -> Http (Response ByteString)
    ParseRequest :: String -> Http Request
    DoRequestJSON :: (FromJSON a) => Request -> Http a
    TryRequestJSON :: (FromJSON a) => Request -> Http (Either JSONParseError a)

-- | Low level function for making an http request
doRequest :: Member Http r => Request -> Eff r (Response ByteString)
doRequest req = send (DoRequest req)

-- | Parse a string representing into a url. This is an effectful computation to
-- mirror 'http-client's behavior
parseReq :: Member Http r => String -> Eff r Request
parseReq = send . ParseRequest

-- | A higher level function that will parse the http response into a data type using aeson
doRequestJSON :: (Member Http r, FromJSON a) => Request -> Eff r a
doRequestJSON = send . DoRequestJSON

-- | Make a request and attempt to parse the response, and report an error if parsing fails
tryRequestJSON :: (Member Http r, FromJSON a) => Request -> Eff r (Either JSONParseError a)
tryRequestJSON = send . TryRequestJSON

-- | Make an HTTP request
request :: (Member Http r)
        => Method
        -> RequestHeaders
        -> String
        -> Maybe RequestBody
        -> Eff r (Response ByteString)
request meth headers url body = do
    req <- parseReq url
    doRequest req
      { requestHeaders = headers
      , method = meth
      , requestBody = fromMaybe mempty body
      }

-- | An error that an http response failed to parse
newtype JSONParseError = JSONParseError String deriving (Show)

-- | Make an HTTP request using JSON for the body and response
requestJSON :: (FromJSON resp, ToJSON req
               ,Member Http r
               )
            => Method
            -> RequestHeaders
            -> String
            -> Maybe req
            -> Eff r resp
requestJSON meth headers url mBody = do
  let body = maybe mempty (RequestBodyLBS . encode) mBody
  req <- parseReq url <&> \req -> req { requestHeaders = headers
                                      , method = meth
                                      , requestBody = body
                                      }
  doRequestJSON req

-- | Make a GET request
get :: (Member Http r)
    => String -> Eff r (Response ByteString)
get url = request methodGet [] url Nothing

-- | Make a GET request that expects a JSON response 
getJSON :: (FromJSON a, Member Http r)
        => String -> Eff r a
getJSON url = requestJSON methodGet [] url (Nothing @())


-- | Make a POST request
post :: (Member Http r)
     => String -> RequestBody -> Eff r (Response ByteString)
post url = request methodPost [] url . Just

-- | Make a POST request with a JSON body and response
postJSON :: (FromJSON resp, ToJSON req, Member Http r)
         => String -> req -> Eff r resp
postJSON url = requestJSON methodPost [("Content-Type", "application/json")] url . Just

-- | Interpret 'Http' using 'IO' and the 'http-client' library
runHttp :: forall r w
         . (Member IO r, Member (Error HttpException) r, Member (Error JSONParseError) r)
        => Manager
        -> Eff (Http ': r) w
        -> Eff r w
runHttp mgr eff = interpret handler eff
 where
   handler :: Http a -> Eff r a
   handler (DoRequest req) = send $ httpLbs req mgr
   handler (ParseRequest str) = send $ parseRequest @IO str
   handler (DoRequestJSON req) = do
     response <- handler (DoRequest req)
     let code = statusCode $ responseStatus response
     unless (200 <= code && code < 300) $
       throwError (HttpExceptionRequest req $ StatusCodeException (() <$ response) "")
     let body = responseBody response
     case eitherDecode body of
       Left err -> throwError $ JSONParseError err
       Right val -> return val
     

-- | Interpret 'Http' using a pure function
mockHttp :: Eff (Http ': r) w -> (Request -> Response ByteString) -> Eff r w
mockHttp eff f = interpret (\(DoRequest req) -> return (f req)) eff

-- | Interpret 'Http' using a static map. Will return a 404 if the method/path are not found in the map
staticHttpMock :: Eff (Http ': r) w -> Map (Method, BS.ByteString) (Status, ByteString) -> Eff r w
staticHttpMock eff endpoints = mockHttp eff findEndpoint
    where findEndpoint req = case M.lookup (method req, path req) endpoints of
                               Nothing -> Response status404 http11 [] "" (CJ []) (ResponseClose $ return ())
                               Just (s, b) -> Response s http11 [] b (CJ []) (ResponseClose $ return ())