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 (..),

  -- * Getters
  responseStatus,
  responseHeaders,
) where

import Control.Category (id)
import Control.Lens (Getter, Lens', Prism', Review, lens, prism', review, 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 (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

instance GetResponse Response where
  getResponse = id
  {-# INLINE getResponse #-}

-- | 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 #-}

instance HasResponse Response where
  setResponse = const
  {-# INLINE setResponse #-}

-- | 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 'Getter' on the 'Status' of a 'Response'.
responseStatus :: Getter Response Status
responseStatus = to Wai.responseStatus
{-# INLINE responseStatus #-}

-- | A 'Getter' on the 'ResponseHeaders' of a 'Response'.
responseHeaders :: Getter Response ResponseHeaders
responseHeaders = to Wai.responseHeaders
{-# INLINE responseHeaders #-}

-- ** 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 #-}