HttpClient.hs

module Http.HttpClient where

import Control.Effect
import Control.Effect.State
import Control.Monad.IO.Class (MonadIO)
import Data.Proxy (Proxy)
import Http.HttpState (HttpState (..))
import qualified Network.HTTP.Req as R

data HttpClient m a where
  GetRequest :: R.HttpResponse response => R.Url 'R.Https -> Proxy response -> HttpClient m response
  PostRequest :: (R.HttpResponse response, R.HttpBody body) => R.Url 'R.Https -> body -> Proxy response -> HttpClient m response

getRequest ::
  (Eff HttpClient m, R.HttpResponse response) =>
  R.Url 'R.Https ->
  Proxy response ->
  m response
getRequest url proxy = send (GetRequest url proxy)

postRequest ::
  (Eff HttpClient m, R.HttpResponse response, R.HttpBody body) =>
  R.Url 'R.Https ->
  body ->
  Proxy response ->
  m response
postRequest url body proxy = send (PostRequest url body proxy)

type HttpClientC m = ReinterpretSimpleC HttpClient '[State HttpState] (StateC HttpState m)

httpClientToIO :: (Eff (Embed IO) m, Threaders '[ReaderThreads, StateThreads] m p) => HttpClientC m a -> m a
httpClientToIO =
  evalState (HttpState Nothing)
    . reinterpretSimple
      ( \eff -> do
          options <- buildOptions
          case eff of
            GetRequest url response -> runRequest $ R.req R.GET url R.NoReqBody response options
            PostRequest url body response -> runRequest $ R.req R.POST url body response options
      )

userAgent :: R.Option 'R.Https
userAgent =
  R.header
    "User-Agent"
    "Mozilla/5.0 (Windows NT 6.1; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) \
    \Chrome/69.0.3497.100 Safari/537.36"

userAgentWithCookies :: Maybe (R.Option 'R.Https) -> R.Option 'R.Https
userAgentWithCookies (Just cookies) = userAgent <> cookies
userAgentWithCookies Nothing = userAgent

buildOptions :: Eff (State HttpState) m => m (R.Option 'R.Https)
buildOptions = do
  HttpState cookies <- get
  return $ userAgentWithCookies cookies

runRequest :: (Eff (State HttpState) m, MonadIO m, R.HttpResponse a) => R.Req a -> m a
runRequest request = do
  result <- R.runReq R.defaultHttpConfig request
  put . HttpState . Just . R.cookieJar $ R.responseCookieJar result
  return result

HttpState.hs

module Http.HttpState (
  HttpState (..),
) where

import Network.HTTP.Req (Option, Scheme (Https))

newtype HttpState = HttpState (Maybe (Option 'Https))