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

{- | Map policy and upstream outcomes to HTTP statuses. Artifact requests use one outcome,
while packuments choose a status from the surviving versions. Ecosystem contracts own response bodies.
-}
module Ecluse.Core.Server.Response (
    -- * Serve outcomes
    ServeDecision (..),
    Rejection (..),
    RejectReason (..),
    Transience (..),
    RetryAfter (..),
    RuleName (..),
    rejectUnavailable,
    serveDecisionOf,

    -- * Concrete-artifact status
    ArtifactStatus (..),
    artifactStatus,
    artifactHttpStatus,

    -- * Packument status (over the merged survivor set)
    PackumentStatus (..),
    packumentStatus,
    longestRetry,

    -- * Denial help text
    HelpMessage,
    mkHelpMessage,
    appendHelp,

    -- * A refusal's two parts
    Refusal (..),
    mkRefusal,
    renderRefusal,
) where

import Data.Semigroup (Max (Max, getMax))
import Data.Text qualified as T
import Network.HTTP.Types (Status, status200, status403, status404, status500, status503)

import Ecluse.Core.Package (PackageDetails)
import Ecluse.Core.Rules (renderDecision)
import Ecluse.Core.Rules.Types (
    Decision (Admitted, Blocked, BlockedByDefault, Undecidable),
    RetryAfter (..),
    Transience (..),
    completeEvidence,
 )

{- | The outcome of deciding a request: serve it, or refuse it with a reason. Every client-facing
reply renders one of these.
-}
data ServeDecision
    = -- | Serve the request (the @200@ stream for an artifact).
      Admit
    | -- | Refuse the request, with the reason and a client-facing message.
      Reject Rejection
    deriving stock (ServeDecision -> ServeDecision -> Bool
(ServeDecision -> ServeDecision -> Bool)
-> (ServeDecision -> ServeDecision -> Bool) -> Eq ServeDecision
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ServeDecision -> ServeDecision -> Bool
== :: ServeDecision -> ServeDecision -> Bool
$c/= :: ServeDecision -> ServeDecision -> Bool
/= :: ServeDecision -> ServeDecision -> Bool
Eq, Int -> ServeDecision -> ShowS
[ServeDecision] -> ShowS
ServeDecision -> String
(Int -> ServeDecision -> ShowS)
-> (ServeDecision -> String)
-> ([ServeDecision] -> ShowS)
-> Show ServeDecision
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ServeDecision -> ShowS
showsPrec :: Int -> ServeDecision -> ShowS
$cshow :: ServeDecision -> String
show :: ServeDecision -> String
$cshowList :: [ServeDecision] -> ShowS
showList :: [ServeDecision] -> ShowS
Show)

-- | A refusal: /why/ the request was refused, and an intuitive message for the client.
data Rejection = Rejection
    { Rejection -> RejectReason
rejectionReason :: RejectReason
    -- ^ The cause of the refusal, which decides the status.
    , Rejection -> Text
rejectionMessage :: Text
    -- ^ The client-facing explanation (the rendered decision, or the cause).
    }
    deriving stock (Rejection -> Rejection -> Bool
(Rejection -> Rejection -> Bool)
-> (Rejection -> Rejection -> Bool) -> Eq Rejection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Rejection -> Rejection -> Bool
== :: Rejection -> Rejection -> Bool
$c/= :: Rejection -> Rejection -> Bool
/= :: Rejection -> Rejection -> Bool
Eq, Int -> Rejection -> ShowS
[Rejection] -> ShowS
Rejection -> String
(Int -> Rejection -> ShowS)
-> (Rejection -> String)
-> ([Rejection] -> ShowS)
-> Show Rejection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Rejection -> ShowS
showsPrec :: Int -> Rejection -> ShowS
$cshow :: Rejection -> String
show :: Rejection -> String
$cshowList :: [Rejection] -> ShowS
showList :: [Rejection] -> ShowS
Show)

{- | Why a request was refused. A policy refusal is final for this request. An unavailability is
an /inability to decide/, whose 'Transience' separates a retryable @503@ from a terminal @500@.
-}
data RejectReason
    = {- | A rule denied the version (deny-by-default included). The 'RuleName' is the rule that
      decided, for the audit trail and the denial body.
      -}
      ByPolicy RuleName
    | -- | The version could not be vetted. Refuse it, with transience indicating whether a retry can help.
      Unavailable Transience
    | {- | A public artifact lacks a digest, so admission cannot verify its bytes and refuses with @403@.
      Trusted private artifacts are exempt.
      -}
      MissingIntegrity
    | {- | A public artifact's strongest digest falls below the configured floor, so admission refuses with @403@.
      Trusted private artifacts are exempt.
      -}
      BelowIntegrityFloor
    | {- | An upstream packument names a different package and cannot enter the merge.
      When no valid origin remains, the packument request returns @502@.
      -}
      UpstreamInvalid
    deriving stock (RejectReason -> RejectReason -> Bool
(RejectReason -> RejectReason -> Bool)
-> (RejectReason -> RejectReason -> Bool) -> Eq RejectReason
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RejectReason -> RejectReason -> Bool
== :: RejectReason -> RejectReason -> Bool
$c/= :: RejectReason -> RejectReason -> Bool
/= :: RejectReason -> RejectReason -> Bool
Eq, Int -> RejectReason -> ShowS
[RejectReason] -> ShowS
RejectReason -> String
(Int -> RejectReason -> ShowS)
-> (RejectReason -> String)
-> ([RejectReason] -> ShowS)
-> Show RejectReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RejectReason -> ShowS
showsPrec :: Int -> RejectReason -> ShowS
$cshow :: RejectReason -> String
show :: RejectReason -> String
$cshowList :: [RejectReason] -> ShowS
showList :: [RejectReason] -> ShowS
Show)

-- | The name of the rule that decided a refusal, for the audit trail and the denial body.
newtype RuleName = RuleName Text
    deriving stock (RuleName -> RuleName -> Bool
(RuleName -> RuleName -> Bool)
-> (RuleName -> RuleName -> Bool) -> Eq RuleName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RuleName -> RuleName -> Bool
== :: RuleName -> RuleName -> Bool
$c/= :: RuleName -> RuleName -> Bool
/= :: RuleName -> RuleName -> Bool
Eq, Eq RuleName
Eq RuleName =>
(RuleName -> RuleName -> Ordering)
-> (RuleName -> RuleName -> Bool)
-> (RuleName -> RuleName -> Bool)
-> (RuleName -> RuleName -> Bool)
-> (RuleName -> RuleName -> Bool)
-> (RuleName -> RuleName -> RuleName)
-> (RuleName -> RuleName -> RuleName)
-> Ord RuleName
RuleName -> RuleName -> Bool
RuleName -> RuleName -> Ordering
RuleName -> RuleName -> RuleName
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 :: RuleName -> RuleName -> Ordering
compare :: RuleName -> RuleName -> Ordering
$c< :: RuleName -> RuleName -> Bool
< :: RuleName -> RuleName -> Bool
$c<= :: RuleName -> RuleName -> Bool
<= :: RuleName -> RuleName -> Bool
$c> :: RuleName -> RuleName -> Bool
> :: RuleName -> RuleName -> Bool
$c>= :: RuleName -> RuleName -> Bool
>= :: RuleName -> RuleName -> Bool
$cmax :: RuleName -> RuleName -> RuleName
max :: RuleName -> RuleName -> RuleName
$cmin :: RuleName -> RuleName -> RuleName
min :: RuleName -> RuleName -> RuleName
Ord, Int -> RuleName -> ShowS
[RuleName] -> ShowS
RuleName -> String
(Int -> RuleName -> ShowS)
-> (RuleName -> String) -> ([RuleName] -> ShowS) -> Show RuleName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RuleName -> ShowS
showsPrec :: Int -> RuleName -> ShowS
$cshow :: RuleName -> String
show :: RuleName -> String
$cshowList :: [RuleName] -> ShowS
showList :: [RuleName] -> ShowS
Show)

{- | Project a rules 'Decision' into a serve outcome. An 'Undecidable' decision rejects as
'Unavailable', which is fail-closed: a version no rule could vet is never admitted.
-}
serveDecisionOf :: PackageDetails -> Decision -> ServeDecision
serveDecisionOf :: PackageDetails -> Decision -> ServeDecision
serveDecisionOf PackageDetails
pd Decision
decision = case Decision
decision of
    Admitted{} -> ServeDecision
Admit
    Blocked Text
name Maybe DbEtag
_ Text
_ -> Rejection -> ServeDecision
Reject (RejectReason -> Rejection
rejectAs (RuleName -> RejectReason
ByPolicy (Text -> RuleName
RuleName Text
name)))
    BlockedByDefault{} -> Rejection -> ServeDecision
Reject (RejectReason -> Rejection
rejectAs (RuleName -> RejectReason
ByPolicy (Text -> RuleName
RuleName Text
"BlockedByDefault")))
    Undecidable Transience
transience Text
_ -> Transience -> Text -> ServeDecision
rejectUnavailable Transience
transience Text
rendered
  where
    rendered :: Text
rendered = RuleEvidence -> Decision -> Text
renderDecision (PackageDetails -> RuleEvidence
completeEvidence PackageDetails
pd) Decision
decision

    rejectAs :: RejectReason -> Rejection
    rejectAs :: RejectReason -> Rejection
rejectAs RejectReason
reason = RejectReason -> Text -> Rejection
Rejection RejectReason
reason Text
rendered

{- | Refuse a request that could not be decided. The 'Transience' it carries is what
'artifactStatus' renders as a @503@ or a @500@, so a caller states that rather than a status.
-}
rejectUnavailable :: Transience -> Text -> ServeDecision
rejectUnavailable :: Transience -> Text -> ServeDecision
rejectUnavailable Transience
transience Text
message = Rejection -> ServeDecision
Reject (RejectReason -> Text -> Rejection
Rejection (Transience -> RejectReason
Unavailable Transience
transience) Text
message)

{- | The HTTP status a __concrete-artifact__ request renders to. A packument request has no single
status, because the pipeline chooses one over the survivors: 'PackumentStatus' models that.
-}
data ArtifactStatus
    = -- | @200@: admitted, so the proxy streams the artifact.
      Ok
    | -- | @403@: refused by policy. The route's response contract shapes the body.
      Forbidden
    | -- | @503@: a transient inability to decide. A known 'RetryAfter' becomes the header.
      Unavailable' (Maybe RetryAfter)
    | -- | @500@: a permanent or internal inability to decide. Not retryable.
      ServerError
    | -- | @404@: the upstream did not have the artifact (forwarded miss).
      NotFound
    deriving stock (ArtifactStatus -> ArtifactStatus -> Bool
(ArtifactStatus -> ArtifactStatus -> Bool)
-> (ArtifactStatus -> ArtifactStatus -> Bool) -> Eq ArtifactStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArtifactStatus -> ArtifactStatus -> Bool
== :: ArtifactStatus -> ArtifactStatus -> Bool
$c/= :: ArtifactStatus -> ArtifactStatus -> Bool
/= :: ArtifactStatus -> ArtifactStatus -> Bool
Eq, Int -> ArtifactStatus -> ShowS
[ArtifactStatus] -> ShowS
ArtifactStatus -> String
(Int -> ArtifactStatus -> ShowS)
-> (ArtifactStatus -> String)
-> ([ArtifactStatus] -> ShowS)
-> Show ArtifactStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ArtifactStatus -> ShowS
showsPrec :: Int -> ArtifactStatus -> ShowS
$cshow :: ArtifactStatus -> String
show :: ArtifactStatus -> String
$cshowList :: [ArtifactStatus] -> ShowS
showList :: [ArtifactStatus] -> ShowS
Show)

{- | Map a serve outcome to its concrete-artifact status: @503@ only where it will resolve, so a
'WontResolve' unavailability is a @500@. An upstream @404@ is no serve decision and never appears.
-}
artifactStatus :: ServeDecision -> ArtifactStatus
artifactStatus :: ServeDecision -> ArtifactStatus
artifactStatus = \case
    ServeDecision
Admit -> ArtifactStatus
Ok
    Reject Rejection
rej -> case Rejection -> RejectReason
rejectionReason Rejection
rej of
        ByPolicy{} -> ArtifactStatus
Forbidden
        RejectReason
MissingIntegrity -> ArtifactStatus
Forbidden
        RejectReason
BelowIntegrityFloor -> ArtifactStatus
Forbidden
        Unavailable (WillResolve Maybe RetryAfter
retryAfter) -> Maybe RetryAfter -> ArtifactStatus
Unavailable' Maybe RetryAfter
retryAfter
        Unavailable Transience
WontResolve -> ArtifactStatus
ServerError
        -- The artifact path never validates a packument name, so this cause does not arise here. A
        -- misbehaving upstream on this path is an internal inability to serve.
        RejectReason
UpstreamInvalid -> ArtifactStatus
ServerError

-- | The HTTP status an 'ArtifactStatus' renders as.
artifactHttpStatus :: ArtifactStatus -> Status
artifactHttpStatus :: ArtifactStatus -> Status
artifactHttpStatus = \case
    ArtifactStatus
Ok -> Status
status200
    ArtifactStatus
Forbidden -> Status
status403
    Unavailable'{} -> Status
status503
    ArtifactStatus
ServerError -> Status
status500
    ArtifactStatus
NotFound -> Status
status404

{- | The HTTP status a __packument__ request renders to, chosen over the merged survivor set. There
is no @404@: the package exists, and a genuine absence is decided before the merge.
-}
data PackumentStatus
    = -- | @200@: at least one version survived, so the proxy serves the merged, filtered packument.
      PackumentOk
    | {- | @403@: no version survived and every exclusion was a policy denial. The response body
      collects the denial reasons.
      -}
      PackumentForbidden
    | {- | @503@: no version survived and an exclusion can recover.
      A suggested delay becomes the @Retry-After@ header.
      -}
      PackumentUnavailable (Maybe RetryAfter)
    | {- | @502@: no valid origin remained and an upstream packument named a different package.
      This gateway fault differs from absence or a retryable outage.
      -}
      PackumentBadGateway
    | {- | @500@: no version survived, no exclusion is retryable, and at least one is
      a permanent or internal inability to decide. Retrying cannot help.
      -}
      PackumentServerError
    deriving stock (PackumentStatus -> PackumentStatus -> Bool
(PackumentStatus -> PackumentStatus -> Bool)
-> (PackumentStatus -> PackumentStatus -> Bool)
-> Eq PackumentStatus
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PackumentStatus -> PackumentStatus -> Bool
== :: PackumentStatus -> PackumentStatus -> Bool
$c/= :: PackumentStatus -> PackumentStatus -> Bool
/= :: PackumentStatus -> PackumentStatus -> Bool
Eq, Int -> PackumentStatus -> ShowS
[PackumentStatus] -> ShowS
PackumentStatus -> String
(Int -> PackumentStatus -> ShowS)
-> (PackumentStatus -> String)
-> ([PackumentStatus] -> ShowS)
-> Show PackumentStatus
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PackumentStatus -> ShowS
showsPrec :: Int -> PackumentStatus -> ShowS
$cshow :: PackumentStatus -> String
show :: PackumentStatus -> String
$cshowList :: [PackumentStatus] -> ShowS
showList :: [PackumentStatus] -> ShowS
Show)

{- | A packument's status from the per-version outcomes: with no survivor the most recoverable cause
wins, @502@ under @503@ as a transient origin may yet answer, and an empty input is a @403@.
-}
packumentStatus :: [ServeDecision] -> PackumentStatus
packumentStatus :: [ServeDecision] -> PackumentStatus
packumentStatus [ServeDecision]
decisions
    | PackumentTally -> Bool
tallyAdmit PackumentTally
tally = PackumentStatus
PackumentOk
    | Bool -> Bool
not ([Maybe RetryAfter] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Maybe RetryAfter]
willResolveDelays) = Maybe RetryAfter -> PackumentStatus
PackumentUnavailable ([Maybe RetryAfter] -> Maybe RetryAfter
longestRetry [Maybe RetryAfter]
willResolveDelays)
    | PackumentTally -> Bool
tallyUpstreamInvalid PackumentTally
tally = PackumentStatus
PackumentBadGateway
    | PackumentTally -> Bool
tallyWontResolve PackumentTally
tally = PackumentStatus
PackumentServerError
    | Bool
otherwise = PackumentStatus
PackumentForbidden
  where
    -- One strict pass collects every signal the guards weigh, so the all-denied path walks
    -- the exclusions once, not once per guard.
    tally :: PackumentTally
    tally :: PackumentTally
tally = (PackumentTally -> ServeDecision -> PackumentTally)
-> PackumentTally -> [ServeDecision] -> PackumentTally
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' PackumentTally -> ServeDecision -> PackumentTally
weighDecision (Bool -> [Maybe RetryAfter] -> Bool -> Bool -> PackumentTally
PackumentTally Bool
False [] Bool
False Bool
False) [ServeDecision]
decisions

    willResolveDelays :: [Maybe RetryAfter]
    willResolveDelays :: [Maybe RetryAfter]
willResolveDelays = PackumentTally -> [Maybe RetryAfter]
tallyWillResolveDelays PackumentTally
tally

-- A deny-by-default cause (policy or admission refusal) leaves no signal of its own,
-- because an empty tally is exactly the @403@ floor.
weighDecision :: PackumentTally -> ServeDecision -> PackumentTally
weighDecision :: PackumentTally -> ServeDecision -> PackumentTally
weighDecision PackumentTally
acc = \case
    ServeDecision
Admit -> PackumentTally
acc{tallyAdmit = True}
    Reject Rejection
rej -> case Rejection -> RejectReason
rejectionReason Rejection
rej of
        Unavailable (WillResolve Maybe RetryAfter
delay) ->
            PackumentTally
acc{tallyWillResolveDelays = delay : tallyWillResolveDelays acc}
        RejectReason
UpstreamInvalid -> PackumentTally
acc{tallyUpstreamInvalid = True}
        Unavailable Transience
WontResolve -> PackumentTally
acc{tallyWontResolve = True}
        ByPolicy{} -> PackumentTally
acc
        RejectReason
MissingIntegrity -> PackumentTally
acc
        RejectReason
BelowIntegrityFloor -> PackumentTally
acc

{- The signals 'packumentStatus' weighs, accumulated in one pass. The fields are strict, so the
tally does not thunk across a large survivor set. -}
data PackumentTally = PackumentTally
    { PackumentTally -> Bool
tallyAdmit :: Bool
    -- ^ At least one 'Admit' was seen, so the merged document has a survivor.
    , PackumentTally -> [Maybe RetryAfter]
tallyWillResolveDelays :: [Maybe RetryAfter]
    -- ^ The suggested delay of every transient ('WillResolve') exclusion.
    , PackumentTally -> Bool
tallyUpstreamInvalid :: Bool
    -- ^ A responding upstream returned a packument naming a different package.
    , PackumentTally -> Bool
tallyWontResolve :: Bool
    -- ^ An exclusion was a permanent ('WontResolve') inability to decide.
    }

{- | The longest suggested 'RetryAfter' among transient causes, or 'Nothing' when
none of them suggested a delay.
-}
longestRetry :: [Maybe RetryAfter] -> Maybe RetryAfter
longestRetry :: [Maybe RetryAfter] -> Maybe RetryAfter
longestRetry = (Max RetryAfter -> RetryAfter)
-> Maybe (Max RetryAfter) -> Maybe RetryAfter
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Max RetryAfter -> RetryAfter
forall a. Max a -> a
getMax (Maybe (Max RetryAfter) -> Maybe RetryAfter)
-> ([Maybe RetryAfter] -> Maybe (Max RetryAfter))
-> [Maybe RetryAfter]
-> Maybe RetryAfter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe RetryAfter -> Maybe (Max RetryAfter))
-> [Maybe RetryAfter] -> Maybe (Max RetryAfter)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((RetryAfter -> Max RetryAfter)
-> Maybe RetryAfter -> Maybe (Max RetryAfter)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RetryAfter -> Max RetryAfter
forall a. a -> Max a
Max)

{- | An operator-configured message appended to every denial, typically where to ask for help.
Stored trimmed, so an all-blank value contributes nothing.
-}
newtype HelpMessage = HelpMessage Text
    deriving stock (HelpMessage -> HelpMessage -> Bool
(HelpMessage -> HelpMessage -> Bool)
-> (HelpMessage -> HelpMessage -> Bool) -> Eq HelpMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: HelpMessage -> HelpMessage -> Bool
== :: HelpMessage -> HelpMessage -> Bool
$c/= :: HelpMessage -> HelpMessage -> Bool
/= :: HelpMessage -> HelpMessage -> Bool
Eq, Int -> HelpMessage -> ShowS
[HelpMessage] -> ShowS
HelpMessage -> String
(Int -> HelpMessage -> ShowS)
-> (HelpMessage -> String)
-> ([HelpMessage] -> ShowS)
-> Show HelpMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HelpMessage -> ShowS
showsPrec :: Int -> HelpMessage -> ShowS
$cshow :: HelpMessage -> String
show :: HelpMessage -> String
$cshowList :: [HelpMessage] -> ShowS
showList :: [HelpMessage] -> ShowS
Show)

-- | Build a 'HelpMessage', trimming surrounding whitespace.
mkHelpMessage :: Text -> HelpMessage
mkHelpMessage :: Text -> HelpMessage
mkHelpMessage = Text -> HelpMessage
HelpMessage (Text -> HelpMessage) -> (Text -> Text) -> Text -> HelpMessage
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip

{- | Append a non-blank operator 'HelpMessage' to a denial message, separated by a single space.
A blank or absent help message contributes nothing.
-}
appendHelp :: Maybe HelpMessage -> Text -> Text
appendHelp :: Maybe HelpMessage -> Text -> Text
appendHelp Maybe HelpMessage
help = Refusal -> Text
renderRefusal (Refusal -> Text) -> (Text -> Refusal) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe HelpMessage -> Text -> Refusal
mkRefusal Maybe HelpMessage
help

{- | A refusal's text in its two parts, so an ecosystem renders whichever its own denial surface
carries and the help message is not dropped for one with no envelope to hold both.
-}
data Refusal = Refusal
    { Refusal -> Text
refusalReason :: Text
    -- ^ Why Écluse refused, in its own words. Always present.
    , Refusal -> Maybe Text
refusalHelp :: Maybe Text
    -- ^ The operator's help message, absent when none is configured or it is blank.
    }
    deriving stock (Refusal -> Refusal -> Bool
(Refusal -> Refusal -> Bool)
-> (Refusal -> Refusal -> Bool) -> Eq Refusal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Refusal -> Refusal -> Bool
== :: Refusal -> Refusal -> Bool
$c/= :: Refusal -> Refusal -> Bool
/= :: Refusal -> Refusal -> Bool
Eq, Int -> Refusal -> ShowS
[Refusal] -> ShowS
Refusal -> String
(Int -> Refusal -> ShowS)
-> (Refusal -> String) -> ([Refusal] -> ShowS) -> Show Refusal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Refusal -> ShowS
showsPrec :: Int -> Refusal -> ShowS
$cshow :: Refusal -> String
show :: Refusal -> String
$cshowList :: [Refusal] -> ShowS
showList :: [Refusal] -> ShowS
Show)

-- | Pair a decided reason with the mount's configured help message, if it has a non-blank one.
mkRefusal :: Maybe HelpMessage -> Text -> Refusal
mkRefusal :: Maybe HelpMessage -> Text -> Refusal
mkRefusal Maybe HelpMessage
help Text
message = Text -> Maybe Text -> Refusal
Refusal Text
message (HelpMessage -> Maybe Text
nonBlankHelp (HelpMessage -> Maybe Text) -> Maybe HelpMessage -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe HelpMessage
help)
  where
    nonBlankHelp :: HelpMessage -> Maybe Text
nonBlankHelp (HelpMessage Text
h) = if Text -> Bool
T.null Text
h then Maybe Text
forall a. Maybe a
Nothing else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
h

-- | The refusal as one line: the reason, with the help message appended after a single space.
renderRefusal :: Refusal -> Text
renderRefusal :: Refusal -> Text
renderRefusal (Refusal Text
reason Maybe Text
help) = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
reason ((Text -> Text
T.strip Text
reason Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) Maybe Text
help