Request.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_GHC -Wall #-}

-- | Classy optics and field lenses for 'Request'.
module Network.Wai.Optics.Request (
  -- * Classy optics
  GetRequest (..),
  HasRequest (..),
  ReviewRequest (..),
  AsRequest (..),
) where

import Control.Category (id)
import Control.Lens (Getter, Lens', Prism', Review, lens, prism', review, set, to, unto, view)
import Data.Bool (Bool)
import Data.ByteString (ByteString)
import Data.Maybe (Maybe (..))
import Data.Text (Text)
import Data.Vault.Lazy (Vault)
import Network.HTTP.Types (HttpVersion, Method, Query, RequestHeaders)
import Network.Socket (SockAddr)
import Network.Wai (Request)
import qualified Network.Wai as Wai
import Network.Wai.Internal (RequestBodyLength)
import Network.Wai.Optics.Internal (
  httpVersionL,
  isSecureL,
  pathInfoL,
  queryStringL,
  rawPathInfoL,
  rawQueryStringL,
  remoteHostL,
  requestBodyL,
  requestBodyLengthL,
  requestHeaderHostL,
  requestHeaderRangeL,
  requestHeaderRefererL,
  requestHeaderUserAgentL,
  requestHeadersL,
  requestMethodL,
  vaultL,
 )
import Prelude (IO, const, flip, (.))

-- | Type class for values that can be viewed as a 'Request'.
class GetRequest s where
  -- | A 'Getter' to obtain a 'Request'.
  getRequest :: Getter s Request

  -- | A 'Getter' on the HTTP request method.
  getRequestMethod :: Getter s Method
  getRequestMethod = getRequest . to Wai.requestMethod
  {-# INLINE getRequestMethod #-}

  -- | A 'Getter' on the HTTP version.
  getHttpVersion :: Getter s HttpVersion
  getHttpVersion = getRequest . to Wai.httpVersion
  {-# INLINE getHttpVersion #-}

  -- | A 'Getter' on the raw path info.
  getRawPathInfo :: Getter s ByteString
  getRawPathInfo = getRequest . to Wai.rawPathInfo
  {-# INLINE getRawPathInfo #-}

  -- | A 'Getter' on the raw query string.
  getRawQueryString :: Getter s ByteString
  getRawQueryString = getRequest . to Wai.rawQueryString
  {-# INLINE getRawQueryString #-}

  -- | A 'Getter' on the request headers.
  getRequestHeaders :: Getter s RequestHeaders
  getRequestHeaders = getRequest . to Wai.requestHeaders
  {-# INLINE getRequestHeaders #-}

  -- | A 'Getter' on whether the request was made over a secure connection.
  getIsSecure :: Getter s Bool
  getIsSecure = getRequest . to Wai.isSecure
  {-# INLINE getIsSecure #-}

  -- | A 'Getter' on the remote host address.
  getRemoteHost :: Getter s SockAddr
  getRemoteHost = getRequest . to Wai.remoteHost
  {-# INLINE getRemoteHost #-}

  -- | A 'Getter' on the parsed path segments.
  getPathInfo :: Getter s [Text]
  getPathInfo = getRequest . to Wai.pathInfo
  {-# INLINE getPathInfo #-}

  -- | A 'Getter' on the parsed query string.
  getQueryString :: Getter s Query
  getQueryString = getRequest . to Wai.queryString
  {-# INLINE getQueryString #-}

  -- | A 'Getter' on the request body action.
  getRequestBody :: Getter s (IO ByteString)
  getRequestBody = getRequest . to Wai.getRequestBodyChunk
  {-# INLINE getRequestBody #-}

  -- | A 'Getter' on the 'Vault'.
  getVault :: Getter s Vault
  getVault = getRequest . to Wai.vault
  {-# INLINE getVault #-}

  -- | A 'Getter' on the 'RequestBodyLength'.
  getRequestBodyLengthField :: Getter s RequestBodyLength
  getRequestBodyLengthField = getRequest . to Wai.requestBodyLength
  {-# INLINE getRequestBodyLengthField #-}

  -- | A 'Getter' on the @Host@ header.
  getRequestHeaderHost :: Getter s (Maybe ByteString)
  getRequestHeaderHost = getRequest . to Wai.requestHeaderHost
  {-# INLINE getRequestHeaderHost #-}

  -- | A 'Getter' on the @Range@ header.
  getRequestHeaderRange :: Getter s (Maybe ByteString)
  getRequestHeaderRange = getRequest . to Wai.requestHeaderRange
  {-# INLINE getRequestHeaderRange #-}

  -- | A 'Getter' on the @Referer@ header.
  getRequestHeaderReferer :: Getter s (Maybe ByteString)
  getRequestHeaderReferer = getRequest . to Wai.requestHeaderReferer
  {-# INLINE getRequestHeaderReferer #-}

  -- | A 'Getter' on the @User-Agent@ header.
  getRequestHeaderUserAgent :: Getter s (Maybe ByteString)
  getRequestHeaderUserAgent = getRequest . to Wai.requestHeaderUserAgent
  {-# INLINE getRequestHeaderUserAgent #-}

instance GetRequest Request where
  getRequest = id
  {-# INLINE getRequest #-}
  getRequestMethod = to Wai.requestMethod
  {-# INLINE getRequestMethod #-}
  getHttpVersion = to Wai.httpVersion
  {-# INLINE getHttpVersion #-}
  getRawPathInfo = to Wai.rawPathInfo
  {-# INLINE getRawPathInfo #-}
  getRawQueryString = to Wai.rawQueryString
  {-# INLINE getRawQueryString #-}
  getRequestHeaders = to Wai.requestHeaders
  {-# INLINE getRequestHeaders #-}
  getIsSecure = to Wai.isSecure
  {-# INLINE getIsSecure #-}
  getRemoteHost = to Wai.remoteHost
  {-# INLINE getRemoteHost #-}
  getPathInfo = to Wai.pathInfo
  {-# INLINE getPathInfo #-}
  getQueryString = to Wai.queryString
  {-# INLINE getQueryString #-}
  getRequestBody = to Wai.getRequestBodyChunk
  {-# INLINE getRequestBody #-}
  getVault = to Wai.vault
  {-# INLINE getVault #-}
  getRequestBodyLengthField = to Wai.requestBodyLength
  {-# INLINE getRequestBodyLengthField #-}
  getRequestHeaderHost = to Wai.requestHeaderHost
  {-# INLINE getRequestHeaderHost #-}
  getRequestHeaderRange = to Wai.requestHeaderRange
  {-# INLINE getRequestHeaderRange #-}
  getRequestHeaderReferer = to Wai.requestHeaderReferer
  {-# INLINE getRequestHeaderReferer #-}
  getRequestHeaderUserAgent = to Wai.requestHeaderUserAgent
  {-# INLINE getRequestHeaderUserAgent #-}

-- | Type class for values with a lens into a 'Request'.
class (GetRequest s) => HasRequest s where
  {-# MINIMAL setRequest #-}

  -- | Replace the 'Request' component.
  setRequest :: Request -> s -> s

  -- | A 'Lens'' into the 'Request' component.
  request :: Lens' s Request
  request = lens (view getRequest) (flip setRequest)
  {-# INLINE request #-}

  -- | Replace the HTTP request method.
  setRequestMethod :: Method -> s -> s
  setRequestMethod = set requestMethod
  {-# INLINE setRequestMethod #-}

  -- | A 'Lens'' on the HTTP request method.
  requestMethod :: Lens' s Method
  requestMethod = request . requestMethodL
  {-# INLINE requestMethod #-}

  -- | Replace the HTTP version.
  setHttpVersion :: HttpVersion -> s -> s
  setHttpVersion = set httpVersion
  {-# INLINE setHttpVersion #-}

  -- | A 'Lens'' on the HTTP version.
  httpVersion :: Lens' s HttpVersion
  httpVersion = request . httpVersionL
  {-# INLINE httpVersion #-}

  -- | Replace the raw path info.
  setRawPathInfo :: ByteString -> s -> s
  setRawPathInfo = set rawPathInfo
  {-# INLINE setRawPathInfo #-}

  -- | A 'Lens'' on the raw path info.
  rawPathInfo :: Lens' s ByteString
  rawPathInfo = request . rawPathInfoL
  {-# INLINE rawPathInfo #-}

  -- | Replace the raw query string.
  setRawQueryString :: ByteString -> s -> s
  setRawQueryString = set rawQueryString
  {-# INLINE setRawQueryString #-}

  -- | A 'Lens'' on the raw query string.
  rawQueryString :: Lens' s ByteString
  rawQueryString = request . rawQueryStringL
  {-# INLINE rawQueryString #-}

  -- | Replace the request headers.
  setRequestHeaders :: RequestHeaders -> s -> s
  setRequestHeaders = set requestHeaders
  {-# INLINE setRequestHeaders #-}

  -- | A 'Lens'' on the request headers.
  requestHeaders :: Lens' s RequestHeaders
  requestHeaders = request . requestHeadersL
  {-# INLINE requestHeaders #-}

  -- | Replace whether the request was made over a secure connection.
  setIsSecure :: Bool -> s -> s
  setIsSecure = set isSecure
  {-# INLINE setIsSecure #-}

  -- | A 'Lens'' on whether the request was made over a secure connection.
  isSecure :: Lens' s Bool
  isSecure = request . isSecureL
  {-# INLINE isSecure #-}

  -- | Replace the remote host address.
  setRemoteHost :: SockAddr -> s -> s
  setRemoteHost = set remoteHost
  {-# INLINE setRemoteHost #-}

  -- | A 'Lens'' on the remote host address.
  remoteHost :: Lens' s SockAddr
  remoteHost = request . remoteHostL
  {-# INLINE remoteHost #-}

  -- | Replace the parsed path segments.
  setPathInfo :: [Text] -> s -> s
  setPathInfo = set pathInfo
  {-# INLINE setPathInfo #-}

  -- | A 'Lens'' on the parsed path segments.
  pathInfo :: Lens' s [Text]
  pathInfo = request . pathInfoL
  {-# INLINE pathInfo #-}

  -- | Replace the parsed query string.
  setQueryString :: Query -> s -> s
  setQueryString = set queryString
  {-# INLINE setQueryString #-}

  -- | A 'Lens'' on the parsed query string.
  queryString :: Lens' s Query
  queryString = request . queryStringL
  {-# INLINE queryString #-}

  -- | Replace the request body action.
  setRequestBody :: IO ByteString -> s -> s
  setRequestBody = set requestBody
  {-# INLINE setRequestBody #-}

  -- | A 'Lens'' on the request body action.
  requestBody :: Lens' s (IO ByteString)
  requestBody = request . requestBodyL
  {-# INLINE requestBody #-}

  -- | Replace the 'Vault'.
  setVault :: Vault -> s -> s
  setVault = set vault
  {-# INLINE setVault #-}

  -- | A 'Lens'' on the 'Vault'.
  vault :: Lens' s Vault
  vault = request . vaultL
  {-# INLINE vault #-}

  -- | Replace the 'RequestBodyLength'.
  setRequestBodyLengthField :: RequestBodyLength -> s -> s
  setRequestBodyLengthField = set requestBodyLengthField
  {-# INLINE setRequestBodyLengthField #-}

  -- | A 'Lens'' on the 'RequestBodyLength'.
  requestBodyLengthField :: Lens' s RequestBodyLength
  requestBodyLengthField = request . requestBodyLengthL
  {-# INLINE requestBodyLengthField #-}

  -- | Replace the @Host@ header.
  setRequestHeaderHost :: Maybe ByteString -> s -> s
  setRequestHeaderHost = set requestHeaderHost
  {-# INLINE setRequestHeaderHost #-}

  -- | A 'Lens'' on the @Host@ header.
  requestHeaderHost :: Lens' s (Maybe ByteString)
  requestHeaderHost = request . requestHeaderHostL
  {-# INLINE requestHeaderHost #-}

  -- | Replace the @Range@ header.
  setRequestHeaderRange :: Maybe ByteString -> s -> s
  setRequestHeaderRange = set requestHeaderRange
  {-# INLINE setRequestHeaderRange #-}

  -- | A 'Lens'' on the @Range@ header.
  requestHeaderRange :: Lens' s (Maybe ByteString)
  requestHeaderRange = request . requestHeaderRangeL
  {-# INLINE requestHeaderRange #-}

  -- | Replace the @Referer@ header.
  setRequestHeaderReferer :: Maybe ByteString -> s -> s
  setRequestHeaderReferer = set requestHeaderReferer
  {-# INLINE setRequestHeaderReferer #-}

  -- | A 'Lens'' on the @Referer@ header.
  requestHeaderReferer :: Lens' s (Maybe ByteString)
  requestHeaderReferer = request . requestHeaderRefererL
  {-# INLINE requestHeaderReferer #-}

  -- | Replace the @User-Agent@ header.
  setRequestHeaderUserAgent :: Maybe ByteString -> s -> s
  setRequestHeaderUserAgent = set requestHeaderUserAgent
  {-# INLINE setRequestHeaderUserAgent #-}

  -- | A 'Lens'' on the @User-Agent@ header.
  requestHeaderUserAgent :: Lens' s (Maybe ByteString)
  requestHeaderUserAgent = request . requestHeaderUserAgentL
  {-# INLINE requestHeaderUserAgent #-}

instance HasRequest Request where
  setRequest = const
  {-# INLINE setRequest #-}
  requestMethod = requestMethodL
  {-# INLINE requestMethod #-}
  httpVersion = httpVersionL
  {-# INLINE httpVersion #-}
  rawPathInfo = rawPathInfoL
  {-# INLINE rawPathInfo #-}
  rawQueryString = rawQueryStringL
  {-# INLINE rawQueryString #-}
  requestHeaders = requestHeadersL
  {-# INLINE requestHeaders #-}
  isSecure = isSecureL
  {-# INLINE isSecure #-}
  remoteHost = remoteHostL
  {-# INLINE remoteHost #-}
  pathInfo = pathInfoL
  {-# INLINE pathInfo #-}
  queryString = queryStringL
  {-# INLINE queryString #-}
  requestBody = requestBodyL
  {-# INLINE requestBody #-}
  vault = vaultL
  {-# INLINE vault #-}
  requestBodyLengthField = requestBodyLengthL
  {-# INLINE requestBodyLengthField #-}
  requestHeaderHost = requestHeaderHostL
  {-# INLINE requestHeaderHost #-}
  requestHeaderRange = requestHeaderRangeL
  {-# INLINE requestHeaderRange #-}
  requestHeaderReferer = requestHeaderRefererL
  {-# INLINE requestHeaderReferer #-}
  requestHeaderUserAgent = requestHeaderUserAgentL
  {-# INLINE requestHeaderUserAgent #-}

-- | Type class for values that can be constructed from a 'Request'.
class ReviewRequest t where
  -- | A 'Review' to construct a value from a 'Request'.
  reviewRequest :: Review t Request

instance ReviewRequest Request where
  reviewRequest = unto id
  {-# INLINE reviewRequest #-}

-- | Type class for values with a prism into a 'Request'.
class (ReviewRequest t) => AsRequest t where
  {-# MINIMAL matchRequest #-}

  -- | Attempt to extract a 'Request'.
  matchRequest :: t -> Maybe Request

  -- | A 'Prism'' into a 'Request'.
  _Request :: Prism' t Request
  _Request = prism' (review reviewRequest) matchRequest
  {-# INLINE _Request #-}

instance AsRequest Request where
  matchRequest = Just
  {-# INLINE matchRequest #-}