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

{- | Digest authority shared by admission and worker verification.
The public floor cannot fall below SHA-256. The trusted floor can, because an
operator may trust a private source that carries legacy digests.
See @docs/architecture/security.md@ for the trust assumptions.
-}
module Ecluse.Core.Package.Integrity (
    -- * Algorithm strength
    assertedAlg,

    -- * The authoritative digest of a set
    authoritativeDigest,

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

    -- ** 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 Data.List.NonEmpty qualified as NE

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

-- | Resolve an SRI prefix or a raw algorithm tag. An unknown prefix clears no floor.
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

-- | Select by asserted algorithm, then computability, retaining the last equal-ranked hash.
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
    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)

-- | Read a floor's minimum algorithm. Each smart constructor owns its floor's restrictions.
class IntegrityFloor floor where
    -- | The minimum algorithm this floor requires.
    floorAlgorithm :: floor -> HashAlg

-- | A public admission floor that cannot fall below SHA-256.
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)

-- | Reject algorithms below SHA-256, whose collisions permit substitution of public bytes.
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 an algorithm name, distinguishing unknown names from a floor below SHA-256.
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

-- | A trusted admission floor that may fall below SHA-256 for an operator's private 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'. It accepts any known algorithm, including the broken
SHA-1 and MD5, and rejects the bare 'SRI' wrapper, which names no algorithm of its own.
-}
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 an algorithm name. Unlike 'parseMinIntegrity' it accepts a sub-SHA-256 one.
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 minimum, by
'HashAlg' 'Ord'. Pass a resolved algorithm 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

-- | Whether a version carries any digest that clears an admission floor.
data VersionIntegrity
    = -- | At least one digest asserts an algorithm at or above the floor: admissible.
      MeetsFloor
    | -- | Digests are present, but none clears the floor.
      BelowFloor
    | -- | No artifact carries 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)

{- | Partition a version's artifacts against a floor, so a release loses the files that clear no
tamper-evident fingerprint rather than disappearing whole.
-}
partitionByFloor :: (IntegrityFloor floor) => floor -> NonEmpty Artifact -> Either VersionIntegrity (NonEmpty Artifact)
partitionByFloor :: forall floor.
IntegrityFloor floor =>
floor
-> NonEmpty Artifact -> Either VersionIntegrity (NonEmpty Artifact)
partitionByFloor floor
flr NonEmpty Artifact
arts = case [Artifact] -> Maybe (NonEmpty Artifact)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ((Artifact -> Bool) -> NonEmpty Artifact -> [Artifact]
forall a. (a -> Bool) -> NonEmpty a -> [a]
NE.filter (floor -> Artifact -> Bool
forall floor. IntegrityFloor floor => floor -> Artifact -> Bool
artifactMeetsFloor floor
flr) NonEmpty Artifact
arts) of
    Just NonEmpty Artifact
survivors -> NonEmpty Artifact -> Either VersionIntegrity (NonEmpty Artifact)
forall a b. b -> Either a b
Right NonEmpty Artifact
survivors
    Maybe (NonEmpty Artifact)
Nothing -> VersionIntegrity -> Either VersionIntegrity (NonEmpty Artifact)
forall a b. a -> Either a b
Left (floor -> NonEmpty Artifact -> VersionIntegrity
forall floor.
IntegrityFloor floor =>
floor -> NonEmpty Artifact -> VersionIntegrity
classifyArtifacts floor
flr NonEmpty Artifact
arts)

artifactMeetsFloor :: (IntegrityFloor floor) => floor -> Artifact -> Bool
artifactMeetsFloor :: forall floor. IntegrityFloor floor => floor -> Artifact -> Bool
artifactMeetsFloor floor
flr Artifact
art = (Hash -> Bool) -> [Hash] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (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) (Maybe HashAlg -> Bool) -> (Hash -> Maybe HashAlg) -> Hash -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash -> Maybe HashAlg
assertedAlg) (Artifact -> [Hash]
artHashes Artifact
art)

-- | Distinguish a floor-clearing version from one carrying only weak digests or none.
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 (floor -> Artifact -> Bool
forall floor. IntegrityFloor floor => floor -> Artifact -> Bool
artifactMeetsFloor floor
flr) 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