module Network.Wai.Middleware.AcceptOverride
    ( acceptOverride
    ) where

import Network.Wai
import Control.Monad (join)
import Data.ByteString (ByteString)

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 :: RequestHeaders
requestHeaders = HeaderName -> ByteString -> RequestHeaders -> RequestHeaders
forall a.
Eq a =>
a -> ByteString -> [(a, ByteString)] -> [(a, ByteString)]
changeVal HeaderName
"Accept" ByteString
a (RequestHeaders -> RequestHeaders)
-> RequestHeaders -> RequestHeaders
forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
req}

changeVal :: Eq a
          => a
          -> ByteString
          -> [(a, ByteString)]
          -> [(a, ByteString)]
changeVal :: a -> ByteString -> [(a, ByteString)] -> [(a, ByteString)]
changeVal a
key ByteString
val [(a, ByteString)]
old = (a
key, ByteString
val)
                      (a, ByteString) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. a -> [a] -> [a]
: ((a, ByteString) -> Bool) -> [(a, ByteString)] -> [(a, ByteString)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(a
k, ByteString
_) -> a
k a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
key) [(a, ByteString)]
old