-- |
-- Module      : ZuulWeeder
-- Description : The project entrypoint
-- Copyright   : (c) Red Hat, 2022
-- License     : Apache-2.0
--
-- Maintainer  : tdecacqu@redhat.com, fboucher@redhat.com
-- Stability   : provisional
-- Portability : portable
--
-- The project entrypoint.
module ZuulWeeder (main, runDemo, demoConfig) where

import Data.Map qualified as Map
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Yaml (decodeThrow)
import Network.Wai.Handler.Warp as Warp (run)
import Streaming
import Streaming.Prelude qualified as S
import System.Environment
import Web.HttpApiData (toHeader)
import Zuul.Config (TenantName)
import Zuul.ConfigLoader (Config (..), ConnectionUrlMap, emptyConfig, loadConfig)
import Zuul.ServiceConfig (ServiceConfig (..), readServiceConfig)
import Zuul.Tenant
import Zuul.ZooKeeper
import ZuulWeeder.Graph
import ZuulWeeder.Monitoring qualified
import ZuulWeeder.Prelude
import ZuulWeeder.UI qualified

data Args = Args
  { Args -> FilePathT
zkPath :: FilePathT,
    Args -> FilePathT
configPath :: FilePathT
  }

getEnvArgs :: IO Args
getEnvArgs :: IO Args
getEnvArgs =
  FilePathT -> FilePathT -> Args
Args (FilePathT -> FilePathT -> Args)
-> IO FilePathT -> IO (FilePathT -> Args)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> String -> IO FilePathT
envPath String
"WEEDER_DATA" String
"/var/tmp/weeder" IO (FilePathT -> Args) -> IO FilePathT -> IO Args
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> String -> IO FilePathT
envPath String
"ZUUL_CONF" String
"/etc/zuul/zuul.conf"
  where
    envPath :: String -> FilePath -> IO FilePathT
    envPath :: String -> String -> IO FilePathT
envPath String
name String
def = Text -> FilePathT
FilePathT (Text -> FilePathT)
-> (Maybe String -> Text) -> Maybe String -> FilePathT
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (Maybe String -> String) -> Maybe String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
def (Maybe String -> FilePathT) -> IO (Maybe String) -> IO FilePathT
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
name

-- | The main function loads the config, prepare the analysis and serve the UI.
main :: IO ()
main :: IO ()
main = IO () -> IO ()
forall (m :: * -> *) r. (MonadIO m, MonadMask m) => m r -> m r
withUtf8 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Logger -> IO ()) -> IO ()
forall a. (Logger -> IO a) -> IO a
withLogger (\Logger
l -> IO Args
getEnvArgs IO Args -> (Args -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Logger -> Args -> IO ()
mainWithArgs Logger
l)

mainWithArgs :: Logger -> Args -> IO ()
mainWithArgs :: Logger -> Args -> IO ()
mainWithArgs Logger
logger Args
args = do
  (ConfigDumper
configDump, ConfigLoader
configLoader) <- do
    Either Text (ConfigDumper, ConfigLoader)
configLoader <- ExceptT Text IO (ConfigDumper, ConfigLoader)
-> IO (Either Text (ConfigDumper, ConfigLoader))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO (ConfigDumper, ConfigLoader)
 -> IO (Either Text (ConfigDumper, ConfigLoader)))
-> ExceptT Text IO (ConfigDumper, ConfigLoader)
-> IO (Either Text (ConfigDumper, ConfigLoader))
forall a b. (a -> b) -> a -> b
$ Logger
-> FilePathT
-> FilePathT
-> ExceptT Text IO (ConfigDumper, ConfigLoader)
mkConfigLoader Logger
logger Args
args.zkPath Args
args.configPath
    case Either Text (ConfigDumper, ConfigLoader)
configLoader of
      Left Text
e -> String -> IO (ConfigDumper, ConfigLoader)
forall a. HasCallStack => String -> a
error (String -> IO (ConfigDumper, ConfigLoader))
-> String -> IO (ConfigDumper, ConfigLoader)
forall a b. (a -> b) -> a -> b
$ Text -> String
Text.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Can't load config: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
e
      Right (ConfigDumper, ConfigLoader)
x -> (ConfigDumper, ConfigLoader) -> IO (ConfigDumper, ConfigLoader)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConfigDumper, ConfigLoader)
x
  IO Analysis
config <- Logger -> ConfigDumper -> ConfigLoader -> IO (IO Analysis)
configReloader Logger
logger ConfigDumper
configDump ConfigLoader
configLoader
  Logger -> IO Analysis -> IO ()
runWeb Logger
logger IO Analysis
config

-- | Start the web interface with the "demoConfig".
-- This is useful for ghcid powered hot-reload development.
runDemo :: IO ()
runDemo :: IO ()
runDemo = do
  (Logger -> IO ()) -> IO ()
forall a. (Logger -> IO a) -> IO a
withLogger ((Logger -> IO ()) -> IO ()) -> (Logger -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (Logger -> IO Analysis -> IO ()) -> IO Analysis -> Logger -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Logger -> IO Analysis -> IO ()
runWeb IO Analysis
demoConfig

runWeb :: Logger -> IO Analysis -> IO ()
runWeb :: Logger -> IO Analysis -> IO ()
runWeb Logger
logger IO Analysis
config = do
  Text
rootUrl <- Text -> Text
ensureTrailingSlash (Text -> Text) -> (Maybe String -> Text) -> Maybe String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text)
-> (Maybe String -> String) -> Maybe String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"/" (Maybe String -> Text) -> IO (Maybe String) -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"WEEDER_ROOT_URL"
  String
distPath <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"dists" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"WEEDER_DIST_PATH"
  Port
port <- Port -> (String -> Port) -> Maybe String -> Port
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Port
9001 String -> Port
forall a. Read a => String -> a
read (Maybe String -> Port) -> IO (Maybe String) -> IO Port
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"WEEDER_PORT"
  Logger -> ByteString -> IO ()
info Logger
logger (ByteString
"[+] serving 0.0.0.0:" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Port -> ByteString
forall a. ToHttpApiData a => a -> ByteString
toHeader Port
port ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall source target. From source target => source -> target
from Text
rootUrl)
  let app :: Application
app = IO Analysis -> BasePath -> String -> Application
ZuulWeeder.UI.app IO Analysis
config (Text -> BasePath
ZuulWeeder.UI.BasePath Text
rootUrl) String
distPath
  -- monitornig
  Middleware
monitoring <- Logger -> IO Middleware
ZuulWeeder.Monitoring.mkMonitoring Logger
logger
  Port -> Application -> IO ()
Warp.run Port
port (Middleware
monitoring Application
app)
  where
    ensureTrailingSlash :: Text -> Text
ensureTrailingSlash Text
url = case Text -> Maybe (Text, Char)
Text.unsnoc Text
url of
      Maybe (Text, Char)
Nothing -> Text
"/"
      Just (Text
x, Char
'/') -> Text -> Text
ensureTrailingSlash Text
x
      Maybe (Text, Char)
_ -> Text -> Char -> Text
Text.snoc Text
url Char
'/'

newtype ConfigDumper = ConfigDumper {ConfigDumper -> ExceptT Text IO ()
dumpConfig :: ExceptT Text IO ()}

newtype ConfigLoader = ConfigLoader {ConfigLoader -> ExceptT Text IO (TenantsConfig, Config)
loadConfig :: ExceptT Text IO (TenantsConfig, Config)}

-- | Create a IO action that reloads the config every hour.
configReloader :: Logger -> ConfigDumper -> ConfigLoader -> IO (IO Analysis)
configReloader :: Logger -> ConfigDumper -> ConfigLoader -> IO (IO Analysis)
configReloader Logger
logger ConfigDumper
configDumper ConfigLoader
configLoader = do
  -- Get current time
  Int64
now <- IO Int64
getSec
  -- Read the inital conf, error is fatal here
  (TenantsConfig, Config)
conf <- (Text -> (TenantsConfig, Config))
-> ((TenantsConfig, Config) -> (TenantsConfig, Config))
-> Either Text (TenantsConfig, Config)
-> (TenantsConfig, Config)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> (TenantsConfig, Config)
forall a. HasCallStack => String -> a
error (String -> (TenantsConfig, Config))
-> (Text -> String) -> Text -> (TenantsConfig, Config)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack) (TenantsConfig, Config) -> (TenantsConfig, Config)
forall a. a -> a
id (Either Text (TenantsConfig, Config) -> (TenantsConfig, Config))
-> IO (Either Text (TenantsConfig, Config))
-> IO (TenantsConfig, Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT Text IO (TenantsConfig, Config)
-> IO (Either Text (TenantsConfig, Config))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ConfigLoader
configLoader.loadConfig)
  -- Cache the result
  IORef Analysis
cache <- Analysis -> IO (IORef Analysis)
forall a. a -> IO (IORef a)
newIORef ((TenantsConfig -> Config -> Analysis)
-> (TenantsConfig, Config) -> Analysis
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TenantsConfig -> Config -> Analysis
analyzeConfig (TenantsConfig, Config)
conf)
  MVar (Int64, IORef Analysis)
ts <- (Int64, IORef Analysis) -> IO (MVar (Int64, IORef Analysis))
forall a. a -> IO (MVar a)
newMVar (Int64
now, IORef Analysis
cache)
  IO Analysis -> IO (IO Analysis)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MVar (Int64, IORef Analysis)
-> ((Int64, IORef Analysis)
    -> IO ((Int64, IORef Analysis), Analysis))
-> IO Analysis
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
modifyMVar MVar (Int64, IORef Analysis)
ts (Int64, IORef Analysis) -> IO ((Int64, IORef Analysis), Analysis)
go)
  where
    go :: (Int64, IORef Analysis) -> IO ((Int64, IORef Analysis), Analysis)
    go :: (Int64, IORef Analysis) -> IO ((Int64, IORef Analysis), Analysis)
go (Int64
ts, IORef Analysis
cache) = do
      Analysis
analysis <- IORef Analysis -> IO Analysis
forall a. IORef a -> IO a
readIORef IORef Analysis
cache
      Int64
now <- IO Int64
getSec
      if Int64
now Int64 -> Int64 -> Int64
forall a. Num a => a -> a -> a
- Int64
ts Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
3600
        then ((Int64, IORef Analysis), Analysis)
-> IO ((Int64, IORef Analysis), Analysis)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int64
ts, IORef Analysis
cache), Analysis
analysis)
        else do
          IORef Analysis -> IO ()
reload IORef Analysis
cache
          ((Int64, IORef Analysis), Analysis)
-> IO ((Int64, IORef Analysis), Analysis)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Int64
now, IORef Analysis
cache), Analysis
analysis)

    reload :: IORef Analysis -> IO ()
    reload :: IORef Analysis -> IO ()
reload IORef Analysis
cache = IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO do
      Maybe ()
res <- Port -> IO () -> IO (Maybe ())
forall a. Port -> IO a -> IO (Maybe a)
timeout Port
600_000_000 (IO () -> IO (Maybe ())) -> IO () -> IO (Maybe ())
forall a b. (a -> b) -> a -> b
$ do
        Logger -> ByteString -> IO ()
info Logger
logger ByteString
"ReLoading the configuration"
        Either Text (TenantsConfig, Config)
confE <- ExceptT Text IO (TenantsConfig, Config)
-> IO (Either Text (TenantsConfig, Config))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
          ConfigDumper
configDumper.dumpConfig
          ConfigLoader
configLoader.loadConfig
        case Either Text (TenantsConfig, Config)
confE of
          Left Text
e -> do
            Logger -> ByteString -> IO ()
info Logger
logger (ByteString
"Error reloading config: " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Text -> ByteString
forall source target. From source target => source -> target
from Text
e)
          Right (TenantsConfig, Config)
conf -> do
            Logger -> ByteString -> IO ()
info Logger
logger ByteString
"Caching the graph result"
            IORef Analysis -> Analysis -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Analysis
cache ((TenantsConfig -> Config -> Analysis)
-> (TenantsConfig, Config) -> Analysis
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry TenantsConfig -> Config -> Analysis
analyzeConfig (TenantsConfig, Config)
conf)
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe () -> Bool
forall a. Maybe a -> Bool
isNothing Maybe ()
res) do
        Logger -> ByteString -> IO ()
info Logger
logger ByteString
"Error reloading config timeout"

-- | Create IO actions to dump and load the config
mkConfigLoader :: Logger -> FilePathT -> FilePathT -> ExceptT Text IO (ConfigDumper, ConfigLoader)
mkConfigLoader :: Logger
-> FilePathT
-> FilePathT
-> ExceptT Text IO (ConfigDumper, ConfigLoader)
mkConfigLoader Logger
logger FilePathT
dataBaseDir FilePathT
configFile = do
  -- Load the zuul.conf
  ServiceConfig
serviceConfig <- IO Text -> ExceptT Text IO ServiceConfig
readServiceConfig (FilePathT -> IO Text
readFileText FilePathT
configFile)
  (ConfigDumper, ConfigLoader)
-> ExceptT Text IO (ConfigDumper, ConfigLoader)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServiceConfig -> ConfigDumper
configDumper ServiceConfig
serviceConfig, ServiceConfig -> ConfigLoader
go ServiceConfig
serviceConfig)
  where
    dataDir :: FilePathT
dataDir = FilePathT
dataBaseDir FilePathT -> FilePathT -> FilePathT
</> FilePathT
"data"
    configDumper :: ServiceConfig -> ConfigDumper
    configDumper :: ServiceConfig -> ConfigDumper
configDumper ServiceConfig
serviceConfig = ExceptT Text IO () -> ConfigDumper
ConfigDumper do
      Maybe String
env <- IO (Maybe String) -> ExceptT Text IO (Maybe String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe String) -> ExceptT Text IO (Maybe String))
-> IO (Maybe String) -> ExceptT Text IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> IO (Maybe String)
lookupEnv String
"ZUUL_WEEDER_NO_ZK"
      case Maybe String
env of
        Just String
_ -> IO () -> ExceptT Text IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> String -> IO ()
hPutStrLn Handle
stderr String
"[+] ZUUL_WEEDER_NO_ZK is set, skipping dumpZK"
        Maybe String
Nothing -> Logger -> FilePathT -> ZKConnection -> ExceptT Text IO ()
Zuul.ZooKeeper.fetchConfigs Logger
logger FilePathT
dataDir ServiceConfig
serviceConfig.zookeeper
    cp :: FilePathT
cp = FilePathT
dataDir FilePathT -> FilePathT -> FilePathT
</> Text -> FilePathT
FilePathT Text
"zuul/system/conf/0000000000"
    go :: ServiceConfig -> ConfigLoader
    go :: ServiceConfig -> ConfigLoader
go ServiceConfig
serviceConfig = ExceptT Text IO (TenantsConfig, Config) -> ConfigLoader
ConfigLoader do
      -- ensure data-dir exists
      ExceptT Text IO Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Bool -> Bool
not (Bool -> Bool) -> ExceptT Text IO Bool -> ExceptT Text IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO Bool -> ExceptT Text IO Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (FilePathT -> IO Bool
doesDirectoryExist FilePathT
cp)) (ConfigDumper -> ExceptT Text IO ()
dumpConfig (ConfigDumper -> ExceptT Text IO ())
-> ConfigDumper -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ ServiceConfig -> ConfigDumper
configDumper ServiceConfig
serviceConfig)
      -- read the tenants config from dataDir
      ZKTenantsConfig
systemConfig <- FilePathT -> ExceptT Text IO ZKTenantsConfig
readTenantsConfig FilePathT
dataDir
      -- decode the tenants config
      TenantsConfig
tenantsConfig <- Either Text TenantsConfig -> ExceptT Text IO TenantsConfig
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (ZKTenantsConfig -> Either Text TenantsConfig
decodeTenantsConfig ZKTenantsConfig
systemConfig)
      -- load all the config objects
      let tr :: TenantResolver
tr = ServiceConfig -> TenantsConfig -> TenantResolver
Zuul.Tenant.mkResolver ServiceConfig
serviceConfig TenantsConfig
tenantsConfig
          allTenants :: Set TenantName
allTenants = [TenantName] -> Set TenantName
forall a. Ord a => [a] -> Set a
Set.fromList ([TenantName] -> Set TenantName) -> [TenantName] -> Set TenantName
forall a b. (a -> b) -> a -> b
$ Map TenantName TenantConfig -> [TenantName]
forall k a. Map k a -> [k]
Map.keys TenantsConfig
tenantsConfig.tenants
      Config
config <- IO Config -> ExceptT Text IO Config
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Config -> ExceptT Text IO Config)
-> IO Config -> ExceptT Text IO Config
forall a b. (a -> b) -> a -> b
$ Set TenantName
-> ConnectionUrlMap -> TenantResolver -> FilePathT -> IO Config
loadConfigFiles Set TenantName
allTenants ServiceConfig
serviceConfig.urlBuilders TenantResolver
tr FilePathT
dataDir
      (TenantsConfig, Config) -> ExceptT Text IO (TenantsConfig, Config)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TenantsConfig
tenantsConfig, Config
config)

loadConfigFiles :: Set TenantName -> ConnectionUrlMap -> TenantResolver -> FilePathT -> IO Zuul.ConfigLoader.Config
loadConfigFiles :: Set TenantName
-> ConnectionUrlMap -> TenantResolver -> FilePathT -> IO Config
loadConfigFiles Set TenantName
tenants ConnectionUrlMap
ub TenantResolver
tr =
  (StateT Config IO () -> Config -> IO Config)
-> Config -> StateT Config IO () -> IO Config
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Config IO () -> Config -> IO Config
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Set TenantName -> Config
Zuul.ConfigLoader.emptyConfig Set TenantName
tenants)
    -- StateT Config IO ()
    (StateT Config IO () -> IO Config)
-> (FilePathT -> StateT Config IO ()) -> FilePathT -> IO Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Stream (Of (Either ConfigError ZKFile)) (StateT Config IO) ()
-> StateT Config IO ()
forall (m :: * -> *) a r. Monad m => Stream (Of a) m r -> m r
S.effects
    -- Apply the loadConfig function to each element
    (Stream (Of (Either ConfigError ZKFile)) (StateT Config IO) ()
 -> StateT Config IO ())
-> (FilePathT
    -> Stream (Of (Either ConfigError ZKFile)) (StateT Config IO) ())
-> FilePathT
-> StateT Config IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either ConfigError ZKFile -> StateT Config IO ())
-> Stream (Of (Either ConfigError ZKFile)) (StateT Config IO) ()
-> Stream (Of (Either ConfigError ZKFile)) (StateT Config IO) ()
forall (m :: * -> *) a y r.
Monad m =>
(a -> m y) -> Stream (Of a) m r -> Stream (Of a) m r
S.chain (ConnectionUrlMap
-> TenantResolver
-> Either ConfigError ZKFile
-> StateT Config IO ()
Zuul.ConfigLoader.loadConfig ConnectionUrlMap
ub TenantResolver
tr)
    -- Stream (Of ZKFile) (StateT Config IO)
    (Stream (Of (Either ConfigError ZKFile)) (StateT Config IO) ()
 -> Stream (Of (Either ConfigError ZKFile)) (StateT Config IO) ())
-> (FilePathT
    -> Stream (Of (Either ConfigError ZKFile)) (StateT Config IO) ())
-> FilePathT
-> Stream (Of (Either ConfigError ZKFile)) (StateT Config IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. IO a -> StateT Config IO a)
-> Stream (Of (Either ConfigError ZKFile)) IO ()
-> Stream (Of (Either ConfigError ZKFile)) (StateT Config IO) ()
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. IO a -> StateT Config IO a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
    -- Stream (Of ZKFile) IO
    (Stream (Of (Either ConfigError ZKFile)) IO ()
 -> Stream (Of (Either ConfigError ZKFile)) (StateT Config IO) ())
-> (FilePathT -> Stream (Of (Either ConfigError ZKFile)) IO ())
-> FilePathT
-> Stream (Of (Either ConfigError ZKFile)) (StateT Config IO) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePathT -> Stream (Of (Either ConfigError ZKFile)) IO ()
walkConfigNodes

-- | The demo configuration.
demoConfig :: IO Analysis
demoConfig :: IO Analysis
demoConfig = do
  (TenantsConfig
tenantsConfig, Config
config) <-
    (Text -> (TenantsConfig, Config))
-> ((TenantsConfig, Config) -> (TenantsConfig, Config))
-> Either Text (TenantsConfig, Config)
-> (TenantsConfig, Config)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> (TenantsConfig, Config)
forall a. HasCallStack => String -> a
error (String -> (TenantsConfig, Config))
-> (Text -> String) -> Text -> (TenantsConfig, Config)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. Show a => a -> String
show) (TenantsConfig, Config) -> (TenantsConfig, Config)
forall a. a -> a
id
      (Either Text (TenantsConfig, Config) -> (TenantsConfig, Config))
-> IO (Either Text (TenantsConfig, Config))
-> IO (TenantsConfig, Config)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT Text IO (TenantsConfig, Config)
-> IO (Either Text (TenantsConfig, Config))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT do
        ServiceConfig
serviceConfig <-
          IO Text -> ExceptT Text IO ServiceConfig
readServiceConfig
            ( Text -> IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                [s|
[zookeeper]
hosts=localhost
tls_cert=cert.pem
tls_key=key.pem
tls_ca=ca.pem

[connection gerrit]
driver=gerrit
server=managesf.sftests.com
canonical_hostname=sftests.com

[connection git]
driver=git
baseurl=http://localhost/cgit
|]
            )
        ZKTenantsConfig
systemConfig <-
          Value -> ZKTenantsConfig
ZKTenantsConfig
            (Value -> ZKTenantsConfig)
-> ExceptT Text IO Value -> ExceptT Text IO ZKTenantsConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> ExceptT Text IO Value
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
decodeThrow
              [s|
unparsed_abide:
  tenants:
    demo:
      source:
        git:
          config-projects:
            - project-config: {}
    local:
      source:
        gerrit:
          config-projects:
            - config: {}
          untrusted-projects:
            - sf-jobs: {}
            - triple-o
            - zuul-jobs:
                include: [job]
                shadow: sf-jobs
|]
        TenantsConfig
tenantsConfig <- Either Text TenantsConfig -> ExceptT Text IO TenantsConfig
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (ZKTenantsConfig -> Either Text TenantsConfig
decodeTenantsConfig ZKTenantsConfig
systemConfig)
        let tr :: TenantResolver
tr = ServiceConfig -> TenantsConfig -> TenantResolver
Zuul.Tenant.mkResolver ServiceConfig
serviceConfig TenantsConfig
tenantsConfig
            allTenants :: Set TenantName
allTenants = [TenantName] -> Set TenantName
forall a. Ord a => [a] -> Set a
Set.fromList ([TenantName] -> Set TenantName) -> [TenantName] -> Set TenantName
forall a b. (a -> b) -> a -> b
$ Map TenantName TenantConfig -> [TenantName]
forall k a. Map k a -> [k]
Map.keys TenantsConfig
tenantsConfig.tenants
        Config
conf <- IO Config -> ExceptT Text IO Config
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Config -> ExceptT Text IO Config)
-> IO Config -> ExceptT Text IO Config
forall a b. (a -> b) -> a -> b
$ (StateT Config IO () -> Config -> IO Config)
-> Config -> StateT Config IO () -> IO Config
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Config IO () -> Config -> IO Config
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Set TenantName -> Config
Zuul.ConfigLoader.emptyConfig Set TenantName
allTenants) do
          [ZKFile]
xs <- [StateT Config IO ZKFile] -> StateT Config IO [ZKFile]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [StateT Config IO ZKFile]
configFiles
          (Either ConfigError ZKFile -> StateT Config IO ())
-> [Either ConfigError ZKFile] -> StateT Config IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (ConnectionUrlMap
-> TenantResolver
-> Either ConfigError ZKFile
-> StateT Config IO ()
Zuul.ConfigLoader.loadConfig ServiceConfig
serviceConfig.urlBuilders TenantResolver
tr) (ZKFile -> Either ConfigError ZKFile
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ZKFile -> Either ConfigError ZKFile)
-> [ZKFile] -> [Either ConfigError ZKFile]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ZKFile]
xs)
        (TenantsConfig, Config) -> ExceptT Text IO (TenantsConfig, Config)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TenantsConfig
tenantsConfig, Config
conf)

  let analysis :: Analysis
analysis = TenantsConfig -> Config -> Analysis
analyzeConfig TenantsConfig
tenantsConfig Config
config
  -- pPrint analysis.config.triggers
  -- pPrint (Algebra.Graph.edgeList analysis.dependentGraph)
  Analysis -> IO Analysis
forall (f :: * -> *) a. Applicative f => a -> f a
pure Analysis
analysis
  where
    mkConfigFile :: Text -> Text -> ByteString -> f ZKFile
mkConfigFile Text
conn Text
proj ByteString
conf =
      Text -> Text -> Text -> FilePathT -> FilePathT -> Value -> ZKFile
ZKFile Text
conn Text
proj Text
"main" (Text -> FilePathT
FilePathT Text
".zuul.yaml") (Text -> FilePathT
FilePathT Text
"/") (Value -> ZKFile) -> f Value -> f ZKFile
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> f Value
forall (m :: * -> *) a.
(MonadThrow m, FromJSON a) =>
ByteString -> m a
decodeThrow ByteString
conf
    configFiles :: [StateT Config IO ZKFile]
configFiles =
      [ Text -> Text -> ByteString -> StateT Config IO ZKFile
forall {f :: * -> *}.
MonadThrow f =>
Text -> Text -> ByteString -> f ZKFile
mkConfigFile
          Text
"sftests.com"
          Text
"config"
          [s|
- job:
    name: base
    abstract: true
    nodeset: centos
    secrets: log-key

- secret:
    name: log-key

- nodeset:
    name: centos
    nodes:
      - name: runner
        label: cloud-centos-7

- queue:
    name: queue

- pipeline:
    name: check
    trigger:
      timer: {}
    success:
      elastic:

- job:
    name: wallaby-job

- job:
    name: zena-job

- job:
    name: config-check

- project-template:
    name: common
    check:
      jobs:
        - linter

- project:
    templates:
      - common
    check:
      jobs:
        - config-check

- project:
    name: triple-o
    queue: queue
    check:
      jobs:
        - wallaby-job
        - zena-job
        - linter:
            nodeset: centos
|],
        Text -> Text -> ByteString -> StateT Config IO ZKFile
forall {f :: * -> *}.
MonadThrow f =>
Text -> Text -> ByteString -> f ZKFile
mkConfigFile
          Text
"sftests.com"
          Text
"sf-jobs"
          [s|
- job:
    name: linter
    nodeset:
      nodes:
        - name: container
          label: pod-centos-7
|],
        Text -> Text -> ByteString -> StateT Config IO ZKFile
forall {f :: * -> *}.
MonadThrow f =>
Text -> Text -> ByteString -> f ZKFile
mkConfigFile
          Text
"localhost"
          Text
"project-config"
          [s|
- job:
    name: base
    nodeset: rhel

- nodeset:
    name: rhel
    nodes:
      - name: runner
        label: cloud-rhel-7
|]
      ]