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

{- | Conditional-GET and @ETag@ handling, split by how the served body relates to upstream's.

A pass-through body (an artifact, unfiltered private metadata) is byte-identical to
upstream's, so the client's validators are relayed upstream ('forwardValidators') and an
upstream @304@ is passed back ('isNotModified'). A transformed body (every packument is
merged and filtered) takes our own strong 'ETag' instead, derived from the serve's inputs
rather than hashed over its output. It can therefore be stale only in the safe direction, a
spurious @200@ and never a wrong @304@, and a @304@ costs no assembly at all.
-}
module Ecluse.Core.Server.Conditional (
    -- * Our own ETag (transformed bodies)
    ETag,
    mkStrongETag,
    renderETag,
    etagHeader,
    Conditional (..),
    evaluateETag,

    -- * Relaying validators (pass-through bodies)
    forwardValidators,
    isNotModified,
) where

import Crypto.Hash (Digest, SHA256)
import Data.ByteArray.Encoding (Base (Base16), convertToBase)
import Data.Text qualified as T
import Network.HTTP.Types (Header, RequestHeaders, Status, statusCode)
import Network.HTTP.Types.Header (hETag, hIfModifiedSince, hIfNoneMatch)

{- | A strong entity tag in the quoted wire form (@"…"@) the @ETag@ header carries. The
'newtype' keeps that quoted form from being confused with the bare digest.
-}
newtype ETag = ETag Text
    deriving stock (ETag -> ETag -> Bool
(ETag -> ETag -> Bool) -> (ETag -> ETag -> Bool) -> Eq ETag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ETag -> ETag -> Bool
== :: ETag -> ETag -> Bool
$c/= :: ETag -> ETag -> Bool
/= :: ETag -> ETag -> Bool
Eq, Eq ETag
Eq ETag =>
(ETag -> ETag -> Ordering)
-> (ETag -> ETag -> Bool)
-> (ETag -> ETag -> Bool)
-> (ETag -> ETag -> Bool)
-> (ETag -> ETag -> Bool)
-> (ETag -> ETag -> ETag)
-> (ETag -> ETag -> ETag)
-> Ord ETag
ETag -> ETag -> Bool
ETag -> ETag -> Ordering
ETag -> ETag -> ETag
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ETag -> ETag -> Ordering
compare :: ETag -> ETag -> Ordering
$c< :: ETag -> ETag -> Bool
< :: ETag -> ETag -> Bool
$c<= :: ETag -> ETag -> Bool
<= :: ETag -> ETag -> Bool
$c> :: ETag -> ETag -> Bool
> :: ETag -> ETag -> Bool
$c>= :: ETag -> ETag -> Bool
>= :: ETag -> ETag -> Bool
$cmax :: ETag -> ETag -> ETag
max :: ETag -> ETag -> ETag
$cmin :: ETag -> ETag -> ETag
min :: ETag -> ETag -> ETag
Ord, Int -> ETag -> ShowS
[ETag] -> ShowS
ETag -> String
(Int -> ETag -> ShowS)
-> (ETag -> String) -> ([ETag] -> ShowS) -> Show ETag
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ETag -> ShowS
showsPrec :: Int -> ETag -> ShowS
$cshow :: ETag -> String
show :: ETag -> String
$cshowList :: [ETag] -> ShowS
showList :: [ETag] -> ShowS
Show)

{- | Quote a SHA-256 digest as a strong 'ETag', hex-encoded. The digest is whatever
fingerprint the serving layer stands behind.
-}
mkStrongETag :: Digest SHA256 -> ETag
mkStrongETag :: Digest SHA256 -> ETag
mkStrongETag Digest SHA256
digest = Text -> ETag
ETag (Text
"\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
hex Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\"")
  where
    hex :: Text
    hex :: Text
hex = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Base -> Digest SHA256 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base16 Digest SHA256
digest :: ByteString)

-- | The 'ETag's wire form, the quoted opaque tag as it goes into the header.
renderETag :: ETag -> Text
renderETag :: ETag -> Text
renderETag (ETag Text
t) = Text
t

-- | The @ETag@ response header carrying this validator.
etagHeader :: ETag -> Header
etagHeader :: ETag -> Header
etagHeader ETag
etag = (HeaderName
hETag, Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 (ETag -> Text
renderETag ETag
etag))

{- | The conditional outcome for a transformed body: whether the client's
validator already matches what we would serve.
-}
data Conditional
    = {- | The served body is unchanged from the client's validator. Answer @304@
      with this 'ETag' and no body.
      -}
      NotModified ETag
    | {- | The served body differs, or no validator was sent. Serve @200@ with
      this 'ETag' header.
      -}
      Modified ETag
    deriving stock (Conditional -> Conditional -> Bool
(Conditional -> Conditional -> Bool)
-> (Conditional -> Conditional -> Bool) -> Eq Conditional
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Conditional -> Conditional -> Bool
== :: Conditional -> Conditional -> Bool
$c/= :: Conditional -> Conditional -> Bool
/= :: Conditional -> Conditional -> Bool
Eq, Int -> Conditional -> ShowS
[Conditional] -> ShowS
Conditional -> String
(Int -> Conditional -> ShowS)
-> (Conditional -> String)
-> ([Conditional] -> ShowS)
-> Show Conditional
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Conditional -> ShowS
showsPrec :: Int -> Conditional -> ShowS
$cshow :: Conditional -> String
show :: Conditional -> String
$cshowList :: [Conditional] -> ShowS
showList :: [Conditional] -> ShowS
Show)

{- | Evaluate a conditional request against our own 'ETag'. The comparison is __weak__ (RFC
7232), and @If-Modified-Since@ is not consulted: a merge has no single upstream timestamp.
-}
evaluateETag :: RequestHeaders -> ETag -> Conditional
evaluateETag :: RequestHeaders -> ETag -> Conditional
evaluateETag RequestHeaders
headers ETag
etag
    | Bool
matches = ETag -> Conditional
NotModified ETag
etag
    | Bool
otherwise = ETag -> Conditional
Modified ETag
etag
  where
    matches :: Bool
    matches :: Bool
matches = (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ByteString -> Bool
clientMatches (HeaderName -> RequestHeaders -> [ByteString]
forall a b. Eq a => a -> [(a, b)] -> [b]
lookupAll HeaderName
hIfNoneMatch RequestHeaders
headers)

    -- One If-None-Match header value matches if it is a wildcard or lists a tag
    -- whose opaque value equals ours (weak comparison).
    clientMatches :: ByteString -> Bool
    clientMatches :: ByteString -> Bool
clientMatches ByteString
raw =
        let value :: Text
value = Text -> Text
T.strip (ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 ByteString
raw)
         in Text
value Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"*"
                Bool -> Bool -> Bool
|| Text
ours Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem` (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
normaliseTag (Text -> [Text]
splitTags Text
value)

    ours :: Text
    ours :: Text
ours = Text -> Text
normaliseTag (ETag -> Text
renderETag ETag
etag)

-- Split a comma-separated If-None-Match value into its individual tags, trimmed.
splitTags :: Text -> [Text]
splitTags :: Text -> [Text]
splitTags = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
","

-- Normalise an entity tag for weak comparison: drop a leading @W/@ weakness
-- marker, leaving the quoted opaque tag the two sides are compared on.
normaliseTag :: Text -> Text
normaliseTag :: Text -> Text
normaliseTag Text
t = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Text -> Text -> Maybe Text
T.stripPrefix Text
"W/" Text
t)

{- | The client's conditional validators to relay upstream for a __pass-through__ body. Only
these two are forwarded, so upstream answers @304@ without receiving any other client header.
-}
forwardValidators :: RequestHeaders -> RequestHeaders
forwardValidators :: RequestHeaders -> RequestHeaders
forwardValidators = (Header -> Bool) -> RequestHeaders -> RequestHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (HeaderName -> Bool
isValidator (HeaderName -> Bool) -> (Header -> HeaderName) -> Header -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Header -> HeaderName
forall a b. (a, b) -> a
fst)
  where
    isValidator :: HeaderName -> Bool
isValidator HeaderName
name = HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hIfNoneMatch Bool -> Bool -> Bool
|| HeaderName
name HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
== HeaderName
hIfModifiedSince

{- | Whether an upstream response is a @304 Not Modified@ to pass straight back to the
client. Used on the pass-through path, where upstream's own validator decided.
-}
isNotModified :: Status -> Bool
isNotModified :: Status -> Bool
isNotModified Status
s = Status -> Int
statusCode Status
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
304

-- All values for a header name (a header may legally repeat).
lookupAll :: (Eq a) => a -> [(a, b)] -> [b]
lookupAll :: forall a b. Eq a => a -> [(a, b)] -> [b]
lookupAll a
name = ((a, b) -> b) -> [(a, b)] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map (a, b) -> b
forall a b. (a, b) -> b
snd ([(a, b)] -> [b]) -> ([(a, b)] -> [(a, b)]) -> [(a, b)] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> Bool) -> [(a, b)] -> [(a, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
name) (a -> Bool) -> ((a, b) -> a) -> (a, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst)