nuthatch/test/RuntimeHttpProbe.hs

module Main (main) where

import           Control.Concurrent (threadDelay)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import           Nuthatch.Probe.Assert
import           Nuthatch.Probe.Http
import           Nuthatch.Probe.Oidc
import           Nuthatch.Probe.ProductClient
import           System.Environment (getArgs)
import           System.IO (hFlush, stdout)
import           Text.Read (readMaybe)

main :: IO ()
main = do
  context <- newProbeContext
  getArgs >>= \case
    ["health", expectedText] ->
      maybe
        (fail "invalid expected readiness status")
        (verifyHealth context)
        (readMaybe expectedText)
    ["baseline"] -> withSession context True "runtime-baseline" $
      verifyBaseline context
    ["coherence"] -> verifyCoherence context
    ["redis-unavailable"] ->
      withSession context False "runtime-redis" $
        verifyRedisUnavailable context
    ["database-unavailable"] ->
      withSession context False "runtime-database" $
        verifyDatabaseUnavailable context
    _ ->
      fail
        "expected health STATUS, baseline, coherence, redis-unavailable, \
        \or database-unavailable"

withSession
  :: ProbeContext
  -> Bool
  -> String
  -> (Session -> IO ())
  -> IO ()
withSession context verifyBoundary suffix action = do
  user <- requireEnv "NUTHATCH_OIDC_USER_A"
  login context verifyBoundary user suffix >>= action

verifyHealth :: ProbeContext -> Int -> IO ()
verifyHealth context expectedReady = do
  health <- get (probeClient context) (probeBase context <> "/healthz")
  assertEqual "runtime health status" 200 (probeStatus health)
  assertContains "runtime health body" "\"ok\":true" (probeBody health)
  ready <- get (probeClient context) (probeBase context <> "/readyz")
  assertEqual "runtime readiness status" expectedReady (probeStatus ready)
  _ <- get (probeClient context) (probeBase context <> "/app")
  session <- get (probeClient context) (probeBase context <> "/api/session")
  assertEqual "runtime unauthenticated session" 303 (probeStatus session)
  putStrLn "Runtime health semantics passed"

verifyBaseline :: ProbeContext -> Session -> IO ()
verifyBaseline context sessionA = do
  browsed <- browse context sessionA ""
  assertEqual "runtime baseline browse" 200 (probeStatus browsed)
  uploaded <- upload context sessionA "personal" "cross-user.txt"
    "76000000-0000-4000-8000-000000000001" "private-a"
  requireSucceeded "runtime baseline put" uploaded
  userB <- requireEnv "NUTHATCH_OIDC_USER_B"
  sessionB <- login context False userB "runtime-baseline-b"
  personalB <- browse context sessionB "?root=personal"
  assert "runtime personal cache crossed users" $
    not ("cross-user.txt" `BS.isInfixOf` probeBody personalB)
  wrongLogout <- postWith
    (probeClient context)
    defaultRequestOptions
      { optionCookies = Just (sessionCookies sessionA)
      , optionHeaders =
          [ ( "X-CSRF-Token"
            , "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
            )
          ]
      }
    (probeBase context <> "/logout")
  assert "runtime baseline accepted wrong logout CSRF" $
    probeStatus wrongLogout >= 400
  deleted <- deleteObject context sessionA "personal" "cross-user.txt"
    "76000000-0000-4000-8000-000000000002"
  requireSucceeded "runtime baseline delete" deleted
  restored <- upload context sessionA "personal" "cross-user.txt"
    "76000000-0000-4000-8000-000000000003" "private-a"
  requireSucceeded "runtime unavailable fixture" restored
  loggedOut <- postWith
    (probeClient context)
    defaultRequestOptions
      { optionCookies = Just (sessionCookies sessionA)
      , optionHeaders = [("X-CSRF-Token", sessionCsrf sessionA)]
      }
    (probeBase context <> "/logout")
  assertEqual "runtime baseline logout" 200 (probeStatus loggedOut)
  putStrLn "Runtime audit baseline passed"

verifyCoherence :: ProbeContext -> IO ()
verifyCoherence context = do
  userA <- requireEnv "NUTHATCH_OIDC_USER_A"
  userB <- requireEnv "NUTHATCH_OIDC_USER_B"
  sessionA <- login context False userA "runtime-coherence-a"
  sessionB <- login context False userB "runtime-coherence-b"
  sequence_
    [ browse context sessionB "?root=shared"
    , browse context sessionB "?root=shared&prefix=runtime"
    , browse context sessionB "?root=shared"
    , browse context sessionB "?root=shared&prefix=runtime"
    ]
  uploaded <- upload context sessionA "shared" "runtime/coherence.txt"
    "74000000-0000-4000-8000-000000000001" "runtime-coherence"
  requireSucceeded "shared coherence upload" uploaded
  rootListing <- browse context sessionB "?root=shared"
  assertContains "shared root cache invalidation"
    "runtime"
    (probeBody rootListing)
  prefixListing <- browse context sessionB "?root=shared&prefix=runtime"
  assertContains "shared prefix cache invalidation"
    "coherence.txt"
    (probeBody prefixListing)
  deleted <- deleteObject context sessionA "shared" "runtime/coherence.txt"
    "74000000-0000-4000-8000-000000000002"
  requireSucceeded "shared coherence delete" deleted
  afterDelete <- browse context sessionB "?root=shared&prefix=runtime"
  assert "shared deletion remained in another replica cache" $
    not ("coherence.txt" `BS.isInfixOf` probeBody afterDelete)
  threadDelay 2000000
  browse context sessionB "?root=shared" >>= \response ->
    assertEqual "cache TTL browse" 200 (probeStatus response)
  putStrLn "Cross-user cache coherence and TTL passed"

verifyRedisUnavailable :: ProbeContext -> Session -> IO ()
verifyRedisUnavailable context session = do
  listing <- browse context session "?root=personal"
  assertEqual "Redis-unavailable browse" 200 (probeStatus listing)
  assertContains "Redis-unavailable browse fixture"
    "cross-user.txt"
    (probeBody listing)
  searched <- browse context session "?root=personal&q=CROSS-USER"
  assertContains "Redis-unavailable search"
    "cross-user.txt"
    (probeBody searched)
  unavailableUpload <- upload context session "personal" "unavailable.bin"
    "72000000-0000-4000-8000-000000000001" "x"
  requireError "Redis-unavailable upload"
    503 "throttle_unavailable" unavailableUpload
  unavailableDownload <- download context session "personal" "cross-user.txt"
  requireError "Redis-unavailable download"
    503 "throttle_unavailable" unavailableDownload
  putStrLn "Redis-unavailable runtime behavior passed"

verifyDatabaseUnavailable :: ProbeContext -> Session -> IO ()
verifyDatabaseUnavailable context session = do
  putStrLn "Database fault checkpoint"
  hFlush stdout
  threadDelay 10000000
  unavailableUpload <- retryPastThrottle 5 $
    upload context session "personal"
      "database-unavailable.txt"
      "75000000-0000-4000-8000-000000000001"
      "x"
  requireError "database-unavailable upload"
    503 "mutation_rejected" unavailableUpload
  unavailableDelete <- deleteObject context session "personal"
    "cross-user.txt"
    "75000000-0000-4000-8000-000000000002"
  requireError "database-unavailable delete"
    503 "mutation_rejected" unavailableDelete
  putStrLn "Database-unavailable mutation behavior passed"

retryPastThrottle :: Int -> IO ProbeResponse -> IO ProbeResponse
retryPastThrottle attempts action = do
  response <- action
  if attempts > 1
      && "\"error\":\"throttle_unavailable\"" `BS.isInfixOf` probeBody response
    then threadDelay 250000 >> retryPastThrottle (attempts - 1) action
    else pure response

requireSucceeded :: String -> ProbeResponse -> IO ()
requireSucceeded label response = do
  assertEqual (label <> " status") 200 (probeStatus response)
  assertContains label "\"result\":\"succeeded\"" (probeBody response)

requireError :: String -> Int -> BS.ByteString -> ProbeResponse -> IO ()
requireError label status code response = do
  assertEqual (label <> " status") status (probeStatus response)
  assert
    (label <> " body: " <> B8.unpack (probeBody response))
    (("\"error\":\"" <> code <> "\"") `BS.isInfixOf` probeBody response)