Use `http-types` types in request and response

[colehaus]

There's a fairly standard set of types for these defined https://hackage.haskell.org/package/http-types. wai (Web Application Interface) depends on them directly. Beyond the general benefits of standardization, using the standards here would make it slightly easier to package up WAI applications for use with API Gateway.

Here's a rough draft of that:

{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TypeApplications  #-}

module Main where

import           AWSLambda.Events.APIGateway as AWS hiding (requestBody)
import qualified AWSLambda.Events.APIGateway as AWS
import           Control.Lens
import           Control.Monad               ((<=<))
import qualified Data.Aeson.TextValue        as Aeson
import           Data.ByteString             (ByteString)
import           Data.ByteString.Builder     (toLazyByteString)
import qualified Data.ByteString.Lazy        as Lazy
import qualified Data.CaseInsensitive        as CI
import           Data.Convertible            (Convertible, convert)
import qualified Data.HashMap.Strict         as HashMap
import           Data.IORef                  (IORef, modifyIORef', newIORef,
                                              readIORef, writeIORef)
import           Data.Maybe
import           Data.Semigroup              ((<>))
import           Data.Text                   (Text, splitOn)
import           Network.HTTP.Types          as HTTP
import qualified Network.Wai                 as Wai
import           Network.Wai.Handler.Warp    (runEnv)
import qualified Network.Wai.Internal        as Wai
import           System.Environment          (lookupEnv)

echo :: Wai.Application
echo req sendResponse =
  sendResponse . Wai.responseLBS HTTP.ok200 mempty =<< Wai.strictRequestBody req

main :: IO ()
main = do
  useWarp <- lookupEnv "WARP"
  case useWarp of
    Just _  -> runEnv 8000 echo
    Nothing -> apiGatewayMain . wrapper @Text @Text $ echo

wrapper ::
     (Eq t, Monoid t, Convertible Lazy.ByteString t, Convertible s ByteString)
  => Wai.Application
  -> APIGatewayProxyRequest s
  -> IO (APIGatewayProxyResponse t)
wrapper app req =
  fromWaiResponse . fromJust <=< withIORef Nothing $ \responseRef -> do
    first <- newIORef True
    app
      (toWaiRequest first req)
      (fmap (const Wai.ResponseReceived) . writeIORef responseRef . Just)

toWaiRequest ::
     (Convertible t ByteString)
  => IORef Bool
  -> APIGatewayProxyRequest t
  -> Wai.Request
toWaiRequest first req = Wai.Request {..}
  where
    requestMethod = req ^. agprqHttpMethod . to convert
    httpVersion = error "No HTTP version"
    rawPathInfo = req ^. agprqPath . to convert
    rawQueryString = error "No raw query string"
    requestHeaders =
      req ^.. agprqHeaders . to itoList . traverse .
      to (bimap (CI.mk . convert) convert)
    isSecure = error "Not HTTP or HTTPS"
    remoteHost = error "No remote host"
    pathInfo = req ^. agprqPath . to (splitOn "/")
    queryString =
      req ^.. agprqQueryStringParameters . to itoList . traverse .
      to (bimap convert (Just . convert))
    requestBody' = req ^? AWS.requestBody . _Just . to convert
    requestBody = yieldOnce (fromMaybe mempty requestBody') first
    vault = mempty
    requestBodyLength = Wai.KnownLength . convert . length $ requestBody'
    requestHeaderHost = req ^? agprqHeaders . ix "Host" . to convert
    requestHeaderRange = req ^? agprqHeaders . ix "Range" . to convert
    requestHeaderReferer = req ^? agprqHeaders . ix "Referer" . to convert
    requestHeaderUserAgent = req ^? agprqHeaders . ix "User-Agent" . to convert

yieldOnce :: Monoid b => b -> IORef Bool -> IO b
yieldOnce payload ref = do
  first <- readIORef ref
  if first
    then payload <$ writeIORef ref False
    else mempty

withIORef :: b -> (IORef b -> IO a) -> IO b
withIORef a m = do
  ref <- newIORef a
  _ <- m ref
  readIORef ref

fromWaiResponse ::
     (Convertible Lazy.ByteString t, Eq t, Monoid t)
  => Wai.Response
  -> IO (APIGatewayProxyResponse t)
fromWaiResponse res = do
  _agprsBody <-
    waiBody $ \f ->
      fmap mungeBody . withIORef mempty $ \contentRef ->
        f (\chunk -> modifyIORef' contentRef (<> chunk)) mempty
  pure $ APIGatewayProxyResponse {..}
  where
    mungeBody = nonEmpty . convert . toLazyByteString
    nonEmpty x
      | x == mempty = Nothing
      | otherwise = Just (Aeson.TextValue x)
    (HTTP.Status _agprsStatusCode _, waiHeaders, waiBody) =
      Wai.responseToStream res
    _agprsHeaders =
      HashMap.fromList . fmap (bimap (convert . CI.original) (convert . id)) $
      waiHeaders

As you can see, toWaiRequest and fromWaiResponse would benefit a bit from better harmony with the standard.

[koterpillar]

Yes, it's the intent to use types compatible with wai, etc. to put applications already using another framework - servant, etc. - behind an API Gateway. Just haven't got around to it yet, pull requests welcome.

[JBetz]

This would also alleviate #32 for API Gateways, since you could use a warp server for local development and deploy to serverless without needing to maintain two separate APIs.

@colehaus Your draft looks nearly complete, unless your usages of error indicate information that can't be extracted from APIGatewayProxyRequest. In either case, I'm going to try to get this working over the next few days, because yeah, this would be great.

[colehaus]

I actually have some time today. I can try to get polish this a bit and actually send out a couple PRs. I'm thinking that the switch to standard types should be a PR to this package and the WAI stuff can be a small standalone package to keep dependencies slim. Sound reasonable?

[colehaus]

See https://github.com/seek-oss/serverless-haskell/pull/45 and https://github.com/colehaus/wai-gateway.