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

{- | Bounded inventory joins for a mount's mirror and private-cache preview.
Each package retains the observations that actually listed it.
-}
module Ecluse.Core.Registry.Sweep.Group (
    groupAlphabet,
    collectGroupBucket,
    boundedVersions,
) where

import Control.Monad (foldM)
import Data.Conduit (fuseUpstream)
import Data.Conduit.List qualified as CL
import Data.Map.Strict qualified as Map

import Ecluse.Core.Package (PackageName)
import Ecluse.Core.Registry.Maintenance (
    StoreFacts (factNameAlphabet),
    StoreFault,
    StoreObservation (obFacts, obListPackagesIn),
    StoredVersion (storedVersion),
    protocolFault,
 )
import Ecluse.Core.Registry.Maintenance.NameSpace (
    NameAlphabet,
    NamePrefix,
    noNameAlphabet,
 )
import Ecluse.Core.Registry.Sweep.Walk (BucketNames, collectBucketWith, insertInventory)
import Ecluse.Core.Version (renderVersion)

-- | Use a common partition only when both backends declare the same alphabet.
groupAlphabet :: StoreObservation -> StoreObservation -> NameAlphabet
groupAlphabet :: StoreObservation -> StoreObservation -> NameAlphabet
groupAlphabet StoreObservation
mirror StoreObservation
cache
    | StoreObservation -> NameAlphabet
alphabet StoreObservation
mirror NameAlphabet -> NameAlphabet -> Bool
forall a. Eq a => a -> a -> Bool
== StoreObservation -> NameAlphabet
alphabet StoreObservation
cache = StoreObservation -> NameAlphabet
alphabet StoreObservation
mirror
    | Bool
otherwise = NameAlphabet
noNameAlphabet
  where
    alphabet :: StoreObservation -> NameAlphabet
alphabet = StoreFacts -> NameAlphabet
factNameAlphabet (StoreFacts -> NameAlphabet)
-> (StoreObservation -> StoreFacts)
-> StoreObservation
-> NameAlphabet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StoreObservation -> StoreFacts
obFacts

-- | Join actual package presence under the shared bucket budget, retaining each location.
collectGroupBucket :: NameAlphabet -> NamePrefix -> StoreObservation -> StoreObservation -> IO (BucketNames (StoreObservation, StoreFault) (PackageName, [Bool]))
collectGroupBucket :: NameAlphabet
-> NamePrefix
-> StoreObservation
-> StoreObservation
-> IO
     (BucketNames (StoreObservation, StoreFault) (PackageName, [Bool]))
collectGroupBucket NameAlphabet
alphabet NamePrefix
prefix StoreObservation
mirror StoreObservation
cache =
    ((PackageName, Map Bool Bool) -> (PackageName, [Bool]))
-> BucketNames
     (StoreObservation, StoreFault) (PackageName, Map Bool Bool)
-> BucketNames (StoreObservation, StoreFault) (PackageName, [Bool])
forall a b.
(a -> b)
-> BucketNames (StoreObservation, StoreFault) a
-> BucketNames (StoreObservation, StoreFault) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Map Bool Bool -> [Bool])
-> (PackageName, Map Bool Bool) -> (PackageName, [Bool])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Map Bool Bool -> [Bool]
forall k a. Map k a -> [a]
Map.elems) (BucketNames
   (StoreObservation, StoreFault) (PackageName, Map Bool Bool)
 -> BucketNames
      (StoreObservation, StoreFault) (PackageName, [Bool]))
-> IO
     (BucketNames
        (StoreObservation, StoreFault) (PackageName, Map Bool Bool))
-> IO
     (BucketNames (StoreObservation, StoreFault) (PackageName, [Bool]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameAlphabet
-> NamePrefix
-> (Map Bool Bool -> Map Bool Bool -> Map Bool Bool)
-> ConduitT
     ()
     [(PackageName, Map Bool Bool)]
     IO
     (Maybe (StoreObservation, StoreFault))
-> IO
     (BucketNames
        (StoreObservation, StoreFault) (PackageName, Map Bool Bool))
forall a fault.
NameAlphabet
-> NamePrefix
-> (a -> a -> a)
-> ConduitT () [(PackageName, a)] IO (Maybe fault)
-> IO (BucketNames fault (PackageName, a))
collectBucketWith NameAlphabet
alphabet NamePrefix
prefix Map Bool Bool -> Map Bool Bool -> Map Bool Bool
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ConduitT
  ()
  [(PackageName, Map Bool Bool)]
  IO
  (Maybe (StoreObservation, StoreFault))
source
  where
    source :: ConduitT
  ()
  [(PackageName, Map Bool Bool)]
  IO
  (Maybe (StoreObservation, StoreFault))
source = do
        fault <- Bool
-> StoreObservation
-> ConduitT
     ()
     [(PackageName, Map Bool Bool)]
     IO
     (Maybe (StoreObservation, StoreFault))
forall {a}.
a
-> StoreObservation
-> ConduitT
     ()
     [(PackageName, Map a a)]
     IO
     (Maybe (StoreObservation, StoreFault))
locatedPages Bool
False StoreObservation
mirror
        maybe (locatedPages True cache) (pure . Just) fault
    -- The slot keys its own entry, so a name a location lists on several pages joins once.
    locatedPages :: a
-> StoreObservation
-> ConduitT
     ()
     [(PackageName, Map a a)]
     IO
     (Maybe (StoreObservation, StoreFault))
locatedPages a
slot StoreObservation
store =
        (StoreFault -> (StoreObservation, StoreFault))
-> Maybe StoreFault -> Maybe (StoreObservation, StoreFault)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (StoreObservation
store,)
            (Maybe StoreFault -> Maybe (StoreObservation, StoreFault))
-> ConduitT () [(PackageName, Map a a)] IO (Maybe StoreFault)
-> ConduitT
     ()
     [(PackageName, Map a a)]
     IO
     (Maybe (StoreObservation, StoreFault))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConduitT () [PackageName] IO (Maybe StoreFault)
-> ConduitT [PackageName] [(PackageName, Map a a)] IO ()
-> ConduitT () [(PackageName, Map a a)] IO (Maybe StoreFault)
forall (m :: * -> *) a b r c.
Monad m =>
ConduitT a b m r -> ConduitT b c m () -> ConduitT a c m r
fuseUpstream
                (StoreObservation
-> NamePrefix -> ConduitT () [PackageName] IO (Maybe StoreFault)
obListPackagesIn StoreObservation
store NamePrefix
prefix)
                (([PackageName] -> [(PackageName, Map a a)])
-> ConduitT [PackageName] [(PackageName, Map a a)] IO ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map ((PackageName -> (PackageName, Map a a))
-> [PackageName] -> [(PackageName, Map a a)]
forall a b. (a -> b) -> [a] -> [b]
map (,a -> a -> Map a a
forall k a. k -> a -> Map k a
Map.singleton a
slot a
slot)))

-- | Reject an oversized combined version inventory and deduplicate identities within each location.
boundedVersions :: Int -> [(a, [StoredVersion])] -> Either StoreFault [(a, [StoredVersion])]
boundedVersions :: forall a.
Int
-> [(a, [StoredVersion])]
-> Either StoreFault [(a, [StoredVersion])]
boundedVersions Int
limit [(a, [StoredVersion])]
locations = do
    combined <- StoreFault
-> Maybe (Map Text (Map Int StoredVersion))
-> Either StoreFault (Map Text (Map Int StoredVersion))
forall l r. l -> Maybe r -> Either l r
maybeToRight StoreFault
overflow ((Map Text (Map Int StoredVersion)
 -> (Int, (a, [StoredVersion]))
 -> Maybe (Map Text (Map Int StoredVersion)))
-> Map Text (Map Int StoredVersion)
-> [(Int, (a, [StoredVersion]))]
-> Maybe (Map Text (Map Int StoredVersion))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Map Text (Map Int StoredVersion)
-> (Int, (a, [StoredVersion]))
-> Maybe (Map Text (Map Int StoredVersion))
forall {t :: * -> *} {k} {a}.
(Foldable t, Ord k) =>
Map Text (Map k StoredVersion)
-> (k, (a, t StoredVersion))
-> Maybe (Map Text (Map k StoredVersion))
addLocation Map Text (Map Int StoredVersion)
forall k a. Map k a
Map.empty [(Int, (a, [StoredVersion]))]
indexed)
    pure [(store, Map.elems (Map.mapMaybe (Map.lookup index) combined)) | (index, (store, _)) <- indexed]
  where
    indexed :: [(Int, (a, [StoredVersion]))]
indexed = [Int] -> [(a, [StoredVersion])] -> [(Int, (a, [StoredVersion]))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 :: Int ..] [(a, [StoredVersion])]
locations
    addLocation :: Map Text (Map k StoredVersion)
-> (k, (a, t StoredVersion))
-> Maybe (Map Text (Map k StoredVersion))
addLocation Map Text (Map k StoredVersion)
held (k
index, (a
_, t StoredVersion
versions)) = (Map Text (Map k StoredVersion)
 -> StoredVersion -> Maybe (Map Text (Map k StoredVersion)))
-> Map Text (Map k StoredVersion)
-> t StoredVersion
-> Maybe (Map Text (Map k StoredVersion))
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (k
-> Map Text (Map k StoredVersion)
-> StoredVersion
-> Maybe (Map Text (Map k StoredVersion))
forall {k}.
Ord k =>
k
-> Map Text (Map k StoredVersion)
-> StoredVersion
-> Maybe (Map Text (Map k StoredVersion))
addVersion k
index) Map Text (Map k StoredVersion)
held t StoredVersion
versions
    addVersion :: k
-> Map Text (Map k StoredVersion)
-> StoredVersion
-> Maybe (Map Text (Map k StoredVersion))
addVersion k
index Map Text (Map k StoredVersion)
held StoredVersion
version =
        Int
-> (Map k StoredVersion
    -> Map k StoredVersion -> Map k StoredVersion)
-> Map Text (Map k StoredVersion)
-> (Text, Map k StoredVersion)
-> Maybe (Map Text (Map k StoredVersion))
forall key value.
Ord key =>
Int
-> (value -> value -> value)
-> Map key value
-> (key, value)
-> Maybe (Map key value)
insertInventory Int
limit Map k StoredVersion -> Map k StoredVersion -> Map k StoredVersion
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union Map Text (Map k StoredVersion)
held (Version -> Text
renderVersion (StoredVersion -> Version
storedVersion StoredVersion
version), k -> StoredVersion -> Map k StoredVersion
forall k a. k -> a -> Map k a
Map.singleton k
index StoredVersion
version)
    overflow :: StoreFault
overflow = Text -> StoreFault
protocolFault Text
"the combined inventory crossed limits.maxVersionCount"