nuthatch/src/Nuthatch/Config.hs

module Nuthatch.Config
  ( Config (..)
  , Secret
  , secret
  , revealSecret
  , loadConfig
  , parseRedisUri
  , validateAbsoluteUri
  ) where

import           Control.Exception (SomeException, try)
import           Control.Monad (when)
import qualified Data.ByteString as BS
import           Data.List (nub)
import           Data.List.NonEmpty (NonEmpty (..))
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Env
import           Nuthatch.Streaming (maximumMultipartBytes)
import qualified Text.URI as URI

newtype Secret value = Secret value

secret :: value -> Secret value
secret = Secret

revealSecret :: Secret value -> value
revealSecret (Secret value) = value

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

loadConfig :: IO Config
loadConfig = do
  listen <- envString "NUTHATCH_LISTEN" "127.0.0.1:8080"
  let (host, portText) = splitHostPort listen
  port <- parseValue "NUTHATCH_LISTEN port" portText
  when (T.null (T.pack host) || port <= 0 || port > 65535) $
    fail "NUTHATCH_LISTEN must contain a host and port between 1 and 65535"
  tlsCertPath <- envString "NUTHATCH_TLS_CERT_PATH" "/tls/tls.crt"
  tlsKeyPath <- envString "NUTHATCH_TLS_KEY_PATH" "/tls/tls.key"
  publicBase <- requireText "NUTHATCH_PUBLIC_BASE_URL"
    >>= validateAbsoluteUri "NUTHATCH_PUBLIC_BASE_URL" ["https"]
  jwtSecretText <- requireTextSecret "NUTHATCH_JWT_SECRET"
  when (BS.length (TE.encodeUtf8 jwtSecretText) < 32) $
    fail "NUTHATCH_JWT_SECRET must be at least 32 bytes"
  let jwtSecret = secret jwtSecretText
  sessionHours <- envInteger "NUTHATCH_SESSION_HOURS" 12
  cookieName <- T.pack <$> envString "NUTHATCH_COOKIE_NAME" "nuthatch_session"
  csrfCookie <- T.pack <$> envString "NUTHATCH_CSRF_COOKIE_NAME" "nuthatch_csrf"
  transactionCookie <- T.pack <$>
    envString "NUTHATCH_OIDC_TRANSACTION_COOKIE_NAME" "nuthatch_oidc"
  oidcIssuerValue <- requireText "NUTHATCH_OIDC_ISSUER"
  oidcIssuer <- T.dropWhileEnd (== '/') <$>
    validateAbsoluteUri "NUTHATCH_OIDC_ISSUER" ["http", "https"] oidcIssuerValue
  oidcClientId <- requireText "NUTHATCH_OIDC_CLIENT_ID"
  additionalAudienceValue <- T.strip . T.pack <$>
    envString "NUTHATCH_OIDC_ADDITIONAL_AUDIENCES" ""
  let oidcAdditionalAudiences
        | T.null additionalAudienceValue = []
        | otherwise = map T.strip (T.splitOn "," additionalAudienceValue)
  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 <- secret <$> requireTextSecret "NUTHATCH_OIDC_CLIENT_SECRET"
  oidcRedirectUri <- requireText "NUTHATCH_OIDC_REDIRECT_URI"
    >>= validateAbsoluteUri "NUTHATCH_OIDC_REDIRECT_URI" ["https"]
  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 <- secret <$> requireStringSecret "NUTHATCH_PG_CONN"
  redisUrl <- requireText "NUTHATCH_REDIS_URL"
  (redisHost, redisPort, redisDb) <- parseRedisUri redisUrl
  s3Endpoint <- requireText "NUTHATCH_S3_ENDPOINT"
    >>= validateOriginUri "NUTHATCH_S3_ENDPOINT" ["http", "https"]
  s3Region <- T.pack <$> envString "NUTHATCH_S3_REGION" "us-east-1"
  s3Bucket <- requireText "NUTHATCH_S3_BUCKET"
  s3Access <- secret <$> requireTextSecret "NUTHATCH_S3_ACCESS_KEY"
  s3Secret <- secret <$> requireTextSecret "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
  browsePageSize <- envBoundedInt "NUTHATCH_BROWSE_PAGE_SIZE" 200 1 1000
  searchMax <- envBoundedInt "NUTHATCH_SEARCH_MAX_KEYS" 500 1 100000
  searchTimeoutMs <- envInteger "NUTHATCH_SEARCH_TIMEOUT_MS" 2000
  deletePageSize <- envBoundedInt "NUTHATCH_DELETE_PAGE_SIZE" 100 1 1000
  recoveryGrace <- envInteger "NUTHATCH_RECOVERY_GRACE_SEC" 90
  idempotencyWindow <- envInteger "NUTHATCH_IDEMPOTENCY_WINDOW_SEC" 86400
  objectRequestTimeout <- envInteger "NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC" 300
  startupAttempts <- envBoundedInt "NUTHATCH_STARTUP_ATTEMPTS" 60 1 1000
  startupDelayMs <- envBoundedInt "NUTHATCH_STARTUP_DELAY_MS" 1000 1 60000
  auditObjectKeys <- envBool "NUTHATCH_AUDIT_OBJECT_KEYS" False
  when (recoveryGrace <= 0) $
    fail "NUTHATCH_RECOVERY_GRACE_SEC must be positive"
  when (idempotencyWindow <= 0) $
    fail "NUTHATCH_IDEMPOTENCY_WINDOW_SEC must be positive"
  when (objectRequestTimeout <= 0) $
    fail "NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC must be positive"
  when (sessionHours <= 0 || sessionHours > 168) $
    fail "NUTHATCH_SESSION_HOURS must be between 1 and 168"
  when (oidcTransactionMinutes <= 0 || oidcTransactionMinutes > 60) $
    fail "NUTHATCH_OIDC_TRANSACTION_MINUTES must be between 1 and 60"
  when (oidcMaxIdTokenSeconds <= 0 || oidcMaxIdTokenSeconds > 86400) $
    fail "NUTHATCH_OIDC_MAX_ID_TOKEN_SECONDS must be between 1 and 86400"
  when (personalQuota <= 0 || sharedQuota <= 0) $
    fail "configured quotas must be positive"
  when (listTtl <= 0 || listTtl > 86400) $
    fail "NUTHATCH_LIST_CACHE_TTL_SEC must be between 1 and 86400"
  when (searchTimeoutMs <= 0 || searchTimeoutMs > 60000) $
    fail "NUTHATCH_SEARCH_TIMEOUT_MS must be between 1 and 60000"
  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
    , cfgBrowsePageSize = browsePageSize
    , cfgSearchMaxKeys = searchMax
    , cfgSearchTimeoutMs = searchTimeoutMs
    , cfgDeletePageSize = deletePageSize
    , cfgRecoveryGraceSec = recoveryGrace
    , cfgIdempotencyWindowSec = idempotencyWindow
    , cfgObjectRequestTimeoutSec = objectRequestTimeout
    , cfgStartupAttempts = startupAttempts
    , cfgStartupDelayMs = startupDelayMs
    , cfgAuditObjectKeys = auditObjectKeys
    }

luaExactIntegerMax :: Integer
luaExactIntegerMax = 9007199254740991

splitHostPort :: String -> (String, String)
splitHostPort s =
  case span (/= ':') s of
    (h, ':' : p) | not (null h) && not (null p) -> (h, p)
    _ -> ("", "")

envInteger :: String -> Integer -> IO Integer
envInteger name defaultValue =
  Env.parse configInfo (Env.var Env.auto name (Env.def defaultValue))

envBoundedInt :: String -> Integer -> Integer -> Integer -> IO Int
envBoundedInt name defaultValue minimumValue maximumValue = do
  value <- envInteger name defaultValue
  when (value < minimumValue || value > maximumValue) $
    fail
      (name <> " must be between "
        <> show minimumValue <> " and " <> show maximumValue)
  pure (fromInteger value)

envBool :: String -> Bool -> IO Bool
envBool name defaultValue =
  Env.parse configInfo $
    Env.var (Env.eitherReader parseBoolean) name (Env.def defaultValue)
  where
    parseBoolean value =
      case map toLowerAscii value of
        "1"     -> Right True
        "true"  -> Right True
        "yes"   -> Right True
        "0"     -> Right False
        "false" -> Right False
        "no"    -> Right False
        _        -> Left "expected true or false"
    toLowerAscii c
      | c >= 'A' && c <= 'Z' = toEnum (fromEnum c + 32)
      | otherwise = c

envString :: String -> String -> IO String
envString name defaultValue =
  Env.parse configInfo (Env.var Env.str name (Env.def defaultValue))

requireText :: String -> IO Text
requireText name = T.pack <$>
  Env.parse configInfo (Env.var Env.nonempty name mempty)

requireTextSecret :: String -> IO Text
requireTextSecret name = T.pack <$>
  Env.parse configInfo (Env.sensitive (Env.var Env.nonempty name mempty))

requireStringSecret :: String -> IO String
requireStringSecret name =
  Env.parse configInfo (Env.sensitive (Env.var Env.nonempty name mempty))

parseValue :: Read value => String -> String -> IO value
parseValue name value =
  case reads value of
    [(parsed, "")] -> pure parsed
    _ -> fail (name <> " is invalid")

configInfo :: Env.Info Env.Error -> Env.Info Env.Error
configInfo = Env.header "Nuthatch configuration"

validateAbsoluteUri :: String -> [Text] -> Text -> IO Text
validateAbsoluteUri name allowedSchemes value = do
  parsed <- try (URI.mkURI value) :: IO (Either SomeException URI.URI)
  uri <- either (const (fail (name <> " is not a valid URI"))) pure parsed
  scheme <- maybe (fail (name <> " must be absolute"))
    (pure . T.toLower . URI.unRText)
    (URI.uriScheme uri)
  when (scheme `notElem` allowedSchemes) $
    fail (name <> " uses an unsupported scheme")
  authority <- either
    (const (fail (name <> " must contain an authority")))
    pure
    (URI.uriAuthority uri)
  when (URI.authUserInfo authority /= Nothing) $
    fail (name <> " must not contain credentials")
  when (T.null (URI.unRText (URI.authHost authority))) $
    fail (name <> " must contain a host")
  pure (URI.render uri)

validateOriginUri :: String -> [Text] -> Text -> IO Text
validateOriginUri name allowedSchemes value = do
  rendered <- validateAbsoluteUri name allowedSchemes value
  parsed <- URI.mkURI rendered
  when
    (URI.uriPath parsed /= Nothing
      || not (null (URI.uriQuery parsed))
      || URI.uriFragment parsed /= Nothing) $
    fail (name <> " must be an origin without path, query, or fragment")
  pure rendered

parseRedisUri :: Text -> IO (String, Int, Integer)
parseRedisUri value = do
  rendered <- validateAbsoluteUri "NUTHATCH_REDIS_URL" ["redis"] value
  parsed <- URI.mkURI rendered
  authority <- either
    (const (fail "NUTHATCH_REDIS_URL must contain an authority"))
    pure
    (URI.uriAuthority parsed)
  when (not (null (URI.uriQuery parsed)) || URI.uriFragment parsed /= Nothing) $
    fail "NUTHATCH_REDIS_URL must not contain a query or fragment"
  database <- case URI.uriPath parsed of
    Nothing -> pure 0
    Just (_, segment :| []) ->
      parseValue "NUTHATCH_REDIS_URL database" (T.unpack (URI.unRText segment))
    _ -> fail "NUTHATCH_REDIS_URL must contain at most one database path segment"
  let port = maybe 6379 fromIntegral (URI.authPort authority)
  when (database < 0 || database > 15) $
    fail "NUTHATCH_REDIS_URL database must be between 0 and 15"
  let renderedHost = URI.unRText (URI.authHost authority)
      connectionHost =
        fromMaybeText renderedHost (T.stripPrefix "[" renderedHost >>= T.stripSuffix "]")
  pure (T.unpack connectionHost, port, database)
  where
    fromMaybeText fallback = maybe fallback id