{-|
Module      : PostgREST.Config
Description : Manages PostgREST configuration type and parser.

-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards       #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

module PostgREST.Config
  ( AppConfig (..)
  , Environment
  , JSPath
  , JSPathExp(..)
  , LogLevel(..)
  , OpenAPIMode(..)
  , Proxy(..)
  , toText
  , isMalformedProxyUri
  , readAppConfig
  , readPGRSTEnvironment
  , toURI
  , parseSecret
  ) where

import qualified Crypto.JOSE.Types      as JOSE
import qualified Crypto.JWT             as JWT
import qualified Data.Aeson             as JSON
import qualified Data.ByteString        as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Lazy   as LBS
import qualified Data.Configurator      as C
import qualified Data.Map.Strict        as M
import qualified Data.Text              as T
import qualified Data.Text.Encoding     as T

import Control.Lens            (preview)
import Control.Monad           (fail)
import Crypto.JWT              (JWK, JWKSet, StringOrURI, stringOrUri)
import Data.Aeson              (toJSON)
import Data.Either.Combinators (mapLeft)
import Data.List               (lookup)
import Data.List.NonEmpty      (fromList, toList)
import Data.Maybe              (fromJust)
import Data.Scientific         (floatingOrInteger)
import Data.Time.Clock         (NominalDiffTime)
import Numeric                 (readOct, showOct)
import System.Environment      (getEnvironment)
import System.Posix.Types      (FileMode)

import PostgREST.Config.JSPath           (JSPath, JSPathExp (..),
                                          dumpJSPath, pRoleClaimKey)
import PostgREST.Config.Proxy            (Proxy (..),
                                          isMalformedProxyUri, toURI)
import PostgREST.DbStructure.Identifiers (QualifiedIdentifier, dumpQi,
                                          toQi)

import Protolude hiding (Proxy, toList)


data AppConfig = AppConfig
  { configAppSettings           :: [(Text, Text)]
  , configDbAnonRole            :: Text
  , configDbChannel             :: Text
  , configDbChannelEnabled      :: Bool
  , configDbExtraSearchPath     :: [Text]
  , configDbMaxRows             :: Maybe Integer
  , configDbPoolSize            :: Int
  , configDbPoolTimeout         :: NominalDiffTime
  , configDbPreRequest          :: Maybe QualifiedIdentifier
  , configDbPreparedStatements  :: Bool
  , configDbRootSpec            :: Maybe QualifiedIdentifier
  , configDbSchemas             :: NonEmpty Text
  , configDbConfig              :: Bool
  , configDbTxAllowOverride     :: Bool
  , configDbTxRollbackAll       :: Bool
  , configDbUri                 :: Text
  , configDbUseLegacyGucs       :: Bool
  , configFilePath              :: Maybe FilePath
  , configJWKS                  :: Maybe JWKSet
  , configJwtAudience           :: Maybe StringOrURI
  , configJwtRoleClaimKey       :: JSPath
  , configJwtSecret             :: Maybe BS.ByteString
  , configJwtSecretIsBase64     :: Bool
  , configLogLevel              :: LogLevel
  , configOpenApiMode           :: OpenAPIMode
  , configOpenApiServerProxyUri :: Maybe Text
  , configRawMediaTypes         :: [BS.ByteString]
  , configServerHost            :: Text
  , configServerPort            :: Int
  , configServerUnixSocket      :: Maybe FilePath
  , configServerUnixSocketMode  :: FileMode
  }

data LogLevel = LogCrit | LogError | LogWarn | LogInfo

dumpLogLevel :: LogLevel -> Text
dumpLogLevel = \case
  LogCrit  -> "crit"
  LogError -> "error"
  LogWarn  -> "warn"
  LogInfo  -> "info"

data OpenAPIMode = OAFollowPriv | OAIgnorePriv | OADisabled
  deriving Eq

dumpOpenApiMode :: OpenAPIMode -> Text
dumpOpenApiMode = \case
  OAFollowPriv -> "follow-privileges"
  OAIgnorePriv -> "ignore-privileges"
  OADisabled   -> "disabled"

-- | Dump the config
toText :: AppConfig -> Text
toText conf =
  unlines $ (\(k, v) -> k <> " = " <> v) <$> pgrstSettings ++ appSettings
  where
    -- apply conf to all pgrst settings
    pgrstSettings = (\(k, v) -> (k, v conf)) <$>
      [("db-anon-role",              q . configDbAnonRole)
      ,("db-channel",                q . configDbChannel)
      ,("db-channel-enabled",            T.toLower . show . configDbChannelEnabled)
      ,("db-extra-search-path",      q . T.intercalate "," . configDbExtraSearchPath)
      ,("db-max-rows",                   maybe "\"\"" show . configDbMaxRows)
      ,("db-pool",                       show . configDbPoolSize)
      ,("db-pool-timeout",               show . floor . configDbPoolTimeout)
      ,("db-pre-request",            q . maybe mempty dumpQi . configDbPreRequest)
      ,("db-prepared-statements",        T.toLower . show . configDbPreparedStatements)
      ,("db-root-spec",              q . maybe mempty dumpQi . configDbRootSpec)
      ,("db-schemas",                q . T.intercalate "," . toList . configDbSchemas)
      ,("db-config",                     T.toLower . show . configDbConfig)
      ,("db-tx-end",                 q . showTxEnd)
      ,("db-uri",                    q . configDbUri)
      ,("db-use-legacy-gucs",            T.toLower . show . configDbUseLegacyGucs)
      ,("jwt-aud",                       T.decodeUtf8 . LBS.toStrict . JSON.encode . maybe "" toJSON . configJwtAudience)
      ,("jwt-role-claim-key",        q . T.intercalate mempty . fmap dumpJSPath . configJwtRoleClaimKey)
      ,("jwt-secret",                q . T.decodeUtf8 . showJwtSecret)
      ,("jwt-secret-is-base64",          T.toLower . show . configJwtSecretIsBase64)
      ,("log-level",                 q . dumpLogLevel . configLogLevel)
      ,("openapi-mode",              q . dumpOpenApiMode . configOpenApiMode)
      ,("openapi-server-proxy-uri",  q . fromMaybe mempty . configOpenApiServerProxyUri)
      ,("raw-media-types",           q . T.decodeUtf8 . BS.intercalate "," . configRawMediaTypes)
      ,("server-host",               q . configServerHost)
      ,("server-port",                   show . configServerPort)
      ,("server-unix-socket",        q . maybe mempty T.pack . configServerUnixSocket)
      ,("server-unix-socket-mode",   q . T.pack . showSocketMode)
      ]

    -- quote all app.settings
    appSettings = second q <$> configAppSettings conf

    -- quote strings and replace " with \"
    q s = "\"" <> T.replace "\"" "\\\"" s <> "\""

    showTxEnd c = case (configDbTxRollbackAll c, configDbTxAllowOverride c) of
      ( False, False ) -> "commit"
      ( False, True  ) -> "commit-allow-override"
      ( True , False ) -> "rollback"
      ( True , True  ) -> "rollback-allow-override"
    showJwtSecret c
      | configJwtSecretIsBase64 c = B64.encode secret
      | otherwise                 = secret
      where
        secret = fromMaybe mempty $ configJwtSecret c
    showSocketMode c = showOct (configServerUnixSocketMode c) mempty

-- This class is needed for the polymorphism of overrideFromDbOrEnvironment
-- because C.required and C.optional have different signatures
class JustIfMaybe a b where
  justIfMaybe :: a -> b

instance JustIfMaybe a a where
  justIfMaybe a = a

instance JustIfMaybe a (Maybe a) where
  justIfMaybe a = Just a

-- | Reads and parses the config and overrides its parameters from env vars,
-- files or db settings.
readAppConfig :: [(Text, Text)] -> Maybe FilePath -> Maybe Text -> IO (Either Text AppConfig)
readAppConfig dbSettings optPath prevDbUri = do
  env <- readPGRSTEnvironment
  -- if no filename provided, start with an empty map to read config from environment
  conf <- maybe (return $ Right M.empty) loadConfig optPath

  case C.runParser (parser optPath env dbSettings) =<< mapLeft show conf of
    Left err ->
      return . Left $ "Error in config " <> err
    Right parsedConfig ->
      Right <$> decodeLoadFiles parsedConfig
  where
    -- Both C.ParseError and IOError are shown here
    loadConfig :: FilePath -> IO (Either SomeException C.Config)
    loadConfig = try . C.load

    decodeLoadFiles :: AppConfig -> IO AppConfig
    decodeLoadFiles parsedConfig =
      decodeJWKS <$>
        (decodeSecret =<< readSecretFile =<< readDbUriFile prevDbUri parsedConfig)

parser :: Maybe FilePath -> Environment -> [(Text, Text)] -> C.Parser C.Config AppConfig
parser optPath env dbSettings =
  AppConfig
    <$> parseAppSettings "app.settings"
    <*> reqString "db-anon-role"
    <*> (fromMaybe "pgrst" <$> optString "db-channel")
    <*> (fromMaybe True <$> optBool "db-channel-enabled")
    <*> (maybe ["public"] splitOnCommas <$> optValue "db-extra-search-path")
    <*> optWithAlias (optInt "db-max-rows")
                     (optInt "max-rows")
    <*> (fromMaybe 10 <$> optInt "db-pool")
    <*> (fromIntegral . fromMaybe 10 <$> optInt "db-pool-timeout")
    <*> (fmap toQi <$> optWithAlias (optString "db-pre-request")
                                    (optString "pre-request"))
    <*> (fromMaybe True <$> optBool "db-prepared-statements")
    <*> (fmap toQi <$> optWithAlias (optString "db-root-spec")
                                    (optString "root-spec"))
    <*> (fromList . splitOnCommas <$> reqWithAlias (optValue "db-schemas")
                                                   (optValue "db-schema")
                                                   "missing key: either db-schemas or db-schema must be set")
    <*> (fromMaybe True <$> optBool "db-config")
    <*> parseTxEnd "db-tx-end" snd
    <*> parseTxEnd "db-tx-end" fst
    <*> reqString "db-uri"
    <*> (fromMaybe True <$> optBool "db-use-legacy-gucs")
    <*> pure optPath
    <*> pure Nothing
    <*> parseJwtAudience "jwt-aud"
    <*> parseRoleClaimKey "jwt-role-claim-key" "role-claim-key"
    <*> (fmap encodeUtf8 <$> optString "jwt-secret")
    <*> (fromMaybe False <$> optWithAlias
          (optBool "jwt-secret-is-base64")
          (optBool "secret-is-base64"))
    <*> parseLogLevel "log-level"
    <*> parseOpenAPIMode "openapi-mode"
    <*> parseOpenAPIServerProxyURI "openapi-server-proxy-uri"
    <*> (maybe [] (fmap encodeUtf8 . splitOnCommas) <$> optValue "raw-media-types")
    <*> (fromMaybe "!4" <$> optString "server-host")
    <*> (fromMaybe 3000 <$> optInt "server-port")
    <*> (fmap T.unpack <$> optString "server-unix-socket")
    <*> parseSocketFileMode "server-unix-socket-mode"
  where
    parseAppSettings :: C.Key -> C.Parser C.Config [(Text, Text)]
    parseAppSettings key = addFromEnv . fmap (fmap coerceText) <$> C.subassocs key C.value
      where
        addFromEnv f = M.toList $ M.union fromEnv $ M.fromList f
        fromEnv = M.mapKeys fromJust $ M.filterWithKey (\k _ -> isJust k) $ M.mapKeys normalize env
        normalize k = ("app.settings." <>) <$> T.stripPrefix "PGRST_APP_SETTINGS_" (toS k)

    parseSocketFileMode :: C.Key -> C.Parser C.Config FileMode
    parseSocketFileMode k =
      optString k >>= \case
        Nothing -> pure 432 -- return default 660 mode if no value was provided
        Just fileModeText ->
          case readOct $ T.unpack fileModeText of
            []              ->
              fail "Invalid server-unix-socket-mode: not an octal"
            (fileMode, _):_ ->
              if fileMode < 384 || fileMode > 511
                then fail "Invalid server-unix-socket-mode: needs to be between 600 and 777"
                else pure fileMode

    parseOpenAPIMode :: C.Key -> C.Parser C.Config OpenAPIMode
    parseOpenAPIMode k =
      optString k >>= \case
        Nothing                  -> pure OAFollowPriv
        Just "follow-privileges" -> pure OAFollowPriv
        Just "ignore-privileges" -> pure OAIgnorePriv
        Just "disabled"          -> pure OADisabled
        Just _                   -> fail "Invalid openapi-mode. Check your configuration."

    parseOpenAPIServerProxyURI :: C.Key -> C.Parser C.Config (Maybe Text)
    parseOpenAPIServerProxyURI k =
      optString k >>= \case
        Nothing                            -> pure Nothing
        Just val | isMalformedProxyUri val -> fail "Malformed proxy uri, a correct example: https://example.com:8443/basePath"
                 | otherwise               -> pure $ Just val

    parseJwtAudience :: C.Key -> C.Parser C.Config (Maybe StringOrURI)
    parseJwtAudience k =
      optString k >>= \case
        Nothing -> pure Nothing -- no audience in config file
        Just aud -> case preview stringOrUri (T.unpack aud) of
          Nothing -> fail "Invalid Jwt audience. Check your configuration."
          aud' -> pure aud'

    parseLogLevel :: C.Key -> C.Parser C.Config LogLevel
    parseLogLevel k =
      optString k >>= \case
        Nothing      -> pure LogError
        Just "crit"  -> pure LogCrit
        Just "error" -> pure LogError
        Just "warn"  -> pure LogWarn
        Just "info"  -> pure LogInfo
        Just _       -> fail "Invalid logging level. Check your configuration."

    parseTxEnd :: C.Key -> ((Bool, Bool) -> Bool) -> C.Parser C.Config Bool
    parseTxEnd k f =
      optString k >>= \case
        --                                          RollbackAll AllowOverride
        Nothing                        -> pure $ f (False,      False)
        Just "commit"                  -> pure $ f (False,      False)
        Just "commit-allow-override"   -> pure $ f (False,      True)
        Just "rollback"                -> pure $ f (True,       False)
        Just "rollback-allow-override" -> pure $ f (True,       True)
        Just _                         -> fail "Invalid transaction termination. Check your configuration."

    parseRoleClaimKey :: C.Key -> C.Key -> C.Parser C.Config JSPath
    parseRoleClaimKey k al =
      optWithAlias (optString k) (optString al) >>= \case
        Nothing  -> pure [JSPKey "role"]
        Just rck -> either (fail . show) pure $ pRoleClaimKey rck

    reqWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> [Char] -> C.Parser C.Config a
    reqWithAlias orig alias err =
      orig >>= \case
        Just v  -> pure v
        Nothing ->
          alias >>= \case
            Just v  -> pure v
            Nothing -> fail err

    optWithAlias :: C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a) -> C.Parser C.Config (Maybe a)
    optWithAlias orig alias =
      orig >>= \case
        Just v  -> pure $ Just v
        Nothing -> alias

    reqString :: C.Key -> C.Parser C.Config Text
    reqString k = overrideFromDbOrEnvironment C.required k coerceText

    optString :: C.Key -> C.Parser C.Config (Maybe Text)
    optString k = mfilter (/= "") <$> overrideFromDbOrEnvironment C.optional k coerceText

    optValue :: C.Key -> C.Parser C.Config (Maybe C.Value)
    optValue k = overrideFromDbOrEnvironment C.optional k identity

    optInt :: (Read i, Integral i) => C.Key -> C.Parser C.Config (Maybe i)
    optInt k = join <$> overrideFromDbOrEnvironment C.optional k coerceInt

    optBool :: C.Key -> C.Parser C.Config (Maybe Bool)
    optBool k = join <$> overrideFromDbOrEnvironment C.optional k coerceBool

    overrideFromDbOrEnvironment :: JustIfMaybe a b =>
                               (C.Key -> C.Parser C.Value a -> C.Parser C.Config b) ->
                               C.Key -> (C.Value -> a) -> C.Parser C.Config b
    overrideFromDbOrEnvironment necessity key coercion =
      case reloadableDbSetting <|> M.lookup envVarName env of
        Just dbOrEnvVal -> pure $ justIfMaybe $ coercion $ C.String dbOrEnvVal
        Nothing  -> necessity key (coercion <$> C.value)
      where
        dashToUnderscore '-' = '_'
        dashToUnderscore c   = c
        envVarName = "PGRST_" <> (toUpper . dashToUnderscore <$> toS key)
        reloadableDbSetting =
          let dbSettingName = T.pack $ dashToUnderscore <$> toS key in
          if dbSettingName `notElem` [
            "server_host", "server_port", "server_unix_socket", "server_unix_socket_mode", "log_level",
            "db_anon_role", "db_uri", "db_channel_enabled", "db_channel", "db_pool", "db_pool_timeout", "db_config"]
          then lookup dbSettingName dbSettings
          else Nothing

    coerceText :: C.Value -> Text
    coerceText (C.String s) = s
    coerceText v            = show v

    coerceInt :: (Read i, Integral i) => C.Value -> Maybe i
    coerceInt (C.Number x) = rightToMaybe $ floatingOrInteger x
    coerceInt (C.String x) = readMaybe x
    coerceInt _            = Nothing

    coerceBool :: C.Value -> Maybe Bool
    coerceBool (C.Bool b)   = Just b
    coerceBool (C.String s) =
      -- parse all kinds of text: True, true, TRUE, "true", ...
      case readMaybe $ T.toTitle $ T.filter isAlpha $ toS s of
        Just b  -> Just b
        -- numeric instead?
        Nothing -> (> 0) <$> (readMaybe s :: Maybe Integer)
    coerceBool _            = Nothing

    splitOnCommas :: C.Value -> [Text]
    splitOnCommas (C.String s) = T.strip <$> T.splitOn "," s
    splitOnCommas _            = []

-- | Read the JWT secret from a file if configJwtSecret is actually a
-- filepath(has @ as its prefix). To check if the JWT secret is provided is
-- in fact a file path, it must be decoded as 'Text' to be processed.
readSecretFile :: AppConfig -> IO AppConfig
readSecretFile conf =
  maybe (return conf) readSecret maybeFilename
  where
    maybeFilename = T.stripPrefix "@" . decodeUtf8 =<< configJwtSecret conf
    readSecret filename = do
      jwtSecret <- chomp <$> BS.readFile (toS filename)
      return $ conf { configJwtSecret = Just jwtSecret }
    chomp bs = fromMaybe bs (BS.stripSuffix "\n" bs)

decodeSecret :: AppConfig -> IO AppConfig
decodeSecret conf@AppConfig{..} =
  case (configJwtSecretIsBase64, configJwtSecret) of
    (True, Just secret) ->
      either fail (return . updateSecret) $ decodeB64 secret
    _ -> return conf
  where
    updateSecret bs = conf { configJwtSecret = Just bs }
    decodeB64 = B64.decode . encodeUtf8 . T.strip . replaceUrlChars . decodeUtf8
    replaceUrlChars = T.replace "_" "/" . T.replace "-" "+" . T.replace "." "="

-- | Parse `jwt-secret` configuration option and turn into a JWKSet.
--
-- There are three ways to specify `jwt-secret`: text secret, JSON Web Key
-- (JWK), or JSON Web Key Set (JWKS). The first two are converted into a JWKSet
-- with one key and the last is converted as is.
decodeJWKS :: AppConfig -> AppConfig
decodeJWKS conf =
  conf { configJWKS = parseSecret <$> configJwtSecret conf }

parseSecret :: ByteString -> JWKSet
parseSecret bytes =
  fromMaybe (maybe secret (\jwk' -> JWT.JWKSet [jwk']) maybeJWK)
    maybeJWKSet
  where
    maybeJWKSet = JSON.decodeStrict bytes :: Maybe JWKSet
    maybeJWK = JSON.decodeStrict bytes :: Maybe JWK
    secret = JWT.JWKSet [JWT.fromKeyMaterial keyMaterial]
    keyMaterial = JWT.OctKeyMaterial . JWT.OctKeyParameters $ JOSE.Base64Octets bytes

-- | Read database uri from a separate file if `db-uri` is a filepath.
readDbUriFile :: Maybe Text -> AppConfig -> IO AppConfig
readDbUriFile maybeDbUri conf =
  case maybeDbUri of
    Just prevDbUri ->
      pure $ conf { configDbUri = prevDbUri }
    Nothing ->
      case T.stripPrefix "@" $ configDbUri conf of
        Nothing -> return conf
        Just filename -> do
          dbUri <- T.strip <$> readFile (toS filename)
          return $ conf { configDbUri = dbUri }

type Environment = M.Map [Char] Text

-- | Read environment variables that start with PGRST_
readPGRSTEnvironment :: IO Environment
readPGRSTEnvironment =
  M.map T.pack . M.fromList . filter (isPrefixOf "PGRST_" . fst) <$> getEnvironment