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

The proxy serves two kinds of body, and they validate differently (see
@docs\/architecture\/web-layer.md@ → "Middleware and helper libraries"):

* __Pass-through bodies__ -- artifacts, and unfiltered private-upstream metadata --
  are byte-identical to upstream's, so upstream's own validator is authoritative.
  The client's validators are __relayed upstream__ ('forwardValidators') and an
  upstream @304@ is passed straight back ('isNotModified'). Relaying is correct
  precisely because we do not change the bytes.

* __Transformed bodies__ -- every packument, which is merged across upstreams and
  filtered by the rules -- differ from any single upstream's body, so an upstream
  validator would validate the wrong bytes. We instead serve our __own__ strong
  'ETag' ('mkStrongETag') and answer the client's conditional request against it
  ('evaluateETag').

The own-ETag is __derived from the serve's inputs__, not hashed over its output: a
SHA-256 over the origin bodies' digests, the per-source surviving version sets, and
the assembly's identity (see 'Ecluse.Core.Server.Pipeline.Packument.packumentETag').
The served document is a deterministic function of exactly those inputs, so the tag
can never validate a stale body as fresh -- the direction correctness needs -- while
it may occasionally change when the re-assembled bytes would not have (a spurious
@200@, never a wrong @304@). Deriving it from inputs is what lets the serve path
answer a @304@ __without assembling, encoding, or hashing the document at all__, and
stream a @200@ body without materialising it for a hash pass first. The functions
here are pure; turning a 'Conditional' or relayed status into a WAI response is the
serving layer's job.
-}
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 for a body we serve: the quoted opaque-tag form
(@"…"@), as it appears in the @ETag@ header. A 'newtype' so the quoted wire form
is not confused with the bare digest or any other 'Text'.
-}
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, in the quoted
opaque-tag wire form. The digest is whatever fingerprint the serving layer stands
behind; for packuments that is the input fingerprint of
'Ecluse.Core.Server.Pipeline.Packument.packumentETag'.
-}
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', 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 for a transformed body.

The given tag is matched against the request's @If-None-Match@: a @*@ wildcard, or
any tag in the (comma-separated) list whose opaque value equals ours, is a match →
'NotModified'. The match is __weak__ (RFC 7232): a @W/@ prefix on either side is
ignored, so a client echoing our tag with a weakness marker still matches. Anything
else -- a stale tag, or no validator -- is 'Modified'.

@If-Modified-Since@ is deliberately not consulted for transformed bodies: a merged
packument has no single upstream @Last-Modified@ to compare to, and the strong
ETag is the precise validator.
-}
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 the request-side conditional headers (@If-None-Match@,
@If-Modified-Since@) are forwarded; everything else is dropped, since this is the
exact set that lets upstream answer @304@ for a body we serve unchanged.
-}
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 unchanged. Used on the pass-through path, where upstream's own
validator decided the conditional request.
-}
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)