-- |
-- Module      : Zuul.Serviceconfig
-- Description : Helper for zuul.conf
-- Copyright   : (c) Red Hat, 2022
-- License     : Apache-2.0
--
-- Maintainer  : tdecacqu@redhat.com, fboucher@redhat.com
-- Stability   : provisional
-- Portability : portable
--
-- The Zuul Service configuration (zuul.conf)
module Zuul.ServiceConfig
  ( ServiceConfig (..),
    readServiceConfig,
  )
where

import Data.HashMap.Strict qualified as HM
import Data.Ini qualified
import Data.Map qualified as Map
import Data.Text qualified as Text
import Network.URI (parseURI, uriAuthority, uriRegName)
import Zuul.Config
  ( ConnectionName (ConnectionName),
    ConnectionUrl (..),
    ProviderName (ProviderName),
  )
import Zuul.ZooKeeper (ZKConnection (..))
import ZuulWeeder.Prelude

type ConfigSection = (Text, [(Text, Text)])

-- | The zuul.conf content
data ServiceConfig = ServiceConfig
  { -- | The list of connections.
    ServiceConfig -> Map ConnectionName ProviderName
connections :: Map ConnectionName ProviderName,
    -- | The list of connection urls, to build config loc url in the UI.
    ServiceConfig -> Map ProviderName ConnectionUrl
urlBuilders :: Map ProviderName ConnectionUrl,
    -- | The dump script parameter: hosts, key, cert, ca
    ServiceConfig -> ZKConnection
zookeeper :: ZKConnection
  }
  deriving (Int -> ServiceConfig -> ShowS
[ServiceConfig] -> ShowS
ServiceConfig -> String
(Int -> ServiceConfig -> ShowS)
-> (ServiceConfig -> String)
-> ([ServiceConfig] -> ShowS)
-> Show ServiceConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ServiceConfig] -> ShowS
$cshowList :: [ServiceConfig] -> ShowS
show :: ServiceConfig -> String
$cshow :: ServiceConfig -> String
showsPrec :: Int -> ServiceConfig -> ShowS
$cshowsPrec :: Int -> ServiceConfig -> ShowS
Show)

-- | Read the zuul.conf file
readServiceConfig ::
  -- | An action to produce the zuul.conf content
  IO Text ->
  -- | The decoded config
  ExceptT Text IO ServiceConfig
readServiceConfig :: IO Text -> ExceptT Text IO ServiceConfig
readServiceConfig IO Text
getContent = do
  Text
content <- IO Text -> ExceptT Text IO Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO Text
getContent
  case Text -> Either String Ini
Data.Ini.parseIni Text
content of
    Right (Data.Ini.Ini HashMap Text [(Text, Text)]
sections [(Text, Text)]
_) -> Either Text ServiceConfig -> ExceptT Text IO ServiceConfig
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either Text ServiceConfig -> ExceptT Text IO ServiceConfig)
-> Either Text ServiceConfig -> ExceptT Text IO ServiceConfig
forall a b. (a -> b) -> a -> b
$ HashMap Text [(Text, Text)] -> Either Text ServiceConfig
parseConfig HashMap Text [(Text, Text)]
sections
    Left String
_ -> Text -> ExceptT Text IO ServiceConfig
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
"Unable to read Zuul config file"

parseConfig :: HM.HashMap Text [(Text, Text)] -> Either Text ServiceConfig
parseConfig :: HashMap Text [(Text, Text)] -> Either Text ServiceConfig
parseConfig HashMap Text [(Text, Text)]
sections = do
  ZKConnection
zookeeper <- do
    [(Text, Text)]
zkSection <- Either Text [(Text, Text)]
getZkSection
    let getZK :: Text -> Either Text Text
getZK Text
k = Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
k [(Text, Text)]
zkSection Maybe Text -> Text -> Either Text Text
forall a b. Maybe a -> b -> Either b a
`orDie` (Text
"No " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" in zookeeper section")
    [Text] -> ZKConnection
ZKConnection ([Text] -> ZKConnection)
-> Either Text [Text] -> Either Text ZKConnection
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Either Text Text) -> [Text] -> Either Text [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Text -> Either Text Text
getZK [Text
"hosts", Text
"tls_key", Text
"tls_cert", Text
"tls_ca"]
  Map ConnectionName ProviderName
connections <- [(ConnectionName, ProviderName)] -> Map ConnectionName ProviderName
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(ConnectionName, ProviderName)]
 -> Map ConnectionName ProviderName)
-> ([Maybe (ConnectionName, ProviderName)]
    -> [(ConnectionName, ProviderName)])
-> [Maybe (ConnectionName, ProviderName)]
-> Map ConnectionName ProviderName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (ConnectionName, ProviderName)]
-> [(ConnectionName, ProviderName)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (ConnectionName, ProviderName)]
 -> Map ConnectionName ProviderName)
-> Either Text [Maybe (ConnectionName, ProviderName)]
-> Either Text (Map ConnectionName ProviderName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConfigSection
 -> Either Text (Maybe (ConnectionName, ProviderName)))
-> [ConfigSection]
-> Either Text [Maybe (ConnectionName, ProviderName)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ConfigSection -> Either Text (Maybe (ConnectionName, ProviderName))
getConn (HashMap Text [(Text, Text)] -> [ConfigSection]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Text [(Text, Text)]
connSections)
  let urlBuilders :: Map ProviderName ConnectionUrl
urlBuilders = [(ProviderName, ConnectionUrl)] -> Map ProviderName ConnectionUrl
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ((ConfigSection -> Maybe (ProviderName, ConnectionUrl))
-> [ConfigSection] -> [(ProviderName, ConnectionUrl)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ConfigSection -> Maybe (ProviderName, ConnectionUrl)
getGitwebBuilder (HashMap Text [(Text, Text)] -> [ConfigSection]
forall k v. HashMap k v -> [(k, v)]
HM.toList HashMap Text [(Text, Text)]
connSections))
  ServiceConfig -> Either Text ServiceConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ServiceConfig -> Either Text ServiceConfig)
-> ServiceConfig -> Either Text ServiceConfig
forall a b. (a -> b) -> a -> b
$ ServiceConfig {Map ConnectionName ProviderName
connections :: Map ConnectionName ProviderName
$sel:connections:ServiceConfig :: Map ConnectionName ProviderName
connections, Map ProviderName ConnectionUrl
urlBuilders :: Map ProviderName ConnectionUrl
$sel:urlBuilders:ServiceConfig :: Map ProviderName ConnectionUrl
urlBuilders, ZKConnection
zookeeper :: ZKConnection
$sel:zookeeper:ServiceConfig :: ZKConnection
zookeeper}
  where
    getZkSection :: Either Text [(Text, Text)]
getZkSection = Text -> HashMap Text [(Text, Text)] -> Maybe [(Text, Text)]
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"zookeeper" HashMap Text [(Text, Text)]
sections Maybe [(Text, Text)] -> Text -> Either Text [(Text, Text)]
forall a b. Maybe a -> b -> Either b a
`orDie` Text
"No zookeeper section"
    connSections :: HashMap Text [(Text, Text)]
connSections = (Text -> [(Text, Text)] -> Bool)
-> HashMap Text [(Text, Text)] -> HashMap Text [(Text, Text)]
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HM.filterWithKey (\Text
k [(Text, Text)]
_ -> Text -> Text -> Bool
Text.isPrefixOf Text
"connection " Text
k) HashMap Text [(Text, Text)]
sections

    getGitwebBuilder :: ConfigSection -> Maybe (ProviderName, ConnectionUrl)
    getGitwebBuilder :: ConfigSection -> Maybe (ProviderName, ConnectionUrl)
getGitwebBuilder (Text
_, [(Text, Text)]
section) =
      let sectionHM :: HashMap Text Text
sectionHM = [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text, Text)]
section
       in case Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"driver" HashMap Text Text
sectionHM of
            Just Text
driver | Text
driver Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"gerrit", Text
"gitlab", Text
"pagure"] -> do
              let baseUrl :: Text
baseUrl = HashMap Text Text -> Text
getBaseUrl HashMap Text Text
sectionHM
              case HashMap Text Text -> Either Text Text
forall {k} {a}.
(Hashable k, IsString k, Show k, Show a) =>
HashMap k a -> Either Text a
getCanonicalName HashMap Text Text
sectionHM of
                Right Text
canonicalName ->
                  (ProviderName, ConnectionUrl)
-> Maybe (ProviderName, ConnectionUrl)
forall a. a -> Maybe a
Just (Text -> ProviderName
ProviderName Text
canonicalName, Text -> Text -> ConnectionUrl
forall {source}.
(Eq source, IsString source, From source String) =>
source -> Text -> ConnectionUrl
getUrl Text
driver Text
baseUrl)
                Either Text Text
_ -> Maybe (ProviderName, ConnectionUrl)
forall a. Maybe a
Nothing
            Just Text
"github" -> do
              let baseUrl :: Text
baseUrl = Text
"https://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"github.com" (Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"server" HashMap Text Text
sectionHM)
              case HashMap Text Text -> Either Text Text
forall {k} {a}.
(Hashable k, IsString k, Show k, Show a) =>
HashMap k a -> Either Text a
getCanonicalName HashMap Text Text
sectionHM of
                Right Text
canonicalName ->
                  (ProviderName, ConnectionUrl)
-> Maybe (ProviderName, ConnectionUrl)
forall a. a -> Maybe a
Just (Text -> ProviderName
ProviderName Text
canonicalName, Text -> ConnectionUrl
GithubUrl Text
baseUrl)
                Either Text Text
_ -> Maybe (ProviderName, ConnectionUrl)
forall a. Maybe a
Nothing
            Just Text
"git" -> do
              case HashMap Text Text -> Either Text (Text, Text)
forall {k} {b} {a}.
(Hashable k, IsString k, IsString b, Semigroup b, From b String,
 From String a) =>
HashMap k b -> Either b (a, b)
getGitProviderInfo HashMap Text Text
sectionHM of
                Left Text
x -> String -> Maybe (ProviderName, ConnectionUrl)
forall a. HasCallStack => String -> a
error (String -> Maybe (ProviderName, ConnectionUrl))
-> String -> Maybe (ProviderName, ConnectionUrl)
forall a b. (a -> b) -> a -> b
$ String
"Can't get git url: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
x
                Right (Text
pn, Text
baseUrl) -> (ProviderName, ConnectionUrl)
-> Maybe (ProviderName, ConnectionUrl)
forall a. a -> Maybe a
Just (Text -> ProviderName
ProviderName Text
pn, Text -> ConnectionUrl
GitUrl Text
baseUrl)
            Maybe Text
_ -> Maybe (ProviderName, ConnectionUrl)
forall a. Maybe a
Nothing
      where
        getUrl :: source -> Text -> ConnectionUrl
getUrl source
driver Text
url = case source
driver of
          source
"gerrit" -> Text -> ConnectionUrl
GerritUrl Text
url
          source
"gitlab" -> Text -> ConnectionUrl
GitlabUrl Text
url
          source
"pagure" -> Text -> ConnectionUrl
PagureUrl Text
url
          source
_ -> String -> ConnectionUrl
forall a. HasCallStack => String -> a
error (String -> ConnectionUrl) -> String -> ConnectionUrl
forall a b. (a -> b) -> a -> b
$ String
"Unknown driver type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> source -> String
forall source target. From source target => source -> target
from source
driver
        getBaseUrl :: HM.HashMap Text Text -> Text
        getBaseUrl :: HashMap Text Text -> Text
getBaseUrl HashMap Text Text
sectionHM = case Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"baseurl" HashMap Text Text
sectionHM of
          Just Text
url -> Text
url
          Maybe Text
Nothing -> case HashMap Text Text -> Either Text Text
forall {k} {a}.
(Hashable k, IsString k, Show k, Show a) =>
HashMap k a -> Either Text a
getServer HashMap Text Text
sectionHM of
            Right Text
server -> Text
"https://" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
server
            Left Text
_ -> String -> Text
forall a. HasCallStack => String -> a
error (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Unable to find 'server' attribute in: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> HashMap Text Text -> String
forall a. Show a => a -> String
show HashMap Text Text
sectionHM

    getConn :: ConfigSection -> Either Text (Maybe (ConnectionName, ProviderName))
    getConn :: ConfigSection -> Either Text (Maybe (ConnectionName, ProviderName))
getConn (Text
sectionName, [(Text, Text)]
section) =
      let sectionHM :: HashMap Text Text
sectionHM = [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList [(Text, Text)]
section
       in case Text -> HashMap Text Text -> Maybe Text
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
"driver" HashMap Text Text
sectionHM of
            Just Text
driver | Text
driver Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"gerrit", Text
"github", Text
"gitlab", Text
"pagure"] -> do
              Text
server <- HashMap Text Text -> Either Text Text
forall {k} {a}.
(Hashable k, IsString k, Show k, Show a) =>
HashMap k a -> Either Text a
getCanonicalName HashMap Text Text
sectionHM
              Maybe (ConnectionName, ProviderName)
-> Either Text (Maybe (ConnectionName, ProviderName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ConnectionName, ProviderName)
 -> Either Text (Maybe (ConnectionName, ProviderName)))
-> Maybe (ConnectionName, ProviderName)
-> Either Text (Maybe (ConnectionName, ProviderName))
forall a b. (a -> b) -> a -> b
$ (ConnectionName, ProviderName)
-> Maybe (ConnectionName, ProviderName)
forall a. a -> Maybe a
Just (Text -> ConnectionName
getSectionName Text
sectionName, Text -> ProviderName
ProviderName Text
server)
            Just Text
"git" -> do
              (Text
pn, Text
_) <- HashMap Text Text -> Either Text (Text, Text)
forall {k} {b} {a}.
(Hashable k, IsString k, IsString b, Semigroup b, From b String,
 From String a) =>
HashMap k b -> Either b (a, b)
getGitProviderInfo HashMap Text Text
sectionHM
              Maybe (ConnectionName, ProviderName)
-> Either Text (Maybe (ConnectionName, ProviderName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (ConnectionName, ProviderName)
 -> Either Text (Maybe (ConnectionName, ProviderName)))
-> Maybe (ConnectionName, ProviderName)
-> Either Text (Maybe (ConnectionName, ProviderName))
forall a b. (a -> b) -> a -> b
$ (ConnectionName, ProviderName)
-> Maybe (ConnectionName, ProviderName)
forall a. a -> Maybe a
Just (Text -> ConnectionName
getSectionName Text
sectionName, Text -> ProviderName
ProviderName Text
pn)
            Maybe Text
_ -> Maybe (ConnectionName, ProviderName)
-> Either Text (Maybe (ConnectionName, ProviderName))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (ConnectionName, ProviderName)
forall a. Maybe a
Nothing

    -- return ('host','http://host:42/') from "baseurl=http://host:42/"
    getGitProviderInfo :: HashMap k b -> Either b (a, b)
getGitProviderInfo HashMap k b
section = do
      b
baseUrl <- k -> HashMap k b -> Maybe b
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup k
"baseurl" HashMap k b
section Maybe b -> b -> Either b b
forall a b. Maybe a -> b -> Either b a
`orDie` b
"No baseurl"
      URI
uri <- String -> Maybe URI
parseURI (b -> String
forall source target. From source target => source -> target
from b
baseUrl) Maybe URI -> b -> Either b URI
forall a b. Maybe a -> b -> Either b a
`orDie` (b
"Unable to parse URI: " b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
baseUrl)
      URIAuth
host <- URI -> Maybe URIAuth
uriAuthority URI
uri Maybe URIAuth -> b -> Either b URIAuth
forall a b. Maybe a -> b -> Either b a
`orDie` b
"invalid url"
      (a, b) -> Either b (a, b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> a
forall source target. From source target => source -> target
from (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ URIAuth -> String
uriRegName URIAuth
host, b
baseUrl)

    dropSectionPrefix :: Text -> Text
dropSectionPrefix = Int -> Text -> Text
Text.drop Int
11
    getSectionName :: Text -> ConnectionName
getSectionName Text
sn = Text -> ConnectionName
ConnectionName (Text -> ConnectionName) -> Text -> ConnectionName
forall a b. (a -> b) -> a -> b
$ Text -> Text
dropSectionPrefix Text
sn
    getCanonicalName :: HashMap k a -> Either Text a
getCanonicalName HashMap k a
hm = case k -> HashMap k a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup k
"canonical_hostname" HashMap k a
hm of
      Just a
hostname -> a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
hostname
      Maybe a
Nothing -> HashMap k a -> Either Text a
forall {k} {a}.
(Hashable k, IsString k, Show k, Show a) =>
HashMap k a -> Either Text a
getServer HashMap k a
hm
    getServer :: HashMap k a -> Either Text a
getServer HashMap k a
hm = case k -> HashMap k a -> Maybe a
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup k
"server" HashMap k a
hm of
      Just a
server -> a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
server
      Maybe a
Nothing -> Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"Unable to find mandatory 'server' key in: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (HashMap k a -> String
forall a. Show a => a -> String
show HashMap k a
hm)