module Network.Wai.Middleware.AcceptOverride (
    -- $howto
    acceptOverride,
) where

import Control.Monad (join)
import Network.Wai

import Network.Wai.Header (replaceHeader)

-- $howto
-- This 'Middleware' provides a way for the request itself to
-- tell the server to override the \"Accept\" header by looking
-- for the \"_accept\" query parameter in the query string and
-- inserting or replacing the \"Accept\" header with that string.
--
-- For example:
--
-- @
-- ?_accept=SomeValue
-- @
--
-- This will result in \"Accept: SomeValue\" being set in the
-- request as a header, and all other previous \"Accept\" headers
-- will be removed from the request.

acceptOverride :: Middleware
acceptOverride :: Middleware
acceptOverride Application
app Request
req =
    Application
app Request
req'
  where
    req' :: Request
req' =
        case Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe ByteString) -> Maybe ByteString)
-> Maybe (Maybe ByteString) -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
-> [(ByteString, Maybe ByteString)] -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"_accept" ([(ByteString, Maybe ByteString)] -> Maybe (Maybe ByteString))
-> [(ByteString, Maybe ByteString)] -> Maybe (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> [(ByteString, Maybe ByteString)]
queryString Request
req of
            Maybe ByteString
Nothing -> Request
req
            Just ByteString
a ->
                Request
req
                    { requestHeaders = replaceHeader "Accept" a $ requestHeaders req
                    }