nuthatch/src/Nuthatch/Config.hs

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

import           Control.Monad (when)
import           Data.Maybe (fromMaybe)
import           Data.Text (Text)
import qualified Data.Text as T
import           System.Environment (lookupEnv)
import           Text.Read (readMaybe)

data AuthMode = AuthDev
  deriving stock (Eq, Show)

data Config = Config
  { cfgListenHost          :: String
  , cfgListenPort          :: Int
  , cfgPublicBaseUrl       :: Text
  , cfgJwtSecret           :: Text
  , cfgSessionHours        :: Integer
  , cfgCookieName          :: Text
  , cfgCsrfCookieName      :: Text
  , 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
  , cfgAuthMode            :: AuthMode
  }
  deriving stock (Show)

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
  publicBase <- T.pack . fromMaybe ("http://" <> listen) <$> lookupEnv "NUTHATCH_PUBLIC_BASE_URL"
  jwtSecret <- T.pack . fromMaybe "dev-only-change-me-to-a-long-random-string" <$> lookupEnv "NUTHATCH_JWT_SECRET"
  when (T.length jwtSecret < 16) $
    fail "NUTHATCH_JWT_SECRET must be at least 16 characters"
  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"
  pgConn <- fromMaybe "host=127.0.0.1 port=5432 user=nuthatch password=nuthatch dbname=nuthatch"
    <$> lookupEnv "NUTHATCH_PG_CONN"
  redisUrl <- fromMaybe "redis://127.0.0.1:6379/0" <$> lookupEnv "NUTHATCH_REDIS_URL"
  (redisHost, redisPort, redisDb) <- parseRedisUrl redisUrl
  s3Endpoint <- T.pack . fromMaybe "http://127.0.0.1:9000" <$> lookupEnv "NUTHATCH_S3_ENDPOINT"
  s3Region <- T.pack . fromMaybe "us-east-1" <$> lookupEnv "NUTHATCH_S3_REGION"
  s3Bucket <- T.pack . fromMaybe "nuthatch" <$> lookupEnv "NUTHATCH_S3_BUCKET"
  s3Access <- T.pack . fromMaybe "minioadmin" <$> lookupEnv "NUTHATCH_S3_ACCESS_KEY"
  s3Secret <- T.pack . fromMaybe "minioadmin" <$> lookupEnv "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)
  listTtl <- envInteger "NUTHATCH_LIST_CACHE_TTL_SEC" 30
  searchMax <- fromInteger <$> envInteger "NUTHATCH_SEARCH_MAX_KEYS" 500
  recoveryGrace <- envInteger "NUTHATCH_RECOVERY_GRACE_SEC" 90
  authModeText <- fromMaybe "dev" <$> lookupEnv "NUTHATCH_AUTH_MODE"
  authMode <- case authModeText of
    "dev" -> pure AuthDev
    other -> fail $ "unsupported NUTHATCH_AUTH_MODE: " <> other
  pure Config
    { cfgListenHost = host
    , cfgListenPort = port
    , cfgPublicBaseUrl = publicBase
    , cfgJwtSecret = jwtSecret
    , cfgSessionHours = sessionHours
    , cfgCookieName = cookieName
    , cfgCsrfCookieName = csrfCookie
    , 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
    , cfgAuthMode = authMode
    }

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

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)