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

{- | Merge admitted source snapshots with trusted-source precedence.
The plan carries exact artifact coordinates for raw assembly and reports integrity divergence.
-}
module Ecluse.Core.Package.Merge (
    -- * Provenance
    Provenance (..),

    -- * Merging
    SourceId,
    MergePlan (..),
    Divergence (..),
    IntegrityFingerprint,
    integrityHashes,
    integrityDivergences,
    mergePackuments,

    -- * The merge accumulator
    -- $accumulator
    Merge,
    contribute,
    planFrom,
) where

import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Time (UTCTime)

import Ecluse.Core.Package (
    Artifact (..),
    Hash,
    HashAlg (SRI),
    PackageDetails (..),
    PackageInfo (..),
    PackageName,
    hashAlg,
    hashValue,
    sriBody,
 )
import Ecluse.Core.Package.Entry (AdmittedEntry (..))
import Ecluse.Core.Package.Hash (canonicalHashValue)
import Ecluse.Core.Package.Integrity (assertedAlg)
import Ecluse.Core.Snapshot (ContentDigest, Snapshot (..))
import Ecluse.Core.Version (Version, renderVersion, selectLatest)

{- | Which upstream a document came from. The caller decides this and applies it before merging.
'Ord' is the trust order: 'TrustedSource' sorts before 'GatedSource', so the smallest wins.
-}
data Provenance
    = {- | A private-upstream document. Its versions are already vetted, so they
      enter the union unfiltered and win any collision.
      -}
      TrustedSource
    | {- | A public-upstream document. Its versions are the set that already
      survived the rules engine. The merge unions them but never re-filters.
      -}
      GatedSource
    deriving stock (Provenance -> Provenance -> Bool
(Provenance -> Provenance -> Bool)
-> (Provenance -> Provenance -> Bool) -> Eq Provenance
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Provenance -> Provenance -> Bool
== :: Provenance -> Provenance -> Bool
$c/= :: Provenance -> Provenance -> Bool
/= :: Provenance -> Provenance -> Bool
Eq, Eq Provenance
Eq Provenance =>
(Provenance -> Provenance -> Ordering)
-> (Provenance -> Provenance -> Bool)
-> (Provenance -> Provenance -> Bool)
-> (Provenance -> Provenance -> Bool)
-> (Provenance -> Provenance -> Bool)
-> (Provenance -> Provenance -> Provenance)
-> (Provenance -> Provenance -> Provenance)
-> Ord Provenance
Provenance -> Provenance -> Bool
Provenance -> Provenance -> Ordering
Provenance -> Provenance -> Provenance
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 :: Provenance -> Provenance -> Ordering
compare :: Provenance -> Provenance -> Ordering
$c< :: Provenance -> Provenance -> Bool
< :: Provenance -> Provenance -> Bool
$c<= :: Provenance -> Provenance -> Bool
<= :: Provenance -> Provenance -> Bool
$c> :: Provenance -> Provenance -> Bool
> :: Provenance -> Provenance -> Bool
$c>= :: Provenance -> Provenance -> Bool
>= :: Provenance -> Provenance -> Bool
$cmax :: Provenance -> Provenance -> Provenance
max :: Provenance -> Provenance -> Provenance
$cmin :: Provenance -> Provenance -> Provenance
min :: Provenance -> Provenance -> Provenance
Ord, Int -> Provenance -> ShowS
[Provenance] -> ShowS
Provenance -> String
(Int -> Provenance -> ShowS)
-> (Provenance -> String)
-> ([Provenance] -> ShowS)
-> Show Provenance
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Provenance -> ShowS
showsPrec :: Int -> Provenance -> ShowS
$cshow :: Provenance -> String
show :: Provenance -> String
$cshowList :: [Provenance] -> ShowS
showList :: [Provenance] -> ShowS
Show)

{- | The 0-based index of an input to one 'mergePackuments' call. The caller pairs each 'SourceId'
back to the raw @Value@ it passed at that position, which 'Provenance' alone cannot name.
-}
type SourceId = Int

-- | Conflicting digests for one version. The private copy wins and both fingerprints remain for alarms.
data Divergence = Divergence
    { Divergence -> Text
divVersion :: Text
    {- ^ The raw version-string key the conflict was found at (the
    'Ecluse.Core.Package.infoVersions' key).
    -}
    , Divergence -> IntegrityFingerprint
divWinning :: IntegrityFingerprint
    -- ^ Integrity of the copy that won the merge (the higher-precedence source).
    , Divergence -> IntegrityFingerprint
divLosing :: IntegrityFingerprint
    -- ^ Integrity of the copy that lost, kept so the conflict is auditable.
    }
    deriving stock (Divergence -> Divergence -> Bool
(Divergence -> Divergence -> Bool)
-> (Divergence -> Divergence -> Bool) -> Eq Divergence
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Divergence -> Divergence -> Bool
== :: Divergence -> Divergence -> Bool
$c/= :: Divergence -> Divergence -> Bool
/= :: Divergence -> Divergence -> Bool
Eq, Eq Divergence
Eq Divergence =>
(Divergence -> Divergence -> Ordering)
-> (Divergence -> Divergence -> Bool)
-> (Divergence -> Divergence -> Bool)
-> (Divergence -> Divergence -> Bool)
-> (Divergence -> Divergence -> Bool)
-> (Divergence -> Divergence -> Divergence)
-> (Divergence -> Divergence -> Divergence)
-> Ord Divergence
Divergence -> Divergence -> Bool
Divergence -> Divergence -> Ordering
Divergence -> Divergence -> Divergence
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 :: Divergence -> Divergence -> Ordering
compare :: Divergence -> Divergence -> Ordering
$c< :: Divergence -> Divergence -> Bool
< :: Divergence -> Divergence -> Bool
$c<= :: Divergence -> Divergence -> Bool
<= :: Divergence -> Divergence -> Bool
$c> :: Divergence -> Divergence -> Bool
> :: Divergence -> Divergence -> Bool
$c>= :: Divergence -> Divergence -> Bool
>= :: Divergence -> Divergence -> Bool
$cmax :: Divergence -> Divergence -> Divergence
max :: Divergence -> Divergence -> Divergence
$cmin :: Divergence -> Divergence -> Divergence
min :: Divergence -> Divergence -> Divergence
Ord, Int -> Divergence -> ShowS
[Divergence] -> ShowS
Divergence -> String
(Int -> Divergence -> ShowS)
-> (Divergence -> String)
-> ([Divergence] -> ShowS)
-> Show Divergence
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Divergence -> ShowS
showsPrec :: Int -> Divergence -> ShowS
$cshow :: Divergence -> String
show :: Divergence -> String
$cshowList :: [Divergence] -> ShowS
showList :: [Divergence] -> ShowS
Show)

{- | The decisions a merge reached over several upstream packuments. The serve layer replays the
plan onto the raw upstream @Value@s. It is never a finished, re-serialisable document.
-}
data MergePlan = MergePlan
    { MergePlan -> PackageName
mpName :: PackageName
    {- ^ The package identity, carried from the contributions. A check upstream of the merge drops
    any contribution whose name disagrees, so this is never a substituted or manufactured value.
    -}
    , MergePlan -> Map Text Int
mpSurvivors :: Map Text SourceId
    {- ^ Each surviving version key mapped to the 'SourceId' of the input that won it. Trusted wins
    a collision. The serve layer takes that version's object from that source's raw @Value@.
    -}
    , MergePlan -> Map Text Version
mpDistTags :: Map Text Version
    {- ^ @dist-tags@ reconciled over the survivors. @latest@ comes from the public tag or the
    ordering, never the private one. Other tags carry by precedence, and an absent target drops.
    -}
    , MergePlan -> Map Text (NonEmpty AdmittedEntry)
mpArtifacts :: Map Text (NonEmpty AdmittedEntry)
    -- ^ Exact admitted entries from each version's winning source snapshot.
    , MergePlan -> Map Text UTCTime
mpTime :: Map Text UTCTime
    -- ^ Publish times from winning candidates. A winner with no known time contributes no entry.
    , MergePlan -> Set Divergence
mpDivergences :: Set Divergence
    {- ^ Every distinct same-version integrity conflict: the winner's fingerprint against each
    fingerprint that contradicts it on a shared algorithm. Differing algorithm sets do not count.
    -}
    }
    deriving stock (MergePlan -> MergePlan -> Bool
(MergePlan -> MergePlan -> Bool)
-> (MergePlan -> MergePlan -> Bool) -> Eq MergePlan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MergePlan -> MergePlan -> Bool
== :: MergePlan -> MergePlan -> Bool
$c/= :: MergePlan -> MergePlan -> Bool
/= :: MergePlan -> MergePlan -> Bool
Eq, Int -> MergePlan -> ShowS
[MergePlan] -> ShowS
MergePlan -> String
(Int -> MergePlan -> ShowS)
-> (MergePlan -> String)
-> ([MergePlan] -> ShowS)
-> Show MergePlan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MergePlan -> ShowS
showsPrec :: Int -> MergePlan -> ShowS
$cshow :: MergePlan -> String
show :: MergePlan -> String
$cshowList :: [MergePlan] -> ShowS
showList :: [MergePlan] -> ShowS
Show)

-- | Sorted file, asserted algorithm, and diagnostic digest triples. Only shared file/algorithm keys can contradict.
newtype IntegrityFingerprint = IntegrityFingerprint [(Text, Maybe HashAlg, Text)]
    deriving stock (IntegrityFingerprint -> IntegrityFingerprint -> Bool
(IntegrityFingerprint -> IntegrityFingerprint -> Bool)
-> (IntegrityFingerprint -> IntegrityFingerprint -> Bool)
-> Eq IntegrityFingerprint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IntegrityFingerprint -> IntegrityFingerprint -> Bool
== :: IntegrityFingerprint -> IntegrityFingerprint -> Bool
$c/= :: IntegrityFingerprint -> IntegrityFingerprint -> Bool
/= :: IntegrityFingerprint -> IntegrityFingerprint -> Bool
Eq, Eq IntegrityFingerprint
Eq IntegrityFingerprint =>
(IntegrityFingerprint -> IntegrityFingerprint -> Ordering)
-> (IntegrityFingerprint -> IntegrityFingerprint -> Bool)
-> (IntegrityFingerprint -> IntegrityFingerprint -> Bool)
-> (IntegrityFingerprint -> IntegrityFingerprint -> Bool)
-> (IntegrityFingerprint -> IntegrityFingerprint -> Bool)
-> (IntegrityFingerprint
    -> IntegrityFingerprint -> IntegrityFingerprint)
-> (IntegrityFingerprint
    -> IntegrityFingerprint -> IntegrityFingerprint)
-> Ord IntegrityFingerprint
IntegrityFingerprint -> IntegrityFingerprint -> Bool
IntegrityFingerprint -> IntegrityFingerprint -> Ordering
IntegrityFingerprint
-> IntegrityFingerprint -> IntegrityFingerprint
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 :: IntegrityFingerprint -> IntegrityFingerprint -> Ordering
compare :: IntegrityFingerprint -> IntegrityFingerprint -> Ordering
$c< :: IntegrityFingerprint -> IntegrityFingerprint -> Bool
< :: IntegrityFingerprint -> IntegrityFingerprint -> Bool
$c<= :: IntegrityFingerprint -> IntegrityFingerprint -> Bool
<= :: IntegrityFingerprint -> IntegrityFingerprint -> Bool
$c> :: IntegrityFingerprint -> IntegrityFingerprint -> Bool
> :: IntegrityFingerprint -> IntegrityFingerprint -> Bool
$c>= :: IntegrityFingerprint -> IntegrityFingerprint -> Bool
>= :: IntegrityFingerprint -> IntegrityFingerprint -> Bool
$cmax :: IntegrityFingerprint
-> IntegrityFingerprint -> IntegrityFingerprint
max :: IntegrityFingerprint
-> IntegrityFingerprint -> IntegrityFingerprint
$cmin :: IntegrityFingerprint
-> IntegrityFingerprint -> IntegrityFingerprint
min :: IntegrityFingerprint
-> IntegrityFingerprint -> IntegrityFingerprint
Ord, Int -> IntegrityFingerprint -> ShowS
[IntegrityFingerprint] -> ShowS
IntegrityFingerprint -> String
(Int -> IntegrityFingerprint -> ShowS)
-> (IntegrityFingerprint -> String)
-> ([IntegrityFingerprint] -> ShowS)
-> Show IntegrityFingerprint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> IntegrityFingerprint -> ShowS
showsPrec :: Int -> IntegrityFingerprint -> ShowS
$cshow :: IntegrityFingerprint -> String
show :: IntegrityFingerprint -> String
$cshowList :: [IntegrityFingerprint] -> ShowS
showList :: [IntegrityFingerprint] -> ShowS
Show)

-- | Sorted filename, algorithm, and original digest-body triples, including duplicates.
integrityHashes :: IntegrityFingerprint -> [(Text, Maybe HashAlg, Text)]
integrityHashes :: IntegrityFingerprint -> [(Text, Maybe HashAlg, Text)]
integrityHashes (IntegrityFingerprint [(Text, Maybe HashAlg, Text)]
hs) = [(Text, Maybe HashAlg, Text)]
hs

data Candidate = Candidate
    { Candidate -> Provenance
candProvenance :: Provenance
    , Candidate -> Int
candSourceId :: SourceId
    , -- Lazy: ranks are unique, so a fingerprint is forced only for a colliding version.
      Candidate -> IntegrityFingerprint
candFingerprint :: ~IntegrityFingerprint
    , Candidate -> PackageDetails
candDetails :: PackageDetails
    , Candidate -> ContentDigest
candSnapshot :: ContentDigest
    }
    deriving stock (Int -> Candidate -> ShowS
[Candidate] -> ShowS
Candidate -> String
(Int -> Candidate -> ShowS)
-> (Candidate -> String)
-> ([Candidate] -> ShowS)
-> Show Candidate
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Candidate -> ShowS
showsPrec :: Int -> Candidate -> ShowS
$cshow :: Candidate -> String
show :: Candidate -> String
$cshowList :: [Candidate] -> ShowS
showList :: [Candidate] -> ShowS
Show)

-- Eq and Ord both go through this key. 'candDetails' is deliberately excluded: a 'SourceId' is
-- unique per call, so two contributions agreeing on rank and integrity are the same candidate.
candKey :: Candidate -> ((Provenance, SourceId), IntegrityFingerprint)
candKey :: Candidate -> ((Provenance, Int), IntegrityFingerprint)
candKey Candidate
c = ((Candidate -> Provenance
candProvenance Candidate
c, Candidate -> Int
candSourceId Candidate
c), Candidate -> IntegrityFingerprint
candFingerprint Candidate
c)

instance Eq Candidate where
    Candidate
a == :: Candidate -> Candidate -> Bool
== Candidate
b = Candidate -> ((Provenance, Int), IntegrityFingerprint)
candKey Candidate
a ((Provenance, Int), IntegrityFingerprint)
-> ((Provenance, Int), IntegrityFingerprint) -> Bool
forall a. Eq a => a -> a -> Bool
== Candidate -> ((Provenance, Int), IntegrityFingerprint)
candKey Candidate
b

instance Ord Candidate where
    compare :: Candidate -> Candidate -> Ordering
compare Candidate
a Candidate
b = ((Provenance, Int), IntegrityFingerprint)
-> ((Provenance, Int), IntegrityFingerprint) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Candidate -> ((Provenance, Int), IntegrityFingerprint)
candKey Candidate
a) (Candidate -> ((Provenance, Int), IntegrityFingerprint)
candKey Candidate
b)

-- Ordering ignores the value so precedence resolves collisions before content.
data Ranked a = Ranked
    { forall a. Ranked a -> (Provenance, Int)
rankedRank :: (Provenance, SourceId)
    , forall a. Ranked a -> a
rankedValue :: a
    }
    deriving stock (Ranked a -> Ranked a -> Bool
(Ranked a -> Ranked a -> Bool)
-> (Ranked a -> Ranked a -> Bool) -> Eq (Ranked a)
forall a. Eq a => Ranked a -> Ranked a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Ranked a -> Ranked a -> Bool
== :: Ranked a -> Ranked a -> Bool
$c/= :: forall a. Eq a => Ranked a -> Ranked a -> Bool
/= :: Ranked a -> Ranked a -> Bool
Eq, Int -> Ranked a -> ShowS
[Ranked a] -> ShowS
Ranked a -> String
(Int -> Ranked a -> ShowS)
-> (Ranked a -> String) -> ([Ranked a] -> ShowS) -> Show (Ranked a)
forall a. Show a => Int -> Ranked a -> ShowS
forall a. Show a => [Ranked a] -> ShowS
forall a. Show a => Ranked a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Ranked a -> ShowS
showsPrec :: Int -> Ranked a -> ShowS
$cshow :: forall a. Show a => Ranked a -> String
show :: Ranked a -> String
$cshowList :: forall a. Show a => [Ranked a] -> ShowS
showList :: [Ranked a] -> ShowS
Show)

instance (Eq a) => Ord (Ranked a) where
    compare :: Ranked a -> Ranked a -> Ordering
compare Ranked a
a Ranked a
b = (Provenance, Int) -> (Provenance, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Ranked a -> (Provenance, Int)
forall a. Ranked a -> (Provenance, Int)
rankedRank Ranked a
a) (Ranked a -> (Provenance, Int)
forall a. Ranked a -> (Provenance, Int)
rankedRank Ranked a
b)

-- Keeps the higher-precedence (smaller-rank) value. Associative and commutative, so a
-- 'Map.unionWith' over it resolves a key's collision independent of input order.
keepBetter :: Ranked a -> Ranked a -> Ranked a
keepBetter :: forall a. Ranked a -> Ranked a -> Ranked a
keepBetter Ranked a
x Ranked a
y = if Ranked a -> (Provenance, Int)
forall a. Ranked a -> (Provenance, Int)
rankedRank Ranked a
x (Provenance, Int) -> (Provenance, Int) -> Bool
forall a. Ord a => a -> a -> Bool
<= Ranked a -> (Provenance, Int)
forall a. Ranked a -> (Provenance, Int)
rankedRank Ranked a
y then Ranked a
x else Ranked a
y

-- 'keepBetter' where either side may be absent, so a source that offered nothing never
-- displaces one that did.
keepBetterOf :: Maybe (Ranked a) -> Maybe (Ranked a) -> Maybe (Ranked a)
keepBetterOf :: forall a. Maybe (Ranked a) -> Maybe (Ranked a) -> Maybe (Ranked a)
keepBetterOf (Just Ranked a
x) (Just Ranked a
y) = Ranked a -> Maybe (Ranked a)
forall a. a -> Maybe a
Just (Ranked a -> Ranked a -> Ranked a
forall a. Ranked a -> Ranked a -> Ranked a
keepBetter Ranked a
x Ranked a
y)
keepBetterOf Maybe (Ranked a)
x Maybe (Ranked a)
y = Maybe (Ranked a)
x Maybe (Ranked a) -> Maybe (Ranked a) -> Maybe (Ranked a)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Ranked a)
y

{- $accumulator
The merge folds each input's 'contribute' into the lawful 'Merge' 'Monoid', which 'planFrom' then
projects to a 'MergePlan'. 'Merge' is opaque, so a 'SourceId' always names a real input position.
-}

{- | The monoidal accumulator the merge folds into. It leaves every version key's candidates
unresolved, because a pairwise winner decision during the fold is not associative for 3+ copies.
-}
data Merge = Merge
    { Merge -> Int
mergeCount :: Int
    -- ^ How many inputs this accumulator represents (the next free 'SourceId').
    , Merge -> Map Text (Set Candidate)
mergeVersions :: Map Text (Set Candidate)
    -- ^ Every candidate offered for each version key, unresolved.
    , Merge -> Map Text (Ranked Version)
mergeDistTags :: Map Text (Ranked Version)
    -- ^ The precedence-winning @dist-tags@ target offered for each tag.
    , Merge -> Maybe (Ranked Version)
mergePublicLatest :: Maybe (Ranked Version)
    {- ^ The @latest@ a 'GatedSource' offered, held apart because the 'mergeDistTags' union
    resolves every tag to the trusted source.
    -}
    , Merge -> Maybe PackageName
mergeName :: Maybe PackageName
    {- ^ The package identity. Every contribution carries the same name, because a check upstream
    of the merge validates each one against the requested name. 'Nothing' only for 'mempty'.
    -}
    }
    deriving stock (Merge -> Merge -> Bool
(Merge -> Merge -> Bool) -> (Merge -> Merge -> Bool) -> Eq Merge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Merge -> Merge -> Bool
== :: Merge -> Merge -> Bool
$c/= :: Merge -> Merge -> Bool
/= :: Merge -> Merge -> Bool
Eq, Int -> Merge -> ShowS
[Merge] -> ShowS
Merge -> String
(Int -> Merge -> ShowS)
-> (Merge -> String) -> ([Merge] -> ShowS) -> Show Merge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Merge -> ShowS
showsPrec :: Int -> Merge -> ShowS
$cshow :: Merge -> String
show :: Merge -> String
$cshowList :: [Merge] -> ShowS
showList :: [Merge] -> ShowS
Show)

-- Source IDs follow input positions, so regrouping preserves the result but permutation changes labels.
instance Semigroup Merge where
    Merge
a <> :: Merge -> Merge -> Merge
<> Merge
b =
        Merge
            { mergeCount :: Int
mergeCount = Merge -> Int
mergeCount Merge
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Merge -> Int
mergeCount Merge
b
            , mergeVersions :: Map Text (Set Candidate)
mergeVersions =
                (Set Candidate -> Set Candidate -> Set Candidate)
-> Map Text (Set Candidate)
-> Map Text (Set Candidate)
-> Map Text (Set Candidate)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Set Candidate -> Set Candidate -> Set Candidate
forall a. Ord a => Set a -> Set a -> Set a
Set.union (Merge -> Map Text (Set Candidate)
mergeVersions Merge
a) (Map Text (Set Candidate) -> Map Text (Set Candidate)
shiftVersions (Merge -> Map Text (Set Candidate)
mergeVersions Merge
b))
            , mergeDistTags :: Map Text (Ranked Version)
mergeDistTags =
                (Ranked Version -> Ranked Version -> Ranked Version)
-> Map Text (Ranked Version)
-> Map Text (Ranked Version)
-> Map Text (Ranked Version)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Ranked Version -> Ranked Version -> Ranked Version
forall a. Ranked a -> Ranked a -> Ranked a
keepBetter (Merge -> Map Text (Ranked Version)
mergeDistTags Merge
a) (Ranked Version -> Ranked Version
forall {a}. Ranked a -> Ranked a
shiftRanked (Ranked Version -> Ranked Version)
-> Map Text (Ranked Version) -> Map Text (Ranked Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Merge -> Map Text (Ranked Version)
mergeDistTags Merge
b)
            , mergePublicLatest :: Maybe (Ranked Version)
mergePublicLatest =
                Maybe (Ranked Version)
-> Maybe (Ranked Version) -> Maybe (Ranked Version)
forall a. Maybe (Ranked a) -> Maybe (Ranked a) -> Maybe (Ranked a)
keepBetterOf (Merge -> Maybe (Ranked Version)
mergePublicLatest Merge
a) (Ranked Version -> Ranked Version
forall {a}. Ranked a -> Ranked a
shiftRanked (Ranked Version -> Ranked Version)
-> Maybe (Ranked Version) -> Maybe (Ranked Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Merge -> Maybe (Ranked Version)
mergePublicLatest Merge
b)
            , mergeName :: Maybe PackageName
mergeName = Merge -> Maybe PackageName
mergeName Merge
a Maybe PackageName -> Maybe PackageName -> Maybe PackageName
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Merge -> Maybe PackageName
mergeName Merge
b
            }
      where
        -- Re-index the right operand's SourceIds past the left operand's inputs, so a fold of
        -- single-input contributions lands each at its list index.
        offset :: Int
offset = Merge -> Int
mergeCount Merge
a
        shiftVersions :: Map Text (Set Candidate) -> Map Text (Set Candidate)
shiftVersions = (Set Candidate -> Set Candidate)
-> Map Text (Set Candidate) -> Map Text (Set Candidate)
forall a b. (a -> b) -> Map Text a -> Map Text b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Candidate -> Candidate) -> Set Candidate -> Set Candidate
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Candidate -> Candidate
shiftCandidate)
        shiftCandidate :: Candidate -> Candidate
shiftCandidate Candidate
c = Candidate
c{candSourceId = candSourceId c + offset}
        shiftRanked :: Ranked a -> Ranked a
shiftRanked (Ranked (Provenance
prov, Int
sid) a
v) = (Provenance, Int) -> a -> Ranked a
forall a. (Provenance, Int) -> a -> Ranked a
Ranked (Provenance
prov, Int
sid Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
offset) a
v

instance Monoid Merge where
    mempty :: Merge
mempty =
        Merge
            { mergeCount :: Int
mergeCount = Int
0
            , mergeVersions :: Map Text (Set Candidate)
mergeVersions = Map Text (Set Candidate)
forall k a. Map k a
Map.empty
            , mergeDistTags :: Map Text (Ranked Version)
mergeDistTags = Map Text (Ranked Version)
forall k a. Map k a
Map.empty
            , mergePublicLatest :: Maybe (Ranked Version)
mergePublicLatest = Maybe (Ranked Version)
forall a. Maybe a
Nothing
            , mergeName :: Maybe PackageName
mergeName = Maybe PackageName
forall a. Maybe a
Nothing
            }

{- | One input's contribution to the accumulator, at local 'SourceId' @0@. The 'Semigroup' offset
re-indexes it to the input's position when 'mergePackuments' folds over the inputs.
-}
contribute :: Provenance -> Snapshot PackageInfo -> Merge
contribute :: Provenance -> Snapshot PackageInfo -> Merge
contribute Provenance
prov (Snapshot ContentDigest
digest PackageInfo
info) =
    Merge
        { mergeCount :: Int
mergeCount = Int
1
        , mergeVersions :: Map Text (Set Candidate)
mergeVersions = (PackageDetails -> Set Candidate)
-> Map Text PackageDetails -> Map Text (Set Candidate)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map PackageDetails -> Set Candidate
candidateFor (PackageInfo -> Map Text PackageDetails
infoVersions PackageInfo
info)
        , mergeDistTags :: Map Text (Ranked Version)
mergeDistTags = (Version -> Ranked Version)
-> Map Text Version -> Map Text (Ranked Version)
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ((Provenance, Int) -> Version -> Ranked Version
forall a. (Provenance, Int) -> a -> Ranked a
Ranked (Provenance, Int)
here) (PackageInfo -> Map Text Version
infoDistTags PackageInfo
info)
        , mergePublicLatest :: Maybe (Ranked Version)
mergePublicLatest = (Provenance, Int) -> Version -> Ranked Version
forall a. (Provenance, Int) -> a -> Ranked a
Ranked (Provenance, Int)
here (Version -> Ranked Version)
-> Maybe Version -> Maybe (Ranked Version)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Version
publicLatest
        , mergeName :: Maybe PackageName
mergeName = PackageName -> Maybe PackageName
forall a. a -> Maybe a
Just (PackageInfo -> PackageName
infoName PackageInfo
info)
        }
  where
    -- Local SourceId 0. The Semigroup offset re-indexes it to the input position.
    here :: (Provenance, Int)
here = (Provenance
prov, Int
0)
    publicLatest :: Maybe Version
publicLatest = case Provenance
prov of
        Provenance
GatedSource -> Text -> Map Text Version -> Maybe Version
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
"latest" (PackageInfo -> Map Text Version
infoDistTags PackageInfo
info)
        Provenance
TrustedSource -> Maybe Version
forall a. Maybe a
Nothing
    candidateFor :: PackageDetails -> Set Candidate
candidateFor PackageDetails
details =
        Candidate -> Set Candidate
forall a. a -> Set a
Set.singleton
            Candidate
                { candProvenance :: Provenance
candProvenance = Provenance
prov
                , candSourceId :: Int
candSourceId = Int
0
                , candFingerprint :: IntegrityFingerprint
candFingerprint = PackageDetails -> IntegrityFingerprint
fingerprint PackageDetails
details
                , candDetails :: PackageDetails
candDetails = PackageDetails
details
                , candSnapshot :: ContentDigest
candSnapshot = ContentDigest
digest
                }

{- | Merge admitted snapshots with trusted-source precedence and divergence reporting.
Empty input yields 'Nothing'.
-}
mergePackuments :: [(Provenance, Snapshot PackageInfo)] -> Maybe MergePlan
mergePackuments :: [(Provenance, Snapshot PackageInfo)] -> Maybe MergePlan
mergePackuments [] = Maybe MergePlan
forall a. Maybe a
Nothing
mergePackuments [(Provenance, Snapshot PackageInfo)]
inputs = Merge -> Maybe MergePlan
planFrom (((Provenance, Snapshot PackageInfo) -> Merge)
-> [(Provenance, Snapshot PackageInfo)] -> Merge
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Provenance -> Snapshot PackageInfo -> Merge)
-> (Provenance, Snapshot PackageInfo) -> Merge
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Provenance -> Snapshot PackageInfo -> Merge
contribute) [(Provenance, Snapshot PackageInfo)]
inputs)

{- | Project the resolved 'MergePlan' from a folded 'Merge'. It resolves each version key to its
precedence winner. 'Nothing' only for 'mempty', the empty merge, which has nothing to serve.
-}
planFrom :: Merge -> Maybe MergePlan
planFrom :: Merge -> Maybe MergePlan
planFrom Merge
acc = do
    name <- Merge -> Maybe PackageName
mergeName Merge
acc
    pure
        MergePlan
            { mpName = name
            , mpSurvivors = Map.map (candSourceId . winnerOf) (mergeVersions acc)
            , mpArtifacts = Map.map (admittedEntries . winnerOf) (mergeVersions acc)
            , mpDistTags = reconciledTags acc
            , mpTime = Map.mapMaybe (pkgPublishedAt . candDetails . winnerOf) (mergeVersions acc)
            , mpDivergences = divergencesOf (mergeVersions acc)
            }

-- The minimum by rank. A key always has at least one candidate, so 'Set.findMin' is total here.
winnerOf :: Set Candidate -> Candidate
winnerOf :: Set Candidate -> Candidate
winnerOf = Set Candidate -> Candidate
forall a. Set a -> a
Set.findMin

admittedEntries :: Candidate -> NonEmpty AdmittedEntry
admittedEntries :: Candidate -> NonEmpty AdmittedEntry
admittedEntries Candidate
candidate =
    (Artifact -> AdmittedEntry)
-> NonEmpty Artifact -> NonEmpty AdmittedEntry
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
        (\Artifact
artifact -> ContentDigest -> EntryKey -> Text -> AdmittedEntry
AdmittedEntry (Candidate -> ContentDigest
candSnapshot Candidate
candidate) (Artifact -> EntryKey
artEntryKey Artifact
artifact) (Artifact -> Text
artFilename Artifact
artifact))
        (PackageDetails -> NonEmpty Artifact
pkgArtifacts (Candidate -> PackageDetails
candDetails Candidate
candidate))

-- Divergence is a property of the /set/ of distinct fingerprints offered for a key, never of a
-- pairwise fold step. That keeps it order-independent and associative for 3+ sources.
divergencesOf :: Map Text (Set Candidate) -> Set Divergence
divergencesOf :: Map Text (Set Candidate) -> Set Divergence
divergencesOf Map Text (Set Candidate)
versions =
    [Divergence] -> Set Divergence
forall a. Ord a => [a] -> Set a
Set.fromList
        [ Divergence{divVersion :: Text
divVersion = Text
key, divWinning :: IntegrityFingerprint
divWinning = IntegrityFingerprint
win, divLosing :: IntegrityFingerprint
divLosing = IntegrityFingerprint
lose}
        | (Text
key, Set Candidate
cs) <- Map Text (Set Candidate) -> [(Text, Set Candidate)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Text (Set Candidate)
versions
        , Set Candidate -> Int
forall a. Set a -> Int
Set.size Set Candidate
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
        , let winner :: Candidate
winner = Set Candidate -> Candidate
winnerOf Set Candidate
cs
        , let win :: IntegrityFingerprint
win = Candidate -> IntegrityFingerprint
candFingerprint Candidate
winner
        , let winningDigests :: DigestSets
winningDigests = PackageDetails -> DigestSets
digestsByKey (Candidate -> PackageDetails
candDetails Candidate
winner)
        , Candidate
candidate <- Set Candidate -> [Candidate]
forall a. Set a -> [a]
Set.toList Set Candidate
cs
        , let lose :: IntegrityFingerprint
lose = Candidate -> IntegrityFingerprint
candFingerprint Candidate
candidate
        , IntegrityFingerprint
lose IntegrityFingerprint -> IntegrityFingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= IntegrityFingerprint
win
        , DigestSets -> DigestSets -> Bool
contradicts DigestSets
winningDigests (PackageDetails -> DigestSets
digestsByKey (Candidate -> PackageDetails
candDetails Candidate
candidate))
        ]

-- The accumulator has already resolved same-tag collisions by provenance, so a carried tag never
-- depends on the order the caller passed the inputs.
reconciledTags :: Merge -> Map Text Version
reconciledTags :: Merge -> Map Text Version
reconciledTags Merge
acc = case Maybe Version -> [Version] -> Maybe Version
selectLatest Maybe Version
chosenLatest ((PackageDetails -> Version) -> [PackageDetails] -> [Version]
forall a b. (a -> b) -> [a] -> [b]
map PackageDetails -> Version
pkgVersion [PackageDetails]
survivingDetails) of
    Maybe Version
Nothing -> Text -> Map Text Version -> Map Text Version
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete Text
"latest" Map Text Version
carried
    Just Version
v -> Text -> Version -> Map Text Version -> Map Text Version
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Text
"latest" Version
v Map Text Version
carried
  where
    carried :: Map Text Version
carried = (Version -> Bool) -> Map Text Version -> Map Text Version
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Text -> Bool
survives (Text -> Bool) -> (Version -> Text) -> Version -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> Text
renderVersion) ((Ranked Version -> Version)
-> Map Text (Ranked Version) -> Map Text Version
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Ranked Version -> Version
forall a. Ranked a -> a
rankedValue (Merge -> Map Text (Ranked Version)
mergeDistTags Merge
acc))
    survives :: Text -> Bool
survives Text
key = Text -> Map Text (Set Candidate) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member Text
key (Merge -> Map Text (Set Candidate)
mergeVersions Merge
acc)
    survivingDetails :: [PackageDetails]
survivingDetails = [Candidate -> PackageDetails
candDetails (Set Candidate -> Candidate
winnerOf Set Candidate
cs) | Set Candidate
cs <- Map Text (Set Candidate) -> [Set Candidate]
forall k a. Map k a -> [a]
Map.elems (Merge -> Map Text (Set Candidate)
mergeVersions Merge
acc)]

    -- A private document, mirror store or not, is never authoritative for @latest@, so
    -- 'selectLatest' projects over the survivors from the public tag alone.
    chosenLatest :: Maybe Version
chosenLatest = Ranked Version -> Version
forall a. Ranked a -> a
rankedValue (Ranked Version -> Version)
-> Maybe (Ranked Version) -> Maybe Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Merge -> Maybe (Ranked Version)
mergePublicLatest Merge
acc

{- | Compare integrity-admitted versions independently of rule eligibility, with the trusted map winning.
Inputs must share a validated package identity. Only shared version keys are compared.
-}
integrityDivergences :: Map Text PackageDetails -> Map Text PackageDetails -> Set Divergence
integrityDivergences :: Map Text PackageDetails
-> Map Text PackageDetails -> Set Divergence
integrityDivergences Map Text PackageDetails
trusted Map Text PackageDetails
public =
    [Divergence] -> Set Divergence
forall a. Ord a => [a] -> Set a
Set.fromList
        [ Text -> IntegrityFingerprint -> IntegrityFingerprint -> Divergence
Divergence Text
key IntegrityFingerprint
win IntegrityFingerprint
lose
        | (Text
key, (PackageDetails
privateDetails, PackageDetails
publicDetails)) <- Map Text (PackageDetails, PackageDetails)
-> [(Text, (PackageDetails, PackageDetails))]
forall k a. Map k a -> [(k, a)]
Map.toList ((PackageDetails
 -> PackageDetails -> (PackageDetails, PackageDetails))
-> Map Text PackageDetails
-> Map Text PackageDetails
-> Map Text (PackageDetails, PackageDetails)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) Map Text PackageDetails
trusted Map Text PackageDetails
public)
        , let win :: IntegrityFingerprint
win = PackageDetails -> IntegrityFingerprint
fingerprint PackageDetails
privateDetails
        , let lose :: IntegrityFingerprint
lose = PackageDetails -> IntegrityFingerprint
fingerprint PackageDetails
publicDetails
        , DigestSets -> DigestSets -> Bool
contradicts (PackageDetails -> DigestSets
digestsByKey PackageDetails
privateDetails) (PackageDetails -> DigestSets
digestsByKey PackageDetails
publicDetails)
        ]

-- Diagnostics retain the existing digest spelling, sorted order, and duplicate entries.
fingerprint :: PackageDetails -> IntegrityFingerprint
fingerprint :: PackageDetails -> IntegrityFingerprint
fingerprint =
    [(Text, Maybe HashAlg, Text)] -> IntegrityFingerprint
IntegrityFingerprint
        ([(Text, Maybe HashAlg, Text)] -> IntegrityFingerprint)
-> (PackageDetails -> [(Text, Maybe HashAlg, Text)])
-> PackageDetails
-> IntegrityFingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Maybe HashAlg, Text)] -> [(Text, Maybe HashAlg, Text)]
forall a. Ord a => [a] -> [a]
sort
        ([(Text, Maybe HashAlg, Text)] -> [(Text, Maybe HashAlg, Text)])
-> (PackageDetails -> [(Text, Maybe HashAlg, Text)])
-> PackageDetails
-> [(Text, Maybe HashAlg, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Artifact -> [(Text, Maybe HashAlg, Text)])
-> [Artifact] -> [(Text, Maybe HashAlg, Text)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Artifact -> [(Text, Maybe HashAlg, Text)]
artHashPairs
        ([Artifact] -> [(Text, Maybe HashAlg, Text)])
-> (PackageDetails -> [Artifact])
-> PackageDetails
-> [(Text, Maybe HashAlg, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty Artifact -> [Artifact]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
        (NonEmpty Artifact -> [Artifact])
-> (PackageDetails -> NonEmpty Artifact)
-> PackageDetails
-> [Artifact]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageDetails -> NonEmpty Artifact
pkgArtifacts
  where
    artHashPairs :: Artifact -> [(Text, Maybe HashAlg, Text)]
artHashPairs Artifact
art = [(Artifact -> Text
artFilename Artifact
art, Hash -> Maybe HashAlg
assertedAlg Hash
h, Hash -> Text
diagnosticBody Hash
h) | Hash
h <- Artifact -> [Hash]
artHashes Artifact
art]

diagnosticBody :: Hash -> Text
diagnosticBody :: Hash -> Text
diagnosticBody Hash
h = case Hash -> HashAlg
hashAlg Hash
h of
    HashAlg
SRI -> Text -> Text
sriBody (Hash -> Text
hashValue Hash
h)
    HashAlg
_ -> Hash -> Text
hashValue Hash
h

-- Record updates can bypass 'mkHash'. Invalid text remains distinct comparison evidence.
comparableBody :: Hash -> Text
comparableBody :: Hash -> Text
comparableBody Hash
h = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Hash -> Text
hashValue Hash
h) (Hash -> Maybe Text
canonicalHashValue Hash
h)

type DigestSets = Map (Text, Maybe HashAlg) (Set Text)

digestsByKey :: PackageDetails -> DigestSets
digestsByKey :: PackageDetails -> DigestSets
digestsByKey PackageDetails
details =
    (Set Text -> Set Text -> Set Text)
-> [((Text, Maybe HashAlg), Set Text)] -> DigestSets
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith
        Set Text -> Set Text -> Set Text
forall a. Ord a => Set a -> Set a -> Set a
Set.union
        [ ((Artifact -> Text
artFilename Artifact
art, Hash -> Maybe HashAlg
assertedAlg Hash
h), Text -> Set Text
forall a. a -> Set a
Set.singleton (Hash -> Text
comparableBody Hash
h))
        | Artifact
art <- NonEmpty Artifact -> [Artifact]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (PackageDetails -> NonEmpty Artifact
pkgArtifacts PackageDetails
details)
        , Hash
h <- Artifact -> [Hash]
artHashes Artifact
art
        ]

-- An omitted file or algorithm makes no conflicting claim. Shared keys require complete set equality.
contradicts :: DigestSets -> DigestSets -> Bool
contradicts :: DigestSets -> DigestSets -> Bool
contradicts DigestSets
a DigestSets
b = Map (Text, Maybe HashAlg) Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ((Set Text -> Set Text -> Bool)
-> DigestSets -> DigestSets -> Map (Text, Maybe HashAlg) Bool
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith Set Text -> Set Text -> Bool
forall a. Eq a => a -> a -> Bool
(/=) DigestSets
a DigestSets
b)