189 lines
7.8 KiB
Haskell
189 lines
7.8 KiB
Haskell
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.Curl
|
|
import Nuthatch.Probe.Oidc
|
|
import Nuthatch.Probe.ProductClient
|
|
import System.Environment (getArgs)
|
|
import System.IO (hFlush, stdout)
|
|
import System.IO.Temp (withSystemTempDirectory)
|
|
import Text.Read (readMaybe)
|
|
|
|
main :: IO ()
|
|
main =
|
|
withSystemTempDirectory "nuthatch-runtime-http-probe" $ \directory -> do
|
|
context <- newProbeContext directory
|
|
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 <- curl [probeBase context <> "/healthz"]
|
|
assertEqual "runtime health status" 200 (curlStatus health)
|
|
assertContains "runtime health body" "\"ok\":true" (curlBody health)
|
|
ready <- curl [probeBase context <> "/readyz"]
|
|
assertEqual "runtime readiness status" expectedReady (curlStatus ready)
|
|
_ <- curl [probeBase context <> "/app"]
|
|
session <- curl [probeBase context <> "/api/session"]
|
|
assertEqual "runtime unauthenticated session" 303 (curlStatus session)
|
|
putStrLn "Runtime health semantics passed"
|
|
|
|
verifyBaseline :: ProbeContext -> Session -> IO ()
|
|
verifyBaseline context sessionA = do
|
|
browsed <- browse context sessionA ""
|
|
assertEqual "runtime baseline browse" 200 (curlStatus 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` curlBody personalB)
|
|
wrongLogout <- curl
|
|
[ "--cookie", sessionCookies sessionA
|
|
, "--header"
|
|
, "X-CSRF-Token: bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
|
|
, "--request", "POST"
|
|
, probeBase context <> "/logout"
|
|
]
|
|
assert "runtime baseline accepted wrong logout CSRF" $
|
|
curlStatus 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 <- curl
|
|
[ "--cookie", sessionCookies sessionA
|
|
, "--cookie-jar", sessionCookies sessionA
|
|
, "--header", "X-CSRF-Token: " <> B8.unpack (sessionCsrf sessionA)
|
|
, "--request", "POST"
|
|
, probeBase context <> "/logout"
|
|
]
|
|
assertEqual "runtime baseline logout" 200 (curlStatus 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"
|
|
(curlBody rootListing)
|
|
prefixListing <- browse context sessionB "?root=shared&prefix=runtime"
|
|
assertContains "shared prefix cache invalidation"
|
|
"coherence.txt"
|
|
(curlBody 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` curlBody afterDelete)
|
|
threadDelay 2000000
|
|
browse context sessionB "?root=shared" >>= \response ->
|
|
assertEqual "cache TTL browse" 200 (curlStatus 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 (curlStatus listing)
|
|
assertContains "Redis-unavailable browse fixture"
|
|
"cross-user.txt"
|
|
(curlBody listing)
|
|
searched <- browse context session "?root=personal&q=CROSS-USER"
|
|
assertContains "Redis-unavailable search"
|
|
"cross-user.txt"
|
|
(curlBody 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 CurlResponse -> IO CurlResponse
|
|
retryPastThrottle attempts action = do
|
|
response <- action
|
|
if attempts > 1
|
|
&& "\"error\":\"throttle_unavailable\"" `BS.isInfixOf` curlBody response
|
|
then threadDelay 250000 >> retryPastThrottle (attempts - 1) action
|
|
else pure response
|
|
|
|
requireSucceeded :: String -> CurlResponse -> IO ()
|
|
requireSucceeded label response = do
|
|
assertEqual (label <> " status") 200 (curlStatus response)
|
|
assertContains label "\"result\":\"succeeded\"" (curlBody response)
|
|
|
|
requireError :: String -> Int -> BS.ByteString -> CurlResponse -> IO ()
|
|
requireError label status code response = do
|
|
assertEqual (label <> " status") status (curlStatus response)
|
|
assert
|
|
(label <> " body: " <> B8.unpack (curlBody response))
|
|
(("\"error\":\"" <> code <> "\"") `BS.isInfixOf` curlBody response)
|