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

-- | The integrity vocabulary shared by admission, merge, and worker verification.
module Ecluse.Core.Package.Hash (
    -- * Hashes
    Hash,
    hashAlg,
    hashValue,
    canonicalHashValue,
    mkHash,
    mkSriHashes,
    HashAlg (..),

    -- * Algorithm vocabulary
    renderHashAlg,
    parseHashAlg,
    sriPrefix,
    sriBody,
    sriAlgorithm,

    -- * Digest computation
    computeDigest,
    isComputable,

    -- * Wire encodings of digest bytes
    hexDigestText,
    base64DigestText,
) where

import Crypto.Hash (Blake2b_512, Digest, MD5, SHA1, SHA256, SHA384, SHA512, digestFromByteString, hashlazy)
import Data.ByteArray (convert)
import Data.ByteArray.Encoding (Base (Base16, Base64), convertFromBase, convertToBase)
import Data.Text qualified as T
import Data.Universe.Class (Universe (..))
import Data.Universe.Generic (universeGeneric)

{- | A hash algorithm an integrity digest is computed with. The 'Ord' instance is integrity
authority, not constructor order: @SRI < MD5 < SHA1 < SHA256 < SHA384 < Blake2b < SHA512@.
-}
data HashAlg
    = SHA1
    | SHA256
    | SHA384
    | SHA512
    | MD5
    | Blake2b
    | -- | One Subresource-Integrity component. 'mkSriHashes' splits whitespace-separated components.
      SRI
    deriving stock (HashAlg -> HashAlg -> Bool
(HashAlg -> HashAlg -> Bool)
-> (HashAlg -> HashAlg -> Bool) -> Eq HashAlg
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HashAlg -> HashAlg -> Bool
== :: HashAlg -> HashAlg -> Bool
$c/= :: HashAlg -> HashAlg -> Bool
/= :: HashAlg -> HashAlg -> Bool
Eq, (forall x. HashAlg -> Rep HashAlg x)
-> (forall x. Rep HashAlg x -> HashAlg) -> Generic HashAlg
forall x. Rep HashAlg x -> HashAlg
forall x. HashAlg -> Rep HashAlg x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. HashAlg -> Rep HashAlg x
from :: forall x. HashAlg -> Rep HashAlg x
$cto :: forall x. Rep HashAlg x -> HashAlg
to :: forall x. Rep HashAlg x -> HashAlg
Generic, Int -> HashAlg -> ShowS
[HashAlg] -> ShowS
HashAlg -> String
(Int -> HashAlg -> ShowS)
-> (HashAlg -> String) -> ([HashAlg] -> ShowS) -> Show HashAlg
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HashAlg -> ShowS
showsPrec :: Int -> HashAlg -> ShowS
$cshow :: HashAlg -> String
show :: HashAlg -> String
$cshowList :: [HashAlg] -> ShowS
showList :: [HashAlg] -> ShowS
Show)

-- Derived from Generic so a new HashAlg needs no hand-maintained list. The cross-module
-- floor-vs-compute invariant test relies on this enumeration being exhaustive.
instance Universe HashAlg where universe :: [HashAlg]
universe = [HashAlg]
forall a. (Generic a, GUniverse (Rep a)) => [a]
universeGeneric

instance Ord HashAlg where
    compare :: HashAlg -> HashAlg -> Ordering
compare HashAlg
a HashAlg
b = Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (HashAlg -> Int
hashAlgRank HashAlg
a) (HashAlg -> Int
hashAlgRank HashAlg
b)

-- Explicit integrity ordering, weakest to strongest. The gaps are only for
-- readability: order, not arithmetic distance, is the policy.
hashAlgRank :: HashAlg -> Int
hashAlgRank :: HashAlg -> Int
hashAlgRank = \case
    HashAlg
SRI -> Int
0
    HashAlg
MD5 -> Int
10
    HashAlg
SHA1 -> Int
20
    HashAlg
SHA256 -> Int
30
    HashAlg
SHA384 -> Int
40
    HashAlg
Blake2b -> Int
50
    HashAlg
SHA512 -> Int
60

-- | An artifact digest validated by 'mkHash'. Record updates must preserve its encoding and length.
data Hash = Hash
    { Hash -> HashAlg
hashAlg :: HashAlg
    -- ^ The algorithm the digest was computed with.
    , Hash -> Text
hashValue :: Text
    {- ^ The digest itself, in the algorithm's wire encoding (e.g. hex, or the
    single @sha512-…@ component for 'SRI').
    -}
    }
    deriving stock (Hash -> Hash -> Bool
(Hash -> Hash -> Bool) -> (Hash -> Hash -> Bool) -> Eq Hash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Hash -> Hash -> Bool
== :: Hash -> Hash -> Bool
$c/= :: Hash -> Hash -> Bool
/= :: Hash -> Hash -> Bool
Eq, Int -> Hash -> ShowS
[Hash] -> ShowS
Hash -> String
(Int -> Hash -> ShowS)
-> (Hash -> String) -> ([Hash] -> ShowS) -> Show Hash
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Hash -> ShowS
showsPrec :: Int -> Hash -> ShowS
$cshow :: Hash -> String
show :: Hash -> String
$cshowList :: [Hash] -> ShowS
showList :: [Hash] -> ShowS
Show)

-- | Validate encoding and digest length, preserving the wire spelling. Strength is a separate admission decision.
mkHash :: HashAlg -> Text -> Either Text Hash
mkHash :: HashAlg -> Text -> Either Text Hash
mkHash HashAlg
alg Text
value
    | Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (HashAlg -> Text -> Maybe ByteString
decodeHash HashAlg
alg Text
value) = Hash -> Either Text Hash
forall a b. b -> Either a b
Right (HashAlg -> Text -> Hash
Hash HashAlg
alg Text
value)
    | Bool
otherwise = Text -> Either Text Hash
forall a b. a -> Either a b
Left (Text
"malformed " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HashAlg -> Text
renderHashAlg HashAlg
alg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" digest")

-- | Split SRI components, rejecting the whole string when empty or when any component is malformed.
mkSriHashes :: Text -> Either Text (NonEmpty Hash)
mkSriHashes :: Text -> Either Text (NonEmpty Hash)
mkSriHashes Text
wire = case [Text] -> Maybe (NonEmpty Text)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty (Text -> [Text]
T.words Text
wire) of
    Maybe (NonEmpty Text)
Nothing -> Text -> Either Text (NonEmpty Hash)
forall a b. a -> Either a b
Left Text
"malformed sri digest"
    -- A lone component equal to the input is the input itself, so a retained hash adds no text object.
    Just (Text
only :| []) | Text
only Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
wire -> Hash -> NonEmpty Hash
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hash -> NonEmpty Hash)
-> Either Text Hash -> Either Text (NonEmpty Hash)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashAlg -> Text -> Either Text Hash
mkHash HashAlg
SRI Text
wire
    Just NonEmpty Text
comps -> (Text -> Either Text Hash)
-> NonEmpty Text -> Either Text (NonEmpty Hash)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse (HashAlg -> Text -> Either Text Hash
mkHash HashAlg
SRI) NonEmpty Text
comps

-- | The lowercase hex a non-SRI digest is compared and reported in.
hexDigestText :: ByteString -> Text
hexDigestText :: ByteString -> Text
hexDigestText ByteString
d = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base16 ByteString
d :: ByteString)

-- | The base64 body an SRI component carries after its algorithm prefix.
base64DigestText :: ByteString -> Text
base64DigestText :: ByteString -> Text
base64DigestText ByteString
d = ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 (Base -> ByteString -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> bout
convertToBase Base
Base64 ByteString
d :: ByteString)

{- | Lowercase hex for comparison, or 'Nothing' if a record update introduced an invalid digest.
The original 'hashValue' remains unchanged.
-}
canonicalHashValue :: Hash -> Maybe Text
canonicalHashValue :: Hash -> Maybe Text
canonicalHashValue Hash
h = ByteString -> Text
hexDigestText (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashAlg -> Text -> Maybe ByteString
decodeHash (Hash -> HashAlg
hashAlg Hash
h) (Hash -> Text
hashValue Hash
h)

decodeHash :: HashAlg -> Text -> Maybe ByteString
decodeHash :: HashAlg -> Text -> Maybe ByteString
decodeHash HashAlg
SRI Text
value = do
    Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> [Text]
T.words Text
value [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text
value])
    alg <- Text -> Maybe HashAlg
sriAlgorithm Text
value
    decodeDigest Base64 alg (sriBody value)
decodeHash HashAlg
alg Text
value = Base -> HashAlg -> Text -> Maybe ByteString
decodeDigest Base
Base16 HashAlg
alg (Text -> Text
T.toLower Text
value)

decodeDigest :: Base -> HashAlg -> Text -> Maybe ByteString
decodeDigest :: Base -> HashAlg -> Text -> Maybe ByteString
decodeDigest Base
base HashAlg
alg Text
value = do
    bytes <- Either String ByteString -> Maybe ByteString
forall l r. Either l r -> Maybe r
rightToMaybe (Base -> ByteString -> Either String ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
Base -> bin -> Either String bout
convertFromBase Base
base (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
value :: ByteString))
    guard (digestLengthOk alg bytes)
    pure bytes

-- 'digestFromByteString' is the length check: it accepts only an input of exactly the
-- algorithm's digest size.
digestLengthOk :: HashAlg -> ByteString -> Bool
digestLengthOk :: HashAlg -> ByteString -> Bool
digestLengthOk HashAlg
alg ByteString
bytes = case HashAlg
alg of
    HashAlg
SHA1 -> Maybe (Digest SHA1) -> Bool
forall a. Maybe a -> Bool
isJust (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString @SHA1 ByteString
bytes)
    HashAlg
SHA256 -> Maybe (Digest SHA256) -> Bool
forall a. Maybe a -> Bool
isJust (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString @SHA256 ByteString
bytes)
    HashAlg
SHA384 -> Maybe (Digest SHA384) -> Bool
forall a. Maybe a -> Bool
isJust (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString @SHA384 ByteString
bytes)
    HashAlg
SHA512 -> Maybe (Digest SHA512) -> Bool
forall a. Maybe a -> Bool
isJust (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString @SHA512 ByteString
bytes)
    HashAlg
MD5 -> Maybe (Digest MD5) -> Bool
forall a. Maybe a -> Bool
isJust (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString @MD5 ByteString
bytes)
    HashAlg
Blake2b -> Maybe (Digest Blake2b_512) -> Bool
forall a. Maybe a -> Bool
isJust (forall a ba.
(HashAlgorithm a, ByteArrayAccess ba) =>
ba -> Maybe (Digest a)
digestFromByteString @Blake2b_512 ByteString
bytes)
    HashAlg
SRI -> Bool
False

-- | Digest computation for verifiable algorithms. MD5 cannot prove integrity, and SRI must first resolve its algorithm.
computeDigest :: HashAlg -> Maybe (LByteString -> ByteString)
computeDigest :: HashAlg -> Maybe (LByteString -> ByteString)
computeDigest = \case
    HashAlg
SHA1 -> (LByteString -> ByteString) -> Maybe (LByteString -> ByteString)
forall a. a -> Maybe a
Just (Digest SHA1 -> ByteString
forall a. Digest a -> ByteString
digestBytes (Digest SHA1 -> ByteString)
-> (LByteString -> Digest SHA1) -> LByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => LByteString -> Digest a
hashlazy @SHA1)
    HashAlg
SHA256 -> (LByteString -> ByteString) -> Maybe (LByteString -> ByteString)
forall a. a -> Maybe a
Just (Digest SHA256 -> ByteString
forall a. Digest a -> ByteString
digestBytes (Digest SHA256 -> ByteString)
-> (LByteString -> Digest SHA256) -> LByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => LByteString -> Digest a
hashlazy @SHA256)
    HashAlg
SHA384 -> (LByteString -> ByteString) -> Maybe (LByteString -> ByteString)
forall a. a -> Maybe a
Just (Digest SHA384 -> ByteString
forall a. Digest a -> ByteString
digestBytes (Digest SHA384 -> ByteString)
-> (LByteString -> Digest SHA384) -> LByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => LByteString -> Digest a
hashlazy @SHA384)
    HashAlg
SHA512 -> (LByteString -> ByteString) -> Maybe (LByteString -> ByteString)
forall a. a -> Maybe a
Just (Digest SHA512 -> ByteString
forall a. Digest a -> ByteString
digestBytes (Digest SHA512 -> ByteString)
-> (LByteString -> Digest SHA512) -> LByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => LByteString -> Digest a
hashlazy @SHA512)
    HashAlg
Blake2b -> (LByteString -> ByteString) -> Maybe (LByteString -> ByteString)
forall a. a -> Maybe a
Just (Digest Blake2b_512 -> ByteString
forall a. Digest a -> ByteString
digestBytes (Digest Blake2b_512 -> ByteString)
-> (LByteString -> Digest Blake2b_512) -> LByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashAlgorithm a => LByteString -> Digest a
hashlazy @Blake2b_512)
    HashAlg
MD5 -> Maybe (LByteString -> ByteString)
forall a. Maybe a
Nothing
    HashAlg
SRI -> Maybe (LByteString -> ByteString)
forall a. Maybe a
Nothing
  where
    digestBytes :: Digest a -> ByteString
    digestBytes :: forall a. Digest a -> ByteString
digestBytes = Digest a -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert

-- | Whether the worker can compute and verify the algorithm.
isComputable :: HashAlg -> Bool
isComputable :: HashAlg -> Bool
isComputable = Maybe (LByteString -> ByteString) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (LByteString -> ByteString) -> Bool)
-> (HashAlg -> Maybe (LByteString -> ByteString))
-> HashAlg
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashAlg -> Maybe (LByteString -> ByteString)
computeDigest

-- | The canonical lowercase name, also used in configuration and error text.
renderHashAlg :: HashAlg -> Text
renderHashAlg :: HashAlg -> Text
renderHashAlg = \case
    HashAlg
MD5 -> Text
"md5"
    HashAlg
SHA1 -> Text
"sha1"
    HashAlg
SHA256 -> Text
"sha256"
    HashAlg
SHA384 -> Text
"sha384"
    HashAlg
SHA512 -> Text
"sha512"
    HashAlg
Blake2b -> Text
"blake2b"
    HashAlg
SRI -> Text
"sri"

-- | Parse canonical names and single-dash aliases, ignoring case and surrounding whitespace. SRI is not selectable.
parseHashAlg :: Text -> Either Text HashAlg
parseHashAlg :: Text -> Either Text HashAlg
parseHashAlg Text
raw = case Text -> Text
T.toLower (Text -> Text
T.strip Text
raw) of
    Text
"md5" -> HashAlg -> Either Text HashAlg
forall a b. b -> Either a b
Right HashAlg
MD5
    Text
"sha1" -> HashAlg -> Either Text HashAlg
forall a b. b -> Either a b
Right HashAlg
SHA1
    Text
"sha-1" -> HashAlg -> Either Text HashAlg
forall a b. b -> Either a b
Right HashAlg
SHA1
    Text
"sha256" -> HashAlg -> Either Text HashAlg
forall a b. b -> Either a b
Right HashAlg
SHA256
    Text
"sha-256" -> HashAlg -> Either Text HashAlg
forall a b. b -> Either a b
Right HashAlg
SHA256
    Text
"sha384" -> HashAlg -> Either Text HashAlg
forall a b. b -> Either a b
Right HashAlg
SHA384
    Text
"sha-384" -> HashAlg -> Either Text HashAlg
forall a b. b -> Either a b
Right HashAlg
SHA384
    Text
"sha512" -> HashAlg -> Either Text HashAlg
forall a b. b -> Either a b
Right HashAlg
SHA512
    Text
"sha-512" -> HashAlg -> Either Text HashAlg
forall a b. b -> Either a b
Right HashAlg
SHA512
    Text
"blake2b" -> HashAlg -> Either Text HashAlg
forall a b. b -> Either a b
Right HashAlg
Blake2b
    Text
_ -> Text -> Either Text HashAlg
forall a b. a -> Either a b
Left (Text
"unknown integrity algorithm: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
raw)

-- | The token before the first dash. Without a dash, the entire string is the prefix.
sriPrefix :: Text -> Text
sriPrefix :: Text -> Text
sriPrefix = (Text, Text) -> Text
forall a b. (a, b) -> a
fst ((Text, Text) -> Text) -> (Text -> (Text, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"-"

-- | The body after the first dash, or empty text when there is no dash.
sriBody :: Text -> Text
sriBody :: Text -> Text
sriBody = Int -> Text -> Text
T.drop Int
1 (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> b
snd ((Text, Text) -> Text) -> (Text -> (Text, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"-"

-- | Resolve an SRI prefix. An unsupported prefix asserts no algorithm and clears no integrity floor.
sriAlgorithm :: Text -> Maybe HashAlg
sriAlgorithm :: Text -> Maybe HashAlg
sriAlgorithm Text
sri = case Text -> Text
sriPrefix Text
sri of
    Text
"sha256" -> HashAlg -> Maybe HashAlg
forall a. a -> Maybe a
Just HashAlg
SHA256
    Text
"sha384" -> HashAlg -> Maybe HashAlg
forall a. a -> Maybe a
Just HashAlg
SHA384
    Text
"sha512" -> HashAlg -> Maybe HashAlg
forall a. a -> Maybe a
Just HashAlg
SHA512
    Text
_ -> Maybe HashAlg
forall a. Maybe a
Nothing