module Ecluse.Composition (
CredentialProviders,
initCredentialProviders,
initializedEcosystems,
lookupProvider,
planMirrorCredential,
resolveCodeArtifactConfig,
BootError (..),
renderBootError,
planMounts,
composeBindings,
MirrorQueuePlan (..),
planMirrorQueue,
mirrorQueuePlanWarning,
memoryQueueBootWarning,
memoryQueueDropWarning,
parseEndpointUrl,
PublishTarget (..),
planPublishTargets,
cacheConfigFor,
connectionPoolSettings,
resolveServeAdmission,
resolvePrivateConnections,
resolvePublicConnections,
openFileSoftLimit,
mirrorEnqueueBufferDepth,
mirrorEnqueueReportInterval,
parseCodeArtifactHost,
) where
import Data.Char (isDigit)
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Time (UTCTime)
import Network.HTTP.Client (ManagerSettings (managerConnCount))
import System.Posix.Resource (Resource (ResourceOpenFiles), ResourceLimit (ResourceLimit, ResourceLimitInfinity, ResourceLimitUnknown), ResourceLimits (softLimit), getResourceLimit)
import UnliftIO (tryAny)
import Ecluse.Config (
AppConfig (..),
Config (..),
CredentialBackend (..),
MirrorTarget (mtCredential, mtUrl),
Mount (..),
MountConfig (..),
MountRegistries (..),
PolicyError,
QueueBackend (..),
Url,
renderPolicyError,
unUrl,
)
import Ecluse.Core.Credential (AuthToken (..), CredentialProvider, Secret, staticProvider)
import Ecluse.Core.Credential.CodeArtifact (CodeArtifactConfig (..), newCodeArtifactProvider)
import Ecluse.Core.Credential.Refresh (CredentialReporters)
import Ecluse.Core.Ecosystem (Ecosystem, ecosystemName, prefixFor)
import Ecluse.Core.Queue (MemoryQueueConfig, defaultMemoryQueueConfig)
import Ecluse.Core.Queue.Sqs (SqsConfig (sqsEndpoint), SqsEndpoint (..), defaultSqsConfig)
import Ecluse.Core.Registry.Npm qualified as Npm
import Ecluse.Core.Registry.Npm.Filter qualified as NpmFilter
import Ecluse.Core.Registry.Npm.Project qualified as NpmProject
import Ecluse.Core.Registry.Npm.Request qualified as NpmRequest
import Ecluse.Core.Wire (renderWire)
import Ecluse.Core.Rules (RuleDeps, prepare)
import Ecluse.Core.Security (Limits (Limits, maxBodyBytes, maxNestingDepth, maxVersionCount), TarballHostPolicy (AnyAllowlistedHost, SameHostAsPackument), hostAddress, splitHostPort, tarballHostGate)
import Ecluse.Core.Security.Egress (registryUrlText)
import Ecluse.Core.Server.Cache (CacheConfig (..))
import Ecluse.Core.Server.Context (MountBinding, PackumentDeps (..), PublishDeps (..))
import Ecluse.Core.Server.Metadata qualified as Metadata
import Ecluse.Core.Server.Response (HelpMessage, mkHelpMessage)
import Ecluse.Core.Text (nonBlank)
connectionPoolSettings :: Int -> ManagerSettings -> ManagerSettings
connectionPoolSettings :: Int -> ManagerSettings -> ManagerSettings
connectionPoolSettings Int
connections ManagerSettings
settings = ManagerSettings
settings{managerConnCount = connections}
resolveServeAdmission :: Maybe Int -> Int -> (Int, Text)
resolveServeAdmission :: Maybe Int -> Int -> (Int, Text)
resolveServeAdmission Maybe Int
explicit Int
capabilities = case Maybe Int
explicit of
Just Int
n -> (Int
n, Text
"runtime: serve admission " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (from config)")
Maybe Int
Nothing ->
let computed :: Int
computed = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
serveAdmissionFloor (Int
serveAdmissionPerCapability Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
capabilities)
in (Int
computed, Text
"runtime: serve admission " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
computed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (computed from " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
capabilities Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" capabilities)")
serveAdmissionPerCapability :: Int
serveAdmissionPerCapability :: Int
serveAdmissionPerCapability = Int
10
serveAdmissionFloor :: Int
serveAdmissionFloor :: Int
serveAdmissionFloor = Int
8
resolvePrivateConnections :: Maybe Int -> Int -> (Int, Text)
resolvePrivateConnections :: Maybe Int -> Int -> (Int, Text)
resolvePrivateConnections Maybe Int
explicit Int
fdLimit = case Maybe Int
explicit of
Just Int
n -> (Int
n, Text
"runtime: private connection pool " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (from config)")
Maybe Int
Nothing ->
let computed :: Int
computed = Int -> Int
clampPrivateConnections (Int
fdLimit Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
privateConnectionsFdShare)
in (Int
computed, Text
"runtime: private connection pool " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
computed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (computed from file-descriptor limit " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
fdLimit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
clampPrivateConnections :: Int -> Int
clampPrivateConnections :: Int -> Int
clampPrivateConnections = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
privateConnectionsFloor (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
privateConnectionsCap
privateConnectionsFdShare :: Int
privateConnectionsFdShare :: Int
privateConnectionsFdShare = Int
4
privateConnectionsFloor :: Int
privateConnectionsFloor :: Int
privateConnectionsFloor = Int
64
privateConnectionsCap :: Int
privateConnectionsCap :: Int
privateConnectionsCap = Int
4096
resolvePublicConnections :: Maybe Int -> Int -> (Int, Text)
resolvePublicConnections :: Maybe Int -> Int -> (Int, Text)
resolvePublicConnections Maybe Int
explicit Int
fdLimit = case Maybe Int
explicit of
Just Int
n -> (Int
n, Text
"runtime: public connection pool " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (from config)")
Maybe Int
Nothing ->
let computed :: Int
computed = Int -> Int
clampPublicConnections (Int
fdLimit Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
publicConnectionsFdShare)
in (Int
computed, Text
"runtime: public connection pool " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
computed Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (computed from file-descriptor limit " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
fdLimit Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")")
clampPublicConnections :: Int -> Int
clampPublicConnections :: Int -> Int
clampPublicConnections = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
publicConnectionsFloor (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
publicConnectionsCap
publicConnectionsFdShare :: Int
publicConnectionsFdShare :: Int
publicConnectionsFdShare = Int
8
publicConnectionsFloor :: Int
publicConnectionsFloor :: Int
publicConnectionsFloor = Int
32
publicConnectionsCap :: Int
publicConnectionsCap :: Int
publicConnectionsCap = Int
1024
mirrorEnqueueBufferDepth :: Int
mirrorEnqueueBufferDepth :: Int
mirrorEnqueueBufferDepth = Int
1024
mirrorEnqueueReportInterval :: Int
mirrorEnqueueReportInterval :: Int
mirrorEnqueueReportInterval = Int
100
openFileSoftLimit :: IO Int
openFileSoftLimit :: IO Int
openFileSoftLimit = do
limits <- Resource -> IO ResourceLimits
getResourceLimit Resource
ResourceOpenFiles
pure $ case softLimit limits of
ResourceLimit Integer
n -> Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n
ResourceLimit
ResourceLimitInfinity -> Int
privateConnectionsCap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
privateConnectionsFdShare
ResourceLimit
ResourceLimitUnknown -> Int
privateConnectionsCap Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
privateConnectionsFdShare
newtype CredentialProviders = CredentialProviders (Map Ecosystem CredentialProvider)
initCredentialProviders :: CredentialReporters -> AppConfig -> IO (Either [BootError] CredentialProviders)
initCredentialProviders :: CredentialReporters
-> AppConfig -> IO (Either [BootError] CredentialProviders)
initCredentialProviders CredentialReporters
reporters AppConfig
app = do
let plans :: [(Ecosystem, MountConfig,
Either [BootError] (Maybe CodeArtifactConfig))]
plans = ((Ecosystem, MountConfig)
-> (Ecosystem, MountConfig,
Either [BootError] (Maybe CodeArtifactConfig)))
-> [(Ecosystem, MountConfig)]
-> [(Ecosystem, MountConfig,
Either [BootError] (Maybe CodeArtifactConfig))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Ecosystem
eco, MountConfig
mcfg) -> (Ecosystem
eco, MountConfig
mcfg, Ecosystem
-> AppConfig
-> MountConfig
-> Either [BootError] (Maybe CodeArtifactConfig)
planMirrorCredential Ecosystem
eco AppConfig
app MountConfig
mcfg)) (Map Ecosystem MountConfig -> [(Ecosystem, MountConfig)]
forall k a. Map k a -> [(k, a)]
Map.toList (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
app))
let errs :: [BootError]
errs = [[BootError]] -> [BootError]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BootError]
e | (Ecosystem
_, MountConfig
_, Left [BootError]
e) <- [(Ecosystem, MountConfig,
Either [BootError] (Maybe CodeArtifactConfig))]
plans]
if Bool -> Bool
not ([BootError] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [BootError]
errs)
then Either [BootError] CredentialProviders
-> IO (Either [BootError] CredentialProviders)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([BootError] -> Either [BootError] CredentialProviders
forall a b. a -> Either a b
Left [BootError]
errs)
else do
let validPlans :: [(Ecosystem, MountConfig, Maybe CodeArtifactConfig)]
validPlans = [(Ecosystem
eco, MountConfig
mcfg, Maybe CodeArtifactConfig
mca) | (Ecosystem
eco, MountConfig
mcfg, Right Maybe CodeArtifactConfig
mca) <- [(Ecosystem, MountConfig,
Either [BootError] (Maybe CodeArtifactConfig))]
plans]
results <- ((Ecosystem, MountConfig, Maybe CodeArtifactConfig)
-> IO (Either [BootError] (Ecosystem, Maybe CredentialProvider)))
-> [(Ecosystem, MountConfig, Maybe CodeArtifactConfig)]
-> IO [Either [BootError] (Ecosystem, Maybe CredentialProvider)]
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) -> [a] -> f [b]
traverse (\(Ecosystem
eco, MountConfig
mcfg, Maybe CodeArtifactConfig
mca) -> CredentialReporters
-> Ecosystem
-> MountConfig
-> Maybe CodeArtifactConfig
-> IO (Either [BootError] (Ecosystem, Maybe CredentialProvider))
initProviderFor CredentialReporters
reporters Ecosystem
eco MountConfig
mcfg Maybe CodeArtifactConfig
mca) [(Ecosystem, MountConfig, Maybe CodeArtifactConfig)]
validPlans
let (initErrs, valid) = partitionEithers results
if not (null initErrs)
then pure (Left (concat initErrs))
else pure (Right (CredentialProviders (Map.fromList [(eco, p) | (eco, Just p) <- valid])))
initProviderFor :: CredentialReporters -> Ecosystem -> MountConfig -> Maybe CodeArtifactConfig -> IO (Either [BootError] (Ecosystem, Maybe CredentialProvider))
initProviderFor :: CredentialReporters
-> Ecosystem
-> MountConfig
-> Maybe CodeArtifactConfig
-> IO (Either [BootError] (Ecosystem, Maybe CredentialProvider))
initProviderFor CredentialReporters
reporters Ecosystem
eco MountConfig
mcfg = \case
Maybe CodeArtifactConfig
Nothing -> Either [BootError] (Ecosystem, Maybe CredentialProvider)
-> IO (Either [BootError] (Ecosystem, Maybe CredentialProvider))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Ecosystem, Maybe CredentialProvider)
-> Either [BootError] (Ecosystem, Maybe CredentialProvider)
forall a b. b -> Either a b
Right (Ecosystem
eco, MountConfig -> Maybe CredentialProvider
staticTokenProvider MountConfig
mcfg))
Just CodeArtifactConfig
caConfig ->
IO CredentialProvider
-> IO (Either SomeException CredentialProvider)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny (CredentialReporters -> CodeArtifactConfig -> IO CredentialProvider
newCodeArtifactProvider CredentialReporters
reporters CodeArtifactConfig
caConfig) IO (Either SomeException CredentialProvider)
-> (Either SomeException CredentialProvider
-> Either [BootError] (Ecosystem, Maybe CredentialProvider))
-> IO (Either [BootError] (Ecosystem, Maybe CredentialProvider))
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
Left SomeException
err -> [BootError]
-> Either [BootError] (Ecosystem, Maybe CredentialProvider)
forall a b. a -> Either a b
Left [Text -> BootError
CodeArtifactMintFailed (String -> Text
forall a. ToText a => a -> Text
toText (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
err))]
Right CredentialProvider
provider -> (Ecosystem, Maybe CredentialProvider)
-> Either [BootError] (Ecosystem, Maybe CredentialProvider)
forall a b. b -> Either a b
Right (Ecosystem
eco, CredentialProvider -> Maybe CredentialProvider
forall a. a -> Maybe a
Just CredentialProvider
provider)
staticTokenProvider :: MountConfig -> Maybe CredentialProvider
staticTokenProvider :: MountConfig -> Maybe CredentialProvider
staticTokenProvider MountConfig
mcfg =
MountConfig -> Maybe Secret
mntMirrorTargetToken MountConfig
mcfg Maybe Secret
-> (Secret -> CredentialProvider) -> Maybe CredentialProvider
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \Secret
token ->
AuthToken -> CredentialProvider
staticProvider AuthToken{authSecret :: Secret
authSecret = Secret
token, authExpiresAt :: Maybe UTCTime
authExpiresAt = Maybe UTCTime
forall a. Maybe a
Nothing}
initializedEcosystems :: CredentialProviders -> Set Ecosystem
initializedEcosystems :: CredentialProviders -> Set Ecosystem
initializedEcosystems (CredentialProviders Map Ecosystem CredentialProvider
ps) = Map Ecosystem CredentialProvider -> Set Ecosystem
forall k a. Map k a -> Set k
Map.keysSet Map Ecosystem CredentialProvider
ps
lookupProvider :: Ecosystem -> CredentialProviders -> Maybe CredentialProvider
lookupProvider :: Ecosystem -> CredentialProviders -> Maybe CredentialProvider
lookupProvider Ecosystem
eco (CredentialProviders Map Ecosystem CredentialProvider
ps) = Ecosystem
-> Map Ecosystem CredentialProvider -> Maybe CredentialProvider
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Ecosystem
eco Map Ecosystem CredentialProvider
ps
planMirrorCredential :: Ecosystem -> AppConfig -> MountConfig -> Either [BootError] (Maybe CodeArtifactConfig)
planMirrorCredential :: Ecosystem
-> AppConfig
-> MountConfig
-> Either [BootError] (Maybe CodeArtifactConfig)
planMirrorCredential Ecosystem
eco AppConfig
app MountConfig
mcfg = case MountConfig -> CredentialBackend
mntCredentialProvider MountConfig
mcfg of
CredentialBackend
StaticCredential -> Maybe CodeArtifactConfig
-> Either [BootError] (Maybe CodeArtifactConfig)
forall a b. b -> Either a b
Right Maybe CodeArtifactConfig
forall a. Maybe a
Nothing
CredentialBackend
CodeArtifactCredential -> CodeArtifactConfig -> Maybe CodeArtifactConfig
forall a. a -> Maybe a
Just (CodeArtifactConfig -> Maybe CodeArtifactConfig)
-> Either [BootError] CodeArtifactConfig
-> Either [BootError] (Maybe CodeArtifactConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ecosystem
-> AppConfig
-> MountConfig
-> Either [BootError] CodeArtifactConfig
resolveCodeArtifactConfig Ecosystem
eco AppConfig
app MountConfig
mcfg
CredentialBackend
AdcCredential -> [BootError] -> Either [BootError] (Maybe CodeArtifactConfig)
forall a b. a -> Either a b
Left [CredentialBackend -> BootError
MirrorCredentialProviderUnavailable CredentialBackend
AdcCredential]
resolveCodeArtifactConfig :: Ecosystem -> AppConfig -> MountConfig -> Either [BootError] CodeArtifactConfig
resolveCodeArtifactConfig :: Ecosystem
-> AppConfig
-> MountConfig
-> Either [BootError] CodeArtifactConfig
resolveCodeArtifactConfig Ecosystem
eco AppConfig
app MountConfig
mcfg =
case [Either BootError Text] -> ([BootError], [Text])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either BootError Text
domainE, Either BootError Text
ownerE, Either BootError Text
regionE] of
([], [Text
domain, Text
owner, Text
region]) ->
CodeArtifactConfig -> Either [BootError] CodeArtifactConfig
forall a b. b -> Either a b
Right
CodeArtifactConfig
{ caRegion :: Text
caRegion = Text
region
, caDomain :: Text
caDomain = Text
domain
, caDomainOwner :: Maybe Text
caDomainOwner = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
owner
, caDurationSeconds :: Maybe Natural
caDurationSeconds = MountConfig -> Maybe Natural
mntMirrorCodeArtifactTokenDuration MountConfig
mcfg
}
([BootError]
errs, [Text]
_) -> [BootError] -> Either [BootError] CodeArtifactConfig
forall a b. a -> Either a b
Left [BootError]
errs
where
parsed :: Maybe (Text, Text, Text)
parsed :: Maybe (Text, Text, Text)
parsed =
Text -> Maybe (Text, Text, Text)
parseCodeArtifactHost (Text -> Maybe (Text, Text, Text))
-> (RegistryUrl -> Text) -> RegistryUrl -> Maybe (Text, Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
hostAddress (Text -> Text) -> (RegistryUrl -> Text) -> RegistryUrl -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegistryUrl -> Text
registryUrlText
(RegistryUrl -> Maybe (Text, Text, Text))
-> Maybe RegistryUrl -> Maybe (Text, Text, Text)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (MountConfig -> Maybe RegistryUrl
mntMirrorTarget MountConfig
mcfg Maybe RegistryUrl -> Maybe RegistryUrl -> Maybe RegistryUrl
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> MountConfig -> Maybe RegistryUrl
mntPrivateUpstream MountConfig
mcfg)
resolve :: Text -> [Maybe Text] -> Either BootError Text
resolve :: Text -> [Maybe Text] -> Either BootError Text
resolve Text
key [Maybe Text]
candidates =
Either BootError Text
-> (Text -> Either BootError Text)
-> Maybe Text
-> Either BootError Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BootError -> Either BootError Text
forall a b. a -> Either a b
Left (Text -> BootError
CodeArtifactConfigMissing (Ecosystem -> Text -> Text
mountEnvKey Ecosystem
eco Text
key))) Text -> Either BootError Text
forall a b. b -> Either a b
Right ([Maybe Text] -> Maybe Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum ((Maybe Text -> Maybe Text) -> [Maybe Text] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe Text -> (Text -> Maybe Text) -> Maybe Text
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe Text
nonBlank) [Maybe Text]
candidates))
domainE :: Either BootError Text
domainE = Text -> [Maybe Text] -> Either BootError Text
resolve Text
"MIRROR_CODE_ARTIFACT_DOMAIN" [MountConfig -> Maybe Text
mntMirrorCodeArtifactDomain MountConfig
mcfg, (Text, Text, Text) -> Text
forall {a} {b} {c}. (a, b, c) -> a
fst3 ((Text, Text, Text) -> Text)
-> Maybe (Text, Text, Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Text, Text, Text)
parsed]
ownerE :: Either BootError Text
ownerE =
Text -> [Maybe Text] -> Either BootError Text
resolve Text
"MIRROR_CODE_ARTIFACT_DOMAIN_OWNER" [MountConfig -> Maybe Text
mntMirrorCodeArtifactDomainOwner MountConfig
mcfg, (Text, Text, Text) -> Text
forall {a} {b} {c}. (a, b, c) -> b
snd3 ((Text, Text, Text) -> Text)
-> Maybe (Text, Text, Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Text, Text, Text)
parsed]
Either BootError Text
-> (Text -> Either BootError Text) -> Either BootError Text
forall a b.
Either BootError a
-> (a -> Either BootError b) -> Either BootError b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Text -> Either BootError Text
validateAccountId (Ecosystem -> Text -> Text
mountEnvKey Ecosystem
eco Text
"MIRROR_CODE_ARTIFACT_DOMAIN_OWNER")
regionE :: Either BootError Text
regionE = Text -> [Maybe Text] -> Either BootError Text
resolve Text
"MIRROR_CODE_ARTIFACT_REGION" [MountConfig -> Maybe Text
mntMirrorCodeArtifactRegion MountConfig
mcfg, (Text, Text, Text) -> Text
forall {a} {b} {c}. (a, b, c) -> c
thd3 ((Text, Text, Text) -> Text)
-> Maybe (Text, Text, Text) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Text, Text, Text)
parsed, AppConfig -> Maybe Text
cfgAwsRegion AppConfig
app]
fst3 :: (a, b, c) -> a
fst3 (a
a, b
_, c
_) = a
a
snd3 :: (a, b, c) -> b
snd3 (a
_, b
b, c
_) = b
b
thd3 :: (a, b, c) -> c
thd3 (a
_, b
_, c
c) = c
c
mountEnvKey :: Ecosystem -> Text -> Text
mountEnvKey :: Ecosystem -> Text -> Text
mountEnvKey Ecosystem
eco Text
key = Text
"ECLUSE_MOUNTS__" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.toUpper (Ecosystem -> Text
ecosystemName Ecosystem
eco) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"__" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key
validateAccountId :: Text -> Text -> Either BootError Text
validateAccountId :: Text -> Text -> Either BootError Text
validateAccountId Text
key Text
owner
| Text -> Bool
isAccountId Text
owner = Text -> Either BootError Text
forall a b. b -> Either a b
Right Text
owner
| Bool
otherwise = BootError -> Either BootError Text
forall a b. a -> Either a b
Left (Text -> Text -> BootError
CodeArtifactConfigInvalid Text
key Text
"expected a 12-digit AWS account id")
isAccountId :: Text -> Bool
isAccountId :: Text -> Bool
isAccountId Text
t = Text -> Int -> Ordering
T.compareLength Text
t Int
12 Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Ordering
EQ Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isDigit Text
t
parseCodeArtifactHost :: Text -> Maybe (Text, Text, Text)
parseCodeArtifactHost :: Text -> Maybe (Text, Text, Text)
parseCodeArtifactHost Text
host = do
[domainOwner, regionTail] <- [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
".d.codeartifact." Text
host)
region <- nonBlank =<< T.stripSuffix ".amazonaws.com" regionTail
let (domainDash, owner) = T.breakOnEnd "-" domainOwner
domain <- nonBlank (T.dropEnd 1 domainDash)
guard (isAccountId owner)
pure (domain, owner, region)
data BootError
=
PolicyBootError PolicyError
|
MissingAdapter Ecosystem
|
UnresolvedCredential Ecosystem CredentialBackend
|
QueueProviderUnavailable QueueBackend
|
QueueRegionMissing
|
QueueUrlMissing QueueBackend
|
QueueEndpointMalformed Text
|
MirrorCredentialProviderUnavailable CredentialBackend
|
CodeArtifactConfigMissing Text
|
CodeArtifactConfigInvalid Text Text
|
CodeArtifactMintFailed Text
|
PublishScopesMissing Ecosystem
|
PublishStaticCredentialNeedsEdge Ecosystem
deriving stock (BootError -> BootError -> Bool
(BootError -> BootError -> Bool)
-> (BootError -> BootError -> Bool) -> Eq BootError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BootError -> BootError -> Bool
== :: BootError -> BootError -> Bool
$c/= :: BootError -> BootError -> Bool
/= :: BootError -> BootError -> Bool
Eq, Int -> BootError -> ShowS
[BootError] -> ShowS
BootError -> String
(Int -> BootError -> ShowS)
-> (BootError -> String)
-> ([BootError] -> ShowS)
-> Show BootError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BootError -> ShowS
showsPrec :: Int -> BootError -> ShowS
$cshow :: BootError -> String
show :: BootError -> String
$cshowList :: [BootError] -> ShowS
showList :: [BootError] -> ShowS
Show)
renderBootError :: BootError -> Text
renderBootError :: BootError -> Text
renderBootError = \case
PolicyBootError PolicyError
err -> PolicyError -> Text
renderPolicyError PolicyError
err
MissingAdapter Ecosystem
eco ->
Text
"mount " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text
ecosystemName Ecosystem
eco Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" has no adapter wired in this build"
UnresolvedCredential Ecosystem
eco CredentialBackend
backend ->
Text
"mount "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text
ecosystemName Ecosystem
eco
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" names credential source "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CredentialBackend -> Text
forall a. (Eq a, WireVocab a) => a -> Text
renderWire CredentialBackend
backend
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", not initialised in this build"
QueueProviderUnavailable QueueBackend
backend ->
Text
"mirror queue provider "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QueueBackend -> Text
forall a. (Eq a, WireVocab a) => a -> Text
renderWire QueueBackend
backend
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not available in this build"
BootError
QueueRegionMissing ->
Text
"mirror queue provider "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QueueBackend -> Text
forall a. (Eq a, WireVocab a) => a -> Text
renderWire QueueBackend
SqsQueue
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" requires AWS_REGION to be set"
QueueUrlMissing QueueBackend
backend ->
Text
"mirror queue provider "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> QueueBackend -> Text
forall a. (Eq a, WireVocab a) => a -> Text
renderWire QueueBackend
backend
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" requires ECLUSE_QUEUE_URL to be set"
QueueEndpointMalformed Text
url ->
Text
"the SQS endpoint override (AWS_ENDPOINT_URL_SQS / AWS_ENDPOINT_URL) is not a valid endpoint URL: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
url
MirrorCredentialProviderUnavailable CredentialBackend
backend ->
Text
"mirror-target credential provider "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CredentialBackend -> Text
forall a. (Eq a, WireVocab a) => a -> Text
renderWire CredentialBackend
backend
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is not available in this build"
CodeArtifactConfigMissing Text
key ->
Text
"mirror-target credential provider codeartifact requires "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (set it explicitly, or use a CodeArtifact ECLUSE_MIRROR_TARGET it can be parsed from)"
CodeArtifactConfigInvalid Text
key Text
reason ->
Text
"mirror-target credential provider codeartifact: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is invalid (" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
reason Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
CodeArtifactMintFailed Text
detail ->
Text
"mirror-target credential provider codeartifact failed to mint an initial token at boot: "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
detail
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" (a transient AWS error may clear on retry; a permanent one -- bad domain/region or missing permission -- must be fixed)"
PublishScopesMissing Ecosystem
eco ->
Text
"ECLUSE_MOUNTS__" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.toUpper (String -> Text
T.pack (Ecosystem -> String
forall b a. (Show a, IsString b) => a -> b
show Ecosystem
eco)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"__PUBLICATION_TARGET is set but ECLUSE_MOUNTS__" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.toUpper (String -> Text
T.pack (Ecosystem -> String
forall b a. (Show a, IsString b) => a -> b
show Ecosystem
eco)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"__PUBLISH_SCOPES is empty: a publication target needs a publish-scope allow-list (e.g. @acme) for the anti-shadowing guard."
PublishStaticCredentialNeedsEdge Ecosystem
eco ->
Text
"ECLUSE_MOUNTS__" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
T.toUpper (String -> Text
T.pack (Ecosystem -> String
forall b a. (Show a, IsString b) => a -> b
show Ecosystem
eco)) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"__PUBLICATION_TARGET_TOKEN is set but ECLUSE_AUTH_TOKEN is not: a static publish credential needs a verifiable inbound edge."
planMounts ::
(Ecosystem -> Maybe PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding) ->
IO UTCTime ->
(Ecosystem -> RuleDeps) ->
CredentialProviders ->
Config ->
IO (Either [BootError] [MountBinding])
planMounts :: (Ecosystem
-> Maybe PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding)
-> IO UTCTime
-> (Ecosystem -> RuleDeps)
-> CredentialProviders
-> Config
-> IO (Either [BootError] [MountBinding])
planMounts = (Ecosystem
-> Maybe PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding)
-> IO UTCTime
-> (Ecosystem -> RuleDeps)
-> CredentialProviders
-> Config
-> IO (Either [BootError] [MountBinding])
composeBindings
composeBindings ::
(Ecosystem -> Maybe PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding) ->
IO UTCTime ->
(Ecosystem -> RuleDeps) ->
CredentialProviders ->
Config ->
IO (Either [BootError] [MountBinding])
composeBindings :: (Ecosystem
-> Maybe PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding)
-> IO UTCTime
-> (Ecosystem -> RuleDeps)
-> CredentialProviders
-> Config
-> IO (Either [BootError] [MountBinding])
composeBindings Ecosystem
-> Maybe PackumentDeps -> Maybe PublishDeps -> Maybe MountBinding
resolveAdapter IO UTCTime
clock Ecosystem -> RuleDeps
ruleDepsFor CredentialProviders
providers Config
config = do
let ([BootError]
pubErrs, Map Ecosystem (Maybe PublishDeps)
pubDepsMap) = case Map Ecosystem (Either [BootError] (Maybe PublishDeps))
-> Either [BootError] (Map Ecosystem (Maybe PublishDeps))
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a.
Monad m =>
Map Ecosystem (m a) -> m (Map Ecosystem a)
sequence ((Ecosystem
-> MountConfig -> Either [BootError] (Maybe PublishDeps))
-> Map Ecosystem MountConfig
-> Map Ecosystem (Either [BootError] (Maybe PublishDeps))
forall k a b. (k -> a -> b) -> Map k a -> Map k b
Map.mapWithKey (\Ecosystem
eco MountConfig
mcfg -> Ecosystem
-> AppConfig
-> MountConfig
-> Limits
-> Maybe HelpMessage
-> Either [BootError] (Maybe PublishDeps)
publishDepsFor Ecosystem
eco AppConfig
app MountConfig
mcfg Limits
limits Maybe HelpMessage
helpMessage) (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
app)) of
Left [BootError]
errs -> ([BootError]
errs, Map Ecosystem (Maybe PublishDeps)
forall k a. Map k a
Map.empty)
Right Map Ecosystem (Maybe PublishDeps)
m -> ([], Map Ecosystem (Maybe PublishDeps)
m)
let mounts :: [(Mount, MountConfig)]
mounts = Map Ecosystem (Mount, MountConfig) -> [(Mount, MountConfig)]
forall k a. Map k a -> [a]
Map.elems ((Mount -> MountConfig -> (Mount, MountConfig))
-> Map Ecosystem Mount
-> Map Ecosystem MountConfig
-> Map Ecosystem (Mount, MountConfig)
forall k a b c.
Ord k =>
(a -> b -> c) -> Map k a -> Map k b -> Map k c
Map.intersectionWith (,) (Config -> Map Ecosystem Mount
configMounts Config
config) (AppConfig -> Map Ecosystem MountConfig
cfgMounts AppConfig
app))
bindingResults <- ((Mount, MountConfig) -> IO (Either [BootError] MountBinding))
-> [(Mount, MountConfig)] -> IO [Either [BootError] MountBinding]
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) -> [a] -> f [b]
traverse (\(Mount
mount, MountConfig
mcfg) -> Maybe PublishDeps
-> Mount -> MountConfig -> IO (Either [BootError] MountBinding)
bindingFor (Maybe (Maybe PublishDeps) -> Maybe PublishDeps
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Ecosystem
-> Map Ecosystem (Maybe PublishDeps) -> Maybe (Maybe PublishDeps)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Mount -> Ecosystem
mountEcosystem Mount
mount) Map Ecosystem (Maybe PublishDeps)
pubDepsMap)) Mount
mount MountConfig
mcfg) [(Mount, MountConfig)]
mounts
pure $ case (pubErrs, partitionEithers bindingResults) of
([], ([], [MountBinding]
bindings)) -> [MountBinding] -> Either [BootError] [MountBinding]
forall a b. b -> Either a b
Right [MountBinding]
bindings
([BootError]
_, ([[BootError]]
errs, [MountBinding]
_)) -> [BootError] -> Either [BootError] [MountBinding]
forall a b. a -> Either a b
Left ([BootError]
pubErrs [BootError] -> [BootError] -> [BootError]
forall a. Semigroup a => a -> a -> a
<> [[BootError]] -> [BootError]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BootError]]
errs)
where
app :: AppConfig
app :: AppConfig
app = Config -> AppConfig
configApp Config
config
limits :: Limits
limits :: Limits
limits =
Limits
{ maxBodyBytes :: Int
maxBodyBytes = AppConfig -> Int
cfgMaxResponseBytes AppConfig
app
, maxVersionCount :: Int
maxVersionCount = AppConfig -> Int
cfgMaxVersionCount AppConfig
app
, maxNestingDepth :: Int
maxNestingDepth = AppConfig -> Int
cfgMaxNestingDepth AppConfig
app
}
helpMessage :: Maybe HelpMessage
helpMessage :: Maybe HelpMessage
helpMessage = Text -> HelpMessage
mkHelpMessage (Text -> HelpMessage) -> Maybe Text -> Maybe HelpMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppConfig -> Maybe Text
cfgHelpMessage AppConfig
app
bindingFor :: Maybe PublishDeps -> Mount -> MountConfig -> IO (Either [BootError] MountBinding)
bindingFor :: Maybe PublishDeps
-> Mount -> MountConfig -> IO (Either [BootError] MountBinding)
bindingFor Maybe PublishDeps
pubDeps Mount
mount MountConfig
mcfg = do
deps <- Mount -> MountConfig -> IO PackumentDeps
packumentDepsFor Mount
mount MountConfig
mcfg
pure $ case (credentialError providers mount, resolveAdapter (mountEcosystem mount) (Just deps) pubDeps) of
(Maybe BootError
Nothing, Just MountBinding
binding) -> MountBinding -> Either [BootError] MountBinding
forall a b. b -> Either a b
Right MountBinding
binding
(Maybe BootError
mCredErr, Maybe MountBinding
mBinding) ->
[BootError] -> Either [BootError] MountBinding
forall a b. a -> Either a b
Left (Maybe BootError -> [BootError]
forall a. Maybe a -> [a]
maybeToList Maybe BootError
mCredErr [BootError] -> [BootError] -> [BootError]
forall a. Semigroup a => a -> a -> a
<> [Ecosystem -> BootError
MissingAdapter (Mount -> Ecosystem
mountEcosystem Mount
mount) | Maybe MountBinding -> Bool
forall a. Maybe a -> Bool
isNothing Maybe MountBinding
mBinding])
packumentDepsFor :: Mount -> MountConfig -> IO PackumentDeps
packumentDepsFor :: Mount -> MountConfig -> IO PackumentDeps
packumentDepsFor Mount
mount MountConfig
mcfg = do
prepared <- RuleDeps -> [PrecededRule] -> IO [PreparedRule]
prepare (Ecosystem -> RuleDeps
ruleDepsFor (Mount -> Ecosystem
mountEcosystem Mount
mount)) (Mount -> [PrecededRule]
mountPolicy Mount
mount)
let regs = Mount -> MountRegistries
mountRegistries Mount
mount
pure
PackumentDeps
{ pdPrivateBaseUrl = registryUrlText (regPrivateUpstream regs)
, pdPublicBaseUrl = registryUrlText (regPublicUpstream regs)
, pdMountBaseUrl = mountBaseUrl (cfgPublicUrl app) (mountEcosystem mount)
, pdMirrorTarget = registryUrlText (mtUrl (regMirrorTarget regs))
, pdRules = prepared
, pdTarballHostPolicy = tarballHostPolicyFor mcfg
,
pdAdditionalBlockedRanges = cfgAdditionalBlockedRanges app
,
pdTarballHostGate =
tarballHostGate
(registryUrlText (regPrivateUpstream regs))
(registryUrlText (regPublicUpstream regs))
(registryUrlText (mtUrl (regMirrorTarget regs)))
, pdLimits = limits
, pdInboundToken = cfgAuthToken app
, pdNow = clock
, pdHelp = helpMessage
,
pdMinIntegrity = cfgMinPublicIntegrity app
,
pdMinTrustedIntegrity = cfgMinTrustedIntegrity app
, pdNewMetadataClient = \TracingPort
t MetricsPort
p Upstream
u ManifestCaching
c PackageName -> MetadataError -> IO ()
f1 PackageName -> [InvalidEntry] -> IO ()
f2 PackageName -> IO ()
f3 Limits
l Manager
m Text
b Maybe Secret
s -> TracingPort
-> MetricsPort
-> Upstream
-> ManifestCaching
-> (PackageName -> MetadataError -> IO ())
-> (PackageName -> [InvalidEntry] -> IO ())
-> (PackageName -> IO ())
-> NpmClientConfig
-> MetadataClient
Metadata.newNpmMetadataClient TracingPort
t MetricsPort
p Upstream
u ManifestCaching
c PackageName -> MetadataError -> IO ()
f1 PackageName -> [InvalidEntry] -> IO ()
f2 PackageName -> IO ()
f3 (Text -> Manager -> Maybe Secret -> Limits -> NpmClientConfig
Npm.NpmClientConfig Text
b Manager
m Maybe Secret
s Limits
l)
, pdBuildArtifactRequestByFile = \Limits
_ Manager
_ Text
t Maybe Secret
s -> Text
-> Maybe Secret
-> PackageName
-> Text
-> Either UrlFormationError Request
NpmRequest.artifactRequestByFile Text
t Maybe Secret
s
, pdBuildArtifactRequestByUrl = \Limits
_ Manager
_ Text
t Maybe Secret
s -> Text -> Maybe Secret -> Text -> Either UrlFormationError Request
NpmRequest.artifactRequestByUrl Text
t Maybe Secret
s
, pdAssemble = NpmFilter.assembleMergedPackument
}
tarballHostPolicyFor :: MountConfig -> TarballHostPolicy
tarballHostPolicyFor :: MountConfig -> TarballHostPolicy
tarballHostPolicyFor MountConfig
mcfg =
if MountConfig -> Bool
mntRespectUpstreamTarballHost MountConfig
mcfg
then TarballHostPolicy
AnyAllowlistedHost
else TarballHostPolicy
SameHostAsPackument
credentialError :: CredentialProviders -> Mount -> Maybe BootError
credentialError :: CredentialProviders -> Mount -> Maybe BootError
credentialError CredentialProviders
providers Mount
mount =
let backend :: CredentialBackend
backend = MirrorTarget -> CredentialBackend
mtCredential (MountRegistries -> MirrorTarget
regMirrorTarget (Mount -> MountRegistries
mountRegistries Mount
mount))
in if Mount -> Ecosystem
mountEcosystem Mount
mount Ecosystem -> Set Ecosystem -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` CredentialProviders -> Set Ecosystem
initializedEcosystems CredentialProviders
providers
then Maybe BootError
forall a. Maybe a
Nothing
else BootError -> Maybe BootError
forall a. a -> Maybe a
Just (Ecosystem -> CredentialBackend -> BootError
UnresolvedCredential (Mount -> Ecosystem
mountEcosystem Mount
mount) CredentialBackend
backend)
mountBaseUrl :: Maybe Url -> Ecosystem -> Text
mountBaseUrl :: Maybe Url -> Ecosystem -> Text
mountBaseUrl Maybe Url
publicUrl Ecosystem
eco =
case Maybe Url
publicUrl of
Maybe Url
Nothing -> Ecosystem -> Text
mountBasePath Ecosystem
eco
Just Url
public -> (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'/') (Url -> Text
unUrl Url
public) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Ecosystem -> Text
mountBasePath Ecosystem
eco
mountBasePath :: Ecosystem -> Text
mountBasePath :: Ecosystem -> Text
mountBasePath Ecosystem
eco = Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"/" (NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Ecosystem -> NonEmpty Text
prefixFor Ecosystem
eco))
publishDepsFor :: Ecosystem -> AppConfig -> MountConfig -> Limits -> Maybe HelpMessage -> Either [BootError] (Maybe PublishDeps)
publishDepsFor :: Ecosystem
-> AppConfig
-> MountConfig
-> Limits
-> Maybe HelpMessage
-> Either [BootError] (Maybe PublishDeps)
publishDepsFor Ecosystem
eco AppConfig
app MountConfig
mcfg Limits
limits Maybe HelpMessage
helpMessage = case MountConfig -> Maybe RegistryUrl
mntPublicationTarget MountConfig
mcfg of
Maybe RegistryUrl
Nothing -> Maybe PublishDeps -> Either [BootError] (Maybe PublishDeps)
forall a b. b -> Either a b
Right Maybe PublishDeps
forall a. Maybe a
Nothing
Just RegistryUrl
url -> case Ecosystem -> MountConfig -> Maybe Secret -> [BootError]
publishBootErrors Ecosystem
eco MountConfig
mcfg Maybe Secret
inboundToken of
[] ->
Maybe PublishDeps -> Either [BootError] (Maybe PublishDeps)
forall a b. b -> Either a b
Right
( PublishDeps -> Maybe PublishDeps
forall a. a -> Maybe a
Just
PublishDeps
{ pubTargetUrl :: Text
pubTargetUrl = RegistryUrl -> Text
registryUrlText RegistryUrl
url
, pubScopes :: [Scope]
pubScopes = MountConfig -> [Scope]
mntPublishScopes MountConfig
mcfg
, pubStaticToken :: Maybe Secret
pubStaticToken = MountConfig -> Maybe Secret
mntPublicationTargetToken MountConfig
mcfg
, pubInboundToken :: Maybe Secret
pubInboundToken = Maybe Secret
inboundToken
, pubLimits :: Limits
pubLimits = Limits
limits
, pubHelp :: Maybe HelpMessage
pubHelp = Maybe HelpMessage
helpMessage
, pubRelayPublish :: Limits
-> Manager
-> Text
-> Maybe Secret
-> PackageName
-> ByteString
-> IO (Either UrlFormationError PublishRelayResponse)
pubRelayPublish = \Limits
l Manager
m Text
t Maybe Secret
s -> NpmClientConfig
-> PackageName
-> ByteString
-> IO (Either UrlFormationError PublishRelayResponse)
Npm.relayPublishDocument (Text -> Manager -> Maybe Secret -> Limits -> NpmClientConfig
Npm.NpmClientConfig Text
t Manager
m Maybe Secret
s Limits
l)
, pubCanonicaliseName :: Text -> Maybe PackageName
pubCanonicaliseName = Either ParseError PackageName -> Maybe PackageName
forall l r. Either l r -> Maybe r
rightToMaybe (Either ParseError PackageName -> Maybe PackageName)
-> (Text -> Either ParseError PackageName)
-> Text
-> Maybe PackageName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either ParseError PackageName
NpmProject.projectName
}
)
[BootError]
errs -> [BootError] -> Either [BootError] (Maybe PublishDeps)
forall a b. a -> Either a b
Left [BootError]
errs
where
inboundToken :: Maybe Secret
inboundToken :: Maybe Secret
inboundToken = AppConfig -> Maybe Secret
cfgAuthToken AppConfig
app
publishBootErrors :: Ecosystem -> MountConfig -> Maybe Secret -> [BootError]
publishBootErrors :: Ecosystem -> MountConfig -> Maybe Secret -> [BootError]
publishBootErrors Ecosystem
eco MountConfig
mcfg Maybe Secret
inboundToken = [Maybe BootError] -> [BootError]
forall a. [Maybe a] -> [a]
catMaybes [Maybe BootError
scopesError, Maybe BootError
edgeError]
where
scopesError, edgeError :: Maybe BootError
scopesError :: Maybe BootError
scopesError
| [Scope] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (MountConfig -> [Scope]
mntPublishScopes MountConfig
mcfg) = BootError -> Maybe BootError
forall a. a -> Maybe a
Just (Ecosystem -> BootError
PublishScopesMissing Ecosystem
eco)
| Bool
otherwise = Maybe BootError
forall a. Maybe a
Nothing
edgeError :: Maybe BootError
edgeError
| Maybe Secret -> Bool
forall a. Maybe a -> Bool
isJust (MountConfig -> Maybe Secret
mntPublicationTargetToken MountConfig
mcfg) Bool -> Bool -> Bool
&& Maybe Secret -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Secret
inboundToken = BootError -> Maybe BootError
forall a. a -> Maybe a
Just (Ecosystem -> BootError
PublishStaticCredentialNeedsEdge Ecosystem
eco)
| Bool
otherwise = Maybe BootError
forall a. Maybe a
Nothing
data PublishTarget = PublishTarget
{ PublishTarget -> Ecosystem
ptEcosystem :: Ecosystem
, PublishTarget -> Text
ptMirrorUrl :: Text
, PublishTarget -> CredentialProvider
ptCredentials :: CredentialProvider
}
planPublishTargets ::
CredentialProviders ->
Config ->
Either [BootError] [PublishTarget]
planPublishTargets :: CredentialProviders -> Config -> Either [BootError] [PublishTarget]
planPublishTargets = CredentialProviders -> Config -> Either [BootError] [PublishTarget]
composePublishTargets
composePublishTargets ::
CredentialProviders ->
Config ->
Either [BootError] [PublishTarget]
composePublishTargets :: CredentialProviders -> Config -> Either [BootError] [PublishTarget]
composePublishTargets CredentialProviders
providers Config
config =
case [Either [BootError] PublishTarget]
-> ([[BootError]], [PublishTarget])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((Mount -> Either [BootError] PublishTarget)
-> [Mount] -> [Either [BootError] PublishTarget]
forall a b. (a -> b) -> [a] -> [b]
map (CredentialProviders -> Mount -> Either [BootError] PublishTarget
publishTargetFor CredentialProviders
providers) (Map Ecosystem Mount -> [Mount]
forall k a. Map k a -> [a]
Map.elems (Config -> Map Ecosystem Mount
configMounts Config
config))) of
([], [PublishTarget]
targets) -> [PublishTarget] -> Either [BootError] [PublishTarget]
forall a b. b -> Either a b
Right [PublishTarget]
targets
([[BootError]]
errs, [PublishTarget]
_) -> [BootError] -> Either [BootError] [PublishTarget]
forall a b. a -> Either a b
Left ([[BootError]] -> [BootError]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[BootError]]
errs)
publishTargetFor :: CredentialProviders -> Mount -> Either [BootError] PublishTarget
publishTargetFor :: CredentialProviders -> Mount -> Either [BootError] PublishTarget
publishTargetFor CredentialProviders
providers Mount
mount =
case Ecosystem -> CredentialProviders -> Maybe CredentialProvider
lookupProvider (Mount -> Ecosystem
mountEcosystem Mount
mount) CredentialProviders
providers of
Just CredentialProvider
provider ->
PublishTarget -> Either [BootError] PublishTarget
forall a b. b -> Either a b
Right
PublishTarget
{ ptEcosystem :: Ecosystem
ptEcosystem = Mount -> Ecosystem
mountEcosystem Mount
mount
, ptMirrorUrl :: Text
ptMirrorUrl = RegistryUrl -> Text
registryUrlText (MirrorTarget -> RegistryUrl
mtUrl MirrorTarget
target)
, ptCredentials :: CredentialProvider
ptCredentials = CredentialProvider
provider
}
Maybe CredentialProvider
Nothing ->
[BootError] -> Either [BootError] PublishTarget
forall a b. a -> Either a b
Left [Ecosystem -> CredentialBackend -> BootError
UnresolvedCredential (Mount -> Ecosystem
mountEcosystem Mount
mount) (MirrorTarget -> CredentialBackend
mtCredential MirrorTarget
target)]
where
target :: MirrorTarget
target = MountRegistries -> MirrorTarget
regMirrorTarget (Mount -> MountRegistries
mountRegistries Mount
mount)
data MirrorQueuePlan
=
SqsBackend SqsConfig
|
MemoryBackend MemoryQueueConfig
deriving stock (MirrorQueuePlan -> MirrorQueuePlan -> Bool
(MirrorQueuePlan -> MirrorQueuePlan -> Bool)
-> (MirrorQueuePlan -> MirrorQueuePlan -> Bool)
-> Eq MirrorQueuePlan
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MirrorQueuePlan -> MirrorQueuePlan -> Bool
== :: MirrorQueuePlan -> MirrorQueuePlan -> Bool
$c/= :: MirrorQueuePlan -> MirrorQueuePlan -> Bool
/= :: MirrorQueuePlan -> MirrorQueuePlan -> Bool
Eq, Int -> MirrorQueuePlan -> ShowS
[MirrorQueuePlan] -> ShowS
MirrorQueuePlan -> String
(Int -> MirrorQueuePlan -> ShowS)
-> (MirrorQueuePlan -> String)
-> ([MirrorQueuePlan] -> ShowS)
-> Show MirrorQueuePlan
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MirrorQueuePlan -> ShowS
showsPrec :: Int -> MirrorQueuePlan -> ShowS
$cshow :: MirrorQueuePlan -> String
show :: MirrorQueuePlan -> String
$cshowList :: [MirrorQueuePlan] -> ShowS
showList :: [MirrorQueuePlan] -> ShowS
Show)
planMirrorQueue :: AppConfig -> Either [BootError] MirrorQueuePlan
planMirrorQueue :: AppConfig -> Either [BootError] MirrorQueuePlan
planMirrorQueue AppConfig
env = case AppConfig -> QueueBackend
cfgQueueBackend AppConfig
env of
QueueBackend
PubSubQueue -> [BootError] -> Either [BootError] MirrorQueuePlan
forall a b. a -> Either a b
Left [QueueBackend -> BootError
QueueProviderUnavailable QueueBackend
PubSubQueue]
QueueBackend
MemoryQueue -> MirrorQueuePlan -> Either [BootError] MirrorQueuePlan
forall a b. b -> Either a b
Right (MemoryQueueConfig -> MirrorQueuePlan
MemoryBackend (Int -> MemoryQueueConfig
defaultMemoryQueueConfig (AppConfig -> Int
cfgQueueMemoryMaxDepth AppConfig
env)))
QueueBackend
SqsQueue -> case (Either BootError Text
regionE, Either BootError Url
urlE, AppConfig -> Either [BootError] (Maybe SqsEndpoint)
resolveSqsEndpoint AppConfig
env) of
(Right Text
region, Right Url
url, Right Maybe SqsEndpoint
endpoint) ->
MirrorQueuePlan -> Either [BootError] MirrorQueuePlan
forall a b. b -> Either a b
Right (SqsConfig -> MirrorQueuePlan
SqsBackend (Text -> Text -> SqsConfig
defaultSqsConfig (Url -> Text
unUrl Url
url) Text
region){sqsEndpoint = endpoint})
(Either BootError Text
_, Either BootError Url
_, Either [BootError] (Maybe SqsEndpoint)
endpointE) ->
[BootError] -> Either [BootError] MirrorQueuePlan
forall a b. a -> Either a b
Left ([Either BootError ()] -> [BootError]
forall a b. [Either a b] -> [a]
lefts [Either BootError Text -> Either BootError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Either BootError Text
regionE, Either BootError Url -> Either BootError ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Either BootError Url
urlE] [BootError] -> [BootError] -> [BootError]
forall a. Semigroup a => a -> a -> a
<> [BootError]
-> Either [BootError] (Maybe SqsEndpoint) -> [BootError]
forall a b. a -> Either a b -> a
fromLeft [] Either [BootError] (Maybe SqsEndpoint)
endpointE)
where
regionE :: Either BootError Text
regionE :: Either BootError Text
regionE = case Text -> Text
T.strip (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppConfig -> Maybe Text
cfgAwsRegion AppConfig
env of
Just Text
region | Bool -> Bool
not (Text -> Bool
T.null Text
region) -> Text -> Either BootError Text
forall a b. b -> Either a b
Right Text
region
Maybe Text
_ -> BootError -> Either BootError Text
forall a b. a -> Either a b
Left BootError
QueueRegionMissing
urlE :: Either BootError Url
urlE :: Either BootError Url
urlE = Either BootError Url
-> (Url -> Either BootError Url)
-> Maybe Url
-> Either BootError Url
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (BootError -> Either BootError Url
forall a b. a -> Either a b
Left (QueueBackend -> BootError
QueueUrlMissing QueueBackend
SqsQueue)) Url -> Either BootError Url
forall a b. b -> Either a b
Right (AppConfig -> Maybe Url
cfgQueueUrl AppConfig
env)
mirrorQueuePlanWarning :: MirrorQueuePlan -> Maybe Text
mirrorQueuePlanWarning :: MirrorQueuePlan -> Maybe Text
mirrorQueuePlanWarning = \case
SqsBackend SqsConfig
_ -> Maybe Text
forall a. Maybe a
Nothing
MemoryBackend MemoryQueueConfig
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
memoryQueueBootWarning
memoryQueueBootWarning :: Text
memoryQueueBootWarning :: Text
memoryQueueBootWarning =
Text
"mirror queue provider 'memory' selected: the mirror queue is IN-MEMORY, NON-DURABLE, and BEST-EFFORT. "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"Jobs are dropped on cap overflow and lost on restart or redeploy; each is re-mirrored on the next "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"demand (no data loss, only deferred mirroring). Use a durable backend ('sqs') for a production mirror "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"that must not shed under load."
memoryQueueDropWarning :: Int -> Text
memoryQueueDropWarning :: Int -> Text
memoryQueueDropWarning Int
dropped =
Text
"mirror queue at capacity: dropped a mirror job (drop-newest); "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
dropped
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" job(s) dropped so far. Each is re-mirrored on the next demand; raise "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ECLUSE_QUEUE_MEMORY_MAX_DEPTH to shed fewer under load."
resolveSqsEndpoint :: AppConfig -> Either [BootError] (Maybe SqsEndpoint)
resolveSqsEndpoint :: AppConfig -> Either [BootError] (Maybe SqsEndpoint)
resolveSqsEndpoint AppConfig
env =
case Text -> Maybe Text
nonBlank (Text -> Maybe Text) -> Maybe Text -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< AppConfig -> Maybe Text
cfgAwsEndpointUrlSqs AppConfig
env of
Maybe Text
Nothing -> Maybe SqsEndpoint -> Either [BootError] (Maybe SqsEndpoint)
forall a b. b -> Either a b
Right Maybe SqsEndpoint
forall a. Maybe a
Nothing
Just Text
url -> case Text -> Maybe (Bool, Text, Int)
parseEndpointUrl Text
url of
Maybe (Bool, Text, Int)
Nothing -> [BootError] -> Either [BootError] (Maybe SqsEndpoint)
forall a b. a -> Either a b
Left [Text -> BootError
QueueEndpointMalformed Text
url]
Just (Bool
secure, Text
host, Int
port) ->
Maybe SqsEndpoint -> Either [BootError] (Maybe SqsEndpoint)
forall a b. b -> Either a b
Right (SqsEndpoint -> Maybe SqsEndpoint
forall a. a -> Maybe a
Just SqsEndpoint{endpointSecure :: Bool
endpointSecure = Bool
secure, endpointHost :: Text
endpointHost = Text
host, endpointPort :: Int
endpointPort = Int
port})
parseEndpointUrl :: Text -> Maybe (Bool, Text, Int)
parseEndpointUrl :: Text -> Maybe (Bool, Text, Int)
parseEndpointUrl Text
raw = do
(secure, afterScheme) <-
((Bool
True,) (Text -> (Bool, Text)) -> Maybe Text -> Maybe (Bool, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripPrefix Text
"https://" Text
raw) Maybe (Bool, Text) -> Maybe (Bool, Text) -> Maybe (Bool, Text)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ((Bool
False,) (Text -> (Bool, Text)) -> Maybe Text -> Maybe (Bool, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripPrefix Text
"http://" Text
raw)
let authority = (Char -> Bool) -> Text -> Text
T.takeWhile (Char -> String -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Char
'/', Char
'?', Char
'#']) Text
afterScheme
(hostText, portText) <- splitHostPort authority
host <- nonBlank hostText
port <- case T.stripPrefix ":" portText of
Maybe Text
Nothing -> Int -> Maybe Int
forall a. a -> Maybe a
Just (if Bool
secure then Int
443 else Int
80)
Just Text
digits -> String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
forall a. ToString a => a -> String
toString Text
digits)
pure (secure, host, port)
cacheConfigFor :: AppConfig -> CacheConfig
cacheConfigFor :: AppConfig -> CacheConfig
cacheConfigFor AppConfig
env =
CacheConfig
{ cacheTtl :: NominalDiffTime
cacheTtl = AppConfig -> NominalDiffTime
cfgCacheTtl AppConfig
env
, cacheMaxEntries :: Int
cacheMaxEntries = AppConfig -> Int
cfgCacheMaxEntries AppConfig
env
, cacheMaxBytes :: Int
cacheMaxBytes = AppConfig -> Int
cfgCacheMaxBytes AppConfig
env
}