-- SPDX-FileCopyrightText: 2026 Alexandra de Wit
--
-- SPDX-License-Identifier: MIT

{- | Whether a request's @Accept@ header admits a media type a route serves, the one question
the router answers @406 Not Acceptable@ on. Nothing is selected by quality: each route serves
one form, so a client that wants another is refused rather than given a substitute.

The reading follows RFC 9110. An absent @Accept@ admits anything, a range matches exactly, by
its type half under @type\/*@, or universally under @*\/*@, and a range parameter is ignored
except @q=0@, which rejects rather than ranks.
-}
module Ecluse.Core.Server.Accept (
    acceptsAny,
) where

import Data.ByteString.Char8 qualified as BS8
import Data.Char (toLower)
import Data.List (lookup)
import Network.HTTP.Types.Header (RequestHeaders, hAccept)

{- | Whether the request admits at least one of the media types a route serves. A request with
no @Accept@ header admits every one of them.
-}
acceptsAny :: RequestHeaders -> NonEmpty ByteString -> Bool
acceptsAny :: RequestHeaders -> NonEmpty ByteString -> Bool
acceptsAny RequestHeaders
headers NonEmpty ByteString
served = case HeaderName -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hAccept RequestHeaders
headers of
    Maybe ByteString
Nothing -> Bool
True
    Just ByteString
raw -> (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\ByteString
range -> (ByteString -> Bool) -> NonEmpty ByteString -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString -> ByteString -> Bool
admits ByteString
range) NonEmpty ByteString
served) (ByteString -> [ByteString]
acceptRanges ByteString
raw)

-- The ranges an @Accept@ value lists, each still carrying its parameters.
acceptRanges :: ByteString -> [ByteString]
acceptRanges :: ByteString -> [ByteString]
acceptRanges = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
trim ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
BS8.split Char
','

{- Whether one range admits one served type. The range's own parameters are ignored, because
Écluse serves one representation per route and negotiates no parameter, but @q=0@ rejects. -}
admits :: ByteString -> ByteString -> Bool
admits :: ByteString -> ByteString -> Bool
admits ByteString
range ByteString
served =
    Bool -> Bool
not (ByteString -> Bool
rejected ByteString
range) Bool -> Bool -> Bool
&& ByteString -> ByteString -> Bool
matches (ByteString -> ByteString
trim ((Char -> Bool) -> ByteString -> ByteString
BS8.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
';') ByteString
range)) ByteString
served

-- Whether a range's parameters carry the @q=0@ rejection, in any of its spellings.
rejected :: ByteString -> Bool
rejected :: ByteString -> Bool
rejected ByteString
range = (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ByteString -> Bool
isZeroQuality (Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
drop Int
1 ((ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
trim (Char -> ByteString -> [ByteString]
BS8.split Char
';' ByteString
range)))
  where
    isZeroQuality :: ByteString -> Bool
isZeroQuality ByteString
parameter = case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'=') ByteString
parameter of
        (ByteString
name, ByteString
value) -> ByteString -> ByteString
lower (ByteString -> ByteString
trim ByteString
name) ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"q" Bool -> Bool -> Bool
&& ByteString -> Bool
isZero (ByteString -> ByteString
trim (Int -> ByteString -> ByteString
BS8.drop Int
1 ByteString
value))
    -- A quality is a fixed-point number, so every zero spelling ("0", "0.", "0.000") rejects.
    isZero :: ByteString -> Bool
isZero ByteString
value = (Char -> Bool) -> ByteString -> Bool
BS8.all (\Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'0' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') ByteString
value Bool -> Bool -> Bool
&& Bool -> Bool
not (ByteString -> Bool
BS8.null ByteString
value)

-- Whether a parameterless range names a served type: exactly, by its type half, or universally.
matches :: ByteString -> ByteString -> Bool
matches :: ByteString -> ByteString -> Bool
matches ByteString
range ByteString
served
    | ByteString
range ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"*/*" = Bool
True
    | ByteString -> ByteString
lower ByteString
range ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> ByteString
lower ByteString
served = Bool
True
    | Bool
otherwise = case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BS8.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') ByteString
range of
        (ByteString
typeHalf, ByteString
subtype) -> ByteString
subtype ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"/*" Bool -> Bool -> Bool
&& ByteString -> ByteString
lower ByteString
typeHalf ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> ByteString
lower ((Char -> Bool) -> ByteString -> ByteString
BS8.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'/') ByteString
served)

lower :: ByteString -> ByteString
lower :: ByteString -> ByteString
lower = (Char -> Char) -> ByteString -> ByteString
BS8.map Char -> Char
toLower

trim :: ByteString -> ByteString
trim :: ByteString -> ByteString
trim = (Char -> Bool) -> ByteString -> ByteString
BS8.dropWhile Char -> Bool
isSpace (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> ByteString
BS8.dropWhileEnd Char -> Bool
isSpace
  where
    isSpace :: Char -> Bool
isSpace Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\t'