nuthatch/test/RuntimeProbe.hs

module Main (main) where

import           Control.Concurrent (threadDelay)
import           Control.Exception (SomeException, try)
import           Control.Monad (unless)
import           Data.Foldable (traverse_)
import           Nuthatch.Config
import           Nuthatch.Redis
import           Nuthatch.Types
import           System.Environment
  ( getArgs
  , lookupEnv
  , setEnv
  , unsetEnv
  )

main :: IO ()
main = do
  mode <- getArgs
  case mode of
    ["config"] -> verifyConfiguration
    ["available"] -> withConfiguration $ \config ->
      withRedis (cfgRedis config) (verifyAvailable config)
    ["unavailable"] -> withConfiguration $ \config ->
      withRedis (cfgRedis config) (verifyUnavailable config)
    _ -> fail "expected config, available, or unavailable mode"

withConfiguration :: (Config -> IO ()) -> IO ()
withConfiguration action = loadConfig >>= action

verifyConfiguration :: IO ()
verifyConfiguration = do
  baseValues <- traverse
    (\name -> (name,) <$> lookupEnv name)
    [ "NUTHATCH_JWT_SECRET"
    , "NUTHATCH_OIDC_CLIENT_SECRET"
    , "NUTHATCH_PG_CONN"
    , "NUTHATCH_S3_ACCESS_KEY"
    , "NUTHATCH_S3_SECRET_KEY"
    , "NUTHATCH_S3_ENDPOINT"
    , "NUTHATCH_BROWSE_PAGE_SIZE"
    , "NUTHATCH_PUBLIC_BASE_URL"
    , "NUTHATCH_REDIS_URL"
    , "NUTHATCH_LISTEN"
    , "NUTHATCH_SESSION_HOURS"
    , "NUTHATCH_OIDC_ADDITIONAL_AUDIENCES"
    , "NUTHATCH_OIDC_MAX_ID_TOKEN_SECONDS"
    , "NUTHATCH_S3_REGION"
    , "NUTHATCH_PERSONAL_QUOTA_BYTES"
    , "NUTHATCH_MAX_OBJECT_BYTES"
    , "NUTHATCH_THROTTLE_BYTES_PER_SEC"
    , "NUTHATCH_RECOVERY_GRACE_SEC"
    , "NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC"
    , "NUTHATCH_STARTUP_ATTEMPTS"
    , "NUTHATCH_STARTUP_DELAY_MS"
    ]
  let load changes = do
        traverse_ (uncurry setVariable) baseValues
        traverse_ (uncurry setVariable) changes
        loadConfig
  expectAccepted (load []) "valid configuration"
  grouped <- load
    [ ("NUTHATCH_LISTEN", Just "127.0.0.2:9090")
    , ("NUTHATCH_SESSION_HOURS", Just "6")
    , ("NUTHATCH_OIDC_MAX_ID_TOKEN_SECONDS", Just "1800")
    , ("NUTHATCH_S3_REGION", Just "group-test")
    , ("NUTHATCH_PERSONAL_QUOTA_BYTES", Just "2048")
    , ("NUTHATCH_THROTTLE_BYTES_PER_SEC", Just "4096")
    , ("NUTHATCH_RECOVERY_GRACE_SEC", Just "45")
    , ("NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC", Just "120")
    , ("NUTHATCH_STARTUP_ATTEMPTS", Just "7")
    , ("NUTHATCH_STARTUP_DELAY_MS", Just "25")
    ]
  requireEqual "127.0.0.2" (cfgListenHost (cfgHttp grouped))
  requireEqual 6 (cfgSessionHours (cfgHttp grouped))
  requireEqual 1800 (cfgOidcMaxIdTokenSeconds (cfgOidc grouped))
  requireEqual "group-test" (cfgS3Region (cfgS3 grouped))
  requireEqual 2048 (cfgPersonalQuotaBytes (cfgProduct grouped))
  requireEqual 4096 (cfgThrottleBytesPerSec (cfgRedis grouped))
  requireEqual 45 (cfgRecoveryGraceSec (cfgRecovery grouped))
  requireEqual 120 (cfgObjectRequestTimeoutSec (cfgRecovery grouped))
  requireEqual 120 (cfgS3RequestTimeoutSec (cfgS3 grouped))
  requireEqual 7 (cfgStartupAttempts (cfgRuntime grouped))
  requireEqual 25 (cfgStartupDelayMs (cfgRuntime grouped))
  expectRejected
    (load [("NUTHATCH_PG_CONN", Nothing)])
    "missing required configuration"
  expectRejected
    (load [("NUTHATCH_S3_ENDPOINT", Just "not a URI")])
    "malformed URI configuration"
  expectRejected
    (load [("NUTHATCH_S3_ENDPOINT", Just "https://store.invalid/path")])
    "non-origin S3 configuration"
  expectRejected
    (load
      [("NUTHATCH_BROWSE_PAGE_SIZE", Just "18446744073709551617")])
    "out-of-range configuration"
  expectRejected
    (load [("NUTHATCH_LISTEN", Just "127.0.0.1:0")])
    "invalid HTTP listener configuration"
  expectRejected
    (load [("NUTHATCH_JWT_SECRET", Just "too-short")])
    "short session secret"
  expectRejected
    (load [("NUTHATCH_OIDC_ADDITIONAL_AUDIENCES", Just "extra,extra")])
    "duplicate OIDC audiences"
  expectRejected
    (load [("NUTHATCH_REDIS_URL", Just "redis://user:secret@redis:6379/0")])
    "credential-bearing Redis configuration"
  expectRejected
    (load [("NUTHATCH_MAX_OBJECT_BYTES", Just "999999999999999")])
    "unsupported product object limit"
  expectRejected
    (load [("NUTHATCH_THROTTLE_BYTES_PER_SEC", Just "0")])
    "invalid Redis throttle configuration"
  expectRejected
    (load [("NUTHATCH_RECOVERY_GRACE_SEC", Just "0")])
    "invalid recovery configuration"
  expectRejected
    (load [("NUTHATCH_STARTUP_ATTEMPTS", Just "0")])
    "invalid runtime startup configuration"
  expectRejected
    (load
      [ ( "NUTHATCH_PUBLIC_BASE_URL"
        , Just "https://user:[email protected]"
        )
      ])
    "credential-bearing URI configuration"
  expectAccepted
    (load [("NUTHATCH_REDIS_URL", Just "redis://[::1]:6379/0")])
    "IPv6 URI configuration"
  putStrLn "runtime configuration cases passed"

expectAccepted :: IO Config -> String -> IO ()
expectAccepted load label = do
  result <- try load :: IO (Either SomeException Config)
  case result of
    Left _ -> fail (label <> " was rejected")
    Right _ -> pure ()

expectRejected :: IO Config -> String -> IO ()
expectRejected load label = do
  result <- try load :: IO (Either SomeException Config)
  case result of
    Left _ -> pure ()
    Right _ -> fail (label <> " was accepted")

setVariable :: String -> Maybe String -> IO ()
setVariable name = maybe (unsetEnv name) (setEnv name)

verifyAvailable :: Config -> Redis -> IO ()
verifyAvailable config redis = do
  let productCfg = cfgProduct config
  cacheSet redis "nuthatch:runtime:ttl"
    (cfgListCacheTtlSec productCfg)
    "cached"
  cacheGet redis "nuthatch:runtime:ttl" >>= requireEqual (Just "cached")
  threadDelay
    (fromInteger ((cfgListCacheTtlSec productCfg + 1) * 1000000))
  cacheGet redis "nuthatch:runtime:ttl" >>= requireEqual Nothing
  let userA = UserId "runtime-user-a"
      userB = UserId "runtime-user-b"
  sharedBeforeA <- cacheGeneration redis userA Shared
  sharedBeforeB <- cacheGeneration redis userB Shared
  requireEqual sharedBeforeA sharedBeforeB
  cacheInvalidatePrefixes redis userA Shared [""]
  sharedAfterB <- cacheGeneration redis userB Shared
  unless (sharedAfterB /= sharedBeforeB) $
    fail "shared cache generation did not change across users"
  personalBeforeB <- cacheGeneration redis userB Personal
  cacheInvalidatePrefixes redis userA Personal [""]
  personalAfterB <- cacheGeneration redis userB Personal
  requireEqual personalBeforeB personalAfterB
  putStrLn "runtime cache coherence passed"

verifyUnavailable :: Config -> Redis -> IO ()
verifyUnavailable config redis = do
  cacheGet redis "nuthatch:runtime:missing" >>= requireEqual Nothing
  cacheSet redis "nuthatch:runtime:missing" 1 "ignored"
  cacheInvalidatePrefixes redis (UserId "runtime-user") Shared [""]
  throttled <- throttleCheck
    redis
    (cfgRedis config)
    (UserId "runtime-user")
    1
  case throttled of
    Left _ -> pure ()
    Right _ -> fail "transfer throttle did not fail closed"
  putStrLn "runtime Redis degradation passed"

requireEqual :: (Eq value, Show value) => value -> value -> IO ()
requireEqual expected actual =
  unless (actual == expected) $
    fail ("expected " <> show expected <> ", got " <> show actual)