ms2k/nuthatch
SHA256
Watch
0
Code Releases Activity

Type ordinary integration probe HTTP traffic

Browse source
This commit is contained in:
ms2k 2026-07-20 23:06:01 +09:00
commit cc5c47f2ce
11 changed files with 1022 additions and 661 deletions
Download patch file Download diff file Expand all files Collapse all files

239
test/AuthProbe.hs
View file

@ -8,28 +8,27 @@ import qualified Data.ByteString.Char8 as B8
import Data.List (find)
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
import Nuthatch.Probe.Http
import Nuthatch.Probe.Oidc
import Nuthatch.Probe.ProductClient
import System.Entropy (getEntropy)
import System.IO.Temp (withSystemTempDirectory)
main :: IO ()
main =
withSystemTempDirectory "nuthatch-auth-probe" $ \directory -> do
context <- newProbeContext directory
runId <- B8.unpack . B16.encode <$> getEntropy 8
verifyCredentialScope
waitForApplication context
verifyPublicBoundary context
userA <- requireEnv "NUTHATCH_OIDC_USER_A"
sessionA <- login context True userA "a"
verifyPkceBoundary context userA
verifyAuthenticatedBoundary context sessionA
exerciseRoot context sessionA runId "personal" "01"
exerciseRoot context sessionA runId "shared" "02"
verifyCrossUserBoundary context sessionA runId
verifyLogout context sessionA
putStrLn "OIDC application boundary passed"
main = do
context <- newProbeContext
runId <- B8.unpack . B16.encode <$> getEntropy 8
verifyCredentialScope
waitForApplication context
verifyPublicBoundary context
userA <- requireEnv "NUTHATCH_OIDC_USER_A"
sessionA <- login context True userA "a"
verifyPkceBoundary context userA
verifyAuthenticatedBoundary context sessionA
exerciseRoot context sessionA runId "personal" "01"
exerciseRoot context sessionA runId "shared" "02"
verifyCrossUserBoundary context sessionA runId
verifyLogout context sessionA
putStrLn "OIDC application boundary passed"
waitForApplication :: ProbeContext -> IO ()
waitForApplication context = go 30
@ -37,16 +36,16 @@ waitForApplication context = go 30
go :: Int -> IO ()
go remaining = do
result <-
try (curl
[ "--connect-timeout", "1"
, "--max-time", "2"
, probeBase context <> "/readyz"
])
:: IO (Either CurlTransportFailure CurlResponse)
try
(getWith
(probeClient context)
defaultRequestOptions { optionTimeoutMicros = Just 2000000 }
(probeBase context <> "/readyz"))
:: IO (Either HttpException ProbeResponse)
case result of
Right _ -> pure ()
Left failure
| curlTransportExitCode failure == 7 && remaining > 1 ->
| isConnectionFailure failure && remaining > 1 ->
threadDelay 1000000 >> go (remaining - 1)
| otherwise -> throwIO failure
@ -63,9 +62,9 @@ verifyCredentialScope = do
denied label arguments = do
response <- curl (signed <> arguments)
assertEqual
(label <> ": " <> B8.unpack (curlBody response))
(label <> ": " <> B8.unpack (probeBody response))
403
(curlStatus response)
(probeStatus response)
emptyPayload =
"X-Amz-Content-Sha256:e3b0c44298fc1c149afbf4c8996fb924"
<> "27ae41e4649b934ca495991b7852b855"
@ -93,73 +92,89 @@ verifyCredentialScope = do
verifyPublicBoundary :: ProbeContext -> IO ()
verifyPublicBoundary context = do
health <- curl [probeBase context <> "/healthz"]
assertEqual "health status" 200 (curlStatus health)
assertContains "health response" "\"ok\":true" (curlBody health)
ready <- curl [probeBase context <> "/readyz"]
assertEqual "readiness status" 200 (curlStatus ready)
assertContains "readiness response" "\"ready\":true" (curlBody ready)
loginPost <- curl ["--request", "POST", probeBase context <> "/login"]
assertEqual "login method boundary" 405 (curlStatus loginPost)
root <- curl [probeBase context <> "/"]
assertEqual "root route boundary" 404 (curlStatus root)
downloadResponse <- curl
[ probeBase context
<> "/api/download?root=personal&path=unauthenticated"
]
assertEqual "unauthenticated download" 303 (curlStatus downloadResponse)
uploadResponse <- curl
[ "--header", "X-Declared-Size: 1"
, "--header", "X-Content-SHA256: " <> B8.unpack (sha256Hex "x")
, "--header"
, "X-CSRF-Token: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
, "--data", "x"
, probeBase context
health <- get (probeClient context) (probeBase context <> "/healthz")
assertEqual "health status" 200 (probeStatus health)
assertContains "health response" "\"ok\":true" (probeBody health)
ready <- get (probeClient context) (probeBase context <> "/readyz")
assertEqual "readiness status" 200 (probeStatus ready)
assertContains "readiness response" "\"ready\":true" (probeBody ready)
loginPost <- postWith
(probeClient context)
defaultRequestOptions
(probeBase context <> "/login")
assertEqual "login method boundary" 405 (probeStatus loginPost)
root <- get (probeClient context) (probeBase context <> "/")
assertEqual "root route boundary" 404 (probeStatus root)
downloadResponse <- get
(probeClient context)
(probeBase context <> "/api/download?root=personal&path=unauthenticated")
assertEqual "unauthenticated download" 303 (probeStatus downloadResponse)
uploadResponse <- postWith
(probeClient context)
defaultRequestOptions
{ optionHeaders =
[ ("X-Declared-Size", "1")
, ("X-Content-SHA256", sha256Hex "x")
, ( "X-CSRF-Token"
, "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
)
]
, optionBody = ByteBody "x"
}
(probeBase context
<> "/api/upload?root=personal&path=unauthenticated"
<> "&operation_id=40000000-0000-4000-8000-000000000001"
]
assertEqual "unauthenticated upload" 303 (curlStatus uploadResponse)
deleteResponse <- curl
[ "--header", "Content-Type: application/json"
, "--data"
, "{\"root\":\"personal\",\"path\":\"unauthenticated\","
<> "&operation_id=40000000-0000-4000-8000-000000000001")
assertEqual "unauthenticated upload" 303 (probeStatus uploadResponse)
deleteResponse <- postWith
(probeClient context)
defaultRequestOptions
{ optionHeaders = [("Content-Type", "application/json")]
, optionBody = ByteBody $
"{\"root\":\"personal\",\"path\":\"unauthenticated\","
<> "\"operation_id\":\"40000000-0000-4000-8000-000000000002\","
<> "\"csrf\":\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"}"
, probeBase context <> "/api/delete"
]
assertEqual "unauthenticated delete" 303 (curlStatus deleteResponse)
removedCompatibility <- curl
[ "--header", "Content-Type: application/json"
, "--data"
, "{\"root\":\"personal\",\"path\":\"unauthenticated\","
}
(probeBase context <> "/api/delete")
assertEqual "unauthenticated delete" 303 (probeStatus deleteResponse)
removedCompatibility <- postWith
(probeClient context)
defaultRequestOptions
{ optionHeaders = [("Content-Type", "application/json")]
, optionBody = ByteBody $
"{\"root\":\"personal\",\"path\":\"unauthenticated\","
<> "\"csrf\":\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"}"
, probeBase context <> "/delete-prefix"
]
assertEqual "removed compatibility route" 404 (curlStatus removedCompatibility)
logoutResponse <- curl
[ "--header"
, "X-CSRF-Token: aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
, "--request", "POST"
, probeBase context <> "/logout"
]
assertEqual "unauthenticated logout" 303 (curlStatus logoutResponse)
}
(probeBase context <> "/delete-prefix")
assertEqual "removed compatibility route" 404 (probeStatus removedCompatibility)
logoutResponse <- postWith
(probeClient context)
defaultRequestOptions
{ optionHeaders =
[ ( "X-CSRF-Token"
, "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
)
]
}
(probeBase context <> "/logout")
assertEqual "unauthenticated logout" 303 (probeStatus logoutResponse)
verifyAuthenticatedBoundary :: ProbeContext -> Session -> IO ()
verifyAuthenticatedBoundary context session = do
html <- curl
[ "--cookie", sessionCookies session
, probeBase context <> "/api/browse"
]
assertEqual "authenticated HTML browse" 200 (curlStatus html)
html <- getWith
(probeClient context)
defaultRequestOptions
{ optionCookies = Just (sessionCookies session) }
(probeBase context <> "/api/browse")
assertEqual "authenticated HTML browse" 200 (probeStatus html)
json <- browse context session ""
assertEqual "authenticated JSON browse" 200 (curlStatus json)
assertEqual "authenticated JSON browse" 200 (probeStatus json)
let prohibited =
[ "NUTHATCH_S3"
, "AWS_ACCESS_KEY"
, "AWS_SECRET_ACCESS_KEY"
, "client_secret"
]
bodies = curlBody html <> curlBody json
bodies = probeBody html <> probeBody json
mapM_
(\value ->
assert ("browser response exposed " <> value) $
@ -182,18 +197,18 @@ exerciseRoot context session runId root suffix = do
firstUpload <- upload context session root path (operation "0") first
requireSucceeded "first upload" firstUpload
listing <- browse context session ("?root=" <> root)
assertContains "uploaded object listing" (B8.pack path) (curlBody listing)
assertContains "uploaded object listing" (B8.pack path) (probeBody listing)
firstDownload <- download context session root path
assertEqual "first download status" 200 (curlStatus firstDownload)
assertEqual "first download body" first (curlBody firstDownload)
assertEqual "first download status" 200 (probeStatus firstDownload)
assertEqual "first download body" first (probeBody firstDownload)
overwrite <- upload context session root path (operation "1") second
requireSucceeded "overwrite" overwrite
secondDownload <- download context session root path
assertEqual "overwrite body" second (curlBody secondDownload)
assertEqual "overwrite body" second (probeBody secondDownload)
deleted <- deleteObject context session root path (operation "2")
requireSucceeded "delete" deleted
missing <- download context session root path
assertEqual "deleted object" 404 (curlStatus missing)
assertEqual "deleted object" 404 (probeStatus missing)
verifyCrossUserBoundary :: ProbeContext -> Session -> String -> IO ()
verifyCrossUserBoundary context sessionA runId = do
@ -208,27 +223,32 @@ verifyCrossUserBoundary context sessionA runId = do
sessionB <- login context False userB "b"
personalB <- browse context sessionB "?root=personal"
assert "another user observed a personal object" $
not ("cross-user.txt" `BS.isInfixOf` curlBody personalB)
not ("cross-user.txt" `BS.isInfixOf` probeBody personalB)
sharedB <- browse context sessionB "?root=shared"
assertContains "shared object visibility" "cross-user.txt" (curlBody sharedB)
assertContains "shared object visibility" "cross-user.txt" (probeBody sharedB)
verifyLogout :: ProbeContext -> Session -> IO ()
verifyLogout context session = do
rejected <- curl
[ "--cookie", sessionCookies session
, "--header"
, "X-CSRF-Token: bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
, "--request", "POST"
, probeBase context <> "/logout"
]
assert "logout accepted the wrong CSRF token" (curlStatus rejected >= 400)
completed <- curl
[ "--cookie", sessionCookies session
, "--header", "X-CSRF-Token: " <> B8.unpack (sessionCsrf session)
, "--request", "POST"
, probeBase context <> "/logout"
]
assertEqual "logout status" 200 (curlStatus completed)
rejected <- postWith
(probeClient context)
defaultRequestOptions
{ optionCookies = Just (sessionCookies session)
, optionHeaders =
[ ( "X-CSRF-Token"
, "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
)
]
}
(probeBase context <> "/logout")
assert "logout accepted the wrong CSRF token" (probeStatus rejected >= 400)
completed <- postWith
(probeClient context)
defaultRequestOptions
{ optionCookies = Just (sessionCookies session)
, optionHeaders = [("X-CSRF-Token", sessionCsrf session)]
}
(probeBase context <> "/logout")
assertEqual "logout status" 200 (probeStatus completed)
mapM_
(\name ->
let matching =
@ -240,13 +260,14 @@ verifyLogout context session = do
(BS.isInfixOf "Max-Age=0")
matching)
["nuthatch_session", "nuthatch_csrf", "nuthatch_oidc"]
after <- curl
[ "--header", "Accept: application/json"
, probeBase context <> "/api/browse"
]
assertEqual "session after logout" 303 (curlStatus after)
after <- getWith
(probeClient context)
defaultRequestOptions
{ optionHeaders = [("Accept", "application/json")] }
(probeBase context <> "/api/browse")
assertEqual "session after logout" 303 (probeStatus after)
requireSucceeded :: String -> CurlResponse -> IO ()
requireSucceeded :: String -> ProbeResponse -> IO ()
requireSucceeded label response = do
assertEqual (label <> " status") 200 (curlStatus response)
assertContains label "\"result\":\"succeeded\"" (curlBody response)
assertEqual (label <> " status") 200 (probeStatus response)
assertContains label "\"result\":\"succeeded\"" (probeBody response)

31
test/DependencyProbe.hs
View file

@ -25,13 +25,16 @@ import Database.Redis
)
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
import Nuthatch.Probe.Http hiding (get)
import qualified Nuthatch.Probe.Http as Http
main :: IO ()
main = do
client <- newProbeClient
verifyPostgres
verifyCoordination "redis"
verifyCoordination "dragonfly"
verifyOidc
verifyOidc client
verifyTarget
"Garage"
"http://garage:3900"
@ -84,15 +87,15 @@ verifyCoordination host =
(Right (Just "passed"))
loaded)
verifyOidc :: IO ()
verifyOidc =
verifyOidc :: ProbeClient -> IO ()
verifyOidc client =
mapM_
(\(label, url, marker) ->
retry label 30 $ do
response <- curl [url]
response <- Http.get client url
pure
( curlStatus response == 200
&& marker `B8.isInfixOf` curlBody response
( probeStatus response == 200
&& marker `B8.isInfixOf` probeBody response
))
[ ( "Keycloak discovery"
, "http://keycloak.nuthatch.test:8080/realms/master/.well-known/openid-configuration"
@ -144,9 +147,9 @@ verifyTarget label endpoint region accessKey secretKey createBucket = do
assert
( label
<> " bucket creation failed: "
<> B8.unpack (curlBody created)
<> B8.unpack (probeBody created)
) $
curlStatus created `elem` [200, 409]
probeStatus created `elem` [200, 409]
else pure ()
uploaded <- retryResponse 30 $ curl
( signed
@ -158,9 +161,9 @@ verifyTarget label endpoint region accessKey secretKey createBucket = do
]
)
assertEqual
(label <> " upload: " <> B8.unpack (curlBody uploaded))
(label <> " upload: " <> B8.unpack (probeBody uploaded))
200
(curlStatus uploaded)
(probeStatus uploaded)
downloaded <- curl
( signed
<> [ "--header"
@ -168,10 +171,10 @@ verifyTarget label endpoint region accessKey secretKey createBucket = do
, bucket <> "/probe/payload"
]
)
assertEqual (label <> " download status") 200 (curlStatus downloaded)
assertEqual (label <> " download status") 200 (probeStatus downloaded)
assertEqual (label <> " object body")
(B8.pack payload)
(curlBody downloaded)
(probeBody downloaded)
retry :: String -> Int -> IO Bool -> IO ()
retry label attempts action =
@ -184,13 +187,13 @@ retry label attempts action =
then fail (label <> " did not become available")
else threadDelay 1000000 >> go (remaining - 1)
retryResponse :: Int -> IO CurlResponse -> IO CurlResponse
retryResponse :: Int -> IO ProbeResponse -> IO ProbeResponse
retryResponse attempts action =
go attempts
where
go remaining = do
response <- action
if curlStatus response == 200 || remaining <= 1
if probeStatus response == 200 || remaining <= 1
then pure response
else threadDelay 1000000 >> go (remaining - 1)

9
test/FixtureProbe.hs
View file

@ -11,7 +11,7 @@ import Database.PostgreSQL.Simple (Only (..))
import Nuthatch.Config (Config (..), loadConfig)
import qualified Nuthatch.Db as Db
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
import Nuthatch.Probe.Http
import Nuthatch.Redis
import Nuthatch.S3
import Nuthatch.Types
@ -19,6 +19,7 @@ import System.Environment (setEnv)
main :: IO ()
main = do
client <- newProbeClient
profile <- requireEnv "NUTHATCH_FIXTURE_PROFILE"
lane <- requireEnv "NUTHATCH_FIXTURE_LANE"
pgConnection <- requireEnv "NUTHATCH_PG_CONN"
@ -39,9 +40,9 @@ main = do
cacheGet redis "lane-canary" >>=
assertEqual "coordination lane canary" (Just (B8.pack profile))
issuer <- requireEnv "NUTHATCH_OIDC_ISSUER"
discovery <- curl [issuer <> "/.well-known/openid-configuration"]
assertEqual "OIDC discovery status" 200 (curlStatus discovery)
assertContains "OIDC discovery issuer" "\"issuer\"" (curlBody discovery)
discovery <- get client (issuer <> "/.well-known/openid-configuration")
assertEqual "OIDC discovery status" 200 (probeStatus discovery)
assertContains "OIDC discovery issuer" "\"issuer\"" (probeBody discovery)
store <- newS3 (cfgS3 config)
let key = ObjectKey "lane-canary"
body = BL.fromStrict (B8.pack profile)

91
test/IdempotencyProbe.hs
View file

@ -6,6 +6,7 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
import Nuthatch.Probe.Http
import Nuthatch.Probe.Oidc
import Nuthatch.Probe.ProductClient
import System.Exit (ExitCode (..))
@ -25,7 +26,7 @@ import System.Process
main :: IO ()
main =
withSystemTempDirectory "nuthatch-idempotency-probe" $ \directory -> do
context <- newProbeContext directory
context <- newProbeContext
user <- requireEnv "NUTHATCH_OIDC_USER_A"
session <- login context False user "idempotency"
lane <- requireEnv "NUTHATCH_FIXTURE_LANE"
@ -53,16 +54,16 @@ verifyEpochs context session lane ipA ipB = do
conflict <- targetedUpload context session lane ipB operationId "conflict"
assertContains "conflicting reuse"
"\"result\":\"conflict\""
(curlBody conflict)
(probeBody conflict)
threadDelay 3000000
(responseA, responseB) <- concurrently
(targetedUpload context session lane ipA operationId "second-epoch-a")
(targetedUpload context session lane ipB operationId "second-epoch-b")
let outcomes = [responseA, responseB]
succeeded response =
"\"result\":\"succeeded\"" `BS.isInfixOf` curlBody response
"\"result\":\"succeeded\"" `BS.isInfixOf` probeBody response
conflicted response =
"\"result\":\"conflict\"" `BS.isInfixOf` curlBody response
"\"result\":\"conflict\"" `BS.isInfixOf` probeBody response
assertEqual "new epoch winner count" 1 (length (filter succeeded outcomes))
assertEqual "new epoch conflict count" 1 (length (filter conflicted outcomes))
let (winningBody, replayIp) =
@ -72,13 +73,9 @@ verifyEpochs context session lane ipA ipB = do
secondReplay <-
targetedUpload context session lane replayIp operationId winningBody
requireSucceededWindow "new epoch replay" secondReplay
downloaded <- downloadFrom
(probeBase context)
(resolveArgs lane ipA)
session
"personal"
"idempotency.txt"
assertEqual "new epoch object body" winningBody (curlBody downloaded)
downloaded <-
targetedDownload context session lane ipA "personal" "idempotency.txt"
assertEqual "new epoch object body" winningBody (probeBody downloaded)
verifyActiveIdentity
:: ProbeContext
@ -106,7 +103,7 @@ verifyActiveIdentity context session lane ipA ipB directory = do
"first-epoch"
assertContains "active replay after terminal window"
"\"result\":\"pending\""
(curlBody pending)
(probeBody pending)
locked <- targetedUploadAt
context
session
@ -115,14 +112,14 @@ verifyActiveIdentity context session lane ipA ipB directory = do
"active-window.bin"
"73000000-0000-4000-8000-000000000003"
"first-epoch"
assertEqual "active key lock status" 200 (curlStatus locked)
assertEqual "active key lock status" 200 (probeStatus locked)
assertContains "active key lock"
"\"result\":\"rejected\""
(curlBody locked)
(probeBody locked)
completed <- wait active
assertContains "active request completion"
"\"result\":\"succeeded\""
(curlBody completed)
(probeBody completed)
targetedUpload
:: ProbeContext
@ -131,7 +128,7 @@ targetedUpload
-> String
-> String
-> BS.ByteString
-> IO CurlResponse
-> IO ProbeResponse
targetedUpload context session lane ip =
targetedUploadAt context session lane ip "idempotency.txt"
@ -143,15 +140,39 @@ targetedUploadAt
-> String
-> String
-> BS.ByteString
-> IO CurlResponse
targetedUploadAt context session lane ip path operationId =
uploadTo
(probeBase context)
(resolveArgs lane ip)
-> IO ProbeResponse
targetedUploadAt context session lane ip path operationId body =
uploadDeclared
context
session
"personal"
lane
ip
path
operationId
(BS.length body)
(sha256Hex body)
body
targetedDownload
:: ProbeContext
-> Session
-> String
-> String
-> String
-> String
-> IO ProbeResponse
targetedDownload context session lane ip root path = do
cookies <- cookieHeader (sessionCookies session)
curl
( resolveArgs lane ip
<> [ "--header", "Cookie: " <> B8.unpack cookies
, probeBase context
<> "/api/download?root="
<> root
<> "&path="
<> path
]
)
uploadDeclared
:: ProbeContext
@ -163,14 +184,15 @@ uploadDeclared
-> Int
-> BS.ByteString
-> BS.ByteString
-> IO CurlResponse
-> IO ProbeResponse
uploadDeclared context session lane ip path operationId size digest body =
withSystemTempFile "nuthatch-declared-upload" $ \bodyPath handle -> do
BS.hPut handle body
hClose handle
cookies <- cookieHeader (sessionCookies session)
curl
( resolveArgs lane ip
<> [ "--cookie", sessionCookies session
<> [ "--header", "Cookie: " <> B8.unpack cookies
, "--header", "Content-Type: application/octet-stream"
, "--header", "X-Declared-Size: " <> show size
, "--header", "X-Content-SHA256: " <> B8.unpack digest
@ -193,8 +215,9 @@ slowUpload
-> FilePath
-> String
-> BS.ByteString
-> IO CurlResponse
-> IO ProbeResponse
slowUpload context session lane ip directory operationId body = do
cookies <- cookieHeader (sessionCookies session)
let outputPath = directory <> "/active-upload-response"
statusPath = directory <> "/active-upload-status"
firstChunk = BS.take 65536 body
@ -204,7 +227,7 @@ slowUpload context session lane ip directory operationId body = do
, "--silent"
, "--show-error"
, "--resolve", "nuthatch-" <> lane <> ":8080:" <> ip
, "--cookie", sessionCookies session
, "--header", "Cookie: " <> B8.unpack cookies
, "--header", "Content-Type: application/octet-stream"
, "--header", "X-Declared-Size: " <> show (BS.length body)
, "--header", "X-Content-SHA256: " <> B8.unpack (sha256Hex body)
@ -240,10 +263,10 @@ slowUpload context session lane ip directory operationId body = do
status <- case reads (B8.unpack statusBytes) of
[(value, "")] -> pure value
_ -> fail "slow upload returned invalid HTTP status"
pure CurlResponse
{ curlStatus = status
, curlHeaders = []
, curlBody = responseBody
pure ProbeResponse
{ probeStatus = status
, probeHeaders = []
, probeBody = responseBody
}
resolveArgs :: String -> String -> [String]
@ -255,13 +278,13 @@ resolveArgs lane ip =
, "--resolve", "nuthatch-" <> lane <> ":8080:" <> ip
]
requireSucceededWindow :: String -> CurlResponse -> IO ()
requireSucceededWindow :: String -> ProbeResponse -> IO ()
requireSucceededWindow label response = do
assertEqual (label <> " status") 200 (curlStatus response)
assertContains label "\"result\":\"succeeded\"" (curlBody response)
assertEqual (label <> " status") 200 (probeStatus response)
assertContains label "\"result\":\"succeeded\"" (probeBody response)
assertContains (label <> " window")
"\"idempotency_window_seconds\":2"
(curlBody response)
(probeBody response)
emitRefinementTrace :: IO ()
emitRefinementTrace =

69
test/Nuthatch/Probe/Curl.hs
View file

@ -1,30 +1,21 @@
module Nuthatch.Probe.Curl
( CurlResponse (..)
, CurlTransportFailure (..)
, cookieValue
( CurlTransportFailure (..)
, curl
, curlToFile
, headerValue
, headerValues
) where
import Control.Exception (Exception, throwIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import Data.Char (toLower)
import Data.List (find)
import qualified Data.CaseInsensitive as CI
import Data.Maybe (mapMaybe)
import Network.HTTP.Types (Header)
import Nuthatch.Probe.Http (ProbeResponse (..))
import System.Exit (ExitCode (..))
import System.IO.Temp (withSystemTempDirectory)
import System.Process (readProcessWithExitCode)
import Text.Read (readMaybe)
data CurlResponse = CurlResponse
{ curlStatus :: Int
, curlHeaders :: [(BS.ByteString, BS.ByteString)]
, curlBody :: BS.ByteString
} deriving stock (Eq, Show)
data CurlTransportFailure = CurlTransportFailure
{ curlTransportExitCode :: Int
, curlTransportStderr :: String
@ -32,19 +23,19 @@ data CurlTransportFailure = CurlTransportFailure
instance Exception CurlTransportFailure
curl :: [String] -> IO CurlResponse
curl :: [String] -> IO ProbeResponse
curl arguments =
withSystemTempDirectory "nuthatch-curl" $ \directory -> do
let bodyPath = directory <> "/body"
response <- runCurl bodyPath arguments
body <- BS.readFile bodyPath
pure response { curlBody = body }
pure response { probeBody = body }
curlToFile :: FilePath -> [String] -> IO CurlResponse
curlToFile :: FilePath -> [String] -> IO ProbeResponse
curlToFile outputPath arguments =
runCurl outputPath arguments
runCurl :: FilePath -> [String] -> IO CurlResponse
runCurl :: FilePath -> [String] -> IO ProbeResponse
runCurl outputPath arguments =
withSystemTempDirectory "nuthatch-curl-headers" $ \directory -> do
let headersPath = directory <> "/headers"
@ -70,13 +61,13 @@ runCurl outputPath arguments =
, curlTransportStderr = stderrText
}
headers <- parseHeaders <$> BS.readFile headersPath
pure CurlResponse
{ curlStatus = status
, curlHeaders = headers
, curlBody = BS.empty
pure ProbeResponse
{ probeStatus = status
, probeHeaders = headers
, probeBody = BS.empty
}
parseHeaders :: BS.ByteString -> [(BS.ByteString, BS.ByteString)]
parseHeaders :: BS.ByteString -> [Header]
parseHeaders input =
case filter (not . null) (splitBlocks (B8.lines input)) of
[] -> []
@ -88,45 +79,15 @@ parseHeaders input =
| otherwise = (stripCarriageReturn line : block) : blocks
splitLine _ [] = []
parseHeader :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)
parseHeader :: BS.ByteString -> Maybe Header
parseHeader line =
case B8.break (== ':') line of
(_, remainder) | BS.null remainder -> Nothing
(name, remainder) ->
Just (lower name, B8.dropWhile (== ' ') (BS.drop 1 remainder))
headerValue :: BS.ByteString -> CurlResponse -> Maybe BS.ByteString
headerValue name response =
snd <$> find ((== lower name) . fst) (curlHeaders response)
headerValues :: BS.ByteString -> CurlResponse -> [BS.ByteString]
headerValues name response =
map snd (filter ((== lower name) . fst) (curlHeaders response))
lower :: BS.ByteString -> BS.ByteString
lower = B8.map toLower
Just (CI.mk name, B8.dropWhile (== ' ') (BS.drop 1 remainder))
stripCarriageReturn :: BS.ByteString -> BS.ByteString
stripCarriageReturn value =
case B8.unsnoc value of
Just (prefix, '\r') -> prefix
_ -> value
cookieValue :: FilePath -> BS.ByteString -> IO BS.ByteString
cookieValue path expectedName = do
contents <- B8.lines <$> BS.readFile path
case mapMaybe parseCookie contents of
cookies ->
maybe
(fail ("cookie not found: " <> B8.unpack expectedName))
pure
(lookup expectedName cookies)
parseCookie :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)
parseCookie line =
let normalized =
maybe line id (BS.stripPrefix "#HttpOnly_" line)
fields = B8.split '\t' normalized
in case drop 5 fields of
name : value : _ -> Just (name, value)
_ -> Nothing

258
test/Nuthatch/Probe/Http.hs Normal file
View file

@ -0,0 +1,258 @@
module Nuthatch.Probe.Http
( CookieSession
, HttpException
, ProbeClient
, ProbeResponse (..)
, RequestBody (..)
, RequestOptions (..)
, cookieHeader
, cookieValue
, defaultRequestOptions
, downloadTo
, get
, getWith
, headWith
, headerValue
, headerValues
, isConnectionFailure
, newCookieSession
, newProbeClient
, postWith
, putWith
) where
import Control.Concurrent.MVar
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import Data.List (find)
import qualified Data.CaseInsensitive as CI
import Network.Connection (TLSSettings (..))
import Network.HTTP.Client
( Cookie (..)
, CookieJar
, HttpException (..)
, HttpExceptionContent (..)
, Manager
, Request
, Response
, brRead
, applyBasicAuth
, checkResponse
, cookieJar
, createCookieJar
, destroyCookieJar
, httpLbs
, method
, parseRequest
, redirectCount
, requestBody
, requestHeaders
, responseBody
, responseCookieJar
, responseHeaders
, responseStatus
, responseTimeout
, responseTimeoutMicro
, withResponse
)
import qualified Network.HTTP.Client as HTTP
import Network.HTTP.Client.TLS (mkManagerSettings)
import Network.HTTP.Types
( Header
, Method
, hContentType
, methodGet
, methodHead
, methodPost
, methodPut
, statusCode
)
import Network.HTTP.Types.URI (renderSimpleQuery)
import Network.TLS (defaultSupported)
import System.IO (IOMode (WriteMode), withBinaryFile)
newtype ProbeClient = ProbeClient Manager
newtype CookieSession = CookieSession (MVar CookieJar)
data ProbeResponse = ProbeResponse
{ probeStatus :: Int
, probeHeaders :: [Header]
, probeBody :: BS.ByteString
}
deriving stock (Eq, Show)
data RequestBody
= NoBody
| ByteBody BS.ByteString
| FileBody FilePath
| FormBody [(BS.ByteString, BS.ByteString)]
deriving stock (Eq, Show)
data RequestOptions = RequestOptions
{ optionHeaders :: [Header]
, optionBody :: RequestBody
, optionCookies :: Maybe CookieSession
, optionBasicAuth :: Maybe (BS.ByteString, BS.ByteString)
, optionQuery :: [(BS.ByteString, Maybe BS.ByteString)]
, optionTimeoutMicros :: Maybe Int
}
defaultRequestOptions :: RequestOptions
defaultRequestOptions = RequestOptions
{ optionHeaders = []
, optionBody = NoBody
, optionCookies = Nothing
, optionBasicAuth = Nothing
, optionQuery = []
, optionTimeoutMicros = Nothing
}
newProbeClient :: IO ProbeClient
newProbeClient =
ProbeClient <$> HTTP.newManager
(mkManagerSettings
TLSSettingsSimple
{ settingDisableCertificateValidation = True
, settingDisableSession = False
, settingUseServerName = True
, settingClientSupported = defaultSupported
}
Nothing)
newCookieSession :: IO CookieSession
newCookieSession = CookieSession <$> newMVar (createCookieJar [])
get :: ProbeClient -> String -> IO ProbeResponse
get client = getWith client defaultRequestOptions
getWith :: ProbeClient -> RequestOptions -> String -> IO ProbeResponse
getWith client = perform client methodGet
postWith :: ProbeClient -> RequestOptions -> String -> IO ProbeResponse
postWith client = perform client methodPost
putWith :: ProbeClient -> RequestOptions -> String -> IO ProbeResponse
putWith client = perform client methodPut
headWith :: ProbeClient -> RequestOptions -> String -> IO ProbeResponse
headWith client = perform client methodHead
downloadTo
:: ProbeClient
-> RequestOptions
-> FilePath
-> String
-> IO ProbeResponse
downloadTo (ProbeClient manager) options outputPath url = do
request <- buildRequest methodGet options url
withResponse request manager $ \response -> do
updateCookies options response
withBinaryFile outputPath WriteMode $ \handle ->
drain handle (responseBody response)
pure (responseWithoutBody response)
where
drain handle reader = do
chunk <- brRead reader
if BS.null chunk
then pure ()
else BS.hPut handle chunk >> drain handle reader
perform
:: ProbeClient
-> Method
-> RequestOptions
-> String
-> IO ProbeResponse
perform (ProbeClient manager) requestMethod options url = do
request <- buildRequest requestMethod options url
response <- httpLbs request manager
updateCookies options response
pure ProbeResponse
{ probeStatus = statusCode (responseStatus response)
, probeHeaders = responseHeaders response
, probeBody = BL.toStrict (responseBody response)
}
buildRequest :: Method -> RequestOptions -> String -> IO Request
buildRequest requestMethod options url = do
initial <- parseRequest url
body <- toRequestBody (optionBody options)
storedCookies <- traverse readCookies (optionCookies options)
let formHeaders =
case optionBody options of
FormBody _ -> [(hContentType, "application/x-www-form-urlencoded")]
_ -> []
queried =
if null (optionQuery options)
then initial
else HTTP.setQueryString (optionQuery options) initial
let configured =
queried
{ method = requestMethod
, requestHeaders = formHeaders <> optionHeaders options
, requestBody = body
, cookieJar = storedCookies
, redirectCount = 0
, checkResponse = \_ _ -> pure ()
, responseTimeout =
maybe
(responseTimeout initial)
responseTimeoutMicro
(optionTimeoutMicros options)
}
pure $ maybe configured
(\(username, password) -> applyBasicAuth username password configured)
(optionBasicAuth options)
toRequestBody :: RequestBody -> IO HTTP.RequestBody
toRequestBody NoBody = pure (HTTP.RequestBodyBS BS.empty)
toRequestBody (ByteBody body) = pure (HTTP.RequestBodyBS body)
toRequestBody (FileBody path) = HTTP.streamFile path
toRequestBody (FormBody fields) =
pure . HTTP.RequestBodyBS $ renderSimpleQuery False fields
updateCookies :: RequestOptions -> Response body -> IO ()
updateCookies options response =
case optionCookies options of
Nothing -> pure ()
Just (CookieSession storage) -> do
_ <- swapMVar storage (responseCookieJar response)
pure ()
readCookies :: CookieSession -> IO CookieJar
readCookies (CookieSession storage) = readMVar storage
cookieValue :: CookieSession -> BS.ByteString -> IO BS.ByteString
cookieValue session expectedName = do
cookies <- destroyCookieJar <$> readCookies session
maybe
(fail ("cookie not found: " <> B8.unpack expectedName))
(pure . cookie_value)
(find ((== expectedName) . cookie_name) cookies)
cookieHeader :: CookieSession -> IO BS.ByteString
cookieHeader session = do
cookies <- destroyCookieJar <$> readCookies session
pure . B8.intercalate "; " $
[cookie_name cookie <> "=" <> cookie_value cookie | cookie <- cookies]
headerValue :: BS.ByteString -> ProbeResponse -> Maybe BS.ByteString
headerValue name response =
snd <$> find ((== CI.mk name) . fst) (probeHeaders response)
headerValues :: BS.ByteString -> ProbeResponse -> [BS.ByteString]
headerValues name response =
map snd (filter ((== CI.mk name) . fst) (probeHeaders response))
responseWithoutBody :: Response body -> ProbeResponse
responseWithoutBody response = ProbeResponse
{ probeStatus = statusCode (responseStatus response)
, probeHeaders = responseHeaders response
, probeBody = BS.empty
}
isConnectionFailure :: HttpException -> Bool
isConnectionFailure (HttpExceptionRequest _ (ConnectionFailure _)) = True
isConnectionFailure _ = False

220
test/Nuthatch/Probe/Oidc.hs
View file

@ -20,13 +20,12 @@ import Data.Char (toLower)
import Data.List (find)
import Data.Maybe (fromMaybe)
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
import Nuthatch.Probe.Http
import System.Environment (lookupEnv)
import System.FilePath ((</>))
data ProbeContext = ProbeContext
{ probeBase :: String
, probeDirectory :: FilePath
{ probeClient :: ProbeClient
, probeBase :: String
, probeOidcIssuer :: String
, probeOidcProvider :: String
, probeOidcPassword :: String
@ -37,7 +36,7 @@ data ProbeContext = ProbeContext
}
data Session = Session
{ sessionCookies :: FilePath
{ sessionCookies :: CookieSession
, sessionCsrf :: BS.ByteString
}
@ -64,8 +63,9 @@ instance FromJSON OidcDiscovery where
parseJSON = withObject "OidcDiscovery" $ \object ->
OidcDiscovery <$> object .: "token_endpoint"
newProbeContext :: FilePath -> IO ProbeContext
newProbeContext directory = do
newProbeContext :: IO ProbeContext
newProbeContext = do
client <- newProbeClient
lane <- requireEnv "NUTHATCH_FIXTURE_LANE"
issuer <- requireEnv "NUTHATCH_OIDC_ISSUER"
provider <- requireEnv "NUTHATCH_OIDC_PROVIDER"
@ -75,8 +75,8 @@ newProbeContext directory = do
clientSecret <- requireEnv "NUTHATCH_OIDC_CLIENT_SECRET"
redirectUri <- requireEnv "NUTHATCH_OIDC_REDIRECT_URI"
pure ProbeContext
{ probeBase = "https://nuthatch-" <> lane <> ":8080"
, probeDirectory = directory
{ probeClient = client
, probeBase = "https://nuthatch-" <> lane <> ":8080"
, probeOidcIssuer = issuer
, probeOidcProvider = provider
, probeOidcPassword = password
@ -88,15 +88,15 @@ newProbeContext directory = do
login :: ProbeContext -> Bool -> String -> String -> IO Session
login context verifyBoundary user suffix = do
let cookies = probeDirectory context </> "cookies-" <> suffix
idpCookies = probeDirectory context </> "idp-" <> suffix
cookies <- newCookieSession
idpCookies <- newCookieSession
started <-
retryTransport 20 $
curl
[ "--cookie-jar", cookies
, probeBase context <> "/login"
]
assertEqual "login redirect status" 303 (curlStatus started)
getWith
(probeClient context)
defaultRequestOptions { optionCookies = Just cookies }
(probeBase context <> "/login")
assertEqual "login redirect status" 303 (probeStatus started)
authorizationUrl <-
maybe (fail "login response omitted Location") (pure . B8.unpack) $
headerValue "location" started
@ -109,12 +109,11 @@ login context verifyBoundary user suffix = do
then verifyTransactionBoundary context cookies authorizationUrl state
else pure ()
callback <- completeAuthorization context idpCookies user suffix authorizationUrl
completed <- curl
[ "--cookie", cookies
, "--cookie-jar", cookies
, callback
]
assertEqual "OIDC callback status" 303 (curlStatus completed)
completed <- getWith
(probeClient context)
defaultRequestOptions { optionCookies = Just cookies }
callback
assertEqual "OIDC callback status" 303 (probeStatus completed)
assertEqual "OIDC callback location"
(Just "/app")
(B8.unpack <$> headerValue "location" completed)
@ -143,12 +142,12 @@ login context verifyBoundary user suffix = do
verifyPkceBoundary :: ProbeContext -> String -> IO ()
verifyPkceBoundary context user = do
let cookies = probeDirectory context </> "cookies-pkce"
idpCookies = probeDirectory context </> "idp-pkce"
started <- curl
[ "--cookie-jar", cookies
, probeBase context <> "/login"
]
cookies <- newCookieSession
idpCookies <- newCookieSession
started <- getWith
(probeClient context)
defaultRequestOptions { optionCookies = Just cookies }
(probeBase context <> "/login")
authorizationUrl <-
maybe (fail "PKCE login omitted Location") (pure . B8.unpack) $
headerValue "location" started
@ -159,62 +158,72 @@ verifyPkceBoundary context user = do
"pkce"
authorizationUrl
code <- queryValue "code" callback
discoveryResponse <- curl
[probeOidcIssuer context <> "/.well-known/openid-configuration"]
assertEqual "OIDC discovery status" 200 (curlStatus discoveryResponse)
discoveryResponse <- get
(probeClient context)
(probeOidcIssuer context <> "/.well-known/openid-configuration")
assertEqual "OIDC discovery status" 200 (probeStatus discoveryResponse)
OidcDiscovery tokenEndpoint <-
decodeBody "OIDC discovery" discoveryResponse
rejected <- curl
[ "--user"
, probeOidcClientId context <> ":" <> probeOidcClientSecret context
, "--data-urlencode", "grant_type=authorization_code"
, "--data-urlencode", "code=" <> code
, "--data-urlencode", "redirect_uri=" <> probeOidcRedirectUri context
, "--data-urlencode"
, "code_verifier=aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
, tokenEndpoint
]
rejected <- postWith
(probeClient context)
defaultRequestOptions
{ optionBasicAuth = Just
( B8.pack (probeOidcClientId context)
, B8.pack (probeOidcClientSecret context)
)
, optionBody = FormBody
[ ("grant_type", "authorization_code")
, ("code", B8.pack code)
, ("redirect_uri", B8.pack (probeOidcRedirectUri context))
, ( "code_verifier"
, "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
)
]
}
tokenEndpoint
assert "provider accepted an invalid PKCE verifier" $
curlStatus rejected >= 400
probeStatus rejected >= 400
verifyTransactionBoundary
:: ProbeContext
-> FilePath
-> CookieSession
-> String
-> String
-> IO ()
verifyTransactionBoundary context cookies authorizationUrl state = do
wrongRedirect <- curl [replaceRedirectUri authorizationUrl]
wrongRedirect <- get (probeClient context) (replaceRedirectUri authorizationUrl)
assert "provider accepted an unregistered redirect URI" $
curlStatus wrongRedirect >= 400
invalidState <- curl
[ "--cookie", cookies
, probeBase context
probeStatus wrongRedirect >= 400
invalidState <- getWith
(probeClient context)
defaultRequestOptions { optionCookies = Just cookies }
(probeBase context
<> "/oidc/callback?code=unused&state=invalid-"
<> state
]
<> state)
assert "application accepted an invalid OIDC state" $
curlStatus invalidState >= 400
probeStatus invalidState >= 400
transaction <- cookieValue cookies "nuthatch_oidc"
malformed <- curl
[ "--header", "Cookie: nuthatch_oidc=malformed"
, probeBase context
malformed <- getWith
(probeClient context)
defaultRequestOptions
{ optionHeaders = [("Cookie", "nuthatch_oidc=malformed")] }
(probeBase context
<> "/oidc/callback?code=unused&state="
<> state
]
assertEqual "malformed transaction cookie" 400 (curlStatus malformed)
<> state)
assertEqual "malformed transaction cookie" 400 (probeStatus malformed)
let tampered = BS.cons 120 (BS.drop 1 transaction)
tamperedResponse <- curl
[ "--header", "Cookie: nuthatch_oidc=" <> B8.unpack tampered
, probeBase context
tamperedResponse <- getWith
(probeClient context)
defaultRequestOptions
{ optionHeaders = [("Cookie", "nuthatch_oidc=" <> tampered)] }
(probeBase context
<> "/oidc/callback?code=unused&state="
<> state
]
assertEqual "tampered transaction cookie" 400 (curlStatus tamperedResponse)
<> state)
assertEqual "tampered transaction cookie" 400 (probeStatus tamperedResponse)
completeAuthorization
:: ProbeContext
-> FilePath
-> CookieSession
-> String
-> String
-> String
@ -230,25 +239,28 @@ completeAuthorization context idpCookies user suffix authorizationUrl =
completeKeycloak
:: ProbeContext
-> FilePath
-> CookieSession
-> String
-> String
-> IO String
completeKeycloak context idpCookies user authorizationUrl = do
form <- curl
[ "--cookie-jar", idpCookies
, authorizationUrl
]
assertEqual "Keycloak authorization form" 200 (curlStatus form)
action <- htmlAttribute "action" (B8.unpack (curlBody form))
submitted <- curl
[ "--cookie", idpCookies
, "--cookie-jar", idpCookies
, "--data-urlencode", "username=" <> user
, "--data-urlencode", "password=" <> probeOidcPassword context
, "--data-urlencode", "credentialId="
, action
]
form <- getWith
(probeClient context)
defaultRequestOptions { optionCookies = Just idpCookies }
authorizationUrl
assertEqual "Keycloak authorization form" 200 (probeStatus form)
action <- htmlAttribute "action" (B8.unpack (probeBody form))
submitted <- postWith
(probeClient context)
defaultRequestOptions
{ optionCookies = Just idpCookies
, optionBody = FormBody
[ ("username", B8.pack user)
, ("password", B8.pack (probeOidcPassword context))
, ("credentialId", "")
]
}
action
maybe
(fail "Keycloak login omitted callback Location")
(pure . B8.unpack)
@ -263,49 +275,57 @@ completeZitadel
completeZitadel context user _ authorizationUrl = do
pat <- maybe (fail "ZITADEL login PAT is missing") pure $
probeOidcLoginPat context
started <- curl [authorizationUrl]
started <- get (probeClient context) authorizationUrl
location <- maybe
(fail "ZITADEL login omitted Location")
(pure . B8.unpack)
(headerValue "location" started)
authRequest <- queryValue "authRequest" location
created <- curl
[ "--header", "Authorization: Bearer " <> pat
, "--header", "Content-Type: application/json"
, "--data"
, "{\"checks\":{\"user\":{\"userId\":\""
created <- postWith
(probeClient context)
defaultRequestOptions
{ optionHeaders =
[ ("Authorization", "Bearer " <> B8.pack pat)
, ("Content-Type", "application/json")
]
, optionBody = ByteBody . B8.pack $
"{\"checks\":{\"user\":{\"userId\":\""
<> user
<> "\"},\"password\":{\"password\":\""
<> probeOidcPassword context
<> "\"}},\"lifetime\":\"300s\"}"
, probeOidcIssuer context <> "/v2/sessions"
]
}
(probeOidcIssuer context <> "/v2/sessions")
assert "ZITADEL session creation failed" $
curlStatus created >= 200 && curlStatus created < 300
probeStatus created >= 200 && probeStatus created < 300
ZitadelSession {..} <- decodeBody "ZITADEL session" created
finalized <- curl
[ "--header", "Authorization: Bearer " <> pat
, "--header", "Content-Type: application/json"
, "--data"
, "{\"session\":{\"sessionId\":\""
finalized <- postWith
(probeClient context)
defaultRequestOptions
{ optionHeaders =
[ ("Authorization", "Bearer " <> B8.pack pat)
, ("Content-Type", "application/json")
]
, optionBody = ByteBody . B8.pack $
"{\"session\":{\"sessionId\":\""
<> zitadelSessionId
<> "\",\"sessionToken\":\""
<> zitadelSessionToken
<> "\"}}"
, probeOidcIssuer context
}
(probeOidcIssuer context
<> "/v2/oidc/auth_requests/"
<> authRequest
]
assertEqual "ZITADEL authorization finalization" 200 (curlStatus finalized)
<> authRequest)
assertEqual "ZITADEL authorization finalization" 200 (probeStatus finalized)
ZitadelCallback callback <- decodeBody "ZITADEL callback" finalized
pure callback
decodeBody :: FromJSON value => String -> CurlResponse -> IO value
decodeBody :: FromJSON value => String -> ProbeResponse -> IO value
decodeBody label response =
either (fail . ((label <> ": ") <>)) pure $
eitherDecodeStrict' (curlBody response)
eitherDecodeStrict' (probeBody response)
findCookie :: BS.ByteString -> CurlResponse -> BS.ByteString
findCookie :: BS.ByteString -> ProbeResponse -> BS.ByteString
findCookie name response =
fromMaybe BS.empty $
find (containsLower (lower name <> "=")) (headerValues "set-cookie" response)

127
test/Nuthatch/Probe/ProductClient.hs
View file

@ -2,10 +2,8 @@ module Nuthatch.Probe.ProductClient
( browse
, deleteObject
, download
, downloadFrom
, sha256Hex
, upload
, uploadTo
) where
import Crypto.Hash (Digest, SHA256, hash)
@ -16,49 +14,39 @@ import qualified Data.ByteString.Char8 as B8
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Network.HTTP.Types.URI (urlEncode)
import Nuthatch.Probe.Curl
import Nuthatch.Probe.Http
import Nuthatch.Probe.Oidc
import System.IO.Temp (withSystemTempFile)
import System.IO (hClose)
browse
:: ProbeContext
-> Session
-> String
-> IO CurlResponse
-> IO ProbeResponse
browse context session query =
curl
[ "--cookie", sessionCookies session
, "--header", "Accept: application/json"
, probeBase context <> "/api/browse" <> query
]
getWith
(probeClient context)
defaultRequestOptions
{ optionCookies = Just (sessionCookies session)
, optionHeaders = [("Accept", "application/json")]
}
(probeBase context <> "/api/browse" <> query)
download
:: ProbeContext
-> Session
-> String
-> String
-> IO CurlResponse
download context =
downloadFrom (probeBase context) []
downloadFrom
:: String
-> [String]
-> Session
-> String
-> String
-> IO CurlResponse
downloadFrom base extra session root path =
curl
( extra
<> [ "--cookie", sessionCookies session
, base
<> "/api/download?root="
<> encode root
<> "&path="
<> encode path
]
-> IO ProbeResponse
download context session root path =
getWith
(probeClient context)
defaultRequestOptions
{ optionCookies = Just (sessionCookies session) }
( probeBase context
<> "/api/download?root="
<> encode root
<> "&path="
<> encode path
)
upload
@ -68,41 +56,28 @@ upload
-> String
-> String
-> BS.ByteString
-> IO CurlResponse
upload context =
uploadTo (probeBase context) []
uploadTo
:: String
-> [String]
-> Session
-> String
-> String
-> String
-> BS.ByteString
-> IO CurlResponse
uploadTo base extra session root path operationId body =
withSystemTempFile "nuthatch-upload" $ \bodyPath handle -> do
BS.hPut handle body
hClose handle
curl
( extra
<> [ "--cookie", sessionCookies session
, "--header", "Content-Type: application/octet-stream"
, "--header", "X-Declared-Size: " <> show (BS.length body)
, "--header", "X-Content-SHA256: " <> B8.unpack (sha256Hex body)
, "--header"
, "X-CSRF-Token: " <> B8.unpack (sessionCsrf session)
, "--data-binary", "@" <> bodyPath
, base
<> "/api/upload?root="
<> encode root
<> "&path="
<> encode path
<> "&operation_id="
<> encode operationId
]
)
-> IO ProbeResponse
upload context session root path operationId body =
postWith
(probeClient context)
defaultRequestOptions
{ optionCookies = Just (sessionCookies session)
, optionHeaders =
[ ("Content-Type", "application/octet-stream")
, ("X-Declared-Size", B8.pack (show (BS.length body)))
, ("X-Content-SHA256", sha256Hex body)
, ("X-CSRF-Token", sessionCsrf session)
]
, optionBody = ByteBody body
}
( probeBase context
<> "/api/upload?root="
<> encode root
<> "&path="
<> encode path
<> "&operation_id="
<> encode operationId
)
deleteObject
:: ProbeContext
@ -110,13 +85,15 @@ deleteObject
-> String
-> String
-> String
-> IO CurlResponse
-> IO ProbeResponse
deleteObject context session root path operationId =
curl
[ "--cookie", sessionCookies session
, "--header", "Content-Type: application/json"
, "--data"
, "{\"root\":\""
postWith
(probeClient context)
defaultRequestOptions
{ optionCookies = Just (sessionCookies session)
, optionHeaders = [("Content-Type", "application/json")]
, optionBody = ByteBody . B8.pack $
"{\"root\":\""
<> root
<> "\",\"path\":\""
<> path
@ -125,8 +102,8 @@ deleteObject context session root path operationId =
<> "\",\"csrf\":\""
<> B8.unpack (sessionCsrf session)
<> "\"}"
, probeBase context <> "/api/delete"
]
}
(probeBase context <> "/api/delete")
sha256Hex :: BS.ByteString -> BS.ByteString
sha256Hex input =

249
test/ProductProbe.hs
View file

@ -7,34 +7,33 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import qualified Data.Text as Text
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
import Nuthatch.Probe.Http
import Nuthatch.Probe.Oidc
import Nuthatch.Probe.ProductClient
import System.Environment (getArgs)
import System.IO.Temp (withSystemTempDirectory)
main :: IO ()
main =
withSystemTempDirectory "nuthatch-product-probe" $ \directory -> do
context <- newProbeContext directory
user <- requireEnv "NUTHATCH_OIDC_USER_A"
session <- login context False user "product"
getArgs >>= \case
["verify"] -> verifyProduct context session
["timeout"] -> verifyTimeout context session
_ -> fail "expected verify or timeout mode"
main = do
context <- newProbeContext
user <- requireEnv "NUTHATCH_OIDC_USER_A"
session <- login context False user "product"
getArgs >>= \case
["verify"] -> verifyProduct context session
["timeout"] -> verifyTimeout context session
_ -> fail "expected verify or timeout mode"
verifyTimeout :: ProbeContext -> Session -> IO ()
verifyTimeout context session = do
response <- curl
[ "--get"
, "--cookie", sessionCookies session
, "--data-urlencode", "root=personal"
, "--data-urlencode", "q=timeout-probe"
, probeBase context <> "/api/browse"
]
assertEqual "timed search status" 200 (curlStatus response)
assertContains "timed search bound" "\"partial\":true" (curlBody response)
response <- authenticatedGetWith context session
defaultRequestOptions
{ optionQuery =
[ ("root", Just "personal")
, ("q", Just "timeout-probe")
]
}
(probeBase context <> "/api/browse")
assertEqual "timed search status" 200 (probeStatus response)
assertContains "timed search bound" "\"partial\":true" (probeBody response)
putStrLn "Timed search bound passed"
verifyProduct :: ProbeContext -> Session -> IO ()
@ -48,20 +47,15 @@ verifyProduct context session = do
verifyApplicationAssets :: ProbeContext -> Session -> IO ()
verifyApplicationAssets context session = do
sessionResponse <- curl
[ "--cookie", sessionCookies session
, probeBase context <> "/api/session"
]
assertEqual "session endpoint status" 200 (curlStatus sessionResponse)
assertContains "session user" "\"user_id\":" (curlBody sessionResponse)
sessionResponse <- authenticatedGet context session
(probeBase context <> "/api/session")
assertEqual "session endpoint status" 200 (probeStatus sessionResponse)
assertContains "session user" "\"user_id\":" (probeBody sessionResponse)
assertContains "session CSRF"
("\"csrf\":\"" <> sessionCsrf session <> "\"")
(curlBody sessionResponse)
application <- curl
[ "--cookie", sessionCookies session
, probeBase context <> "/app"
]
assertEqual "application status" 200 (curlStatus application)
(probeBody sessionResponse)
application <- authenticatedGet context session (probeBase context <> "/app")
assertEqual "application status" 200 (probeStatus application)
csp <- maybe (fail "application omitted CSP") pure $
headerValue "content-security-policy" application
mapM_
@ -70,18 +64,16 @@ verifyApplicationAssets context session = do
directive
csp)
["default-src 'none'", "script-src 'self'", "frame-ancestors 'none'"]
asset <- between "src=\"/assets/" "\"" (B8.unpack (curlBody application))
javascript <- curl
[ "--cookie", sessionCookies session
, probeBase context <> "/assets/" <> asset
]
assertEqual "asset status" 200 (curlStatus javascript)
asset <- between "src=\"/assets/" "\"" (B8.unpack (probeBody application))
javascript <- authenticatedGet context session
(probeBase context <> "/assets/" <> asset)
assertEqual "asset status" 200 (probeStatus javascript)
assertContains "asset content type" "javascript" $
maybe BS.empty id (headerValue "content-type" javascript)
assertEqual "asset nosniff"
(Just "nosniff")
(headerValue "x-content-type-options" javascript)
let visible = curlBody application <> curlBody javascript
let visible = probeBody application <> probeBody javascript
mapM_
(\value ->
assert ("browser artifact exposed " <> value) $
@ -95,7 +87,7 @@ verifyApplicationAssets context session = do
(\marker ->
assertContains ("asset omitted " <> marker)
(B8.pack marker)
(curlBody javascript))
(probeBody javascript))
[ "Drop a file here"
, "Shared root"
, "Retry same upload"
@ -103,10 +95,12 @@ verifyApplicationAssets context session = do
, "nuthatch-recursive-delete"
, "URLSearchParams"
]
unauthenticatedApp <- curl [probeBase context <> "/app"]
assertEqual "unauthenticated application" 303 (curlStatus unauthenticatedApp)
unauthenticatedAsset <- curl [probeBase context <> "/assets/" <> asset]
assertEqual "unauthenticated asset" 303 (curlStatus unauthenticatedAsset)
unauthenticatedApp <- get (probeClient context) (probeBase context <> "/app")
assertEqual "unauthenticated application" 303 (probeStatus unauthenticatedApp)
unauthenticatedAsset <- get
(probeClient context)
(probeBase context <> "/assets/" <> asset)
assertEqual "unauthenticated asset" 303 (probeStatus unauthenticatedAsset)
verifyPaginationAndSearch :: ProbeContext -> Session -> IO ()
verifyPaginationAndSearch context session = do
@ -119,34 +113,36 @@ verifyPaginationAndSearch context session = do
"81000000-0000-4000-8000-000000000002" "beta"
uploadSucceeded context session "product-browse/gamma.txt"
"81000000-0000-4000-8000-000000000003" "gamma"
firstPage <- curl
[ "--get"
, "--cookie", sessionCookies session
, "--data-urlencode", "root=personal"
, "--data-urlencode", "prefix=product-browse"
, probeBase context <> "/api/browse"
]
firstPage <- authenticatedGetWith context session
defaultRequestOptions
{ optionQuery =
[ ("root", Just "personal")
, ("prefix", Just "product-browse")
]
}
(probeBase context <> "/api/browse")
requireStatus "first browse page" 200 firstPage
assertContains "first page Alpha"
"\"path\":\"product-browse/Alpha.txt\""
(curlBody firstPage)
(probeBody firstPage)
assertContains "first page beta"
"\"path\":\"product-browse/beta.txt\""
(curlBody firstPage)
(probeBody firstPage)
assert "first page exceeded configured size" $
not ("product-browse/gamma.txt" `BS.isInfixOf` curlBody firstPage)
continuation <- stringField "continuation" (curlBody firstPage)
secondPage <- curl
[ "--get"
, "--cookie", sessionCookies session
, "--data-urlencode", "root=personal"
, "--data-urlencode", "prefix=product-browse"
, "--data-urlencode", "continuation=" <> continuation
, probeBase context <> "/api/browse"
]
not ("product-browse/gamma.txt" `BS.isInfixOf` probeBody firstPage)
continuation <- stringField "continuation" (probeBody firstPage)
secondPage <- authenticatedGetWith context session
defaultRequestOptions
{ optionQuery =
[ ("root", Just "personal")
, ("prefix", Just "product-browse")
, ("continuation", Just (B8.pack continuation))
]
}
(probeBase context <> "/api/browse")
assertContains "second browse page"
"\"path\":\"product-browse/gamma.txt\""
(curlBody secondPage)
(probeBody secondPage)
mapM_
(\(path, operationId, body) ->
uploadSucceeded context session path operationId body)
@ -155,49 +151,48 @@ verifyPaginationAndSearch context session = do
, ("002-filler.txt", "81000000-0000-4000-8000-000000000006", "three")
, ("003-needle-after-bound.txt", "81000000-0000-4000-8000-000000000007", "four")
]
searched <- curl
[ "--get"
, "--cookie", sessionCookies session
, "--data-urlencode", "root=personal"
, "--data-urlencode", "q=NEEDLE"
, probeBase context <> "/api/browse"
]
searched <- authenticatedGetWith context session
defaultRequestOptions
{ optionQuery =
[ ("root", Just "personal")
, ("q", Just "NEEDLE")
]
}
(probeBase context <> "/api/browse")
mapM_
(\value -> assertContains "bounded case-insensitive search" value (curlBody searched))
(\value -> assertContains "bounded case-insensitive search" value (probeBody searched))
[ "\"path\":\"000-Needle-A.txt\""
, "\"path\":\"001-needle-b.txt\""
, "\"partial\":true"
]
assert "search crossed the configured scan bound" $
not ("003-needle-after-bound.txt" `BS.isInfixOf` curlBody searched)
not ("003-needle-after-bound.txt" `BS.isInfixOf` probeBody searched)
verifyCanonicalPaths :: ProbeContext -> Session -> IO ()
verifyCanonicalPaths context session = do
mapM_
(\url -> curl ["--cookie", sessionCookies session, url] >>=
(\url -> authenticatedGet context session url >>=
requireStatus "non-canonical path" 400)
[ probeBase context <> "/api/browse?root=Personal"
, probeBase context <> "/api/browse?root=personal&prefix=a//b"
, probeBase context <> "/api/download?root=personal&path=./file"
]
decomposed <- curl
[ "--cookie", sessionCookies session
, probeBase context
decomposed <- authenticatedGet context session
(probeBase context
<> "/api/download?root=personal&path=cafe%CC%81.txt"
]
)
requireStatus "non-NFC path" 400 decomposed
uploadSucceeded context session "encoded%2Fname.txt"
"81000000-0000-4000-8000-000000000008" "encoded"
encoded <- curl
[ "--cookie", sessionCookies session
, probeBase context
encoded <- authenticatedGet context session
(probeBase context
<> "/api/download?root=personal&path=encoded%252Fname.txt"
]
assertEqual "encoded path body" "encoded" (curlBody encoded)
)
assertEqual "encoded path body" "encoded" (probeBody encoded)
uploadSucceeded context session "café.txt"
"81000000-0000-4000-8000-000000000014" "unicode"
unicode <- download context session "personal" "café.txt"
assertEqual "Unicode path body" "unicode" (curlBody unicode)
assertEqual "Unicode path body" "unicode" (probeBody unicode)
assertContains "Unicode filename"
"filename*=UTF-8''caf%C3%A9.txt"
(maybe BS.empty id (headerValue "content-disposition" unicode))
@ -207,15 +202,13 @@ verifySafeDownload context session = do
let svg = "<svg onload=\"alert(1)\"></svg>"
uploadSucceeded context session "active.svg"
"81000000-0000-4000-8000-000000000009" svg
ranged <- curl
[ "--cookie", sessionCookies session
, "--header", "Range: bytes=0-1"
, probeBase context <> "/api/download?root=personal&path=active.svg"
]
ranged <- authenticatedGetWith context session
defaultRequestOptions { optionHeaders = [("Range", "bytes=0-1")] }
(probeBase context <> "/api/download?root=personal&path=active.svg")
requireStatus "unsupported range" 416 ranged
assertContains "range error"
"\"error\":\"range_not_supported\""
(curlBody ranged)
(probeBody ranged)
downloaded <- download context session "personal" "active.svg"
requireStatus "safe download" 200 downloaded
let disposition =
@ -228,7 +221,7 @@ verifySafeDownload context session = do
assertContains "download sandbox"
"sandbox"
(maybe BS.empty id (headerValue "content-security-policy" downloaded))
assertEqual "download body" svg (curlBody downloaded)
assertEqual "download body" svg (probeBody downloaded)
verifyRecursiveDelete :: ProbeContext -> Session -> IO ()
verifyRecursiveDelete context session = do
@ -242,9 +235,9 @@ verifyRecursiveDelete context session = do
planned <- deletePlan context session
assertContains "first delete plan"
"\"paths\":[\"delete-tree/a.txt\",\"delete-tree/b.txt\"]"
(curlBody planned)
(probeBody planned)
assert "first delete plan omitted continuation" $
not ("\"continuation\":null" `BS.isInfixOf` curlBody planned)
not ("\"continuation\":null" `BS.isInfixOf` probeBody planned)
let firstBatch =
"{\"root\":\"personal\",\"csrf\":\""
<> B8.unpack (sessionCsrf session)
@ -262,7 +255,7 @@ verifyRecursiveDelete context session = do
restarted <- deletePlan context session
assertContains "restarted delete plan"
"\"paths\":[\"delete-tree/c.txt\",\"delete-tree/d-concurrent.txt\"]"
(curlBody restarted)
(probeBody restarted)
let secondBatch =
"{\"root\":\"personal\",\"csrf\":\""
<> B8.unpack (sessionCsrf session)
@ -274,39 +267,42 @@ verifyRecursiveDelete context session = do
second <- deleteBatch context session secondBatch
requireBatchSucceeded "second delete batch" second
empty <- deletePlan context session
assertContains "empty delete plan" "\"paths\":[]" (curlBody empty)
assertContains "empty delete plan" "\"paths\":[]" (probeBody empty)
assertContains "empty delete continuation"
"\"continuation\":null"
(curlBody empty)
(probeBody empty)
deletePlan :: ProbeContext -> Session -> IO CurlResponse
deletePlan :: ProbeContext -> Session -> IO ProbeResponse
deletePlan context session =
curl
[ "--get"
, "--cookie", sessionCookies session
, "--data-urlencode", "root=personal"
, "--data-urlencode", "path=delete-tree"
, probeBase context <> "/api/delete-plan"
]
authenticatedGetWith context session
defaultRequestOptions
{ optionQuery =
[ ("root", Just "personal")
, ("path", Just "delete-tree")
]
}
(probeBase context <> "/api/delete-plan")
deleteBatch
:: ProbeContext
-> Session
-> String
-> IO CurlResponse
-> IO ProbeResponse
deleteBatch context session body =
curl
[ "--cookie", sessionCookies session
, "--header", "Content-Type: application/json"
, "--data", body
, probeBase context <> "/api/delete-batch"
]
postWith
(probeClient context)
defaultRequestOptions
{ optionCookies = Just (sessionCookies session)
, optionHeaders = [("Content-Type", "application/json")]
, optionBody = ByteBody (B8.pack body)
}
(probeBase context <> "/api/delete-batch")
requireBatchSucceeded :: String -> CurlResponse -> IO ()
requireBatchSucceeded :: String -> ProbeResponse -> IO ()
requireBatchSucceeded label response = do
requireStatus label 200 response
assertEqual label 2 $
countOccurrences "\"result\":\"succeeded\"" (curlBody response)
countOccurrences "\"result\":\"succeeded\"" (probeBody response)
uploadSucceeded
:: ProbeContext
@ -319,14 +315,33 @@ uploadSucceeded context session path operationId body =
upload context session "personal" path operationId body >>=
requireSucceeded ("upload " <> path)
requireSucceeded :: String -> CurlResponse -> IO ()
requireSucceeded :: String -> ProbeResponse -> IO ()
requireSucceeded label response = do
requireStatus label 200 response
assertContains label "\"result\":\"succeeded\"" (curlBody response)
assertContains label "\"result\":\"succeeded\"" (probeBody response)
requireStatus :: String -> Int -> CurlResponse -> IO ()
requireStatus :: String -> Int -> ProbeResponse -> IO ()
requireStatus label expected response =
assertEqual (label <> " status") expected (curlStatus response)
assertEqual (label <> " status") expected (probeStatus response)
authenticatedGet
:: ProbeContext
-> Session
-> String
-> IO ProbeResponse
authenticatedGet context session =
authenticatedGetWith context session defaultRequestOptions
authenticatedGetWith
:: ProbeContext
-> Session
-> RequestOptions
-> String
-> IO ProbeResponse
authenticatedGetWith context session options =
getWith
(probeClient context)
options { optionCookies = Just (sessionCookies session) }
stringField :: String -> BS.ByteString -> IO String
stringField name bytes =

134
test/RuntimeHttpProbe.hs
View file

@ -4,37 +4,35 @@ 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.Http
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"
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
@ -48,20 +46,20 @@ withSession context verifyBoundary suffix action = do
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)
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 (curlStatus browsed)
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
@ -69,30 +67,34 @@ verifyBaseline context sessionA = do
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"
]
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" $
curlStatus wrongLogout >= 400
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 <- 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)
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 ()
@ -113,33 +115,33 @@ verifyCoherence context = do
rootListing <- browse context sessionB "?root=shared"
assertContains "shared root cache invalidation"
"runtime"
(curlBody rootListing)
(probeBody rootListing)
prefixListing <- browse context sessionB "?root=shared&prefix=runtime"
assertContains "shared prefix cache invalidation"
"coherence.txt"
(curlBody prefixListing)
(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` curlBody afterDelete)
not ("coherence.txt" `BS.isInfixOf` probeBody afterDelete)
threadDelay 2000000
browse context sessionB "?root=shared" >>= \response ->
assertEqual "cache TTL browse" 200 (curlStatus 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 (curlStatus listing)
assertEqual "Redis-unavailable browse" 200 (probeStatus listing)
assertContains "Redis-unavailable browse fixture"
"cross-user.txt"
(curlBody listing)
(probeBody listing)
searched <- browse context session "?root=personal&q=CROSS-USER"
assertContains "Redis-unavailable search"
"cross-user.txt"
(curlBody searched)
(probeBody searched)
unavailableUpload <- upload context session "personal" "unavailable.bin"
"72000000-0000-4000-8000-000000000001" "x"
requireError "Redis-unavailable upload"
@ -168,22 +170,22 @@ verifyDatabaseUnavailable context session = do
503 "mutation_rejected" unavailableDelete
putStrLn "Database-unavailable mutation behavior passed"
retryPastThrottle :: Int -> IO CurlResponse -> IO CurlResponse
retryPastThrottle :: Int -> IO ProbeResponse -> IO ProbeResponse
retryPastThrottle attempts action = do
response <- action
if attempts > 1
&& "\"error\":\"throttle_unavailable\"" `BS.isInfixOf` curlBody response
&& "\"error\":\"throttle_unavailable\"" `BS.isInfixOf` probeBody response
then threadDelay 250000 >> retryPastThrottle (attempts - 1) action
else pure response
requireSucceeded :: String -> CurlResponse -> IO ()
requireSucceeded :: String -> ProbeResponse -> IO ()
requireSucceeded label response = do
assertEqual (label <> " status") 200 (curlStatus response)
assertContains label "\"result\":\"succeeded\"" (curlBody response)
assertEqual (label <> " status") 200 (probeStatus response)
assertContains label "\"result\":\"succeeded\"" (probeBody response)
requireError :: String -> Int -> BS.ByteString -> CurlResponse -> IO ()
requireError :: String -> Int -> BS.ByteString -> ProbeResponse -> IO ()
requireError label status code response = do
assertEqual (label <> " status") status (curlStatus response)
assertEqual (label <> " status") status (probeStatus response)
assert
(label <> " body: " <> B8.unpack (curlBody response))
(("\"error\":\"" <> code <> "\"") `BS.isInfixOf` curlBody response)
(label <> " body: " <> B8.unpack (probeBody response))
(("\"error\":\"" <> code <> "\"") `BS.isInfixOf` probeBody response)

237
test/StreamingProbe.hs
View file

@ -31,13 +31,14 @@ import System.Process (readProcessWithExitCode)
import Text.Read (readMaybe)
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
import Nuthatch.Probe.Http
import Nuthatch.Probe.Oidc
import Nuthatch.Probe.ProductClient
main :: IO ()
main =
withSystemTempDirectory "nuthatch-streaming-probe" $ \directory -> do
context <- newProbeContext directory
context <- newProbeContext
user <- requireEnv "NUTHATCH_OIDC_USER_A"
session <- login context False user "streaming-a"
getArgs >>= \case
@ -58,14 +59,16 @@ verifyLarge context session directory = do
uploaded <- uploadFileDeclared
context session "streaming-large.bin"
"70000000-0000-4000-8000-000000000001"
largeBytes largeDigest largePath []
largeBytes largeDigest largePath defaultRequestOptions
requireSucceeded "large streaming upload" uploaded
downloaded <- curlToFile downloadPath
[ "--cookie", sessionCookies session
, probeBase context
<> "/api/download?root=personal&path=streaming-large.bin"
]
assertEqual "large streaming download status" 200 (curlStatus downloaded)
downloaded <- downloadTo
(probeClient context)
defaultRequestOptions
{ optionCookies = Just (sessionCookies session) }
downloadPath
(probeBase context
<> "/api/download?root=personal&path=streaming-large.bin")
assertEqual "large streaming download status" 200 (probeStatus downloaded)
hashFile downloadPath >>= assertEqual "large download digest" largeDigest
let tiny = "x"
mapM_
@ -73,25 +76,25 @@ verifyLarge context session directory = do
replay <- uploadBytesDeclared
context session "streaming-large.bin"
"70000000-0000-4000-8000-000000000007"
largeBytes largeDigest tiny []
largeBytes largeDigest tiny defaultRequestOptions
requireSucceeded ("prior/desired observation " <> label) replay)
["first", "replay"]
sizeMismatch <- uploadBytesDeclared
context session "size-mismatch.bin"
"70000000-0000-4000-8000-000000000002"
2 (sha256Hex tiny) tiny []
2 (sha256Hex tiny) tiny defaultRequestOptions
requireError "size mismatch" 400 "size_mismatch" sizeMismatch
identityMismatch <- uploadBytesDeclared
context session "identity-mismatch.bin"
"70000000-0000-4000-8000-000000000003"
1 (BS.replicate 64 48) tiny []
1 (BS.replicate 64 48) tiny defaultRequestOptions
requireError "content identity mismatch"
400 "content_identity_mismatch" identityMismatch
tooLarge <- uploadFileDeclared
context session "too-large.bin"
"70000000-0000-4000-8000-000000000004"
overLimit (sha256Hex tiny) largePath
["--max-time", "5", "--limit-rate", "64k"]
defaultRequestOptions { optionTimeoutMicros = Just 5000000 }
requireError "object size limit" 413 "object_too_large" tooLarge
aborted <- interruptedUpload
context session "aborted-upload.bin"
@ -99,14 +102,14 @@ verifyLarge context session directory = do
largeBytes largeDigest largePath
assert "aborted upload unexpectedly completed" (not aborted)
missing <- download context session "personal" "aborted-upload.bin"
assertEqual "aborted upload visibility" 404 (curlStatus missing)
assertEqual "aborted upload visibility" 404 (probeStatus missing)
replayAfterAbort <- uploadBytesDeclared
context session "aborted-upload.bin"
"70000000-0000-4000-8000-000000000005"
largeBytes largeDigest tiny []
assertEqual "aborted upload replay status" 200 (curlStatus replayAfterAbort)
largeBytes largeDigest tiny defaultRequestOptions
assertEqual "aborted upload replay status" 200 (probeStatus replayAfterAbort)
assert "aborted upload replay lost active or failed identity" $
any (`BS.isInfixOf` curlBody replayAfterAbort)
any (`BS.isInfixOf` probeBody replayAfterAbort)
["\"result\":\"pending\"", "\"result\":\"failed\""]
abortedOverwrite <- interruptedUpload
context session "streaming-large.bin"
@ -114,12 +117,14 @@ verifyLarge context session directory = do
largeBytes (BS.replicate 64 48) largePath
assert "aborted overwrite unexpectedly completed" (not abortedOverwrite)
preservedPath <- pure (directory <> "/preserved.bin")
preserved <- curlToFile preservedPath
[ "--cookie", sessionCookies session
, probeBase context
<> "/api/download?root=personal&path=streaming-large.bin"
]
assertEqual "preserved object status" 200 (curlStatus preserved)
preserved <- downloadTo
(probeClient context)
defaultRequestOptions
{ optionCookies = Just (sessionCookies session) }
preservedPath
(probeBase context
<> "/api/download?root=personal&path=streaming-large.bin")
assertEqual "preserved object status" 200 (probeStatus preserved)
hashFile preservedPath >>= assertEqual "preserved object digest" largeDigest
let partialPath = directory <> "/partial-download.bin"
partial <- interruptedDownload context session partialPath
@ -128,9 +133,9 @@ verifyLarge context session directory = do
assert "aborted download emitted no bytes" (partialBytes > 0)
assert "aborted download emitted the complete object" $
partialBytes < largeBytes
ready <- curl [probeBase context <> "/readyz"]
ready <- get (probeClient context) (probeBase context <> "/readyz")
requireStatus "readiness after aborts" 200 ready
assertContains "readiness after aborts" "\"ready\":true" (curlBody ready)
assertContains "readiness after aborts" "\"ready\":true" (probeBody ready)
putStrLn "Large streaming and abort behavior passed"
verifyThrottle :: ProbeContext -> Session -> FilePath -> IO ()
@ -141,35 +146,42 @@ verifyThrottle context session directory = do
throttlePath = directory <> "/throttle-upload.bin"
writeZeros jointPath 65536
jointDigest <- hashFile jointPath
joint <- uploadFileDeclared
joint <- curlUploadFileDeclared
context session "joint-throttle.bin"
"70000000-0000-4000-8000-000000000013"
65536 jointDigest jointPath []
65536 jointDigest jointPath
requireSucceeded "joint throttle setup" joint
writeZeros throttlePath 1048576
uploadDigest <- hashFile throttlePath
throttled <- uploadFileDeclared
throttled <- curlUploadFileDeclared
context sessionB "throttled-upload.bin"
"71000000-0000-4000-8000-000000000001"
1048576 uploadDigest throttlePath []
1048576 uploadDigest throttlePath
requireError "incremental upload throttle"
429 "bandwidth_exceeded" throttled
prestart <- uploadBytesDeclared
prestart <- curlUploadBytesDeclared
context sessionB "prestart.bin"
"71000000-0000-4000-8000-000000000002"
1 uploadDigest "x" []
assertEqual "pre-start upload throttle" 429 (curlStatus prestart)
1 uploadDigest "x"
assertEqual
("pre-start upload throttle: " <> B8.unpack (probeBody prestart))
429
(probeStatus prestart)
let firstPath = directory <> "/parallel-a"
secondPath = directory <> "/parallel-b"
downloadTo path =
try (curlToFile path
[ "--cookie", sessionCookies session
, probeBase context
<> "/api/download?root=personal&path=streaming-large.bin"
]) :: IO (Either SomeException CurlResponse)
downloadAttempt path = do
cookies <- cookieHeader (sessionCookies session)
try
(curlToFile path
[ "--header", "Cookie: " <> B8.unpack cookies
, probeBase context
<> "/api/download?root=personal&path=streaming-large.bin"
])
:: IO (Either SomeException ProbeResponse)
BS.writeFile firstPath BS.empty
BS.writeFile secondPath BS.empty
(first, second) <- concurrently (downloadTo firstPath) (downloadTo secondPath)
(first, second) <-
concurrently (downloadAttempt firstPath) (downloadAttempt secondPath)
assert "first throttled download completed" (isLeft first)
assert "second throttled download completed" (isLeft second)
firstBytes <- getFileSize firstPath
@ -189,21 +201,21 @@ verifyRefill context session directory = do
let bodyPath = directory <> "/refill-upload.bin"
writeZeros bodyPath 65536
digest <- hashFile bodyPath
initial <- uploadFileDeclared
initial <- curlUploadFileDeclared
context session "refill-initial.bin"
"72000000-0000-4000-8000-000000000001"
65536 digest bodyPath []
65536 digest bodyPath
requireSucceeded "initial token use" initial
exhausted <- uploadFileDeclared
exhausted <- curlUploadFileDeclared
context session "refill-exhausted.bin"
"72000000-0000-4000-8000-000000000003"
65536 digest bodyPath []
65536 digest bodyPath
requireStatus "exhausted token bucket" 429 exhausted
threadDelay 2000000
refilled <- uploadFileDeclared
refilled <- curlUploadFileDeclared
context session "refill-refilled.bin"
"72000000-0000-4000-8000-000000000002"
65536 digest bodyPath []
65536 digest bodyPath
requireSucceeded "refilled token bucket" refilled
putStrLn "Token-bucket refill behavior passed"
@ -211,15 +223,15 @@ verifyUnavailable :: ProbeContext -> Session -> IO ()
verifyUnavailable context session = do
listing <- browse context session "?root=personal"
requireStatus "browse without Redis" 200 listing
assertContains "browse without Redis" "\"path\":" (curlBody listing)
assertContains "browse without Redis" "\"path\":" (probeBody listing)
let path =
if "cross-user.txt" `BS.isInfixOf` curlBody listing
if "cross-user.txt" `BS.isInfixOf` probeBody listing
then "cross-user.txt"
else "streaming-large.bin"
query =
if path == "cross-user.txt" then "CROSS-USER" else "STREAMING-LARGE"
searched <- browse context session ("?root=personal&q=" <> query)
assertContains "search without Redis" (B8.pack path) (curlBody searched)
assertContains "search without Redis" (B8.pack path) (probeBody searched)
unavailableUpload <- upload context session "personal" "unavailable.bin"
"72000000-0000-4000-8000-000000000001" "x"
requireError "upload without Redis"
@ -249,14 +261,22 @@ uploadFileDeclared
-> Integer
-> BS.ByteString
-> FilePath
-> [String]
-> IO CurlResponse
uploadFileDeclared context session path operationId size digest bodyPath extra =
curl
( extra
<> uploadArguments context session path operationId size digest
<> ["--data-binary", "@" <> bodyPath]
)
-> RequestOptions
-> IO ProbeResponse
uploadFileDeclared context session path operationId size digest bodyPath options =
postWith
(probeClient context)
options
{ optionCookies = Just (sessionCookies session)
, optionHeaders =
[ ("Content-Type", "application/octet-stream")
, ("X-Declared-Size", B8.pack (show size))
, ("X-Content-SHA256", digest)
, ("X-CSRF-Token", sessionCsrf session)
] <> optionHeaders options
, optionBody = FileBody bodyPath
}
(uploadUrl context path operationId)
uploadBytesDeclared
:: ProbeContext
@ -266,14 +286,22 @@ uploadBytesDeclared
-> Integer
-> BS.ByteString
-> BS.ByteString
-> [String]
-> IO CurlResponse
uploadBytesDeclared context session path operationId size digest body extra =
withSystemTempFile "nuthatch-streaming-body" $ \bodyPath handle -> do
BS.hPut handle body
hClose handle
uploadFileDeclared
context session path operationId size digest bodyPath extra
-> RequestOptions
-> IO ProbeResponse
uploadBytesDeclared context session path operationId size digest body options =
postWith
(probeClient context)
options
{ optionCookies = Just (sessionCookies session)
, optionHeaders =
[ ("Content-Type", "application/octet-stream")
, ("X-Declared-Size", B8.pack (show size))
, ("X-Content-SHA256", digest)
, ("X-CSRF-Token", sessionCsrf session)
] <> optionHeaders options
, optionBody = ByteBody body
}
(uploadUrl context path operationId)
uploadArguments
:: ProbeContext
@ -282,19 +310,50 @@ uploadArguments
-> String
-> Integer
-> BS.ByteString
-> [String]
uploadArguments context session path operationId size digest =
[ "--cookie", sessionCookies session
, "--header", "Content-Type: application/octet-stream"
, "--header", "X-Declared-Size: " <> show size
, "--header", "X-Content-SHA256: " <> B8.unpack digest
, "--header", "X-CSRF-Token: " <> B8.unpack (sessionCsrf session)
, probeBase context
<> "/api/upload?root=personal&path="
<> path
<> "&operation_id="
<> operationId
]
-> IO [String]
uploadArguments context session path operationId size digest = do
cookies <- cookieHeader (sessionCookies session)
pure
[ "--header", "Cookie: " <> B8.unpack cookies
, "--header", "Content-Type: application/octet-stream"
, "--header", "X-Declared-Size: " <> show size
, "--header", "X-Content-SHA256: " <> B8.unpack digest
, "--header", "X-CSRF-Token: " <> B8.unpack (sessionCsrf session)
, probeBase context
<> "/api/upload?root=personal&path="
<> path
<> "&operation_id="
<> operationId
]
curlUploadFileDeclared
:: ProbeContext
-> Session
-> String
-> String
-> Integer
-> BS.ByteString
-> FilePath
-> IO ProbeResponse
curlUploadFileDeclared context session path operationId size digest bodyPath = do
arguments <- uploadArguments context session path operationId size digest
curl (arguments <> ["--data-binary", "@" <> bodyPath])
curlUploadBytesDeclared
:: ProbeContext
-> Session
-> String
-> String
-> Integer
-> BS.ByteString
-> BS.ByteString
-> IO ProbeResponse
curlUploadBytesDeclared context session path operationId size digest body =
withSystemTempFile "nuthatch-streaming-body" $ \bodyPath handle -> do
BS.hPut handle body
hClose handle
curlUploadFileDeclared
context session path operationId size digest bodyPath
interruptedUpload
:: ProbeContext
@ -306,6 +365,7 @@ interruptedUpload
-> FilePath
-> IO Bool
interruptedUpload context session path operationId size digest bodyPath = do
common <- uploadArguments context session path operationId size digest
let arguments =
[ "--insecure"
, "--silent"
@ -315,7 +375,7 @@ interruptedUpload context session path operationId size digest bodyPath = do
, "--request", "POST"
, "--upload-file", bodyPath
]
<> uploadArguments context session path operationId size digest
<> common
(exitCode, _, _) <- readProcessWithExitCode "curl" arguments ""
pure (exitCode == ExitSuccess)
@ -325,13 +385,14 @@ interruptedDownload
-> FilePath
-> IO Bool
interruptedDownload context session outputPath = do
cookies <- cookieHeader (sessionCookies session)
let arguments =
[ "--insecure"
, "--silent"
, "--show-error"
, "--max-time", "1"
, "--limit-rate", "64k"
, "--cookie", sessionCookies session
, "--header", "Cookie: " <> B8.unpack cookies
, "--output", outputPath
, probeBase context
<> "/api/download?root=personal&path=streaming-large.bin"
@ -339,6 +400,14 @@ interruptedDownload context session outputPath = do
(exitCode, _, _) <- readProcessWithExitCode "curl" arguments ""
pure (exitCode == ExitSuccess)
uploadUrl :: ProbeContext -> String -> String -> String
uploadUrl context path operationId =
probeBase context
<> "/api/upload?root=personal&path="
<> path
<> "&operation_id="
<> operationId
writeZeros :: FilePath -> Integer -> IO ()
writeZeros path byteCount =
withBinaryFile path WriteMode $ \handle -> do
@ -369,19 +438,19 @@ readEnvInteger name = do
value <- requireEnv name
maybe (fail ("invalid " <> name)) pure (readMaybe value)
requireSucceeded :: String -> CurlResponse -> IO ()
requireSucceeded :: String -> ProbeResponse -> IO ()
requireSucceeded label response = do
requireStatus label 200 response
assertContains label "\"result\":\"succeeded\"" (curlBody response)
assertContains label "\"result\":\"succeeded\"" (probeBody response)
requireError :: String -> Int -> BS.ByteString -> CurlResponse -> IO ()
requireError :: String -> Int -> BS.ByteString -> ProbeResponse -> IO ()
requireError label status code response = do
requireStatus label status response
assertContains label ("\"error\":\"" <> code <> "\"") (curlBody response)
assertContains label ("\"error\":\"" <> code <> "\"") (probeBody response)
requireStatus :: String -> Int -> CurlResponse -> IO ()
requireStatus :: String -> Int -> ProbeResponse -> IO ()
requireStatus label expected response =
assertEqual (label <> " status") expected (curlStatus response)
assertEqual (label <> " status") expected (probeStatus response)
isLeft :: Either left right -> Bool
isLeft (Left _) = True