Response.hs

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

-- | Classy optics and constructor prisms for 'Response'.
module Network.Wai.Optics.Response (
  -- * Classy optics
  GetResponse (..),
  HasResponse (..),
  ReviewResponse (..),
  AsResponse (..),

  -- * Constructor prisms

  -- ** ResponseFile
  ReviewResponseFile (..),
  AsResponseFile (..),

  -- ** ResponseBuilder
  ReviewResponseBuilder (..),
  AsResponseBuilder (..),

  -- ** ResponseStream
  ReviewResponseStream (..),
  AsResponseStream (..),

  -- ** ResponseRaw
  ReviewResponseRaw (..),
  AsResponseRaw (..),

  -- * Setters
  applicationResponse,
) where

import Control.Category (id, (.))
import Control.Lens (Getter, Lens', Prism', Review, Setter', lens, prism', review, sets, to, unto, view)
import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder)
import Data.Maybe (Maybe (..))
import Network.HTTP.Types (ResponseHeaders, Status)
import Network.Wai (Application, Response, StreamingBody)
import qualified Network.Wai as Wai
import Network.Wai.Internal (
  FilePart,
  Response (..),
 )
import Prelude (FilePath, IO, const, flip, uncurry)

-- | Type class for values that can be viewed as a 'Response'.
class GetResponse s where
  -- | A 'Getter' to obtain a 'Response'.
  getResponse :: Getter s Response
  -- | A 'Getter' on the 'Status'.
  getResponseStatus :: Getter s Status
  getResponseStatus = getResponse . getResponseStatus
  {-# INLINE getResponseStatus #-}
  -- | A 'Getter' on the 'ResponseHeaders'.
  getResponseHeaders :: Getter s ResponseHeaders
  getResponseHeaders = getResponse . getResponseHeaders
  {-# INLINE getResponseHeaders #-}

instance GetResponse Response where
  getResponse = id
  {-# INLINE getResponse #-}
  getResponseStatus = to Wai.responseStatus
  {-# INLINE getResponseStatus #-}
  getResponseHeaders = to Wai.responseHeaders
  {-# INLINE getResponseHeaders #-}

-- | Type class for values with a lens into a 'Response'.
class (GetResponse s) => HasResponse s where
  {-# MINIMAL setResponse #-}

  -- | Replace the 'Response' component.
  setResponse :: Response -> s -> s

  -- | A 'Lens'' into the 'Response' component.
  response :: Lens' s Response
  response = lens (view getResponse) (flip setResponse)
  {-# INLINE response #-}

  -- | A 'Lens'' on the 'Status'.
  responseStatus :: Lens' s Status
  responseStatus = response . responseStatus
  {-# INLINE responseStatus #-}

  -- | A 'Lens'' on the 'ResponseHeaders'.
  responseHeaders :: Lens' s ResponseHeaders
  responseHeaders = response . responseHeaders
  {-# INLINE responseHeaders #-}

instance HasResponse Response where
  setResponse = const
  {-# INLINE setResponse #-}
  responseStatus = lens Wai.responseStatus (\r s -> Wai.mapResponseStatus (const s) r)
  {-# INLINE responseStatus #-}
  responseHeaders = lens Wai.responseHeaders (\r h -> Wai.mapResponseHeaders (const h) r)
  {-# INLINE responseHeaders #-}

-- | Type class for values that can be constructed from a 'Response'.
class ReviewResponse t where
  -- | A 'Review' to construct a value from a 'Response'.
  reviewResponse :: Review t Response

instance ReviewResponse Response where
  reviewResponse = unto id
  {-# INLINE reviewResponse #-}

-- | Type class for values with a prism into a 'Response'.
class (ReviewResponse t) => AsResponse t where
  {-# MINIMAL matchResponse #-}

  -- | Attempt to extract a 'Response'.
  matchResponse :: t -> Maybe Response

  -- | A 'Prism'' into a 'Response'.
  _Response :: Prism' t Response
  _Response = prism' (review reviewResponse) matchResponse
  {-# INLINE _Response #-}

instance AsResponse Response where
  matchResponse = Just
  {-# INLINE matchResponse #-}

-- | A 'Setter'' on the 'Response' within an 'Application'.
--
-- Uses 'Wai.modifyResponse' under the hood. Allows modifying the response
-- that an 'Application' produces without manually threading the CPS callback.
applicationResponse :: Setter' Application Response
applicationResponse = sets Wai.modifyResponse
{-# INLINE applicationResponse #-}

-- ** ResponseFile

-- | Type class for values that can be constructed from a @ResponseFile@.
class ReviewResponseFile t where
  -- | A 'Review' to construct a value from @ResponseFile@ components.
  reviewResponseFile :: Review t (Status, ResponseHeaders, FilePath, Maybe FilePart)

instance ReviewResponseFile Response where
  reviewResponseFile = unto (\(s, h, fp, mfp) -> ResponseFile s h fp mfp)
  {-# INLINE reviewResponseFile #-}

-- | Type class for values with a prism into a @ResponseFile@.
class (ReviewResponseFile t) => AsResponseFile t where
  {-# MINIMAL matchResponseFile #-}

  -- | Attempt to extract @ResponseFile@ components.
  matchResponseFile :: t -> Maybe (Status, ResponseHeaders, FilePath, Maybe FilePart)

  -- | A 'Prism'' into @ResponseFile@ components.
  _ResponseFile :: Prism' t (Status, ResponseHeaders, FilePath, Maybe FilePart)
  _ResponseFile = prism' (review reviewResponseFile) matchResponseFile
  {-# INLINE _ResponseFile #-}

instance AsResponseFile Response where
  matchResponseFile = \case
    ResponseFile s h fp mfp -> Just (s, h, fp, mfp)
    _ -> Nothing
  {-# INLINE matchResponseFile #-}

-- ** ResponseBuilder

-- | Type class for values that can be constructed from a @ResponseBuilder@.
class ReviewResponseBuilder t where
  -- | A 'Review' to construct a value from @ResponseBuilder@ components.
  reviewResponseBuilder :: Review t (Status, ResponseHeaders, Builder)

instance ReviewResponseBuilder Response where
  reviewResponseBuilder = unto (\(s, h, b) -> ResponseBuilder s h b)
  {-# INLINE reviewResponseBuilder #-}

-- | Type class for values with a prism into a @ResponseBuilder@.
class (ReviewResponseBuilder t) => AsResponseBuilder t where
  {-# MINIMAL matchResponseBuilder #-}

  -- | Attempt to extract @ResponseBuilder@ components.
  matchResponseBuilder :: t -> Maybe (Status, ResponseHeaders, Builder)

  -- | A 'Prism'' into @ResponseBuilder@ components.
  _ResponseBuilder :: Prism' t (Status, ResponseHeaders, Builder)
  _ResponseBuilder = prism' (review reviewResponseBuilder) matchResponseBuilder
  {-# INLINE _ResponseBuilder #-}

instance AsResponseBuilder Response where
  matchResponseBuilder = \case
    ResponseBuilder s h b -> Just (s, h, b)
    _ -> Nothing
  {-# INLINE matchResponseBuilder #-}

-- ** ResponseStream

-- | Type class for values that can be constructed from a @ResponseStream@.
class ReviewResponseStream t where
  -- | A 'Review' to construct a value from @ResponseStream@ components.
  reviewResponseStream :: Review t (Status, ResponseHeaders, StreamingBody)

instance ReviewResponseStream Response where
  reviewResponseStream = unto (\(s, h, sb) -> ResponseStream s h sb)
  {-# INLINE reviewResponseStream #-}

-- | Type class for values with a prism into a @ResponseStream@.
class (ReviewResponseStream t) => AsResponseStream t where
  {-# MINIMAL matchResponseStream #-}

  -- | Attempt to extract @ResponseStream@ components.
  matchResponseStream :: t -> Maybe (Status, ResponseHeaders, StreamingBody)

  -- | A 'Prism'' into @ResponseStream@ components.
  _ResponseStream :: Prism' t (Status, ResponseHeaders, StreamingBody)
  _ResponseStream = prism' (review reviewResponseStream) matchResponseStream
  {-# INLINE _ResponseStream #-}

instance AsResponseStream Response where
  matchResponseStream = \case
    ResponseStream s h sb -> Just (s, h, sb)
    _ -> Nothing
  {-# INLINE matchResponseStream #-}

-- ** ResponseRaw

-- | Type class for values that can be constructed from a @ResponseRaw@.
class ReviewResponseRaw t where
  -- | A 'Review' to construct a value from @ResponseRaw@ components.
  reviewResponseRaw :: Review t (IO ByteString -> (ByteString -> IO ()) -> IO (), Response)

instance ReviewResponseRaw Response where
  reviewResponseRaw = unto (uncurry ResponseRaw)
  {-# INLINE reviewResponseRaw #-}

-- | Type class for values with a prism into a @ResponseRaw@.
class (ReviewResponseRaw t) => AsResponseRaw t where
  {-# MINIMAL matchResponseRaw #-}

  -- | Attempt to extract @ResponseRaw@ components.
  matchResponseRaw :: t -> Maybe (IO ByteString -> (ByteString -> IO ()) -> IO (), Response)

  -- | A 'Prism'' into @ResponseRaw@ components.
  _ResponseRaw :: Prism' t (IO ByteString -> (ByteString -> IO ()) -> IO (), Response)
  _ResponseRaw = prism' (review reviewResponseRaw) matchResponseRaw
  {-# INLINE _ResponseRaw #-}

instance AsResponseRaw Response where
  matchResponseRaw = \case
    ResponseRaw f r -> Just (f, r)
    _ -> Nothing
  {-# INLINE matchResponseRaw #-}