{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}

module SAML2.WebSSO.Config where

import Control.Lens hiding (Level, element, enum, (.=))
import Control.Monad (when)
import Data.Aeson qualified as A
import Data.Domain
import Data.Map
import Data.Map qualified as Map
import Data.Schema
import Data.String.Conversions
import Data.Yaml qualified as Yaml
import GHC.Generics
import SAML2.WebSSO.Types
import System.Environment
import System.FilePath
import System.IO
import System.Logger (Level (..))
import URI.ByteString
import URI.ByteString.QQ

----------------------------------------------------------------------
-- data types

data Config = Config
  { Config -> Level
_cfgLogLevel :: Level,
    Config -> FilePath
_cfgSPHost :: String,
    Config -> Int
_cfgSPPort :: Int,
    -- | if you don't use the multi-ingress feature, you only ever need one of these, so
    -- you'll use the `Left` case.
    Config
-> Either
     MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
_cfgDomainConfigs ::
      Either MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
  }
  deriving (Config -> Config -> Bool
(Config -> Config -> Bool)
-> (Config -> Config -> Bool) -> Eq Config
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Config -> Config -> Bool
== :: Config -> Config -> Bool
$c/= :: Config -> Config -> Bool
/= :: Config -> Config -> Bool
Eq, Int -> Config -> ShowS
[Config] -> ShowS
Config -> FilePath
(Int -> Config -> ShowS)
-> (Config -> FilePath) -> ([Config] -> ShowS) -> Show Config
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Config -> ShowS
showsPrec :: Int -> Config -> ShowS
$cshow :: Config -> FilePath
show :: Config -> FilePath
$cshowList :: [Config] -> ShowS
showList :: [Config] -> ShowS
Show, (forall x. Config -> Rep Config x)
-> (forall x. Rep Config x -> Config) -> Generic Config
forall x. Rep Config x -> Config
forall x. Config -> Rep Config x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Config -> Rep Config x
from :: forall x. Config -> Rep Config x
$cto :: forall x. Rep Config x -> Config
to :: forall x. Rep Config x -> Config
Generic)
  deriving ([Config] -> Value
[Config] -> Encoding
Config -> Bool
Config -> Value
Config -> Encoding
(Config -> Value)
-> (Config -> Encoding)
-> ([Config] -> Value)
-> ([Config] -> Encoding)
-> (Config -> Bool)
-> ToJSON Config
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: Config -> Value
toJSON :: Config -> Value
$ctoEncoding :: Config -> Encoding
toEncoding :: Config -> Encoding
$ctoJSONList :: [Config] -> Value
toJSONList :: [Config] -> Value
$ctoEncodingList :: [Config] -> Encoding
toEncodingList :: [Config] -> Encoding
$comitField :: Config -> Bool
omitField :: Config -> Bool
A.ToJSON, Maybe Config
Value -> Parser [Config]
Value -> Parser Config
(Value -> Parser Config)
-> (Value -> Parser [Config]) -> Maybe Config -> FromJSON Config
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser Config
parseJSON :: Value -> Parser Config
$cparseJSONList :: Value -> Parser [Config]
parseJSONList :: Value -> Parser [Config]
$comittedField :: Maybe Config
omittedField :: Maybe Config
A.FromJSON) via Schema Config

getMultiIngressDomainConfig :: Config -> Maybe Domain -> Maybe MultiIngressDomainConfig
getMultiIngressDomainConfig :: Config -> Maybe Domain -> Maybe MultiIngressDomainConfig
getMultiIngressDomainConfig Config
config Maybe Domain
mbDomain =
  case (Config
-> Either
     MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
_cfgDomainConfigs Config
config, Maybe Domain
mbDomain) of
    (Left MultiIngressDomainConfig
cfg, Maybe Domain
_) -> MultiIngressDomainConfig -> Maybe MultiIngressDomainConfig
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure MultiIngressDomainConfig
cfg
    (Right Map Domain MultiIngressDomainConfig
cfgMap, Just Domain
d) -> Domain
-> Map Domain MultiIngressDomainConfig
-> Maybe MultiIngressDomainConfig
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Domain
d Map Domain MultiIngressDomainConfig
cfgMap
    (Right Map Domain MultiIngressDomainConfig
_, Maybe Domain
Nothing) -> Maybe MultiIngressDomainConfig
forall a. Maybe a
Nothing

data MultiIngressDomainConfig = MultiIngressDomainConfig
  { MultiIngressDomainConfig -> URI
_cfgSPAppURI :: URI,
    MultiIngressDomainConfig -> URI
_cfgSPSsoURI :: URI,
    MultiIngressDomainConfig -> [ContactPerson]
_cfgContacts :: [ContactPerson]
  }
  deriving (MultiIngressDomainConfig -> MultiIngressDomainConfig -> Bool
(MultiIngressDomainConfig -> MultiIngressDomainConfig -> Bool)
-> (MultiIngressDomainConfig -> MultiIngressDomainConfig -> Bool)
-> Eq MultiIngressDomainConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MultiIngressDomainConfig -> MultiIngressDomainConfig -> Bool
== :: MultiIngressDomainConfig -> MultiIngressDomainConfig -> Bool
$c/= :: MultiIngressDomainConfig -> MultiIngressDomainConfig -> Bool
/= :: MultiIngressDomainConfig -> MultiIngressDomainConfig -> Bool
Eq, Int -> MultiIngressDomainConfig -> ShowS
[MultiIngressDomainConfig] -> ShowS
MultiIngressDomainConfig -> FilePath
(Int -> MultiIngressDomainConfig -> ShowS)
-> (MultiIngressDomainConfig -> FilePath)
-> ([MultiIngressDomainConfig] -> ShowS)
-> Show MultiIngressDomainConfig
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MultiIngressDomainConfig -> ShowS
showsPrec :: Int -> MultiIngressDomainConfig -> ShowS
$cshow :: MultiIngressDomainConfig -> FilePath
show :: MultiIngressDomainConfig -> FilePath
$cshowList :: [MultiIngressDomainConfig] -> ShowS
showList :: [MultiIngressDomainConfig] -> ShowS
Show, (forall x.
 MultiIngressDomainConfig -> Rep MultiIngressDomainConfig x)
-> (forall x.
    Rep MultiIngressDomainConfig x -> MultiIngressDomainConfig)
-> Generic MultiIngressDomainConfig
forall x.
Rep MultiIngressDomainConfig x -> MultiIngressDomainConfig
forall x.
MultiIngressDomainConfig -> Rep MultiIngressDomainConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x.
MultiIngressDomainConfig -> Rep MultiIngressDomainConfig x
from :: forall x.
MultiIngressDomainConfig -> Rep MultiIngressDomainConfig x
$cto :: forall x.
Rep MultiIngressDomainConfig x -> MultiIngressDomainConfig
to :: forall x.
Rep MultiIngressDomainConfig x -> MultiIngressDomainConfig
Generic)
  deriving ([MultiIngressDomainConfig] -> Value
[MultiIngressDomainConfig] -> Encoding
MultiIngressDomainConfig -> Bool
MultiIngressDomainConfig -> Value
MultiIngressDomainConfig -> Encoding
(MultiIngressDomainConfig -> Value)
-> (MultiIngressDomainConfig -> Encoding)
-> ([MultiIngressDomainConfig] -> Value)
-> ([MultiIngressDomainConfig] -> Encoding)
-> (MultiIngressDomainConfig -> Bool)
-> ToJSON MultiIngressDomainConfig
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: MultiIngressDomainConfig -> Value
toJSON :: MultiIngressDomainConfig -> Value
$ctoEncoding :: MultiIngressDomainConfig -> Encoding
toEncoding :: MultiIngressDomainConfig -> Encoding
$ctoJSONList :: [MultiIngressDomainConfig] -> Value
toJSONList :: [MultiIngressDomainConfig] -> Value
$ctoEncodingList :: [MultiIngressDomainConfig] -> Encoding
toEncodingList :: [MultiIngressDomainConfig] -> Encoding
$comitField :: MultiIngressDomainConfig -> Bool
omitField :: MultiIngressDomainConfig -> Bool
A.ToJSON, Maybe MultiIngressDomainConfig
Value -> Parser [MultiIngressDomainConfig]
Value -> Parser MultiIngressDomainConfig
(Value -> Parser MultiIngressDomainConfig)
-> (Value -> Parser [MultiIngressDomainConfig])
-> Maybe MultiIngressDomainConfig
-> FromJSON MultiIngressDomainConfig
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser MultiIngressDomainConfig
parseJSON :: Value -> Parser MultiIngressDomainConfig
$cparseJSONList :: Value -> Parser [MultiIngressDomainConfig]
parseJSONList :: Value -> Parser [MultiIngressDomainConfig]
$comittedField :: Maybe MultiIngressDomainConfig
omittedField :: Maybe MultiIngressDomainConfig
A.FromJSON) via Schema MultiIngressDomainConfig

----------------------------------------------------------------------
-- schema-profunctor

data ConfigRaw = ConfigRaw
  { ConfigRaw -> Level
_cfgRawLogLevel :: Level,
    ConfigRaw -> FilePath
_cfgRawSPHost :: String,
    ConfigRaw -> Int
_cfgRawSPPort :: Int,
    ConfigRaw -> Maybe (Map Domain MultiIngressDomainConfig)
_cfgRawDomainConfigs :: Maybe (Map Domain MultiIngressDomainConfig),
    ConfigRaw -> Maybe URI
_cfgRawSPAppURI :: Maybe URI,
    ConfigRaw -> Maybe URI
_cfgRawSPSsoURI :: Maybe URI,
    ConfigRaw -> Maybe [ContactPerson]
_cfgRawContacts :: Maybe [ContactPerson]
  }
  deriving (Int -> ConfigRaw -> ShowS
[ConfigRaw] -> ShowS
ConfigRaw -> FilePath
(Int -> ConfigRaw -> ShowS)
-> (ConfigRaw -> FilePath)
-> ([ConfigRaw] -> ShowS)
-> Show ConfigRaw
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConfigRaw -> ShowS
showsPrec :: Int -> ConfigRaw -> ShowS
$cshow :: ConfigRaw -> FilePath
show :: ConfigRaw -> FilePath
$cshowList :: [ConfigRaw] -> ShowS
showList :: [ConfigRaw] -> ShowS
Show)

instance ToSchema ConfigRaw where
  schema :: ValueSchema NamedSwaggerDoc ConfigRaw
schema =
    Text
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw ConfigRaw
-> ValueSchema NamedSwaggerDoc ConfigRaw
forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object Text
"ConfigRaw" (SchemaP SwaggerDoc Object [Pair] ConfigRaw ConfigRaw
 -> ValueSchema NamedSwaggerDoc ConfigRaw)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw ConfigRaw
-> ValueSchema NamedSwaggerDoc ConfigRaw
forall a b. (a -> b) -> a -> b
$
      Level
-> FilePath
-> Int
-> Maybe (Map Domain MultiIngressDomainConfig)
-> Maybe URI
-> Maybe URI
-> Maybe [ContactPerson]
-> ConfigRaw
ConfigRaw
        (Level
 -> FilePath
 -> Int
 -> Maybe (Map Domain MultiIngressDomainConfig)
 -> Maybe URI
 -> Maybe URI
 -> Maybe [ContactPerson]
 -> ConfigRaw)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw Level
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     ConfigRaw
     (FilePath
      -> Int
      -> Maybe (Map Domain MultiIngressDomainConfig)
      -> Maybe URI
      -> Maybe URI
      -> Maybe [ContactPerson]
      -> ConfigRaw)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ConfigRaw -> Level
_cfgRawLogLevel (ConfigRaw -> Level)
-> SchemaP SwaggerDoc Object [Pair] Level Level
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw Level
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value Level Level
-> SchemaP SwaggerDoc Object [Pair] Level Level
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"logLevel" SchemaP NamedSwaggerDoc Value Value Level Level
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  ConfigRaw
  (FilePath
   -> Int
   -> Maybe (Map Domain MultiIngressDomainConfig)
   -> Maybe URI
   -> Maybe URI
   -> Maybe [ContactPerson]
   -> ConfigRaw)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw FilePath
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     ConfigRaw
     (Int
      -> Maybe (Map Domain MultiIngressDomainConfig)
      -> Maybe URI
      -> Maybe URI
      -> Maybe [ContactPerson]
      -> ConfigRaw)
forall a b.
SchemaP SwaggerDoc Object [Pair] ConfigRaw (a -> b)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw a
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ConfigRaw -> FilePath
_cfgRawSPHost (ConfigRaw -> FilePath)
-> SchemaP SwaggerDoc Object [Pair] FilePath FilePath
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw FilePath
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value FilePath FilePath
-> SchemaP SwaggerDoc Object [Pair] FilePath FilePath
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"spHost" SchemaP NamedSwaggerDoc Value Value FilePath FilePath
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  ConfigRaw
  (Int
   -> Maybe (Map Domain MultiIngressDomainConfig)
   -> Maybe URI
   -> Maybe URI
   -> Maybe [ContactPerson]
   -> ConfigRaw)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw Int
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     ConfigRaw
     (Maybe (Map Domain MultiIngressDomainConfig)
      -> Maybe URI -> Maybe URI -> Maybe [ContactPerson] -> ConfigRaw)
forall a b.
SchemaP SwaggerDoc Object [Pair] ConfigRaw (a -> b)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw a
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ConfigRaw -> Int
_cfgRawSPPort (ConfigRaw -> Int)
-> SchemaP SwaggerDoc Object [Pair] Int Int
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw Int
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value Int Int
-> SchemaP SwaggerDoc Object [Pair] Int Int
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"spPort" SchemaP NamedSwaggerDoc Value Value Int Int
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  ConfigRaw
  (Maybe (Map Domain MultiIngressDomainConfig)
   -> Maybe URI -> Maybe URI -> Maybe [ContactPerson] -> ConfigRaw)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     ConfigRaw
     (Maybe (Map Domain MultiIngressDomainConfig))
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     ConfigRaw
     (Maybe URI -> Maybe URI -> Maybe [ContactPerson] -> ConfigRaw)
forall a b.
SchemaP SwaggerDoc Object [Pair] ConfigRaw (a -> b)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw a
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ConfigRaw -> Maybe (Map Domain MultiIngressDomainConfig)
_cfgRawDomainConfigs (ConfigRaw -> Maybe (Map Domain MultiIngressDomainConfig))
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     (Maybe (Map Domain MultiIngressDomainConfig))
     (Maybe (Map Domain MultiIngressDomainConfig))
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     ConfigRaw
     (Maybe (Map Domain MultiIngressDomainConfig))
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= SchemaP
  SwaggerDoc
  Object
  [Pair]
  (Map Domain MultiIngressDomainConfig)
  (Maybe (Map Domain MultiIngressDomainConfig))
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     (Maybe (Map Domain MultiIngressDomainConfig))
     (Maybe (Map Domain MultiIngressDomainConfig))
forall w d v a b.
Monoid w =>
SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybe_ (Text
-> SchemaP
     SwaggerDoc
     Value
     Value
     (Map Domain MultiIngressDomainConfig)
     (Map Domain MultiIngressDomainConfig)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     (Map Domain MultiIngressDomainConfig)
     (Maybe (Map Domain MultiIngressDomainConfig))
forall doc doc' a b.
(HasOpt doc, HasField doc' doc) =>
Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (Maybe b)
optField Text
"spDomainConfigs" (ValueSchema NamedSwaggerDoc MultiIngressDomainConfig
-> SchemaP
     SwaggerDoc
     Value
     Value
     (Map Domain MultiIngressDomainConfig)
     (Map Domain MultiIngressDomainConfig)
forall ndoc doc k a.
(HasMap ndoc doc, Ord k, FromJSONKey k, ToJSONKey k) =>
ValueSchema ndoc a -> ValueSchema doc (Map k a)
map_ ValueSchema NamedSwaggerDoc MultiIngressDomainConfig
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)))
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  ConfigRaw
  (Maybe URI -> Maybe URI -> Maybe [ContactPerson] -> ConfigRaw)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw (Maybe URI)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     ConfigRaw
     (Maybe URI -> Maybe [ContactPerson] -> ConfigRaw)
forall a b.
SchemaP SwaggerDoc Object [Pair] ConfigRaw (a -> b)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw a
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ConfigRaw -> Maybe URI
_cfgRawSPAppURI (ConfigRaw -> Maybe URI)
-> SchemaP SwaggerDoc Object [Pair] (Maybe URI) (Maybe URI)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw (Maybe URI)
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= SchemaP SwaggerDoc Object [Pair] URI (Maybe URI)
-> SchemaP SwaggerDoc Object [Pair] (Maybe URI) (Maybe URI)
forall w d v a b.
Monoid w =>
SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybe_ (Text
-> SchemaP NamedSwaggerDoc Value Value URI URI
-> SchemaP SwaggerDoc Object [Pair] URI (Maybe URI)
forall doc doc' a b.
(HasOpt doc, HasField doc' doc) =>
Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (Maybe b)
optField Text
"spAppUri" SchemaP NamedSwaggerDoc Value Value URI URI
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema))
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  ConfigRaw
  (Maybe URI -> Maybe [ContactPerson] -> ConfigRaw)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw (Maybe URI)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     ConfigRaw
     (Maybe [ContactPerson] -> ConfigRaw)
forall a b.
SchemaP SwaggerDoc Object [Pair] ConfigRaw (a -> b)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw a
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ConfigRaw -> Maybe URI
_cfgRawSPSsoURI (ConfigRaw -> Maybe URI)
-> SchemaP SwaggerDoc Object [Pair] (Maybe URI) (Maybe URI)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw (Maybe URI)
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= SchemaP SwaggerDoc Object [Pair] URI (Maybe URI)
-> SchemaP SwaggerDoc Object [Pair] (Maybe URI) (Maybe URI)
forall w d v a b.
Monoid w =>
SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybe_ (Text
-> SchemaP NamedSwaggerDoc Value Value URI URI
-> SchemaP SwaggerDoc Object [Pair] URI (Maybe URI)
forall doc doc' a b.
(HasOpt doc, HasField doc' doc) =>
Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (Maybe b)
optField Text
"spSsoUri" SchemaP NamedSwaggerDoc Value Value URI URI
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema))
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  ConfigRaw
  (Maybe [ContactPerson] -> ConfigRaw)
-> SchemaP
     SwaggerDoc Object [Pair] ConfigRaw (Maybe [ContactPerson])
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw ConfigRaw
forall a b.
SchemaP SwaggerDoc Object [Pair] ConfigRaw (a -> b)
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw a
-> SchemaP SwaggerDoc Object [Pair] ConfigRaw b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (ConfigRaw -> Maybe [ContactPerson]
_cfgRawContacts (ConfigRaw -> Maybe [ContactPerson])
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     (Maybe [ContactPerson])
     (Maybe [ContactPerson])
-> SchemaP
     SwaggerDoc Object [Pair] ConfigRaw (Maybe [ContactPerson])
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= SchemaP
  SwaggerDoc Object [Pair] [ContactPerson] (Maybe [ContactPerson])
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     (Maybe [ContactPerson])
     (Maybe [ContactPerson])
forall w d v a b.
Monoid w =>
SchemaP d v w a b -> SchemaP d v w (Maybe a) b
maybe_ (Text
-> SchemaP SwaggerDoc Value Value [ContactPerson] [ContactPerson]
-> SchemaP
     SwaggerDoc Object [Pair] [ContactPerson] (Maybe [ContactPerson])
forall doc doc' a b.
(HasOpt doc, HasField doc' doc) =>
Text
-> SchemaP doc' Value Value a b
-> SchemaP doc Object [Pair] a (Maybe b)
optField Text
"contacts" (ValueSchema NamedSwaggerDoc ContactPerson
-> SchemaP SwaggerDoc Value Value [ContactPerson] [ContactPerson]
forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc) =>
ValueSchema ndoc a -> ValueSchema doc [a]
array ValueSchema NamedSwaggerDoc ContactPerson
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)))

instance ToSchema MultiIngressDomainConfig where
  schema :: ValueSchema NamedSwaggerDoc MultiIngressDomainConfig
schema =
    Text
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     MultiIngressDomainConfig
     MultiIngressDomainConfig
-> ValueSchema NamedSwaggerDoc MultiIngressDomainConfig
forall doc doc' a b.
HasObject doc doc' =>
Text
-> SchemaP doc Object [Pair] a b -> SchemaP doc' Value Value a b
object Text
"MultiIngressDomainConfig" (SchemaP
   SwaggerDoc
   Object
   [Pair]
   MultiIngressDomainConfig
   MultiIngressDomainConfig
 -> ValueSchema NamedSwaggerDoc MultiIngressDomainConfig)
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     MultiIngressDomainConfig
     MultiIngressDomainConfig
-> ValueSchema NamedSwaggerDoc MultiIngressDomainConfig
forall a b. (a -> b) -> a -> b
$
      URI -> URI -> [ContactPerson] -> MultiIngressDomainConfig
MultiIngressDomainConfig
        (URI -> URI -> [ContactPerson] -> MultiIngressDomainConfig)
-> SchemaP SwaggerDoc Object [Pair] MultiIngressDomainConfig URI
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     MultiIngressDomainConfig
     (URI -> [ContactPerson] -> MultiIngressDomainConfig)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (MultiIngressDomainConfig -> URI
_cfgSPAppURI (MultiIngressDomainConfig -> URI)
-> SchemaP SwaggerDoc Object [Pair] URI URI
-> SchemaP SwaggerDoc Object [Pair] MultiIngressDomainConfig URI
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value URI URI
-> SchemaP SwaggerDoc Object [Pair] URI URI
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"spAppUri" SchemaP NamedSwaggerDoc Value Value URI URI
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  MultiIngressDomainConfig
  (URI -> [ContactPerson] -> MultiIngressDomainConfig)
-> SchemaP SwaggerDoc Object [Pair] MultiIngressDomainConfig URI
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     MultiIngressDomainConfig
     ([ContactPerson] -> MultiIngressDomainConfig)
forall a b.
SchemaP SwaggerDoc Object [Pair] MultiIngressDomainConfig (a -> b)
-> SchemaP SwaggerDoc Object [Pair] MultiIngressDomainConfig a
-> SchemaP SwaggerDoc Object [Pair] MultiIngressDomainConfig b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (MultiIngressDomainConfig -> URI
_cfgSPSsoURI (MultiIngressDomainConfig -> URI)
-> SchemaP SwaggerDoc Object [Pair] URI URI
-> SchemaP SwaggerDoc Object [Pair] MultiIngressDomainConfig URI
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP NamedSwaggerDoc Value Value URI URI
-> SchemaP SwaggerDoc Object [Pair] URI URI
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"spSsoUri" SchemaP NamedSwaggerDoc Value Value URI URI
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema)
        SchemaP
  SwaggerDoc
  Object
  [Pair]
  MultiIngressDomainConfig
  ([ContactPerson] -> MultiIngressDomainConfig)
-> SchemaP
     SwaggerDoc Object [Pair] MultiIngressDomainConfig [ContactPerson]
-> SchemaP
     SwaggerDoc
     Object
     [Pair]
     MultiIngressDomainConfig
     MultiIngressDomainConfig
forall a b.
SchemaP SwaggerDoc Object [Pair] MultiIngressDomainConfig (a -> b)
-> SchemaP SwaggerDoc Object [Pair] MultiIngressDomainConfig a
-> SchemaP SwaggerDoc Object [Pair] MultiIngressDomainConfig b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (MultiIngressDomainConfig -> [ContactPerson]
_cfgContacts (MultiIngressDomainConfig -> [ContactPerson])
-> SchemaP SwaggerDoc Object [Pair] [ContactPerson] [ContactPerson]
-> SchemaP
     SwaggerDoc Object [Pair] MultiIngressDomainConfig [ContactPerson]
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= Text
-> SchemaP SwaggerDoc Value Value [ContactPerson] [ContactPerson]
-> SchemaP SwaggerDoc Object [Pair] [ContactPerson] [ContactPerson]
forall doc' doc a b.
HasField doc' doc =>
Text
-> SchemaP doc' Value Value a b -> SchemaP doc Object [Pair] a b
field Text
"contacts" (ValueSchema NamedSwaggerDoc ContactPerson
-> SchemaP SwaggerDoc Value Value [ContactPerson] [ContactPerson]
forall ndoc doc a.
(HasArray ndoc doc, HasName ndoc) =>
ValueSchema ndoc a -> ValueSchema doc [a]
array ValueSchema NamedSwaggerDoc ContactPerson
forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema))

instance ToSchema Config where
  schema :: ValueSchema NamedSwaggerDoc Config
schema = Config -> ConfigRaw
unprs (Config -> ConfigRaw)
-> SchemaP NamedSwaggerDoc Value Value ConfigRaw Config
-> ValueSchema NamedSwaggerDoc Config
forall (p :: * -> * -> *) a a' b.
Profunctor p =>
(a -> a') -> p a' b -> p a b
.= ((forall a. ToSchema a => ValueSchema NamedSwaggerDoc a
schema @ConfigRaw) ValueSchema NamedSwaggerDoc ConfigRaw
-> (ConfigRaw -> Parser Config)
-> SchemaP NamedSwaggerDoc Value Value ConfigRaw Config
forall doc v w a b b'.
SchemaP doc v w a b -> (b -> Parser b') -> SchemaP doc v w a b'
`withParser` ConfigRaw -> Parser Config
prs)
    where
      prs :: ConfigRaw -> Yaml.Parser Config
      prs :: ConfigRaw -> Parser Config
prs config :: ConfigRaw
config@(ConfigRaw {Int
FilePath
Maybe [ContactPerson]
Maybe (Map Domain MultiIngressDomainConfig)
Maybe URI
Level
_cfgRawLogLevel :: ConfigRaw -> Level
_cfgRawSPHost :: ConfigRaw -> FilePath
_cfgRawSPPort :: ConfigRaw -> Int
_cfgRawDomainConfigs :: ConfigRaw -> Maybe (Map Domain MultiIngressDomainConfig)
_cfgRawSPAppURI :: ConfigRaw -> Maybe URI
_cfgRawSPSsoURI :: ConfigRaw -> Maybe URI
_cfgRawContacts :: ConfigRaw -> Maybe [ContactPerson]
_cfgRawLogLevel :: Level
_cfgRawSPHost :: FilePath
_cfgRawSPPort :: Int
_cfgRawDomainConfigs :: Maybe (Map Domain MultiIngressDomainConfig)
_cfgRawSPAppURI :: Maybe URI
_cfgRawSPSsoURI :: Maybe URI
_cfgRawContacts :: Maybe [ContactPerson]
..}) =
        case (Maybe (Map Domain MultiIngressDomainConfig)
_cfgRawDomainConfigs, Maybe URI
_cfgRawSPAppURI, Maybe URI
_cfgRawSPSsoURI, Maybe [ContactPerson]
_cfgRawContacts) of
          (Maybe (Map Domain MultiIngressDomainConfig)
Nothing, Just URI
_cfgSPAppURI, Just URI
_cfgSPSsoURI, Just [ContactPerson]
_cfgContacts) ->
            Config -> Parser Config
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              Config
                { _cfgLogLevel :: Level
_cfgLogLevel = Level
_cfgRawLogLevel,
                  _cfgSPHost :: FilePath
_cfgSPHost = FilePath
_cfgRawSPHost,
                  _cfgSPPort :: Int
_cfgSPPort = Int
_cfgRawSPPort,
                  _cfgDomainConfigs :: Either
  MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
_cfgDomainConfigs = MultiIngressDomainConfig
-> Either
     MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
forall a b. a -> Either a b
Left MultiIngressDomainConfig {[ContactPerson]
URI
_cfgSPAppURI :: URI
_cfgSPSsoURI :: URI
_cfgContacts :: [ContactPerson]
_cfgSPAppURI :: URI
_cfgSPSsoURI :: URI
_cfgContacts :: [ContactPerson]
..}
                }
          (Just Map Domain MultiIngressDomainConfig
domainConfigsMap, Maybe URI
Nothing, Maybe URI
Nothing, Maybe [ContactPerson]
Nothing) ->
            Config -> Parser Config
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              Config
                { _cfgLogLevel :: Level
_cfgLogLevel = Level
_cfgRawLogLevel,
                  _cfgSPHost :: FilePath
_cfgSPHost = FilePath
_cfgRawSPHost,
                  _cfgSPPort :: Int
_cfgSPPort = Int
_cfgRawSPPort,
                  _cfgDomainConfigs :: Either
  MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
_cfgDomainConfigs = Map Domain MultiIngressDomainConfig
-> Either
     MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
forall a b. b -> Either a b
Right Map Domain MultiIngressDomainConfig
domainConfigsMap
                }
          (Maybe (Map Domain MultiIngressDomainConfig), Maybe URI, Maybe URI,
 Maybe [ContactPerson])
_ ->
            FilePath -> Parser Config
forall a. FilePath -> Parser a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> Parser Config) -> FilePath -> Parser Config
forall a b. (a -> b) -> a -> b
$
              FilePath
"Cannot parse to Config from ConfigRaw: "
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ ConfigRaw -> FilePath
forall a. Show a => a -> FilePath
show ConfigRaw
config
                FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ FilePath
" (give either all of `spAppUri`, `spSsoUri`, `contacts`, or `spDomainConfigs`)"

      unprs :: Config -> ConfigRaw
      unprs :: Config -> ConfigRaw
unprs (Config {Int
FilePath
Either
  MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
Level
_cfgLogLevel :: Config -> Level
_cfgSPHost :: Config -> FilePath
_cfgSPPort :: Config -> Int
_cfgDomainConfigs :: Config
-> Either
     MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
_cfgLogLevel :: Level
_cfgSPHost :: FilePath
_cfgSPPort :: Int
_cfgDomainConfigs :: Either
  MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
..}) = case Either
  MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
_cfgDomainConfigs of
        Left MultiIngressDomainConfig {[ContactPerson]
URI
_cfgSPAppURI :: MultiIngressDomainConfig -> URI
_cfgSPSsoURI :: MultiIngressDomainConfig -> URI
_cfgContacts :: MultiIngressDomainConfig -> [ContactPerson]
_cfgSPAppURI :: URI
_cfgSPSsoURI :: URI
_cfgContacts :: [ContactPerson]
..} ->
          ConfigRaw
            { _cfgRawLogLevel :: Level
_cfgRawLogLevel = Level
_cfgLogLevel,
              _cfgRawSPHost :: FilePath
_cfgRawSPHost = FilePath
_cfgSPHost,
              _cfgRawSPPort :: Int
_cfgRawSPPort = Int
_cfgSPPort,
              _cfgRawDomainConfigs :: Maybe (Map Domain MultiIngressDomainConfig)
_cfgRawDomainConfigs = Maybe (Map Domain MultiIngressDomainConfig)
forall a. Maybe a
Nothing,
              _cfgRawSPAppURI :: Maybe URI
_cfgRawSPAppURI = URI -> Maybe URI
forall a. a -> Maybe a
Just URI
_cfgSPAppURI,
              _cfgRawSPSsoURI :: Maybe URI
_cfgRawSPSsoURI = URI -> Maybe URI
forall a. a -> Maybe a
Just URI
_cfgSPSsoURI,
              _cfgRawContacts :: Maybe [ContactPerson]
_cfgRawContacts = [ContactPerson] -> Maybe [ContactPerson]
forall a. a -> Maybe a
Just [ContactPerson]
_cfgContacts
            }
        Right Map Domain MultiIngressDomainConfig
domainConfigsMap ->
          ConfigRaw
            { _cfgRawLogLevel :: Level
_cfgRawLogLevel = Level
_cfgLogLevel,
              _cfgRawSPHost :: FilePath
_cfgRawSPHost = FilePath
_cfgSPHost,
              _cfgRawSPPort :: Int
_cfgRawSPPort = Int
_cfgSPPort,
              _cfgRawDomainConfigs :: Maybe (Map Domain MultiIngressDomainConfig)
_cfgRawDomainConfigs = Map Domain MultiIngressDomainConfig
-> Maybe (Map Domain MultiIngressDomainConfig)
forall a. a -> Maybe a
Just Map Domain MultiIngressDomainConfig
domainConfigsMap,
              _cfgRawSPAppURI :: Maybe URI
_cfgRawSPAppURI = Maybe URI
forall a. Maybe a
Nothing,
              _cfgRawSPSsoURI :: Maybe URI
_cfgRawSPSsoURI = Maybe URI
forall a. Maybe a
Nothing,
              _cfgRawContacts :: Maybe [ContactPerson]
_cfgRawContacts = Maybe [ContactPerson]
forall a. Maybe a
Nothing
            }

----------------------------------------------------------------------
-- default

fallbackConfig :: Config
fallbackConfig :: Config
fallbackConfig =
  Config
    { _cfgLogLevel :: Level
_cfgLogLevel = Level
Debug,
      _cfgSPHost :: FilePath
_cfgSPHost = FilePath
"localhost",
      _cfgSPPort :: Int
_cfgSPPort = Int
8081,
      _cfgDomainConfigs :: Either
  MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
_cfgDomainConfigs =
        MultiIngressDomainConfig
-> Either
     MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
forall a b. a -> Either a b
Left
          MultiIngressDomainConfig
            { _cfgSPAppURI :: URI
_cfgSPAppURI = [uri|https://example-sp.com/landing|],
              _cfgSPSsoURI :: URI
_cfgSPSsoURI = [uri|https://example-sp.com/sso|],
              _cfgContacts :: [ContactPerson]
_cfgContacts = [ContactPerson
fallbackContact]
            }
    }

fallbackContact :: ContactPerson
fallbackContact :: ContactPerson
fallbackContact =
  ContactType
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe URI
-> Maybe Text
-> ContactPerson
ContactPerson
    ContactType
ContactSupport
    (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"evil corp.")
    (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Dr.")
    (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Girlfriend")
    (URI -> Maybe URI
forall a. a -> Maybe a
Just [uri|email:president@evil.corp|])
    (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"+314159265")

----------------------------------------------------------------------
-- IO

configIO :: IO Config
configIO :: IO Config
configIO = FilePath -> IO Config
readConfig (FilePath -> IO Config) -> IO FilePath -> IO Config
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
configFilePath

configFilePath :: IO FilePath
configFilePath :: IO FilePath
configFilePath = (FilePath -> ShowS
</> FilePath
"server.yaml") ShowS -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
getEnv FilePath
"SAML2_WEB_SSO_ROOT" -- TODO(fisx): this doesn't work any more. think of something nicer instead of fixing it!

readConfig :: FilePath -> IO Config
readConfig :: FilePath -> IO Config
readConfig FilePath
filepath =
  (ParseException -> IO Config)
-> (Config -> IO Config)
-> Either ParseException Config
-> IO Config
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ParseException
err -> Config
fallbackConfig Config -> IO () -> IO Config
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ParseException -> IO ()
warn ParseException
err) (\Config
cnf -> Config -> IO ()
info Config
cnf IO () -> IO Config -> IO Config
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Config -> IO Config
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Config
cnf)
    (Either ParseException Config -> IO Config)
-> IO (Either ParseException Config) -> IO Config
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO (Either ParseException Config)
forall a. FromJSON a => FilePath -> IO (Either ParseException a)
Yaml.decodeFileEither FilePath
filepath
  where
    info :: Config -> IO ()
    info :: Config -> IO ()
info Config
cfg =
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Config -> Level
_cfgLogLevel Config
cfg Level -> Level -> Bool
forall a. Ord a => a -> a -> Bool
<= Level
Info)
        (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr
          (FilePath -> IO ()) -> (Config -> FilePath) -> Config -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath
"\n>>> server config:\n" <>)
          ShowS -> (Config -> FilePath) -> Config -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> FilePath
forall a b. ConvertibleStrings a b => a -> b
cs
          (ByteString -> FilePath)
-> (Config -> ByteString) -> Config -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> ByteString
forall a. ToJSON a => a -> ByteString
Yaml.encode
        (Config -> IO ()) -> Config -> IO ()
forall a b. (a -> b) -> a -> b
$ Config
cfg
    warn :: Yaml.ParseException -> IO ()
    warn :: ParseException -> IO ()
warn ParseException
err =
      Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$
        FilePath
"*** could not read config file: "
          FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> ParseException -> FilePath
forall a. Show a => a -> FilePath
show ParseException
err
          FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
"  using default!  see SAML.WebSSO.Config for details!"

----------------------------------------------------------------------
-- class

class HasConfig m where
  getConfig :: m Config

instance HasConfig ((->) Config) where
  getConfig :: Config -> Config
getConfig = Config -> Config
forall a. a -> a
id

----------------------------------------------------------------------
-- TH stuff at the end of the module

makeLenses ''Config

makeLenses ''MultiIngressDomainConfig