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

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2025 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

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.Either
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
  { _cfgLogLevel :: Level,
    _cfgSPHost :: String,
    _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.
    _cfgDomainConfigs ::
      Either MultiIngressDomainConfig (Map Domain MultiIngressDomainConfig)
  }
  deriving (Eq, Show, Generic)
  deriving (A.ToJSON, A.FromJSON) via Schema Config

getMultiIngressDomainConfig :: Config -> Maybe Domain -> Maybe MultiIngressDomainConfig
getMultiIngressDomainConfig config mbDomain =
  case (_cfgDomainConfigs config, mbDomain) of
    (Left cfg, _) -> pure cfg
    (Right cfgMap, Just d) -> Map.lookup d cfgMap
    (Right _, Nothing) -> Nothing

data MultiIngressDomainConfig = MultiIngressDomainConfig
  { _cfgSPAppURI :: URI,
    _cfgSPSsoURI :: URI,
    _cfgContacts :: [ContactPerson]
  }
  deriving (Eq, Show, Generic)
  deriving (A.ToJSON, A.FromJSON) via Schema MultiIngressDomainConfig

isMultiIngressConfig :: Config -> Bool
isMultiIngressConfig = isRight . _cfgDomainConfigs

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

data ConfigRaw = ConfigRaw
  { _cfgRawLogLevel :: Level,
    _cfgRawSPHost :: String,
    _cfgRawSPPort :: Int,
    _cfgRawDomainConfigs :: Maybe (Map Domain MultiIngressDomainConfig),
    _cfgRawSPAppURI :: Maybe URI,
    _cfgRawSPSsoURI :: Maybe URI,
    _cfgRawContacts :: Maybe [ContactPerson]
  }
  deriving (Show)

instance ToSchema ConfigRaw where
  schema =
    object $
      ConfigRaw
        <$> (_cfgRawLogLevel .= field "logLevel" schema)
        <*> (_cfgRawSPHost .= field "spHost" schema)
        <*> (_cfgRawSPPort .= field "spPort" schema)
        <*> (_cfgRawDomainConfigs .= maybe_ (optField "spDomainConfigs" (map_ schema)))
        <*> (_cfgRawSPAppURI .= maybe_ (optField "spAppUri" schema))
        <*> (_cfgRawSPSsoURI .= maybe_ (optField "spSsoUri" schema))
        <*> (_cfgRawContacts .= maybe_ (optField "contacts" (array schema)))

instance ToSchema MultiIngressDomainConfig where
  schema =
    object $
      MultiIngressDomainConfig
        <$> (_cfgSPAppURI .= field "spAppUri" schema)
        <*> (_cfgSPSsoURI .= field "spSsoUri" schema)
        <*> (_cfgContacts .= field "contacts" (array schema))

instance ToSchema Config where
  schema = unprs .= ((schema @ConfigRaw) `withParser` prs)
    where
      prs :: ConfigRaw -> Yaml.Parser Config
      prs config@(ConfigRaw {..}) =
        case (_cfgRawDomainConfigs, _cfgRawSPAppURI, _cfgRawSPSsoURI, _cfgRawContacts) of
          (Nothing, Just _cfgSPAppURI, Just _cfgSPSsoURI, Just _cfgContacts) ->
            pure
              Config
                { _cfgLogLevel = _cfgRawLogLevel,
                  _cfgSPHost = _cfgRawSPHost,
                  _cfgSPPort = _cfgRawSPPort,
                  _cfgDomainConfigs = Left MultiIngressDomainConfig {..}
                }
          (Just domainConfigsMap, Nothing, Nothing, Nothing) ->
            pure
              Config
                { _cfgLogLevel = _cfgRawLogLevel,
                  _cfgSPHost = _cfgRawSPHost,
                  _cfgSPPort = _cfgRawSPPort,
                  _cfgDomainConfigs = Right domainConfigsMap
                }
          _ ->
            fail $
              "Cannot parse to Config from ConfigRaw: "
                ++ show config
                ++ " (give either all of `spAppUri`, `spSsoUri`, `contacts`, or `spDomainConfigs`)"

      unprs :: Config -> ConfigRaw
      unprs (Config {..}) = case _cfgDomainConfigs of
        Left MultiIngressDomainConfig {..} ->
          ConfigRaw
            { _cfgRawLogLevel = _cfgLogLevel,
              _cfgRawSPHost = _cfgSPHost,
              _cfgRawSPPort = _cfgSPPort,
              _cfgRawDomainConfigs = Nothing,
              _cfgRawSPAppURI = Just _cfgSPAppURI,
              _cfgRawSPSsoURI = Just _cfgSPSsoURI,
              _cfgRawContacts = Just _cfgContacts
            }
        Right domainConfigsMap ->
          ConfigRaw
            { _cfgRawLogLevel = _cfgLogLevel,
              _cfgRawSPHost = _cfgSPHost,
              _cfgRawSPPort = _cfgSPPort,
              _cfgRawDomainConfigs = Just domainConfigsMap,
              _cfgRawSPAppURI = Nothing,
              _cfgRawSPSsoURI = Nothing,
              _cfgRawContacts = Nothing
            }

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

fallbackConfig :: Config
fallbackConfig =
  Config
    { _cfgLogLevel = Debug,
      _cfgSPHost = "localhost",
      _cfgSPPort = 8081,
      _cfgDomainConfigs =
        Left
          MultiIngressDomainConfig
            { _cfgSPAppURI = [uri|https://example-sp.com/landing|],
              _cfgSPSsoURI = [uri|https://example-sp.com/sso|],
              _cfgContacts = [fallbackContact]
            }
    }

fallbackContact :: ContactPerson
fallbackContact =
  ContactPerson
    ContactSupport
    (Just "evil corp.")
    (Just "Dr.")
    (Just "Girlfriend")
    (Just [uri|email:president@evil.corp|])
    (Just "+314159265")

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

configIO :: IO Config
configIO = readConfig =<< configFilePath

configFilePath :: IO FilePath
configFilePath = (</> "server.yaml") <$> getEnv "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 =
  either (\err -> fallbackConfig <$ warn err) (\cnf -> info cnf >> pure cnf)
    =<< Yaml.decodeFileEither filepath
  where
    info :: Config -> IO ()
    info cfg =
      when (_cfgLogLevel cfg <= Info)
        $ hPutStrLn stderr
          . ("\n>>> server config:\n" <>)
          . cs
          . Yaml.encode
        $ cfg
    warn :: Yaml.ParseException -> IO ()
    warn err =
      hPutStrLn stderr $
        "*** could not read config file: "
          <> show err
          <> "  using default!  see SAML.WebSSO.Config for details!"

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

class HasConfig m where
  getConfig :: m Config

instance HasConfig ((->) Config) where
  getConfig = id

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

makeLenses ''Config

makeLenses ''MultiIngressDomainConfig
