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

{- | Whether public content can reach clients through a private repository, and the bounded walk
of its upstream chain a backend answers with. The answer is a value the boot reads, so the words
an operator sees live in the boot renderers rather than here.
-}
module Ecluse.Core.Registry.Maintenance.Upstream (
    -- * The answer
    UpstreamSafety (..),
    UnsafeReason (..),
    UndecidabilityReason (..),
    noUpstreamMechanism,

    -- * What an answer names
    RepositoryName (..),
    ExternalConnection (..),
    PermissionName (..),

    -- * The chain walk
    RepositoryLinks (..),
    walkUpstreamChain,
    upstreamHopCeiling,
    upstreamCallCeiling,
) where

import Data.Set qualified as Set

-- | Whether public content can reach a client through one repository.
data UpstreamSafety
    = -- | Nothing public reaches a client through it.
      Safe
    | -- | Public content reaches a client, or an identity that cannot ask assumed that it does.
      Unsafe UnsafeReason
    | -- | The question stayed open, so the threat stays the operator's.
      Undecidable UndecidabilityReason
    deriving stock (UpstreamSafety -> UpstreamSafety -> Bool
(UpstreamSafety -> UpstreamSafety -> Bool)
-> (UpstreamSafety -> UpstreamSafety -> Bool) -> Eq UpstreamSafety
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UpstreamSafety -> UpstreamSafety -> Bool
== :: UpstreamSafety -> UpstreamSafety -> Bool
$c/= :: UpstreamSafety -> UpstreamSafety -> Bool
/= :: UpstreamSafety -> UpstreamSafety -> Bool
Eq, Int -> UpstreamSafety -> ShowS
[UpstreamSafety] -> ShowS
UpstreamSafety -> String
(Int -> UpstreamSafety -> ShowS)
-> (UpstreamSafety -> String)
-> ([UpstreamSafety] -> ShowS)
-> Show UpstreamSafety
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UpstreamSafety -> ShowS
showsPrec :: Int -> UpstreamSafety -> ShowS
$cshow :: UpstreamSafety -> String
show :: UpstreamSafety -> String
$cshowList :: [UpstreamSafety] -> ShowS
showList :: [UpstreamSafety] -> ShowS
Show)

-- | What made a repository unsafe to serve private content from.
data UnsafeReason
    = -- | This repository, or one in its chain, carries the named connection to a public registry.
      ConfigurationEvidence RepositoryName ExternalConnection
    | -- | The role's identity may not read the configuration, which fails closed.
      InsufficientPermissions PermissionName
    deriving stock (UnsafeReason -> UnsafeReason -> Bool
(UnsafeReason -> UnsafeReason -> Bool)
-> (UnsafeReason -> UnsafeReason -> Bool) -> Eq UnsafeReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnsafeReason -> UnsafeReason -> Bool
== :: UnsafeReason -> UnsafeReason -> Bool
$c/= :: UnsafeReason -> UnsafeReason -> Bool
/= :: UnsafeReason -> UnsafeReason -> Bool
Eq, Int -> UnsafeReason -> ShowS
[UnsafeReason] -> ShowS
UnsafeReason -> String
(Int -> UnsafeReason -> ShowS)
-> (UnsafeReason -> String)
-> ([UnsafeReason] -> ShowS)
-> Show UnsafeReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UnsafeReason -> ShowS
showsPrec :: Int -> UnsafeReason -> ShowS
$cshow :: UnsafeReason -> String
show :: UnsafeReason -> String
$cshowList :: [UnsafeReason] -> ShowS
showList :: [UnsafeReason] -> ShowS
Show)

-- | Why an answer stayed open.
data UndecidabilityReason
    = -- | The backend reports no upstream configuration at all.
      NoMechanism
    | -- | The backend did not answer, or faulted before it did.
      NetworkFailure
    | -- | The walk met a ceiling with part of the chain still unread.
      ChainBoundExceeded
    deriving stock (UndecidabilityReason -> UndecidabilityReason -> Bool
(UndecidabilityReason -> UndecidabilityReason -> Bool)
-> (UndecidabilityReason -> UndecidabilityReason -> Bool)
-> Eq UndecidabilityReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UndecidabilityReason -> UndecidabilityReason -> Bool
== :: UndecidabilityReason -> UndecidabilityReason -> Bool
$c/= :: UndecidabilityReason -> UndecidabilityReason -> Bool
/= :: UndecidabilityReason -> UndecidabilityReason -> Bool
Eq, Int -> UndecidabilityReason -> ShowS
[UndecidabilityReason] -> ShowS
UndecidabilityReason -> String
(Int -> UndecidabilityReason -> ShowS)
-> (UndecidabilityReason -> String)
-> ([UndecidabilityReason] -> ShowS)
-> Show UndecidabilityReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> UndecidabilityReason -> ShowS
showsPrec :: Int -> UndecidabilityReason -> ShowS
$cshow :: UndecidabilityReason -> String
show :: UndecidabilityReason -> String
$cshowList :: [UndecidabilityReason] -> ShowS
showList :: [UndecidabilityReason] -> ShowS
Show)

-- | The answer of a backend whose control plane reports no upstream configuration.
noUpstreamMechanism :: (Applicative m) => m UpstreamSafety
noUpstreamMechanism :: forall (m :: * -> *). Applicative m => m UpstreamSafety
noUpstreamMechanism = UpstreamSafety -> m UpstreamSafety
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UndecidabilityReason -> UpstreamSafety
Undecidable UndecidabilityReason
NoMechanism)

-- | A repository, as the backend that holds it names it.
newtype RepositoryName = RepositoryName {RepositoryName -> Text
repositoryNameText :: Text}
    deriving stock (RepositoryName -> RepositoryName -> Bool
(RepositoryName -> RepositoryName -> Bool)
-> (RepositoryName -> RepositoryName -> Bool) -> Eq RepositoryName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RepositoryName -> RepositoryName -> Bool
== :: RepositoryName -> RepositoryName -> Bool
$c/= :: RepositoryName -> RepositoryName -> Bool
/= :: RepositoryName -> RepositoryName -> Bool
Eq, Eq RepositoryName
Eq RepositoryName =>
(RepositoryName -> RepositoryName -> Ordering)
-> (RepositoryName -> RepositoryName -> Bool)
-> (RepositoryName -> RepositoryName -> Bool)
-> (RepositoryName -> RepositoryName -> Bool)
-> (RepositoryName -> RepositoryName -> Bool)
-> (RepositoryName -> RepositoryName -> RepositoryName)
-> (RepositoryName -> RepositoryName -> RepositoryName)
-> Ord RepositoryName
RepositoryName -> RepositoryName -> Bool
RepositoryName -> RepositoryName -> Ordering
RepositoryName -> RepositoryName -> RepositoryName
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 :: RepositoryName -> RepositoryName -> Ordering
compare :: RepositoryName -> RepositoryName -> Ordering
$c< :: RepositoryName -> RepositoryName -> Bool
< :: RepositoryName -> RepositoryName -> Bool
$c<= :: RepositoryName -> RepositoryName -> Bool
<= :: RepositoryName -> RepositoryName -> Bool
$c> :: RepositoryName -> RepositoryName -> Bool
> :: RepositoryName -> RepositoryName -> Bool
$c>= :: RepositoryName -> RepositoryName -> Bool
>= :: RepositoryName -> RepositoryName -> Bool
$cmax :: RepositoryName -> RepositoryName -> RepositoryName
max :: RepositoryName -> RepositoryName -> RepositoryName
$cmin :: RepositoryName -> RepositoryName -> RepositoryName
min :: RepositoryName -> RepositoryName -> RepositoryName
Ord, Int -> RepositoryName -> ShowS
[RepositoryName] -> ShowS
RepositoryName -> String
(Int -> RepositoryName -> ShowS)
-> (RepositoryName -> String)
-> ([RepositoryName] -> ShowS)
-> Show RepositoryName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RepositoryName -> ShowS
showsPrec :: Int -> RepositoryName -> ShowS
$cshow :: RepositoryName -> String
show :: RepositoryName -> String
$cshowList :: [RepositoryName] -> ShowS
showList :: [RepositoryName] -> ShowS
Show)

-- | A backend's own name for a connection that admits content from a public registry.
newtype ExternalConnection = ExternalConnection {ExternalConnection -> Text
externalConnectionText :: Text}
    deriving stock (ExternalConnection -> ExternalConnection -> Bool
(ExternalConnection -> ExternalConnection -> Bool)
-> (ExternalConnection -> ExternalConnection -> Bool)
-> Eq ExternalConnection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExternalConnection -> ExternalConnection -> Bool
== :: ExternalConnection -> ExternalConnection -> Bool
$c/= :: ExternalConnection -> ExternalConnection -> Bool
/= :: ExternalConnection -> ExternalConnection -> Bool
Eq, Eq ExternalConnection
Eq ExternalConnection =>
(ExternalConnection -> ExternalConnection -> Ordering)
-> (ExternalConnection -> ExternalConnection -> Bool)
-> (ExternalConnection -> ExternalConnection -> Bool)
-> (ExternalConnection -> ExternalConnection -> Bool)
-> (ExternalConnection -> ExternalConnection -> Bool)
-> (ExternalConnection -> ExternalConnection -> ExternalConnection)
-> (ExternalConnection -> ExternalConnection -> ExternalConnection)
-> Ord ExternalConnection
ExternalConnection -> ExternalConnection -> Bool
ExternalConnection -> ExternalConnection -> Ordering
ExternalConnection -> ExternalConnection -> ExternalConnection
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 :: ExternalConnection -> ExternalConnection -> Ordering
compare :: ExternalConnection -> ExternalConnection -> Ordering
$c< :: ExternalConnection -> ExternalConnection -> Bool
< :: ExternalConnection -> ExternalConnection -> Bool
$c<= :: ExternalConnection -> ExternalConnection -> Bool
<= :: ExternalConnection -> ExternalConnection -> Bool
$c> :: ExternalConnection -> ExternalConnection -> Bool
> :: ExternalConnection -> ExternalConnection -> Bool
$c>= :: ExternalConnection -> ExternalConnection -> Bool
>= :: ExternalConnection -> ExternalConnection -> Bool
$cmax :: ExternalConnection -> ExternalConnection -> ExternalConnection
max :: ExternalConnection -> ExternalConnection -> ExternalConnection
$cmin :: ExternalConnection -> ExternalConnection -> ExternalConnection
min :: ExternalConnection -> ExternalConnection -> ExternalConnection
Ord, Int -> ExternalConnection -> ShowS
[ExternalConnection] -> ShowS
ExternalConnection -> String
(Int -> ExternalConnection -> ShowS)
-> (ExternalConnection -> String)
-> ([ExternalConnection] -> ShowS)
-> Show ExternalConnection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExternalConnection -> ShowS
showsPrec :: Int -> ExternalConnection -> ShowS
$cshow :: ExternalConnection -> String
show :: ExternalConnection -> String
$cshowList :: [ExternalConnection] -> ShowS
showList :: [ExternalConnection] -> ShowS
Show)

-- | The grant an identity needs to read a repository's configuration, as the backend spells it.
newtype PermissionName = PermissionName {PermissionName -> Text
permissionNameText :: Text}
    deriving stock (PermissionName -> PermissionName -> Bool
(PermissionName -> PermissionName -> Bool)
-> (PermissionName -> PermissionName -> Bool) -> Eq PermissionName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PermissionName -> PermissionName -> Bool
== :: PermissionName -> PermissionName -> Bool
$c/= :: PermissionName -> PermissionName -> Bool
/= :: PermissionName -> PermissionName -> Bool
Eq, Int -> PermissionName -> ShowS
[PermissionName] -> ShowS
PermissionName -> String
(Int -> PermissionName -> ShowS)
-> (PermissionName -> String)
-> ([PermissionName] -> ShowS)
-> Show PermissionName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PermissionName -> ShowS
showsPrec :: Int -> PermissionName -> ShowS
$cshow :: PermissionName -> String
show :: PermissionName -> String
$cshowList :: [PermissionName] -> ShowS
showList :: [PermissionName] -> ShowS
Show)

-- | What one repository reported: what it admits from outside, and where it forwards a miss.
data RepositoryLinks = RepositoryLinks
    { RepositoryLinks -> [ExternalConnection]
rlConnections :: [ExternalConnection]
    , RepositoryLinks -> [RepositoryName]
rlUpstreams :: [RepositoryName]
    }
    deriving stock (RepositoryLinks -> RepositoryLinks -> Bool
(RepositoryLinks -> RepositoryLinks -> Bool)
-> (RepositoryLinks -> RepositoryLinks -> Bool)
-> Eq RepositoryLinks
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RepositoryLinks -> RepositoryLinks -> Bool
== :: RepositoryLinks -> RepositoryLinks -> Bool
$c/= :: RepositoryLinks -> RepositoryLinks -> Bool
/= :: RepositoryLinks -> RepositoryLinks -> Bool
Eq, Int -> RepositoryLinks -> ShowS
[RepositoryLinks] -> ShowS
RepositoryLinks -> String
(Int -> RepositoryLinks -> ShowS)
-> (RepositoryLinks -> String)
-> ([RepositoryLinks] -> ShowS)
-> Show RepositoryLinks
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RepositoryLinks -> ShowS
showsPrec :: Int -> RepositoryLinks -> ShowS
$cshow :: RepositoryLinks -> String
show :: RepositoryLinks -> String
$cshowList :: [RepositoryLinks] -> ShowS
showList :: [RepositoryLinks] -> ShowS
Show)

-- | How many repositories deep the walk follows a chain.
upstreamHopCeiling :: Int
upstreamHopCeiling :: Int
upstreamHopCeiling = Int
10

-- | How many reads one whole walk makes.
upstreamCallCeiling :: Int
upstreamCallCeiling :: Int
upstreamCallCeiling = Int
25

{- | Walk a repository's upstream chain breadth-first, stopping at the first external connection.
A hop the reader could not read settles the answer, and a ceiling leaves it undecided, never safe.
-}
walkUpstreamChain ::
    (Monad m) =>
    (RepositoryName -> m (Either UpstreamSafety RepositoryLinks)) ->
    RepositoryName ->
    m UpstreamSafety
walkUpstreamChain :: forall (m :: * -> *).
Monad m =>
(RepositoryName -> m (Either UpstreamSafety RepositoryLinks))
-> RepositoryName -> m UpstreamSafety
walkUpstreamChain RepositoryName -> m (Either UpstreamSafety RepositoryLinks)
readLinks RepositoryName
start = Int
-> Set RepositoryName
-> [(RepositoryName, Int)]
-> m UpstreamSafety
go Int
0 (RepositoryName -> Set RepositoryName
forall a. a -> Set a
Set.singleton RepositoryName
start) [(RepositoryName
start, Int
0 :: Int)]
  where
    go :: Int
-> Set RepositoryName
-> [(RepositoryName, Int)]
-> m UpstreamSafety
go Int
calls Set RepositoryName
seen = \case
        [] -> UpstreamSafety -> m UpstreamSafety
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpstreamSafety
Safe
        (RepositoryName
repository, Int
depth) : [(RepositoryName, Int)]
rest
            | Int
depth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
upstreamHopCeiling Bool -> Bool -> Bool
|| Int
calls Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
upstreamCallCeiling ->
                UpstreamSafety -> m UpstreamSafety
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UndecidabilityReason -> UpstreamSafety
Undecidable UndecidabilityReason
ChainBoundExceeded)
            | Bool
otherwise ->
                RepositoryName -> m (Either UpstreamSafety RepositoryLinks)
readLinks RepositoryName
repository m (Either UpstreamSafety RepositoryLinks)
-> (Either UpstreamSafety RepositoryLinks -> m UpstreamSafety)
-> m UpstreamSafety
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Left UpstreamSafety
settled -> UpstreamSafety -> m UpstreamSafety
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure UpstreamSafety
settled
                    Right RepositoryLinks
links -> case RepositoryLinks -> [ExternalConnection]
rlConnections RepositoryLinks
links of
                        ExternalConnection
connection : [ExternalConnection]
_ -> UpstreamSafety -> m UpstreamSafety
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (UnsafeReason -> UpstreamSafety
Unsafe (RepositoryName -> ExternalConnection -> UnsafeReason
ConfigurationEvidence RepositoryName
repository ExternalConnection
connection))
                        [] -> Int
-> Set RepositoryName
-> [(RepositoryName, Int)]
-> Int
-> RepositoryLinks
-> m UpstreamSafety
follow (Int
calls Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Set RepositoryName
seen [(RepositoryName, Int)]
rest Int
depth RepositoryLinks
links

    -- The visited set is written when a repository is queued, so a cycle never queues one twice.
    follow :: Int
-> Set RepositoryName
-> [(RepositoryName, Int)]
-> Int
-> RepositoryLinks
-> m UpstreamSafety
follow Int
calls Set RepositoryName
seen [(RepositoryName, Int)]
rest Int
depth RepositoryLinks
links =
        let fresh :: [RepositoryName]
fresh = [RepositoryName] -> [RepositoryName]
forall a. Ord a => [a] -> [a]
ordNub [RepositoryName
next | RepositoryName
next <- RepositoryLinks -> [RepositoryName]
rlUpstreams RepositoryLinks
links, Bool -> Bool
not (RepositoryName -> Set RepositoryName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member RepositoryName
next Set RepositoryName
seen)]
         in Int
-> Set RepositoryName
-> [(RepositoryName, Int)]
-> m UpstreamSafety
go Int
calls ((RepositoryName -> Set RepositoryName -> Set RepositoryName)
-> Set RepositoryName -> [RepositoryName] -> Set RepositoryName
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RepositoryName -> Set RepositoryName -> Set RepositoryName
forall a. Ord a => a -> Set a -> Set a
Set.insert Set RepositoryName
seen [RepositoryName]
fresh) ([(RepositoryName, Int)]
rest [(RepositoryName, Int)]
-> [(RepositoryName, Int)] -> [(RepositoryName, Int)]
forall a. Semigroup a => a -> a -> a
<> [(RepositoryName
next, Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) | RepositoryName
next <- [RepositoryName]
fresh])