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

{- | Integrity-algorithm strength and the admission integrity floors.

Écluse trusts a digest only as far as its algorithm is collision-resistant. Both
contexts -- the /untrusted/ public upstream and the /trusted/ private upstream -- default
to requiring a SHA-256-or-stronger digest, but they are floored __asymmetrically__: the
public floor is a __hard__ SHA-256 boundary (raisable, never lowerable), while the
trusted floor is __operator-loosenable__ below SHA-256 for a legacy private mirror, where
trust in the operator's own vetted source substitutes for cryptographic strength. This
module applies the 'HashAlg' ordering that ranks algorithms by checksum authority and
decides what clears a floor, so the worker's tamper gate and the serve layer's two
admission gates share a single notion of "strong enough" rather than each re-encoding
the ranking.

== The strength ranking

'HashAlg' 'Ord' is the operational total ordering: MD5 and SHA-1 rank below the
SHA-256 floor; SHA-256 and the modern long digests rank at or above it; SHA-512 ranks
above Blake2b as the npm/SRI-native top digest. 'assertedAlg' resolves what a 'Hash'
/claims/ -- its tag directly, or for a Subresource-Integrity string the algorithm named
in its @\<alg\>-\<base64\>@ prefix -- so an SRI is ranked and floored by the algorithm
it embeds. The 'IntegrityFloor' class abstracts "the minimum algorithm a floor requires",
so 'meetsFloor' and 'classifyArtifacts' rank candidates against either floor through this
one ordering.

== The public-integrity floor

A 'MinIntegrity' is the configured minimum algorithm a __public__ (untrusted) version's
digest must meet to be admitted. It is opaque and __hard-floored at SHA-256__: it can be
/raised/ (to SHA-512 or Blake2b, as cryptanalysis ages an algorithm) but never set below
SHA-256, because admitting a public version on a SHA-1 digest would let a collision
substitute its bytes. There is no escape-hatch: 'mkMinIntegrity' \/ 'parseMinIntegrity'
reject a sub-SHA-256 value at construction, so no config or constructor path can lower
this floor.

== The trusted-integrity floor

A 'MinTrustedIntegrity' is the configured minimum algorithm a __trusted__ (private)
version's digest must meet to be served. It also defaults to SHA-256, but is __not
hard-floored__: an operator may loosen it to SHA-1 or MD5 for a legacy private mirror
(see @docs\/architecture\/security.md@ → "Asymmetric integrity trust"). It still rejects
an unknown algorithm name. This loosening is the /only/ way Écluse will serve a sub-SHA-256
digest, and only on the operator's own trusted source -- never on untrusted public bytes.
-}
module Ecluse.Core.Package.Integrity (
    -- * Algorithm strength
    assertedAlg,

    -- * Algorithm names and SRI strings
    renderHashAlg,
    parseHashAlg,
    sriAlgorithm,
    sriPrefix,
    sriBody,

    -- * The authoritative digest of a set
    authoritativeDigest,

    -- * Integrity floors
    IntegrityFloor (..),
    meetsFloor,

    -- ** The public-integrity floor (hard-floored at SHA-256)
    MinIntegrity,
    mkMinIntegrity,
    parseMinIntegrity,
    unMinIntegrity,

    -- ** The trusted-integrity floor (loosenable below SHA-256)
    MinTrustedIntegrity,
    mkMinTrustedIntegrity,
    parseMinTrustedIntegrity,
    unMinTrustedIntegrity,

    -- * Version admissibility
    VersionIntegrity (..),
    classifyArtifacts,
) where

import Data.Foldable (maximumBy)

import Ecluse.Core.Package (Artifact (artHashes))
import Ecluse.Core.Package.Hash (
    Hash,
    HashAlg (SHA256, SRI),
    hashAlg,
    hashValue,
    isComputable,
    parseHashAlg,
    renderHashAlg,
    sriAlgorithm,
    sriBody,
    sriPrefix,
 )

{- | The algorithm a 'Hash' asserts: its tag directly, or -- for an 'SRI' string -- the
algorithm named in its @\<alg\>-\<base64\>@ prefix. The SRI prefixes resolved are
@sha256@, @sha384@ and @sha512@ (every long digest the model represents and a registry
serves); an unrecognised or malformed prefix yields 'Nothing', so it asserts no
algorithm and clears no floor (the fail-closed reading).

>>> import Ecluse.Core.Package (mkHash, HashAlg (SHA1, SRI))
>>> assertedAlg <$> mkHash SRI "sha512-z4PhNX7vuL3xVChQ1m2AB9Yg5AULVxXcg/SpIdNs6c5H0NE8XYXysP+DGNKHfuwvY7kxvUdBeoGlODJ6+SfaPg=="
Right (Just SHA512)

>>> assertedAlg <$> mkHash SHA1 "da39a3ee5e6b4b0d3255bfef95601890afd80709"
Right (Just SHA1)

>>> assertedAlg <$> mkHash SRI "sha384-OLBgp1GsljhM2TJ+sbHjaiH9txEUvgdDTAzHv2P24donTt6/529l+9Ua0vFImLlb"
Right (Just SHA384)
-}
assertedAlg :: Hash -> Maybe HashAlg
assertedAlg :: Hash -> Maybe HashAlg
assertedAlg Hash
h = case Hash -> HashAlg
hashAlg Hash
h of
    HashAlg
SRI -> Text -> Maybe HashAlg
sriAlgorithm (Hash -> Text
hashValue Hash
h)
    HashAlg
alg -> HashAlg -> Maybe HashAlg
forall a. a -> Maybe a
Just HashAlg
alg

{- | The __most authoritative__ digest of a set: ranked by the algorithm each digest
asserts ('assertedAlg' -- an SRI ranks as its embedded algorithm), under the same
'HashAlg' 'Ord' the admission floors rank candidates by, so the worker's tamper gate
and the serve-side floor agree on one authority order rather than each re-encoding
it. This is the digest fetched bytes must be verified against -- never a weaker one
while a stronger is present, since a match on a weaker algorithm cannot rescue a
failed strong one.

A digest asserting no algorithm (an unresolvable SRI -- unconstructable today, since
'Ecluse.Core.Package.mkHash' resolves every component, but ranked defensively) sits
at the SHA-256 floor tier. __Inside__ an equal algorithm authority, a digest Écluse
can recompute ('Ecluse.Core.Package.isComputable') wins over one it cannot, so a tie
never over-rejects an artifact a co-present verifiable digest could prove; the
selection never drops __below__ the strongest tier to a weaker computable algorithm.
The final tie-break is 'maximumBy''s keep-latest, deterministic over the artifact's
wire order.
-}
authoritativeDigest :: NonEmpty Hash -> Hash
authoritativeDigest :: NonEmpty Hash -> Hash
authoritativeDigest = (Hash -> Hash -> Ordering) -> NonEmpty Hash -> Hash
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy ((Hash -> (HashAlg, Bool)) -> Hash -> Hash -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Hash -> (HashAlg, Bool)
digestAuthority)
  where
    -- The two-level authority key: the asserted algorithm first (by the operational
    -- 'HashAlg' ordering), then recomputability inside an equal algorithm.
    digestAuthority :: Hash -> (HashAlg, Bool)
    digestAuthority :: Hash -> (HashAlg, Bool)
digestAuthority Hash
h = case Hash -> Maybe HashAlg
assertedAlg Hash
h of
        Maybe HashAlg
Nothing -> (HashAlg
SHA256, Bool
False)
        Just HashAlg
alg -> (HashAlg
alg, HashAlg -> Bool
isComputable HashAlg
alg)

{- | The shared interface of an integrity floor: the minimum algorithm it requires. Both
the hard-floored public 'MinIntegrity' and the loosenable trusted 'MinTrustedIntegrity'
are floors, so 'meetsFloor' and 'classifyArtifacts' rank candidates against either through
this one class -- backed by the same 'HashAlg' ordering the worker's tamper gate also
consults. The class only /reads/ a floor's algorithm; a newtype's construction
invariant (the public hard-floor, the trusted loosenability) lives in its smart
constructors, never here.
-}
class IntegrityFloor floor where
    -- | The minimum algorithm this floor requires.
    floorAlgorithm :: floor -> HashAlg

{- | The configured minimum integrity algorithm a __public__ (untrusted) version's
digest must meet to be admitted. Opaque and __hard-floored at SHA-256__: build it
only through 'mkMinIntegrity' \/ 'parseMinIntegrity', which reject anything weaker, so
a value of this type carries the proof that the floor is itself collision-resistant.
There is deliberately no loosenable variant of /this/ floor: untrusted public bytes are
never admitted on a sub-SHA-256 digest.
-}
newtype MinIntegrity = MinIntegrity HashAlg
    deriving stock (MinIntegrity -> MinIntegrity -> Bool
(MinIntegrity -> MinIntegrity -> Bool)
-> (MinIntegrity -> MinIntegrity -> Bool) -> Eq MinIntegrity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MinIntegrity -> MinIntegrity -> Bool
== :: MinIntegrity -> MinIntegrity -> Bool
$c/= :: MinIntegrity -> MinIntegrity -> Bool
/= :: MinIntegrity -> MinIntegrity -> Bool
Eq, Int -> MinIntegrity -> ShowS
[MinIntegrity] -> ShowS
MinIntegrity -> String
(Int -> MinIntegrity -> ShowS)
-> (MinIntegrity -> String)
-> ([MinIntegrity] -> ShowS)
-> Show MinIntegrity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MinIntegrity -> ShowS
showsPrec :: Int -> MinIntegrity -> ShowS
$cshow :: MinIntegrity -> String
show :: MinIntegrity -> String
$cshowList :: [MinIntegrity] -> ShowS
showList :: [MinIntegrity] -> ShowS
Show)

{- | Build a 'MinIntegrity', rejecting any algorithm weaker than SHA-256 (the hard
floor). A weak floor is a configuration error, never a silent clamp: a public version
admitted on a SHA-1 digest could be substituted by a collision, defeating the gate.
-}
mkMinIntegrity :: HashAlg -> Either Text MinIntegrity
mkMinIntegrity :: HashAlg -> Either Text MinIntegrity
mkMinIntegrity HashAlg
alg
    | HashAlg
alg HashAlg -> HashAlg -> Bool
forall a. Ord a => a -> a -> Bool
>= HashAlg
SHA256 = MinIntegrity -> Either Text MinIntegrity
forall a b. b -> Either a b
Right (HashAlg -> MinIntegrity
MinIntegrity HashAlg
alg)
    | Bool
otherwise =
        Text -> Either Text MinIntegrity
forall a b. a -> Either a b
Left
            ( Text
"the minimum public integrity algorithm must be SHA-256 or stronger, not "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HashAlg -> Text
renderHashAlg HashAlg
alg
            )

{- | Parse a 'MinIntegrity' from an algorithm name (e.g. @"sha256"@, @"sha512"@,
@"blake2b"@), case- and separator-insensitive. An unrecognised name and an
algorithm below the SHA-256 floor are distinct errors, so a misconfiguration is
reported precisely.
-}
parseMinIntegrity :: Text -> Either Text MinIntegrity
parseMinIntegrity :: Text -> Either Text MinIntegrity
parseMinIntegrity Text
raw = Text -> Either Text HashAlg
parseHashAlg Text
raw Either Text HashAlg
-> (HashAlg -> Either Text MinIntegrity)
-> Either Text MinIntegrity
forall a b. Either Text a -> (a -> Either Text b) -> Either Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashAlg -> Either Text MinIntegrity
mkMinIntegrity

-- | The floor algorithm.
unMinIntegrity :: MinIntegrity -> HashAlg
unMinIntegrity :: MinIntegrity -> HashAlg
unMinIntegrity (MinIntegrity HashAlg
alg) = HashAlg
alg

instance IntegrityFloor MinIntegrity where
    floorAlgorithm :: MinIntegrity -> HashAlg
floorAlgorithm = MinIntegrity -> HashAlg
unMinIntegrity

{- | The configured minimum integrity algorithm a __trusted__ (private) version's digest
must meet to be served. Like 'MinIntegrity' it defaults to SHA-256, but unlike it carries
__no hard floor__: an operator may loosen it to SHA-1 or MD5 for a legacy private mirror,
where trust in their own vetted source substitutes for cryptographic strength. Build it
only through 'mkMinTrustedIntegrity' \/ 'parseMinTrustedIntegrity', which still reject an
unknown algorithm name (and the bare 'SRI' wrapper, which names no algorithm). Loosening
this floor is the /only/ path by which Écluse serves a sub-SHA-256 digest, and only on the
operator's own trusted source.
-}
newtype MinTrustedIntegrity = MinTrustedIntegrity HashAlg
    deriving stock (MinTrustedIntegrity -> MinTrustedIntegrity -> Bool
(MinTrustedIntegrity -> MinTrustedIntegrity -> Bool)
-> (MinTrustedIntegrity -> MinTrustedIntegrity -> Bool)
-> Eq MinTrustedIntegrity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MinTrustedIntegrity -> MinTrustedIntegrity -> Bool
== :: MinTrustedIntegrity -> MinTrustedIntegrity -> Bool
$c/= :: MinTrustedIntegrity -> MinTrustedIntegrity -> Bool
/= :: MinTrustedIntegrity -> MinTrustedIntegrity -> Bool
Eq, Int -> MinTrustedIntegrity -> ShowS
[MinTrustedIntegrity] -> ShowS
MinTrustedIntegrity -> String
(Int -> MinTrustedIntegrity -> ShowS)
-> (MinTrustedIntegrity -> String)
-> ([MinTrustedIntegrity] -> ShowS)
-> Show MinTrustedIntegrity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MinTrustedIntegrity -> ShowS
showsPrec :: Int -> MinTrustedIntegrity -> ShowS
$cshow :: MinTrustedIntegrity -> String
show :: MinTrustedIntegrity -> String
$cshowList :: [MinTrustedIntegrity] -> ShowS
showList :: [MinTrustedIntegrity] -> ShowS
Show)

{- | Build a 'MinTrustedIntegrity'. Any /known/ algorithm is accepted -- including the
broken SHA-1 and MD5, which an operator may deliberately loosen the trusted floor to --
but the bare 'SRI' wrapper, which asserts no algorithm of its own, is rejected (it could
never be a meaningful floor). There is intentionally no SHA-256 hard minimum here: that is
the one behavioural difference from 'mkMinIntegrity'.
-}
mkMinTrustedIntegrity :: HashAlg -> Either Text MinTrustedIntegrity
mkMinTrustedIntegrity :: HashAlg -> Either Text MinTrustedIntegrity
mkMinTrustedIntegrity HashAlg
SRI =
    Text -> Either Text MinTrustedIntegrity
forall a b. a -> Either a b
Left Text
"the minimum trusted integrity algorithm must name a concrete algorithm, not a bare SRI"
mkMinTrustedIntegrity HashAlg
alg = MinTrustedIntegrity -> Either Text MinTrustedIntegrity
forall a b. b -> Either a b
Right (HashAlg -> MinTrustedIntegrity
MinTrustedIntegrity HashAlg
alg)

{- | Parse a 'MinTrustedIntegrity' from an algorithm name (e.g. @"sha256"@, @"sha1"@,
@"md5"@), case- and separator-insensitive. An unrecognised name is rejected; unlike
'parseMinIntegrity', a sub-SHA-256 name is /accepted/ -- the trusted floor is loosenable.
-}
parseMinTrustedIntegrity :: Text -> Either Text MinTrustedIntegrity
parseMinTrustedIntegrity :: Text -> Either Text MinTrustedIntegrity
parseMinTrustedIntegrity Text
raw = Text -> Either Text HashAlg
parseHashAlg Text
raw Either Text HashAlg
-> (HashAlg -> Either Text MinTrustedIntegrity)
-> Either Text MinTrustedIntegrity
forall a b. Either Text a -> (a -> Either Text b) -> Either Text b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashAlg -> Either Text MinTrustedIntegrity
mkMinTrustedIntegrity

-- | The trusted floor algorithm.
unMinTrustedIntegrity :: MinTrustedIntegrity -> HashAlg
unMinTrustedIntegrity :: MinTrustedIntegrity -> HashAlg
unMinTrustedIntegrity (MinTrustedIntegrity HashAlg
alg) = HashAlg
alg

instance IntegrityFloor MinTrustedIntegrity where
    floorAlgorithm :: MinTrustedIntegrity -> HashAlg
floorAlgorithm = MinTrustedIntegrity -> HashAlg
unMinTrustedIntegrity

{- | Whether an algorithm meets a floor: at least as strong as the floor's configured
minimum, by 'HashAlg' 'Ord'. The candidate algorithm is a
/resolved/ one (from 'assertedAlg'), never a bare 'SRI'.
-}
meetsFloor :: (IntegrityFloor floor) => floor -> HashAlg -> Bool
meetsFloor :: forall floor. IntegrityFloor floor => floor -> HashAlg -> Bool
meetsFloor floor
flr HashAlg
alg = HashAlg
alg HashAlg -> HashAlg -> Bool
forall a. Ord a => a -> a -> Bool
>= floor -> HashAlg
forall floor. IntegrityFloor floor => floor -> HashAlg
floorAlgorithm floor
flr

{- | How a version's artifacts stand against an integrity floor -- the three-way verdict
an admission gate (public or trusted) acts on.
-}
data VersionIntegrity
    = -- | At least one digest asserts an algorithm at or above the floor: admissible.
      MeetsFloor
    | {- | The version carries an integrity digest, but none meets the floor (e.g. a
      legacy SHA-1 shasum only under a SHA-256 floor). Inadmissible -- distinct from
      carrying no digest at all, so the refusal can say which.
      -}
      BelowFloor
    | {- | The version carries no integrity digest of any kind: inadmissible (no floor
      can be met without a digest).
      -}
      NoIntegrity
    deriving stock (VersionIntegrity -> VersionIntegrity -> Bool
(VersionIntegrity -> VersionIntegrity -> Bool)
-> (VersionIntegrity -> VersionIntegrity -> Bool)
-> Eq VersionIntegrity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VersionIntegrity -> VersionIntegrity -> Bool
== :: VersionIntegrity -> VersionIntegrity -> Bool
$c/= :: VersionIntegrity -> VersionIntegrity -> Bool
/= :: VersionIntegrity -> VersionIntegrity -> Bool
Eq, Int -> VersionIntegrity -> ShowS
[VersionIntegrity] -> ShowS
VersionIntegrity -> String
(Int -> VersionIntegrity -> ShowS)
-> (VersionIntegrity -> String)
-> ([VersionIntegrity] -> ShowS)
-> Show VersionIntegrity
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VersionIntegrity -> ShowS
showsPrec :: Int -> VersionIntegrity -> ShowS
$cshow :: VersionIntegrity -> String
show :: VersionIntegrity -> String
$cshowList :: [VersionIntegrity] -> ShowS
showList :: [VersionIntegrity] -> ShowS
Show)

{- | Classify a version's artifacts against a floor (public or trusted). A version
'MeetsFloor' iff any of its digests (across all of its artifacts) asserts a floor-clearing
algorithm; failing that, it is 'NoIntegrity' when no artifact carries any digest at all,
else 'BelowFloor'. npm publishes one artifact per version, but the check spans the whole
'NonEmpty' so it holds for a multi-artifact ecosystem too.
-}
classifyArtifacts :: (IntegrityFloor floor) => floor -> NonEmpty Artifact -> VersionIntegrity
classifyArtifacts :: forall floor.
IntegrityFloor floor =>
floor -> NonEmpty Artifact -> VersionIntegrity
classifyArtifacts floor
flr NonEmpty Artifact
arts
    | (Artifact -> Bool) -> NonEmpty Artifact -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Artifact -> Bool
meetsFloorArtifact NonEmpty Artifact
arts = VersionIntegrity
MeetsFloor
    | (Artifact -> Bool) -> NonEmpty Artifact -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Hash] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Hash] -> Bool) -> (Artifact -> [Hash]) -> Artifact -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Artifact -> [Hash]
artHashes) NonEmpty Artifact
arts = VersionIntegrity
NoIntegrity
    | Bool
otherwise = VersionIntegrity
BelowFloor
  where
    meetsFloorArtifact :: Artifact -> Bool
meetsFloorArtifact Artifact
art = (Hash -> Bool) -> [Hash] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Hash -> Bool
hashMeetsFloor (Artifact -> [Hash]
artHashes Artifact
art)
    hashMeetsFloor :: Hash -> Bool
hashMeetsFloor Hash
h = Bool -> (HashAlg -> Bool) -> Maybe HashAlg -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (floor -> HashAlg -> Bool
forall floor. IntegrityFloor floor => floor -> HashAlg -> Bool
meetsFloor floor
flr) (Hash -> Maybe HashAlg
assertedAlg Hash
h)

-- The algorithm vocabulary (the wire name renderer\/parser and the SRI splitter\/resolver)
-- lives in "Ecluse.Core.Package", the lowest layer, and is re-exported above so this module's
-- callers (and the worker and SQS) keep importing it from here.