nuthatch/src/Nuthatch/Config.hs

module Nuthatch.Config
  ( Config (..)
  , loadConfig
  ) where

import           Control.Monad (when)
import qualified Data.ByteString as BS
import           Data.List (nub)
import           Data.Maybe (fromMaybe)
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           Nuthatch.Streaming (maximumMultipartBytes)
import           System.Environment (lookupEnv)
import           Text.Read (readMaybe)

data Config = Config
  { cfgListenHost          :: String
  , cfgListenPort          :: Int
  , cfgTlsCertPath         :: FilePath
  , cfgTlsKeyPath          :: FilePath
  , cfgPublicBaseUrl       :: Text
  , cfgJwtSecret           :: Text
  , cfgSessionHours        :: Integer
  , cfgCookieName          :: Text
  , cfgCsrfCookieName      :: Text
  , cfgOidcTransactionCookieName :: Text
  , cfgOidcIssuer          :: Text
  , cfgOidcClientId        :: Text
  , cfgOidcAdditionalAudiences :: [Text]
  , cfgOidcClientSecret    :: Text
  , cfgOidcRedirectUri     :: Text
  , cfgOidcTransactionMinutes :: Integer
  , cfgOidcMaxIdTokenSeconds :: Integer
  , cfgPgConn              :: String
  , cfgRedisHost           :: String
  , cfgRedisPort           :: Int
  , cfgRedisDb             :: Integer
  , cfgS3Endpoint          :: Text
  , cfgS3Region            :: Text
  , cfgS3Bucket            :: Text
  , cfgS3AccessKey         :: Text
  , cfgS3SecretKey         :: Text
  , cfgS3PathStyle         :: Bool
  , cfgPersonalQuotaBytes  :: Integer
  , cfgSharedQuotaBytes    :: Integer
  , cfgMaxObjectBytes      :: Integer
  , cfgThrottleBytesPerSec :: Integer
  , cfgThrottleBurstBytes  :: Integer
  , cfgListCacheTtlSec     :: Integer
  , cfgSearchMaxKeys       :: Int
  , cfgRecoveryGraceSec    :: Integer
  , cfgIdempotencyWindowSec :: Integer
  }

loadConfig :: IO Config
loadConfig = do
  listen <- fromMaybe "127.0.0.1:8080" <$> lookupEnv "NUTHATCH_LISTEN"
  let (host, portText) = splitHostPort listen
  port <- requireRead "NUTHATCH_LISTEN port" portText
  tlsCertPath <- fromMaybe "/tls/tls.crt" <$> lookupEnv "NUTHATCH_TLS_CERT_PATH"
  tlsKeyPath <- fromMaybe "/tls/tls.key" <$> lookupEnv "NUTHATCH_TLS_KEY_PATH"
  publicBase <- T.pack <$> requireEnv "NUTHATCH_PUBLIC_BASE_URL"
  when (not ("https://" `T.isPrefixOf` publicBase)) $
    fail "NUTHATCH_PUBLIC_BASE_URL must use https"
  jwtSecret <- T.pack <$> requireEnv "NUTHATCH_JWT_SECRET"
  when (BS.length (TE.encodeUtf8 jwtSecret) < 32) $
    fail "NUTHATCH_JWT_SECRET must be at least 32 bytes"
  sessionHours <- envInteger "NUTHATCH_SESSION_HOURS" 12
  cookieName <- T.pack . fromMaybe "nuthatch_session" <$> lookupEnv "NUTHATCH_COOKIE_NAME"
  csrfCookie <- T.pack . fromMaybe "nuthatch_csrf" <$> lookupEnv "NUTHATCH_CSRF_COOKIE_NAME"
  transactionCookie <- T.pack . fromMaybe "nuthatch_oidc" <$> lookupEnv "NUTHATCH_OIDC_TRANSACTION_COOKIE_NAME"
  oidcIssuer <- T.dropWhileEnd (== '/') . T.pack <$> requireEnv "NUTHATCH_OIDC_ISSUER"
  oidcClientId <- T.pack <$> requireEnv "NUTHATCH_OIDC_CLIENT_ID"
  additionalAudienceValue <- lookupEnv "NUTHATCH_OIDC_ADDITIONAL_AUDIENCES"
  let oidcAdditionalAudiences =
        case T.strip . T.pack <$> additionalAudienceValue of
          Nothing -> []
          Just "" -> []
          Just value -> map T.strip (T.splitOn "," value)
  when
    ( any T.null oidcAdditionalAudiences
      || oidcClientId `elem` oidcAdditionalAudiences
      || length oidcAdditionalAudiences /= length (nub oidcAdditionalAudiences)
    ) $
    fail "NUTHATCH_OIDC_ADDITIONAL_AUDIENCES must contain unique non-client values"
  oidcClientSecret <- T.pack <$> requireEnv "NUTHATCH_OIDC_CLIENT_SECRET"
  oidcRedirectUri <- T.pack <$> requireEnv "NUTHATCH_OIDC_REDIRECT_URI"
  when (oidcRedirectUri /= publicBase <> "/oidc/callback") $
    fail "NUTHATCH_OIDC_REDIRECT_URI must equal the public callback URL"
  oidcTransactionMinutes <- envInteger "NUTHATCH_OIDC_TRANSACTION_MINUTES" 5
  oidcMaxIdTokenSeconds <- envInteger "NUTHATCH_OIDC_MAX_ID_TOKEN_SECONDS" 3600
  pgConn <- requireEnv "NUTHATCH_PG_CONN"
  redisUrl <- requireEnv "NUTHATCH_REDIS_URL"
  (redisHost, redisPort, redisDb) <- parseRedisUrl redisUrl
  s3Endpoint <- T.pack <$> requireEnv "NUTHATCH_S3_ENDPOINT"
  s3Region <- T.pack . fromMaybe "us-east-1" <$> lookupEnv "NUTHATCH_S3_REGION"
  s3Bucket <- T.pack <$> requireEnv "NUTHATCH_S3_BUCKET"
  s3Access <- T.pack <$> requireEnv "NUTHATCH_S3_ACCESS_KEY"
  s3Secret <- T.pack <$> requireEnv "NUTHATCH_S3_SECRET_KEY"
  pathStyle <- envBool "NUTHATCH_S3_PATH_STYLE" True
  personalQuota <- envInteger "NUTHATCH_PERSONAL_QUOTA_BYTES" (1024 * 1024 * 1024)
  sharedQuota <- envInteger "NUTHATCH_SHARED_QUOTA_BYTES" (10 * 1024 * 1024 * 1024)
  maxObject <- envInteger "NUTHATCH_MAX_OBJECT_BYTES" (100 * 1024 * 1024)
  throttleRate <- envInteger "NUTHATCH_THROTTLE_BYTES_PER_SEC" (10 * 1024 * 1024)
  throttleBurst <- envInteger "NUTHATCH_THROTTLE_BURST_BYTES" (20 * 1024 * 1024)
  when (maxObject <= 0 || maxObject > maximumMultipartBytes) $
    fail "NUTHATCH_MAX_OBJECT_BYTES exceeds the supported streaming range"
  when (throttleRate <= 0 || throttleRate > luaExactIntegerMax) $
    fail "NUTHATCH_THROTTLE_BYTES_PER_SEC exceeds the exact throttle range"
  when (throttleBurst <= 0 || throttleBurst > luaExactIntegerMax) $
    fail "NUTHATCH_THROTTLE_BURST_BYTES exceeds the exact throttle range"
  listTtl <- envInteger "NUTHATCH_LIST_CACHE_TTL_SEC" 30
  searchMax <- fromInteger <$> envInteger "NUTHATCH_SEARCH_MAX_KEYS" 500
  recoveryGrace <- envInteger "NUTHATCH_RECOVERY_GRACE_SEC" 90
  idempotencyWindow <- envInteger "NUTHATCH_IDEMPOTENCY_WINDOW_SEC" 86400
  when (idempotencyWindow <= 0) $
    fail "NUTHATCH_IDEMPOTENCY_WINDOW_SEC must be positive"
  pure Config
    { cfgListenHost = host
    , cfgListenPort = port
    , cfgTlsCertPath = tlsCertPath
    , cfgTlsKeyPath = tlsKeyPath
    , cfgPublicBaseUrl = publicBase
    , cfgJwtSecret = jwtSecret
    , cfgSessionHours = sessionHours
    , cfgCookieName = cookieName
    , cfgCsrfCookieName = csrfCookie
    , cfgOidcTransactionCookieName = transactionCookie
    , cfgOidcIssuer = oidcIssuer
    , cfgOidcClientId = oidcClientId
    , cfgOidcAdditionalAudiences = oidcAdditionalAudiences
    , cfgOidcClientSecret = oidcClientSecret
    , cfgOidcRedirectUri = oidcRedirectUri
    , cfgOidcTransactionMinutes = oidcTransactionMinutes
    , cfgOidcMaxIdTokenSeconds = oidcMaxIdTokenSeconds
    , cfgPgConn = pgConn
    , cfgRedisHost = redisHost
    , cfgRedisPort = redisPort
    , cfgRedisDb = redisDb
    , cfgS3Endpoint = s3Endpoint
    , cfgS3Region = s3Region
    , cfgS3Bucket = s3Bucket
    , cfgS3AccessKey = s3Access
    , cfgS3SecretKey = s3Secret
    , cfgS3PathStyle = pathStyle
    , cfgPersonalQuotaBytes = personalQuota
    , cfgSharedQuotaBytes = sharedQuota
    , cfgMaxObjectBytes = maxObject
    , cfgThrottleBytesPerSec = throttleRate
    , cfgThrottleBurstBytes = throttleBurst
    , cfgListCacheTtlSec = listTtl
    , cfgSearchMaxKeys = searchMax
    , cfgRecoveryGraceSec = recoveryGrace
    , cfgIdempotencyWindowSec = idempotencyWindow
    }

luaExactIntegerMax :: Integer
luaExactIntegerMax = 9007199254740991

splitHostPort :: String -> (String, String)
splitHostPort s =
  case break (== ':') s of
    (h, ':' : p) -> (h, p)
    _            -> ("127.0.0.1", "8080")

requireEnv :: String -> IO String
requireEnv name = do
  value <- lookupEnv name
  case value of
    Just present | not (null present) -> pure present
    _ -> fail $ name <> " is required"

envInteger :: String -> Integer -> IO Integer
envInteger name def = do
  m <- lookupEnv name
  case m of
    Nothing -> pure def
    Just v  -> requireRead name v

envBool :: String -> Bool -> IO Bool
envBool name def = do
  m <- lookupEnv name
  case fmap T.toLower (T.pack <$> m) of
    Nothing      -> pure def
    Just "1"     -> pure True
    Just "true"  -> pure True
    Just "yes"   -> pure True
    Just "0"     -> pure False
    Just "false" -> pure False
    Just "no"    -> pure False
    Just other   -> fail $ name <> ": invalid boolean " <> T.unpack other

requireRead :: (Read a) => String -> String -> IO a
requireRead name v =
  case readMaybe v of
    Just x  -> pure x
    Nothing -> fail $ name <> ": cannot parse " <> v

parseRedisUrl :: String -> IO (String, Int, Integer)
parseRedisUrl url =
  case T.stripPrefix "redis://" (T.pack url) of
    Nothing -> fail "NUTHATCH_REDIS_URL must start with redis://"
    Just rest -> do
      let (hostPort, dbPart) =
            case T.breakOn "/" rest of
              (hp, d) | T.null d -> (hp, "/0")
              (hp, d)            -> (hp, d)
          (hostText, portText) =
            case T.breakOn ":" hostPort of
              (h, p) | T.null p -> (h, "6379")
              (h, p)            -> (h, T.drop 1 p)
      port <- requireRead "redis port" (T.unpack portText)
      db <- requireRead "redis db" (T.unpack (T.drop 1 dbPart))
      pure (T.unpack hostText, port, db)