Split kind tests into component-owned probes

This commit is contained in:
ms2k 2026-07-19 23:57:21 +09:00
commit 691ad92e30
47 changed files with 4269 additions and 3108 deletions

View file

@ -27,13 +27,21 @@ COPY app ./app
COPY src ./src
COPY test ./test
RUN cabal build exe:nuthatch exe:nuthatch-storage-integration exe:nuthatch-recovery-probe exe:nuthatch-protocol-conformance exe:nuthatch-runtime-probe \
RUN cabal build exe:nuthatch exe:nuthatch-storage-integration exe:nuthatch-recovery-probe exe:nuthatch-protocol-conformance exe:nuthatch-runtime-probe exe:nuthatch-auth-probe exe:nuthatch-product-probe exe:nuthatch-idempotency-probe exe:nuthatch-streaming-probe exe:nuthatch-runtime-http-probe exe:nuthatch-runtime-audit-probe exe:nuthatch-fixture-probe exe:nuthatch-dependency-probe \
&& mkdir -p /out \
&& cp "$(cabal list-bin exe:nuthatch)" /out/nuthatch \
&& cp "$(cabal list-bin exe:nuthatch-storage-integration)" /out/nuthatch-storage-integration \
&& cp "$(cabal list-bin exe:nuthatch-recovery-probe)" /out/nuthatch-recovery-probe \
&& cp "$(cabal list-bin exe:nuthatch-protocol-conformance)" /out/nuthatch-protocol-conformance \
&& cp "$(cabal list-bin exe:nuthatch-runtime-probe)" /out/nuthatch-runtime-probe
&& cp "$(cabal list-bin exe:nuthatch-runtime-probe)" /out/nuthatch-runtime-probe \
&& cp "$(cabal list-bin exe:nuthatch-auth-probe)" /out/nuthatch-auth-probe \
&& cp "$(cabal list-bin exe:nuthatch-product-probe)" /out/nuthatch-product-probe \
&& cp "$(cabal list-bin exe:nuthatch-idempotency-probe)" /out/nuthatch-idempotency-probe \
&& cp "$(cabal list-bin exe:nuthatch-streaming-probe)" /out/nuthatch-streaming-probe \
&& cp "$(cabal list-bin exe:nuthatch-runtime-http-probe)" /out/nuthatch-runtime-http-probe \
&& cp "$(cabal list-bin exe:nuthatch-runtime-audit-probe)" /out/nuthatch-runtime-audit-probe \
&& cp "$(cabal list-bin exe:nuthatch-fixture-probe)" /out/nuthatch-fixture-probe \
&& cp "$(cabal list-bin exe:nuthatch-dependency-probe)" /out/nuthatch-dependency-probe
FROM debian:bookworm-slim AS runtime-base
@ -59,6 +67,14 @@ COPY --from=build /out/nuthatch-storage-integration /usr/local/bin/nuthatch-stor
COPY --from=build /out/nuthatch-recovery-probe /usr/local/bin/nuthatch-recovery-probe
COPY --from=build /out/nuthatch-protocol-conformance /usr/local/bin/nuthatch-protocol-conformance
COPY --from=build /out/nuthatch-runtime-probe /usr/local/bin/nuthatch-runtime-probe
COPY --from=build /out/nuthatch-auth-probe /usr/local/bin/nuthatch-auth-probe
COPY --from=build /out/nuthatch-product-probe /usr/local/bin/nuthatch-product-probe
COPY --from=build /out/nuthatch-idempotency-probe /usr/local/bin/nuthatch-idempotency-probe
COPY --from=build /out/nuthatch-streaming-probe /usr/local/bin/nuthatch-streaming-probe
COPY --from=build /out/nuthatch-runtime-http-probe /usr/local/bin/nuthatch-runtime-http-probe
COPY --from=build /out/nuthatch-runtime-audit-probe /usr/local/bin/nuthatch-runtime-audit-probe
COPY --from=build /out/nuthatch-fixture-probe /usr/local/bin/nuthatch-fixture-probe
COPY --from=build /out/nuthatch-dependency-probe /usr/local/bin/nuthatch-dependency-probe
CMD ["nuthatch"]
FROM runtime-base AS runtime

View file

@ -16,10 +16,10 @@ check-storage-foundation:
./tests/kind/storage-foundation-run.sh
check-auth:
./tests/kind/product-matrix-run.sh
./tests/kind/auth-run.sh
check-app:
./tests/kind/product-matrix-run.sh
./tests/kind/auth-run.sh
check-app-boundaries:
./tests/application-boundaries.sh
@ -40,7 +40,7 @@ check-protocol: check-model-correspondence
./tests/kind/protocol-conformance-run.sh
check-product: test-frontend check-frontend build-frontend
NUTHATCH_PRODUCT_GATE=1 ./tests/kind/product-matrix-run.sh
./tests/kind/product-run.sh
check-runtime: test check-recovery
./tests/runtime-static.sh
@ -53,7 +53,7 @@ check-specs:
./tests/spec-contracts.sh
app-up:
NUTHATCH_APP_INTERACTIVE=1 ./tests/kind/product-matrix-run.sh
NUTHATCH_APP_INTERACTIVE=1 ./tests/kind/auth-run.sh
app-down:
./tests/kind/destroy.sh

View file

@ -179,10 +179,9 @@ authority over other buckets. End users and browsers never receive its
credentials.
The deployment's object-store IAM or policy system enforces that scope. The
Kubernetes manifest supplies the scoped credential through the secret boundary;
`tests/kind/lib.sh` provisions equivalent fixture principals, and
`tests/kind/product-matrix-job.yaml.in` verifies denial against a different
bucket.
Kubernetes manifest supplies the scoped credential through the secret boundary.
`tests/kind/fixture/target.sh` provisions equivalent fixture principals, and
`test/AuthProbe.hs` verifies denial against a different bucket.
Nuthatch is the exclusive writer to `users/` and `shared/` in the configured
bucket while the service is enabled. Operators may inspect those prefixes, but

View file

@ -37,9 +37,9 @@ The fixture provides PostgreSQL, Redis and DragonflyDB, Keycloak and ZITADEL,
and Garage and VersityGW. Images and fixture tools are checksum or
digest-pinned.
`make check-dependencies` creates the complete fixture, verifies each released
dependency image through its product interface, and destroys the fixture.
`make check-kind-matrix` runs a fixture-consumer Job sequentially across the
`make check-dependencies` creates the complete fixture, runs the Haskell
dependency probe against each released product interface, and destroys the
fixture. `make check-kind-matrix` runs the Haskell fixture probe sequentially across the
Redis/DragonflyDB × Keycloak/ZITADEL × Garage/VersityGW matrix without
deploying Nuthatch. `make check-app` deploys Nuthatch and runs its smoke Job
across the Redis/DragonflyDB × Garage/VersityGW matrix. `make app-up` retains
@ -72,6 +72,14 @@ retained. Locally built application or test images are loaded with
`load_local_image`; released dependencies always use the digest-pinned images
from `tests/kind/versions.env`.
`tests/kind/lib.sh` is a compatibility facade over the fixture modules.
The shared core owns only paths, the explicit Kubernetes wrapper, locking, and
Job observation. Runtime-provider setup, dependency deployment, lane
selection, PostgreSQL, Redis-compatible coordination, OIDC, target
provisioning, profiles, and lane cleanup have separate modules under
`tests/kind/fixture/`. Job manifests configure and launch one component-owned
Haskell probe; they do not contain shell test programs.
The host provides rootless nerdctl and containerd at the versions recorded in
`tests/kind/versions.env`, together with `ctr`, `curl`, `flock`, `jq`, and
`sha256sum`. The fixture downloads its pinned kind and kubectl binaries.

View file

@ -207,6 +207,171 @@ executable nuthatch-runtime-probe
-rtsopts
-with-rtsopts=-N
executable nuthatch-auth-probe
import: shared
main-is: AuthProbe.hs
hs-source-dirs: test
other-modules:
Nuthatch.Probe.Assert
Nuthatch.Probe.Curl
Nuthatch.Probe.Oidc
Nuthatch.Probe.ProductClient
build-depends:
, nuthatch
, aeson
, base
, bytestring
, crypton
, memory
, process
, temporary
ghc-options:
-threaded
-rtsopts
-with-rtsopts=-N
executable nuthatch-product-probe
import: shared
main-is: ProductProbe.hs
hs-source-dirs: test
other-modules:
Nuthatch.Probe.Assert
Nuthatch.Probe.Curl
Nuthatch.Probe.Oidc
Nuthatch.Probe.ProductClient
build-depends:
, nuthatch
, aeson
, base
, bytestring
, crypton
, memory
, process
, temporary
ghc-options:
-threaded
-rtsopts
-with-rtsopts=-N
executable nuthatch-idempotency-probe
import: shared
main-is: IdempotencyProbe.hs
hs-source-dirs: test
other-modules:
Nuthatch.Probe.Assert
Nuthatch.Probe.Curl
Nuthatch.Probe.Oidc
Nuthatch.Probe.ProductClient
build-depends:
, nuthatch
, aeson
, async
, base
, bytestring
, crypton
, memory
, process
, temporary
ghc-options:
-threaded
-rtsopts
-with-rtsopts=-N
executable nuthatch-streaming-probe
import: shared
main-is: StreamingProbe.hs
hs-source-dirs: test
other-modules:
Nuthatch.Probe.Assert
Nuthatch.Probe.Curl
Nuthatch.Probe.Oidc
Nuthatch.Probe.ProductClient
build-depends:
, nuthatch
, aeson
, async
, base
, bytestring
, crypton
, directory
, memory
, process
, temporary
ghc-options:
-threaded
-rtsopts
-with-rtsopts=-N
executable nuthatch-runtime-http-probe
import: shared
main-is: RuntimeHttpProbe.hs
hs-source-dirs: test
other-modules:
Nuthatch.Probe.Assert
Nuthatch.Probe.Curl
Nuthatch.Probe.Oidc
Nuthatch.Probe.ProductClient
build-depends:
, nuthatch
, aeson
, base
, bytestring
, crypton
, memory
, process
, temporary
ghc-options:
-threaded
-rtsopts
-with-rtsopts=-N
executable nuthatch-runtime-audit-probe
import: shared
main-is: RuntimeAuditProbe.hs
hs-source-dirs: test
other-modules:
Nuthatch.Probe.Assert
build-depends:
, nuthatch
, aeson
, base
, bytestring
, text
executable nuthatch-fixture-probe
import: shared
main-is: FixtureProbe.hs
hs-source-dirs: test
other-modules:
Nuthatch.Probe.Assert
Nuthatch.Probe.Curl
build-depends:
, nuthatch
, base
, bytestring
, crypton
, memory
, postgresql-simple
, process
, temporary
, text
executable nuthatch-dependency-probe
import: shared
main-is: DependencyProbe.hs
hs-source-dirs: test
other-modules:
Nuthatch.Probe.Assert
Nuthatch.Probe.Curl
build-depends:
, nuthatch
, base
, bytestring
, hedis
, postgresql-simple
, process
, temporary
test-suite nuthatch-unit
import: shared
type: exitcode-stdio-1.0

230
test/AuthProbe.hs Normal file
View file

@ -0,0 +1,230 @@
module Main (main) where
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as B8
import Data.List (find)
import System.Entropy (getEntropy)
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
import Nuthatch.Probe.Oidc
import Nuthatch.Probe.ProductClient
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
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"
verifyCredentialScope :: IO ()
verifyCredentialScope = do
endpoint <- requireEnv "NUTHATCH_S3_ENDPOINT"
region <- requireEnv "NUTHATCH_S3_REGION"
accessKey <- requireEnv "NUTHATCH_S3_ACCESS_KEY"
secretKey <- requireEnv "NUTHATCH_S3_SECRET_KEY"
let signed =
[ "--aws-sigv4", "aws:amz:" <> region <> ":s3"
, "--user", accessKey <> ":" <> secretKey
]
denied label arguments = do
response <- curl (signed <> arguments)
assertEqual
(label <> ": " <> B8.unpack (curlBody response))
403
(curlStatus response)
emptyPayload =
"X-Amz-Content-Sha256:e3b0c44298fc1c149afbf4c8996fb924"
<> "27ae41e4649b934ca495991b7852b855"
denied "unscoped bucket head"
[ "--head"
, "--header", emptyPayload
, endpoint <> "/nuthatch-fixture"
]
denied "unscoped bucket listing"
[ "--header", emptyPayload
, endpoint <> "/nuthatch-fixture?list-type=2"
]
denied "unscoped object read"
[ "--header", emptyPayload
, endpoint <> "/nuthatch-fixture/scope-canary"
]
denied "unscoped object write"
[ "--request", "PUT"
, "--header"
, "X-Amz-Content-Sha256:16d02fe317ec0615c2039631cc72bdf9"
<> "e6c8b7a2cb32895d6235c5775522bbc6"
, "--data-binary", "denied-write"
, endpoint <> "/nuthatch-fixture/denied-write"
]
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
<> "/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-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\","
<> "\"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)
verifyAuthenticatedBoundary :: ProbeContext -> Session -> IO ()
verifyAuthenticatedBoundary context session = do
html <- curl
[ "--cookie", sessionCookies session
, probeBase context <> "/api/browse"
]
assertEqual "authenticated HTML browse" 200 (curlStatus html)
json <- browse context session ""
assertEqual "authenticated JSON browse" 200 (curlStatus json)
let prohibited =
[ "NUTHATCH_S3"
, "AWS_ACCESS_KEY"
, "AWS_SECRET_ACCESS_KEY"
, "client_secret"
]
bodies = curlBody html <> curlBody json
mapM_
(\value ->
assert ("browser response exposed " <> value) $
not (B8.pack value `BS.isInfixOf` bodies))
prohibited
exerciseRoot
:: ProbeContext
-> Session
-> String
-> String
-> String
-> IO ()
exerciseRoot context session runId root suffix = do
let path = "smoke-" <> suffix <> ".txt"
first = B8.pack ("first-" <> root)
second = B8.pack ("second-" <> root)
operation prefix =
runId <> "-" <> prefix <> "-" <> suffix
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)
firstDownload <- download context session root path
assertEqual "first download status" 200 (curlStatus firstDownload)
assertEqual "first download body" first (curlBody 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)
deleted <- deleteObject context session root path (operation "2")
requireSucceeded "delete" deleted
missing <- download context session root path
assertEqual "deleted object" 404 (curlStatus missing)
verifyCrossUserBoundary :: ProbeContext -> Session -> String -> IO ()
verifyCrossUserBoundary context sessionA runId = do
let body = "private-a"
personal <- upload context sessionA "personal" "cross-user.txt"
(runId <> "-cross-personal") body
requireSucceeded "personal cross-user setup" personal
shared <- upload context sessionA "shared" "cross-user.txt"
(runId <> "-cross-shared") body
requireSucceeded "shared cross-user setup" shared
userB <- requireEnv "NUTHATCH_OIDC_USER_B"
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)
sharedB <- browse context sessionB "?root=shared"
assertContains "shared object visibility" "cross-user.txt" (curlBody 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)
mapM_
(\name ->
let matching =
find
(BS.isPrefixOf (name <> "="))
(headerValues "set-cookie" completed)
in assert (B8.unpack name <> " was not expired") $
maybe False
(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)
requireSucceeded :: String -> CurlResponse -> IO ()
requireSucceeded label response = do
assertEqual (label <> " status") 200 (curlStatus response)
assertContains label "\"result\":\"succeeded\"" (curlBody response)

199
test/DependencyProbe.hs Normal file
View file

@ -0,0 +1,199 @@
module Main (main) where
import Control.Concurrent (threadDelay)
import Control.Exception (bracket)
import Control.Monad (unless)
import qualified Data.ByteString.Char8 as B8
import Database.PostgreSQL.Simple
( Only (..)
, close
, connectPostgreSQL
, execute_
, query_
)
import Database.Redis
( ConnectInfo (..)
, PortID (..)
, Reply
, Status
, connect
, defaultConnectInfo
, disconnect
, get
, runRedis
, set
)
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
main :: IO ()
main = do
verifyPostgres
verifyCoordination "redis"
verifyCoordination "dragonfly"
verifyOidc
verifyTarget
"Garage"
"http://garage:3900"
"garage"
"GK00000000000000000000000000000000"
"0000000000000000000000000000000000000000000000000000000000000000"
False
verifyTarget
"VersityGW"
"http://versitygw:10000"
"us-east-1"
"synthetic-s3-access"
"synthetic-s3-secret"
True
putStrLn "Dependency product interfaces passed"
verifyPostgres :: IO ()
verifyPostgres =
bracket
(connectPostgreSQL
"host=postgres port=5432 user=nuthatch password=synthetic-postgres dbname=nuthatch")
close
(\connection -> do
_ <- execute_ connection
"CREATE TEMP TABLE dependency_probe (value text NOT NULL)"
_ <- execute_ connection
"INSERT INTO dependency_probe VALUES ('passed')"
values <- query_ connection
"SELECT value FROM dependency_probe"
:: IO [Only B8.ByteString]
assertEqual "PostgreSQL product interface"
[Only "passed"]
values)
verifyCoordination :: String -> IO ()
verifyCoordination host =
bracket
(connect defaultConnectInfo
{ connectHost = host
, connectPort = PortNumber 6379
})
disconnect
(\connection -> do
stored <- runRedis connection (set "nuthatch-probe" "passed")
:: IO (Either Reply Status)
assert "coordination write failed" (isRight stored)
loaded <- runRedis connection (get "nuthatch-probe")
:: IO (Either Reply (Maybe B8.ByteString))
assertEqual (host <> " product interface")
(Right (Just "passed"))
loaded)
verifyOidc :: IO ()
verifyOidc =
mapM_
(\(label, url, marker) ->
retry label 30 $ do
response <- curl [url]
pure
( curlStatus response == 200
&& marker `B8.isInfixOf` curlBody response
))
[ ( "Keycloak discovery"
, "http://keycloak.nuthatch.test:8080/realms/master/.well-known/openid-configuration"
, "\"issuer\""
)
, ( "Keycloak keys"
, "http://keycloak.nuthatch.test:8080/realms/master/protocol/openid-connect/certs"
, "\"keys\""
)
, ( "ZITADEL discovery"
, "http://zitadel.nuthatch.test:8080/.well-known/openid-configuration"
, "\"issuer\""
)
, ( "ZITADEL keys"
, "http://zitadel.nuthatch.test:8080/oauth/v2/keys"
, "\"keys\""
)
]
verifyTarget
:: String
-> String
-> String
-> String
-> String
-> Bool
-> IO ()
verifyTarget label endpoint region accessKey secretKey createBucket = do
let signed =
[ "--aws-sigv4", "aws:amz:" <> region <> ":s3"
, "--user", accessKey <> ":" <> secretKey
]
bucket = endpoint <> "/nuthatch-fixture"
payload = "nuthatch-dependency-compatibility-probe"
payloadDigest =
"d0d4c515c2723784b6ca1b22b97d89ae8229a9c2abcb9ca912b85c1f02e17303"
emptyDigest =
"e3b0c44298fc1c149afbf4c8996fb924"
<> "27ae41e4649b934ca495991b7852b855"
if createBucket
then do
created <- curl
( signed
<> [ "--request", "PUT"
, "--header", "X-Amz-Content-Sha256:" <> emptyDigest
, bucket
]
)
assert
( label
<> " bucket creation failed: "
<> B8.unpack (curlBody created)
) $
curlStatus created `elem` [200, 409]
else pure ()
uploaded <- retryResponse 30 $ curl
( signed
<> [ "--request", "PUT"
, "--header"
, "X-Amz-Content-Sha256:" <> payloadDigest
, "--data-binary", payload
, bucket <> "/probe/payload"
]
)
assertEqual
(label <> " upload: " <> B8.unpack (curlBody uploaded))
200
(curlStatus uploaded)
downloaded <- curl
( signed
<> [ "--header"
, "X-Amz-Content-Sha256:" <> emptyDigest
, bucket <> "/probe/payload"
]
)
assertEqual (label <> " download status") 200 (curlStatus downloaded)
assertEqual (label <> " object body")
(B8.pack payload)
(curlBody downloaded)
retry :: String -> Int -> IO Bool -> IO ()
retry label attempts action =
go attempts
where
go remaining = do
succeeded <- action
unless succeeded $
if remaining <= 1
then fail (label <> " did not become available")
else threadDelay 1000000 >> go (remaining - 1)
retryResponse :: Int -> IO CurlResponse -> IO CurlResponse
retryResponse attempts action =
go attempts
where
go remaining = do
response <- action
if curlStatus response == 200 || remaining <= 1
then pure response
else threadDelay 1000000 >> go (remaining - 1)
isRight :: Either left right -> Bool
isRight (Right _) = True
isRight (Left _) = False

81
test/FixtureProbe.hs Normal file
View file

@ -0,0 +1,81 @@
module Main (main) where
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import Crypto.Hash (Digest, SHA256, hash)
import qualified Data.ByteArray as BA
import qualified Data.ByteString.Base16 as B16
import qualified Data.Text as Text
import qualified Data.Text.Encoding as TextEncoding
import Database.PostgreSQL.Simple (Only (..))
import Nuthatch.Config (loadConfig)
import qualified Nuthatch.Db as Db
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
import Nuthatch.Redis
import Nuthatch.S3
import Nuthatch.Types
import System.Environment (setEnv)
main :: IO ()
main = do
profile <- requireEnv "NUTHATCH_FIXTURE_PROFILE"
lane <- requireEnv "NUTHATCH_FIXTURE_LANE"
pgConnection <- requireEnv "NUTHATCH_PG_CONN"
setEnv "NUTHATCH_JWT_SECRET" "synthetic-fixture-session-secret"
setEnv "NUTHATCH_PUBLIC_BASE_URL" ("https://nuthatch-" <> lane <> ":8080")
setEnv "NUTHATCH_OIDC_CLIENT_SECRET" "synthetic-fixture-client-secret"
config <- loadConfig
verifyProfileFile profile lane pgConnection
Db.withDb config $ \database -> do
_ <- Db.execute_ database
"CREATE TEMP TABLE lane_canary (value text NOT NULL)"
_ <- Db.execute database
"INSERT INTO lane_canary VALUES (?)"
(Only (Text.pack profile))
pure ()
withRedis config $ \redis -> do
cacheSet redis "lane-canary" 60 (B8.pack profile)
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)
store <- newS3 config
let key = ObjectKey "lane-canary"
body = BL.fromStrict (B8.pack profile)
digest =
ContentSha256 (TextEncoding.decodeUtf8 (sha256Hex (BL.toStrict body)))
putObject store key (toInteger (BL.length body)) (Just digest) body >>=
assertEqual "target lane canary put" (Right ())
getObjectBytes store key >>=
assertEqual "target lane canary get" (Right body)
putStrLn "Fixture lane passed"
verifyProfileFile :: String -> String -> String -> IO ()
verifyProfileFile profile lane pgConnection = do
contents <- lines <$> readFile "/run/nuthatch-fixture/profile.env"
mapM_
(\name -> do
value <- requireEnv name
assert (name <> " missing from mounted lane profile") $
name <> "=" <> value `elem` contents)
[ "NUTHATCH_FIXTURE_PROFILE"
, "NUTHATCH_COORDINATION_PROVIDER"
, "NUTHATCH_OIDC_PROVIDER"
, "NUTHATCH_TARGET_PROVIDER"
]
bucket <- requireEnv "NUTHATCH_S3_BUCKET"
assertEqual "lane bucket"
("nuthatch-lane-" <> lane)
bucket
assertContains "lane database"
(B8.pack ("dbname=nuthatch_lane_" <> lane))
(B8.pack pgConnection)
assertEqual "mounted profile name" profile =<<
requireEnv "NUTHATCH_FIXTURE_PROFILE"
sha256Hex :: B8.ByteString -> B8.ByteString
sha256Hex input =
B16.encode (BA.convert (hash input :: Digest SHA256))

285
test/IdempotencyProbe.hs Normal file
View file

@ -0,0 +1,285 @@
module Main (main) where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (async, concurrently, wait)
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.Exit (ExitCode (..))
import System.IO (hClose)
import System.IO.Temp
( withSystemTempDirectory
, withSystemTempFile
)
import System.Process
( CreateProcess (..)
, StdStream (..)
, createProcess
, proc
, waitForProcess
)
main :: IO ()
main =
withSystemTempDirectory "nuthatch-idempotency-probe" $ \directory -> do
context <- newProbeContext directory
user <- requireEnv "NUTHATCH_OIDC_USER_A"
session <- login context False user "idempotency"
lane <- requireEnv "NUTHATCH_FIXTURE_LANE"
ipA <- requireEnv "NUTHATCH_IDEMPOTENCY_IP_A"
ipB <- requireEnv "NUTHATCH_IDEMPOTENCY_IP_B"
verifyEpochs context session lane ipA ipB
verifyActiveIdentity context session lane ipA ipB directory
emitRefinementTrace
putStrLn "Cross-process idempotency epochs passed"
verifyEpochs
:: ProbeContext
-> Session
-> String
-> String
-> String
-> IO ()
verifyEpochs context session lane ipA ipB = do
let operationId = "73000000-0000-4000-8000-000000000001"
firstBody = "first-epoch"
first <- targetedUpload context session lane ipA operationId firstBody
requireSucceededWindow "first epoch" first
replay <- targetedUpload context session lane ipB operationId firstBody
requireSucceededWindow "cross-process replay" replay
conflict <- targetedUpload context session lane ipB operationId "conflict"
assertContains "conflicting reuse"
"\"result\":\"conflict\""
(curlBody 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
conflicted response =
"\"result\":\"conflict\"" `BS.isInfixOf` curlBody response
assertEqual "new epoch winner count" 1 (length (filter succeeded outcomes))
assertEqual "new epoch conflict count" 1 (length (filter conflicted outcomes))
let (winningBody, replayIp) =
if succeeded responseA
then ("second-epoch-a", ipB)
else ("second-epoch-b", ipA)
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)
verifyActiveIdentity
:: ProbeContext
-> Session
-> String
-> String
-> String
-> FilePath
-> IO ()
verifyActiveIdentity context session lane ipA ipB directory = do
let activeBody = BS.replicate 1048576 0
activeOperation = "73000000-0000-4000-8000-000000000002"
active <- async $
slowUpload context session lane ipA directory activeOperation activeBody
threadDelay 3000000
pending <- uploadDeclared
context
session
lane
ipB
"active-window.bin"
activeOperation
(BS.length activeBody)
(sha256Hex activeBody)
"first-epoch"
assertContains "active replay after terminal window"
"\"result\":\"pending\""
(curlBody pending)
locked <- targetedUploadAt
context
session
lane
ipB
"active-window.bin"
"73000000-0000-4000-8000-000000000003"
"first-epoch"
assertEqual "active key lock status" 200 (curlStatus locked)
assertContains "active key lock"
"\"result\":\"rejected\""
(curlBody locked)
completed <- wait active
assertContains "active request completion"
"\"result\":\"succeeded\""
(curlBody completed)
targetedUpload
:: ProbeContext
-> Session
-> String
-> String
-> String
-> BS.ByteString
-> IO CurlResponse
targetedUpload context session lane ip =
targetedUploadAt context session lane ip "idempotency.txt"
targetedUploadAt
:: ProbeContext
-> Session
-> String
-> String
-> String
-> String
-> BS.ByteString
-> IO CurlResponse
targetedUploadAt context session lane ip path operationId =
uploadTo
(probeBase context)
(resolveArgs lane ip)
session
"personal"
path
operationId
uploadDeclared
:: ProbeContext
-> Session
-> String
-> String
-> String
-> String
-> Int
-> BS.ByteString
-> BS.ByteString
-> IO CurlResponse
uploadDeclared context session lane ip path operationId size digest body =
withSystemTempFile "nuthatch-declared-upload" $ \bodyPath handle -> do
BS.hPut handle body
hClose handle
curl
( resolveArgs lane ip
<> [ "--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)
, "--data-binary", "@" <> bodyPath
, probeBase context
<> "/api/upload?root=personal&path="
<> path
<> "&operation_id="
<> operationId
]
)
slowUpload
:: ProbeContext
-> Session
-> String
-> String
-> FilePath
-> String
-> BS.ByteString
-> IO CurlResponse
slowUpload context session lane ip directory operationId body = do
let outputPath = directory <> "/active-upload-response"
statusPath = directory <> "/active-upload-status"
firstChunk = BS.take 65536 body
remaining = BS.drop 65536 body
arguments =
[ "--insecure"
, "--silent"
, "--show-error"
, "--resolve", "nuthatch-" <> lane <> ":8080:" <> ip
, "--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)
, "--request", "POST"
, "--upload-file", "-"
, "--output", outputPath
, "--write-out", "%{http_code}"
, probeBase context
<> "/api/upload?root=personal&path=active-window.bin"
<> "&operation_id="
<> operationId
]
(Just input, Just statusOutput, _, processHandle) <-
createProcess
(proc "curl" arguments)
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = Inherit
}
BS.hPut input firstChunk
threadDelay 5000000
BS.hPut input remaining
hClose input
statusBytes <- BS.hGetContents statusOutput
exitCode <- waitForProcess processHandle
case exitCode of
ExitSuccess -> pure ()
ExitFailure code -> fail ("slow upload curl failed: " <> show code)
BS.writeFile statusPath statusBytes
responseBody <- BS.readFile outputPath
status <- case reads (B8.unpack statusBytes) of
[(value, "")] -> pure value
_ -> fail "slow upload returned invalid HTTP status"
pure CurlResponse
{ curlStatus = status
, curlHeaders = []
, curlBody = responseBody
}
resolveArgs :: String -> String -> [String]
resolveArgs lane ip =
[ "--connect-timeout", "2"
, "--retry", "10"
, "--retry-connrefused"
, "--retry-delay", "1"
, "--resolve", "nuthatch-" <> lane <> ":8080:" <> ip
]
requireSucceededWindow :: String -> CurlResponse -> IO ()
requireSucceededWindow label response = do
assertEqual (label <> " status") 200 (curlStatus response)
assertContains label "\"result\":\"succeeded\"" (curlBody response)
assertContains (label <> " window")
"\"idempotency_window_seconds\":2"
(curlBody response)
emitRefinementTrace :: IO ()
emitRefinementTrace =
mapM_ putStrLn
[ "{\"epoch\":1,\"action\":\"Init\"}"
, "{\"epoch\":1,\"action\":\"FirstRequest\",\"observation\":{\"result\":\"pending\",\"disposition\":\"first\"}}"
, "{\"epoch\":1,\"action\":\"PrepareEffect\"}"
, "{\"epoch\":1,\"action\":\"DispatchEffect\"}"
, "{\"epoch\":1,\"action\":\"ExternalEffectApplied\"}"
, "{\"epoch\":1,\"action\":\"FinalizeSuccess\"}"
, "{\"epoch\":1,\"action\":\"ReplayRequest\",\"observation\":{\"result\":\"succeeded\",\"disposition\":\"replay\"}}"
, "{\"epoch\":1,\"action\":\"ConflictRequest\",\"observation\":{\"result\":\"conflict\",\"disposition\":\"conflict\"}}"
, "{\"after_epoch\":1,\"action\":\"TraceCut\",\"reason\":\"terminal_identity_expired\"}"
, "{\"epoch\":2,\"action\":\"Init\"}"
, "{\"epoch\":2,\"action\":\"FirstRequest\",\"observation\":{\"result\":\"pending\",\"disposition\":\"first\"}}"
, "{\"epoch\":2,\"action\":\"PrepareEffect\"}"
, "{\"epoch\":2,\"action\":\"DispatchEffect\"}"
, "{\"epoch\":2,\"action\":\"ExternalEffectApplied\"}"
, "{\"epoch\":2,\"action\":\"FinalizeSuccess\"}"
, "{\"epoch\":2,\"action\":\"ReplayRequest\",\"observation\":{\"result\":\"succeeded\",\"disposition\":\"replay\"}}"
]

View file

@ -0,0 +1,27 @@
module Nuthatch.Probe.Assert
( assert
, assertContains
, assertEqual
, requireEnv
) where
import Control.Monad (unless)
import qualified Data.ByteString as BS
import System.Environment (lookupEnv)
assert :: String -> Bool -> IO ()
assert label condition =
unless condition (fail label)
assertContains :: String -> BS.ByteString -> BS.ByteString -> IO ()
assertContains label needle haystack =
assert label (needle `BS.isInfixOf` haystack)
assertEqual :: (Eq value, Show value) => String -> value -> value -> IO ()
assertEqual label expected actual =
unless (actual == expected) $
fail (label <> ": expected " <> show expected <> ", got " <> show actual)
requireEnv :: String -> IO String
requireEnv name =
lookupEnv name >>= maybe (fail ("missing " <> name)) pure

125
test/Nuthatch/Probe/Curl.hs Normal file
View file

@ -0,0 +1,125 @@
module Nuthatch.Probe.Curl
( CurlResponse (..)
, cookieValue
, curl
, curlToFile
, headerValue
, headerValues
) where
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import Data.Char (toLower)
import Data.List (find)
import Data.Maybe (mapMaybe)
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)
curl :: [String] -> IO CurlResponse
curl arguments =
withSystemTempDirectory "nuthatch-curl" $ \directory -> do
let bodyPath = directory <> "/body"
response <- runCurl bodyPath arguments
body <- BS.readFile bodyPath
pure response { curlBody = body }
curlToFile :: FilePath -> [String] -> IO CurlResponse
curlToFile outputPath arguments =
runCurl outputPath arguments
runCurl :: FilePath -> [String] -> IO CurlResponse
runCurl outputPath arguments =
withSystemTempDirectory "nuthatch-curl-headers" $ \directory -> do
let headersPath = directory <> "/headers"
common =
[ "--insecure"
, "--silent"
, "--show-error"
, "--dump-header", headersPath
, "--output", outputPath
, "--write-out", "%{http_code}"
]
(exitCode, statusText, stderrText) <-
readProcessWithExitCode "curl" (common <> arguments) ""
status <- case readMaybe statusText of
Just value -> pure value
Nothing ->
fail ("curl returned an invalid status: " <> statusText)
case exitCode of
ExitSuccess -> pure ()
ExitFailure code ->
fail
( "curl transport failed with exit "
<> show code
<> ": "
<> stderrText
)
headers <- parseHeaders <$> BS.readFile headersPath
pure CurlResponse
{ curlStatus = status
, curlHeaders = headers
, curlBody = BS.empty
}
parseHeaders :: BS.ByteString -> [(BS.ByteString, BS.ByteString)]
parseHeaders input =
case filter (not . null) (splitBlocks (B8.lines input)) of
[] -> []
blocks -> mapMaybe parseHeader (last blocks)
where
splitBlocks = foldr splitLine [[]]
splitLine line (block : blocks)
| BS.null (stripCarriageReturn line) = [] : block : blocks
| otherwise = (stripCarriageReturn line : block) : blocks
splitLine _ [] = []
parseHeader :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)
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
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

399
test/Nuthatch/Probe/Oidc.hs Normal file
View file

@ -0,0 +1,399 @@
module Nuthatch.Probe.Oidc
( ProbeContext (..)
, Session (..)
, login
, newProbeContext
, verifyPkceBoundary
) where
import Data.Aeson
( FromJSON (..)
, eitherDecodeStrict'
, withObject
, (.:)
)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import Data.Char (toLower)
import Data.List (find)
import Data.Maybe (fromMaybe)
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
import System.Environment (lookupEnv)
import System.FilePath ((</>))
data ProbeContext = ProbeContext
{ probeBase :: String
, probeDirectory :: FilePath
, probeOidcIssuer :: String
, probeOidcProvider :: String
, probeOidcPassword :: String
, probeOidcLoginPat :: Maybe String
, probeOidcClientId :: String
, probeOidcClientSecret :: String
, probeOidcRedirectUri :: String
}
data Session = Session
{ sessionCookies :: FilePath
, sessionCsrf :: BS.ByteString
}
data ZitadelSession = ZitadelSession
{ zitadelSessionId :: String
, zitadelSessionToken :: String
}
instance FromJSON ZitadelSession where
parseJSON = withObject "ZitadelSession" $ \object ->
ZitadelSession
<$> object .: "sessionId"
<*> object .: "sessionToken"
newtype ZitadelCallback = ZitadelCallback String
instance FromJSON ZitadelCallback where
parseJSON = withObject "ZitadelCallback" $ \object ->
ZitadelCallback <$> object .: "callbackUrl"
newtype OidcDiscovery = OidcDiscovery String
instance FromJSON OidcDiscovery where
parseJSON = withObject "OidcDiscovery" $ \object ->
OidcDiscovery <$> object .: "token_endpoint"
newProbeContext :: FilePath -> IO ProbeContext
newProbeContext directory = do
lane <- requireEnv "NUTHATCH_FIXTURE_LANE"
issuer <- requireEnv "NUTHATCH_OIDC_ISSUER"
provider <- requireEnv "NUTHATCH_OIDC_PROVIDER"
password <- requireEnv "NUTHATCH_OIDC_USER_PASSWORD"
loginPat <- optionalEnv "NUTHATCH_OIDC_LOGIN_PAT"
clientId <- requireEnv "NUTHATCH_OIDC_CLIENT_ID"
clientSecret <- requireEnv "NUTHATCH_OIDC_CLIENT_SECRET"
redirectUri <- requireEnv "NUTHATCH_OIDC_REDIRECT_URI"
pure ProbeContext
{ probeBase = "https://nuthatch-" <> lane <> ":8080"
, probeDirectory = directory
, probeOidcIssuer = issuer
, probeOidcProvider = provider
, probeOidcPassword = password
, probeOidcLoginPat = loginPat
, probeOidcClientId = clientId
, probeOidcClientSecret = clientSecret
, probeOidcRedirectUri = redirectUri
}
login :: ProbeContext -> Bool -> String -> String -> IO Session
login context verifyBoundary user suffix = do
let cookies = probeDirectory context </> "cookies-" <> suffix
idpCookies = probeDirectory context </> "idp-" <> suffix
started <- curl
[ "--cookie-jar", cookies
, probeBase context <> "/login"
]
assertEqual "login redirect status" 303 (curlStatus started)
authorizationUrl <-
maybe (fail "login response omitted Location") (pure . B8.unpack) $
headerValue "location" started
requireCookieAttributes
"OIDC transaction"
["secure", "httponly", "samesite=lax", "path=/oidc/callback"]
(findCookie "nuthatch_oidc" started)
state <- queryValue "state" authorizationUrl
if verifyBoundary
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)
assertEqual "OIDC callback location"
(Just "/app")
(B8.unpack <$> headerValue "location" completed)
requireCookieAttributes
"session"
["secure", "httponly", "samesite=lax", "path=/;"]
(findCookie "nuthatch_session" completed)
requireCookieAttributes
"CSRF"
["secure", "samesite=lax", "path=/;"]
(findCookie "nuthatch_csrf" completed)
assert "CSRF cookie must be readable by the browser" $
not ("httponly" `containsLower` findCookie "nuthatch_csrf" completed)
requireCookieAttributes
"expired OIDC transaction"
["max-age=0", "path=/oidc/callback;"]
(findCookie "nuthatch_oidc" completed)
let responseCookies = headerValues "set-cookie" completed
assert "application cookies must be host-only" $
all (not . containsLower "domain=") responseCookies
csrf <- cookieValue cookies "nuthatch_csrf"
pure Session
{ sessionCookies = cookies
, sessionCsrf = csrf
}
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"
]
authorizationUrl <-
maybe (fail "PKCE login omitted Location") (pure . B8.unpack) $
headerValue "location" started
callback <- completeAuthorization
context
idpCookies
user
"pkce"
authorizationUrl
code <- queryValue "code" callback
discoveryResponse <- curl
[probeOidcIssuer context <> "/.well-known/openid-configuration"]
assertEqual "OIDC discovery status" 200 (curlStatus 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
]
assert "provider accepted an invalid PKCE verifier" $
curlStatus rejected >= 400
verifyTransactionBoundary
:: ProbeContext
-> FilePath
-> String
-> String
-> IO ()
verifyTransactionBoundary context cookies authorizationUrl state = do
wrongRedirect <- curl [replaceRedirectUri authorizationUrl]
assert "provider accepted an unregistered redirect URI" $
curlStatus wrongRedirect >= 400
invalidState <- curl
[ "--cookie", cookies
, probeBase context
<> "/oidc/callback?code=unused&state=invalid-"
<> state
]
assert "application accepted an invalid OIDC state" $
curlStatus invalidState >= 400
transaction <- cookieValue cookies "nuthatch_oidc"
malformed <- curl
[ "--header", "Cookie: nuthatch_oidc=malformed"
, probeBase context
<> "/oidc/callback?code=unused&state="
<> state
]
assertEqual "malformed transaction cookie" 400 (curlStatus malformed)
let tampered = BS.cons 120 (BS.drop 1 transaction)
tamperedResponse <- curl
[ "--header", "Cookie: nuthatch_oidc=" <> B8.unpack tampered
, probeBase context
<> "/oidc/callback?code=unused&state="
<> state
]
assertEqual "tampered transaction cookie" 400 (curlStatus tamperedResponse)
completeAuthorization
:: ProbeContext
-> FilePath
-> String
-> String
-> String
-> IO String
completeAuthorization context idpCookies user suffix authorizationUrl =
case probeOidcProvider context of
"keycloak" ->
completeKeycloak context idpCookies user authorizationUrl
"zitadel" ->
completeZitadel context user suffix authorizationUrl
provider ->
fail ("unsupported OIDC provider: " <> provider)
completeKeycloak
:: ProbeContext
-> FilePath
-> 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
]
maybe
(fail "Keycloak login omitted callback Location")
(pure . B8.unpack)
(headerValue "location" submitted)
completeZitadel
:: ProbeContext
-> String
-> String
-> String
-> IO String
completeZitadel context user _ authorizationUrl = do
pat <- maybe (fail "ZITADEL login PAT is missing") pure $
probeOidcLoginPat context
started <- curl [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\":\""
<> user
<> "\"},\"password\":{\"password\":\""
<> probeOidcPassword context
<> "\"}},\"lifetime\":\"300s\"}"
, probeOidcIssuer context <> "/v2/sessions"
]
assert "ZITADEL session creation failed" $
curlStatus created >= 200 && curlStatus created < 300
ZitadelSession {..} <- decodeBody "ZITADEL session" created
finalized <- curl
[ "--header", "Authorization: Bearer " <> pat
, "--header", "Content-Type: application/json"
, "--data"
, "{\"session\":{\"sessionId\":\""
<> zitadelSessionId
<> "\",\"sessionToken\":\""
<> zitadelSessionToken
<> "\"}}"
, probeOidcIssuer context
<> "/v2/oidc/auth_requests/"
<> authRequest
]
assertEqual "ZITADEL authorization finalization" 200 (curlStatus finalized)
ZitadelCallback callback <- decodeBody "ZITADEL callback" finalized
pure callback
decodeBody :: FromJSON value => String -> CurlResponse -> IO value
decodeBody label response =
either (fail . ((label <> ": ") <>)) pure $
eitherDecodeStrict' (curlBody response)
findCookie :: BS.ByteString -> CurlResponse -> BS.ByteString
findCookie name response =
fromMaybe BS.empty $
find (containsLower (lower name <> "=")) (headerValues "set-cookie" response)
requireCookieAttributes
:: String
-> [BS.ByteString]
-> BS.ByteString
-> IO ()
requireCookieAttributes label attributes cookie = do
assert (label <> " cookie is missing") (not (BS.null cookie))
mapM_
(\attribute ->
assert (label <> " cookie omitted " <> B8.unpack attribute) $
attribute `containsLower` cookie)
attributes
containsLower :: BS.ByteString -> BS.ByteString -> Bool
containsLower needle haystack =
lower needle `BS.isInfixOf` lower haystack
lower :: BS.ByteString -> BS.ByteString
lower = B8.map toLower
queryValue :: String -> String -> IO String
queryValue name url =
case drop 1 (dropWhile (/= '?') url) of
"" -> fail ("URL has no query: " <> url)
query ->
case find ((== name) . fst) (map splitPair (splitOn '&' query)) of
Just (_, value) | not (null value) -> pure value
_ -> fail ("URL query omitted " <> name)
splitPair :: String -> (String, String)
splitPair value =
case break (== '=') value of
(name, '=' : rest) -> (name, rest)
(name, _) -> (name, "")
splitOn :: Char -> String -> [String]
splitOn delimiter value =
case break (== delimiter) value of
(prefix, []) -> [prefix]
(prefix, _ : suffix) -> prefix : splitOn delimiter suffix
replaceRedirectUri :: String -> String
replaceRedirectUri url =
let marker = "redirect_uri="
(prefix, rest) = breakOn marker url
in case rest of
"" -> url
_ ->
let afterName = drop (length marker) rest
suffix = dropWhile (/= '&') afterName
in prefix
<> marker
<> "https%3A%2F%2Finvalid.example%2Fcallback"
<> suffix
htmlAttribute :: String -> String -> IO String
htmlAttribute name html =
let marker = name <> "=\""
(_, rest) = breakOn marker html
in case rest of
"" -> fail ("HTML omitted " <> name)
_ ->
pure
( replaceAll "&amp;" "&"
$ takeWhile (/= '"')
$ drop (length marker) rest
)
breakOn :: String -> String -> (String, String)
breakOn needle = go []
where
go prefix remaining
| needle `isPrefixOf` remaining = (reverse prefix, remaining)
go prefix [] = (reverse prefix, "")
go prefix (next : remaining) = go (next : prefix) remaining
isPrefixOf :: String -> String -> Bool
isPrefixOf prefix value =
take (length prefix) value == prefix
replaceAll :: String -> String -> String -> String
replaceAll needle replacement value =
case breakOn needle value of
(prefix, "") -> prefix
(prefix, rest) ->
prefix
<> replacement
<> replaceAll needle replacement (drop (length needle) rest)
optionalEnv :: String -> IO (Maybe String)
optionalEnv = lookupEnv

View file

@ -0,0 +1,136 @@
module Nuthatch.Probe.ProductClient
( browse
, deleteObject
, download
, downloadFrom
, sha256Hex
, upload
, uploadTo
) where
import Crypto.Hash (Digest, SHA256, hash)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
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.Oidc
import System.IO.Temp (withSystemTempFile)
import System.IO (hClose)
browse
:: ProbeContext
-> Session
-> String
-> IO CurlResponse
browse context session query =
curl
[ "--cookie", sessionCookies session
, "--header", "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
]
)
upload
:: ProbeContext
-> Session
-> String
-> 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
]
)
deleteObject
:: ProbeContext
-> Session
-> String
-> String
-> String
-> IO CurlResponse
deleteObject context session root path operationId =
curl
[ "--cookie", sessionCookies session
, "--header", "Content-Type: application/json"
, "--data"
, "{\"root\":\""
<> root
<> "\",\"path\":\""
<> path
<> "\",\"operation_id\":\""
<> operationId
<> "\",\"csrf\":\""
<> B8.unpack (sessionCsrf session)
<> "\"}"
, probeBase context <> "/api/delete"
]
sha256Hex :: BS.ByteString -> BS.ByteString
sha256Hex input =
B16.encode (BA.convert (hash input :: Digest SHA256))
encode :: String -> String
encode = B8.unpack . urlEncode True . Text.encodeUtf8 . Text.pack

373
test/ProductProbe.hs Normal file
View file

@ -0,0 +1,373 @@
module Main (main) where
import Data.Aeson (Value (..), eitherDecodeStrict')
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
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.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"
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)
putStrLn "Timed search bound passed"
verifyProduct :: ProbeContext -> Session -> IO ()
verifyProduct context session = do
verifyApplicationAssets context session
verifyPaginationAndSearch context session
verifyCanonicalPaths context session
verifySafeDownload context session
verifyRecursiveDelete context session
putStrLn "Product behavior passed"
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)
assertContains "session CSRF"
("\"csrf\":\"" <> sessionCsrf session <> "\"")
(curlBody sessionResponse)
application <- curl
[ "--cookie", sessionCookies session
, probeBase context <> "/app"
]
assertEqual "application status" 200 (curlStatus application)
csp <- maybe (fail "application omitted CSP") pure $
headerValue "content-security-policy" application
mapM_
(\directive ->
assertContains ("application CSP omitted " <> B8.unpack directive)
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)
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
mapM_
(\value ->
assert ("browser artifact exposed " <> value) $
not (B8.pack value `BS.isInfixOf` visible))
[ "NUTHATCH_S3"
, "AWS_ACCESS_KEY"
, "AWS_SECRET_ACCESS_KEY"
, "client_secret"
]
mapM_
(\marker ->
assertContains ("asset omitted " <> marker)
(B8.pack marker)
(curlBody javascript))
[ "Drop a file here"
, "Shared root"
, "Retry same upload"
, "Retry same delete"
, "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)
verifyPaginationAndSearch :: ProbeContext -> Session -> IO ()
verifyPaginationAndSearch context session = do
uploadSucceeded context session "product-browse/Alpha.txt"
"81000000-0000-4000-8000-000000000001" "alpha"
replay <- upload context session "personal" "product-browse/Alpha.txt"
"81000000-0000-4000-8000-000000000001" "alpha"
requireSucceeded "product upload replay" replay
uploadSucceeded context session "product-browse/beta.txt"
"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"
]
requireStatus "first browse page" 200 firstPage
assertContains "first page Alpha"
"\"path\":\"product-browse/Alpha.txt\""
(curlBody firstPage)
assertContains "first page beta"
"\"path\":\"product-browse/beta.txt\""
(curlBody 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"
]
assertContains "second browse page"
"\"path\":\"product-browse/gamma.txt\""
(curlBody secondPage)
mapM_
(\(path, operationId, body) ->
uploadSucceeded context session path operationId body)
[ ("000-Needle-A.txt", "81000000-0000-4000-8000-000000000004", "one")
, ("001-needle-b.txt", "81000000-0000-4000-8000-000000000005", "two")
, ("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"
]
mapM_
(\value -> assertContains "bounded case-insensitive search" value (curlBody 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)
verifyCanonicalPaths :: ProbeContext -> Session -> IO ()
verifyCanonicalPaths context session = do
mapM_
(\url -> curl ["--cookie", sessionCookies 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
<> "/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
<> "/api/download?root=personal&path=encoded%252Fname.txt"
]
assertEqual "encoded path body" "encoded" (curlBody 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)
assertContains "Unicode filename"
"filename*=UTF-8''caf%C3%A9.txt"
(maybe BS.empty id (headerValue "content-disposition" unicode))
verifySafeDownload :: ProbeContext -> Session -> IO ()
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"
]
requireStatus "unsupported range" 416 ranged
assertContains "range error"
"\"error\":\"range_not_supported\""
(curlBody ranged)
downloaded <- download context session "personal" "active.svg"
requireStatus "safe download" 200 downloaded
let disposition =
maybe BS.empty id (headerValue "content-disposition" downloaded)
assertContains "download attachment" "attachment;" disposition
assertContains "download filename" "filename*=UTF-8''active.svg" disposition
assertEqual "download nosniff"
(Just "nosniff")
(headerValue "x-content-type-options" downloaded)
assertContains "download sandbox"
"sandbox"
(maybe BS.empty id (headerValue "content-security-policy" downloaded))
assertEqual "download body" svg (curlBody downloaded)
verifyRecursiveDelete :: ProbeContext -> Session -> IO ()
verifyRecursiveDelete context session = do
mapM_
(\(path, operationId, body) ->
uploadSucceeded context session path operationId body)
[ ("delete-tree/a.txt", "81000000-0000-4000-8000-000000000010", "a")
, ("delete-tree/b.txt", "81000000-0000-4000-8000-000000000011", "b")
, ("delete-tree/c.txt", "81000000-0000-4000-8000-000000000012", "c")
]
planned <- deletePlan context session
assertContains "first delete plan"
"\"paths\":[\"delete-tree/a.txt\",\"delete-tree/b.txt\"]"
(curlBody planned)
assert "first delete plan omitted continuation" $
not ("\"continuation\":null" `BS.isInfixOf` curlBody planned)
let firstBatch =
"{\"root\":\"personal\",\"csrf\":\""
<> B8.unpack (sessionCsrf session)
<> "\",\"items\":["
<> "{\"path\":\"delete-tree/a.txt\",\"operation_id\":"
<> "\"82000000-0000-4000-8000-000000000001\"},"
<> "{\"path\":\"delete-tree/b.txt\",\"operation_id\":"
<> "\"82000000-0000-4000-8000-000000000002\"}]}"
first <- deleteBatch context session firstBatch
requireBatchSucceeded "first delete batch" first
replay <- deleteBatch context session firstBatch
requireBatchSucceeded "delete batch replay" replay
uploadSucceeded context session "delete-tree/d-concurrent.txt"
"81000000-0000-4000-8000-000000000013" "d"
restarted <- deletePlan context session
assertContains "restarted delete plan"
"\"paths\":[\"delete-tree/c.txt\",\"delete-tree/d-concurrent.txt\"]"
(curlBody restarted)
let secondBatch =
"{\"root\":\"personal\",\"csrf\":\""
<> B8.unpack (sessionCsrf session)
<> "\",\"items\":["
<> "{\"path\":\"delete-tree/c.txt\",\"operation_id\":"
<> "\"82000000-0000-4000-8000-000000000003\"},"
<> "{\"path\":\"delete-tree/d-concurrent.txt\",\"operation_id\":"
<> "\"82000000-0000-4000-8000-000000000004\"}]}"
second <- deleteBatch context session secondBatch
requireBatchSucceeded "second delete batch" second
empty <- deletePlan context session
assertContains "empty delete plan" "\"paths\":[]" (curlBody empty)
assertContains "empty delete continuation"
"\"continuation\":null"
(curlBody empty)
deletePlan :: ProbeContext -> Session -> IO CurlResponse
deletePlan context session =
curl
[ "--get"
, "--cookie", sessionCookies session
, "--data-urlencode", "root=personal"
, "--data-urlencode", "path=delete-tree"
, probeBase context <> "/api/delete-plan"
]
deleteBatch
:: ProbeContext
-> Session
-> String
-> IO CurlResponse
deleteBatch context session body =
curl
[ "--cookie", sessionCookies session
, "--header", "Content-Type: application/json"
, "--data", body
, probeBase context <> "/api/delete-batch"
]
requireBatchSucceeded :: String -> CurlResponse -> IO ()
requireBatchSucceeded label response = do
requireStatus label 200 response
assertEqual label 2 $
countOccurrences "\"result\":\"succeeded\"" (curlBody response)
uploadSucceeded
:: ProbeContext
-> Session
-> String
-> String
-> BS.ByteString
-> IO ()
uploadSucceeded context session path operationId body =
upload context session "personal" path operationId body >>=
requireSucceeded ("upload " <> path)
requireSucceeded :: String -> CurlResponse -> IO ()
requireSucceeded label response = do
requireStatus label 200 response
assertContains label "\"result\":\"succeeded\"" (curlBody response)
requireStatus :: String -> Int -> CurlResponse -> IO ()
requireStatus label expected response =
assertEqual (label <> " status") expected (curlStatus response)
stringField :: String -> BS.ByteString -> IO String
stringField name bytes =
case eitherDecodeStrict' bytes of
Right (Object object) ->
case KeyMap.lookup (Key.fromString name) object of
Just (String value) -> pure (Text.unpack value)
_ -> fail ("JSON omitted string field " <> name)
Right _ -> fail "expected JSON object"
Left reason -> fail ("invalid JSON: " <> reason)
between :: String -> String -> String -> IO String
between start end value =
case dropUntil start value of
Nothing -> fail ("value omitted " <> start)
Just afterStart ->
case takeUntil end afterStart of
Nothing -> fail ("value omitted " <> end)
Just result -> pure result
dropUntil :: String -> String -> Maybe String
dropUntil needle value
| needle `prefixOf` value = Just (drop (length needle) value)
dropUntil _ [] = Nothing
dropUntil needle (_ : rest) = dropUntil needle rest
takeUntil :: String -> String -> Maybe String
takeUntil needle = go []
where
go prefix value
| needle `prefixOf` value = Just (reverse prefix)
go _ [] = Nothing
go prefix (next : rest) = go (next : prefix) rest
prefixOf :: String -> String -> Bool
prefixOf prefix value =
take (length prefix) value == prefix
countOccurrences :: BS.ByteString -> BS.ByteString -> Int
countOccurrences needle input
| BS.null input = 0
| needle `BS.isPrefixOf` input =
1 + countOccurrences needle (BS.drop (BS.length needle) input)
| otherwise = countOccurrences needle (BS.drop 1 input)

View file

@ -6,6 +6,12 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.Text (Text)
import qualified Data.Text as T
import Database.PostgreSQL.Simple
( FromRow
, Only (..)
, Query
, ToRow
)
import Nuthatch.App (newEnv)
import Nuthatch.Config
import Nuthatch.Db
@ -16,19 +22,112 @@ import Nuthatch.Redis
import Nuthatch.S3
import Nuthatch.Types
import Servant.Types.SourceT
import System.Environment (getEnv)
import System.Environment (getArgs, getEnv)
import System.IO (BufferMode (LineBuffering), hSetBuffering, stdout)
import Text.Read (readMaybe)
main :: IO ()
main = do
hSetBuffering stdout LineBuffering
cfg <- loadConfig
phase <- getEnv "NUTHATCH_RECOVERY_PHASE"
withDb cfg $ \database -> do
migrate database "sql" cfg
withRedis cfg $ \redis -> do
store <- newS3 cfg
runPhase cfg database redis store phase
getArgs >>= \case
[] -> getEnv "NUTHATCH_RECOVERY_PHASE" >>=
runPhase cfg database redis store
["wait-phase", operation, expected] ->
waitForPhase database operation expected
["terminal", operation, expected] ->
verifyTerminal database operation expected
["active", operation, expectedReservation] ->
maybe
(fail "invalid expected reservation")
(verifyActive database operation)
(readMaybe expectedReservation)
["object", expectation, key] ->
verifyObject store expectation (ObjectKey (T.pack key))
["cache-invalidated"] ->
cacheGet redis "nuthatch:list:recovery-user:shared::" >>=
requireEqual "cache invalidation" Nothing
["database-available"] ->
waitForQuery database "SELECT 1" ((), Only (1 :: Int))
["log-exhausted"] -> do
logBytes <- BS.readFile "/run/nuthatch-recovery/app.log"
unless ("\"result\":\"exhausted\"" `BS.isInfixOf` logBytes) $
fail "recovery log omitted exhausted retry result"
_ -> fail "unknown recovery probe mode"
waitForPhase :: Db -> String -> String -> IO ()
waitForPhase database operation expected =
waitForQuery database
"SELECT state || ':' || external_state FROM mutations WHERE operation_id = ?"
(Only (T.pack operation), Only (T.pack expected))
verifyTerminal :: Db -> String -> String -> IO ()
verifyTerminal database operation expected = do
waitForQuery database
"SELECT state FROM mutations WHERE operation_id = ?"
(Only (T.pack operation), Only (T.pack expected))
locks <- Db.query database
"SELECT count(*) FROM key_locks WHERE operation_id = ?"
(Only (T.pack operation))
:: IO [Only Int]
requireEqual "terminal key lock" [Only 0] locks
reservations <- Db.query database
"SELECT reserved_bytes FROM pools WHERE pool_id = 'shared'"
()
:: IO [Only Integer]
requireEqual "terminal reservation" [Only 0] reservations
verifyActive :: Db -> String -> Integer -> IO ()
verifyActive database operation expectedReservation = do
locks <- Db.query database
"SELECT count(*) FROM key_locks WHERE operation_id = ?"
(Only (T.pack operation))
:: IO [Only Int]
requireEqual "active key lock" [Only 1] locks
reservations <- Db.query database
"SELECT reserved_bytes FROM pools WHERE pool_id = 'shared'"
()
:: IO [Only Integer]
requireEqual "active reservation"
[Only expectedReservation]
reservations
verifyObject :: S3 -> String -> ObjectKey -> IO ()
verifyObject store expectation key = do
observed <- headObject store key
case (expectation, observed) of
("present", Right (Just _)) -> pure ()
("absent", Right Nothing) -> pure ()
_ -> fail
("object expectation failed: " <> expectation <> " " <> show observed)
waitForQuery
:: (Eq row, Show row, ToRow parameters, FromRow row)
=> Db
-> Query
-> (parameters, row)
-> IO ()
waitForQuery database queryText (parameters, expected) =
go (120 :: Int)
where
go remaining = do
rows <- Db.query database queryText parameters
if rows == [expected]
then pure ()
else
if remaining <= 1
then fail
("timed out waiting for database value: " <> show rows)
else threadDelay 250000 >> go (remaining - 1)
requireEqual :: (Eq value, Show value) => String -> value -> value -> IO ()
requireEqual label expected actual =
unless (actual == expected) $
fail (label <> ": expected " <> show expected <> ", got " <> show actual)
runPhase :: Config -> Db -> Redis -> S3 -> String -> IO ()
runPhase cfg database redis store phase =

108
test/RuntimeAuditProbe.hs Normal file
View file

@ -0,0 +1,108 @@
module Main (main) where
import Data.Aeson (Value (..), eitherDecodeStrict')
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import Data.List (nub)
import Data.Maybe (mapMaybe)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Nuthatch.Probe.Assert
import System.Environment (lookupEnv)
main :: IO ()
main = do
logBytes <- BS.readFile "/run/nuthatch-runtime/app.log"
let auditLines =
filter (BS.isPrefixOf "{") (B8.lines logBytes)
records <- traverse decodeRecord auditLines
assert "runtime audit log is empty" (not (null records))
mapM_ verifyRequiredFields records
mapM_ (requireAction records)
["authentication", "login", "logout", "authorization", "put", "delete"]
verifyMutationFields records
verifyNoProhibitedData logBytes
putStrLn "Runtime audit structure and redaction passed"
decodeRecord :: BS.ByteString -> IO (KeyMap.KeyMap Value)
decodeRecord bytes =
case eitherDecodeStrict' bytes of
Right (Object object) -> pure object
Right _ -> fail "runtime audit record is not an object"
Left reason -> fail ("invalid runtime audit JSON: " <> reason)
verifyRequiredFields :: KeyMap.KeyMap Value -> IO ()
verifyRequiredFields record =
mapM_
(\name ->
assert ("runtime audit record omitted " <> name) $
KeyMap.member (Key.fromString name) record)
["ts", "action", "result"]
requireAction :: [KeyMap.KeyMap Value] -> String -> IO ()
requireAction records expected =
assert ("runtime audit omitted action " <> expected) $
any ((== Just expected) . textField "action") records
verifyMutationFields :: [KeyMap.KeyMap Value] -> IO ()
verifyMutationFields records = do
let puts = filter ((== Just "put") . textField "action") records
mutations =
filter
(\record ->
textField "action" record `elem` [Just "put", Just "delete"])
records
failed =
filter ((/= Just "ok") . textField "result") mutations
assert "runtime audit omitted put records" (not (null puts))
mapM_
(\record ->
mapM_
(\name ->
assert ("put audit omitted " <> name) $
KeyMap.member (Key.fromString name) record)
["user_id", "root", "bytes"])
puts
assert "runtime audit omitted failed mutations" (not (null failed))
mapM_
(\record ->
assert "failed mutation audit omitted reason" $
KeyMap.member "reason" record)
failed
verifyNoProhibitedData :: BS.ByteString -> IO ()
verifyNoProhibitedData logBytes = do
let folded = Text.toCaseFold (Text.decodeUtf8 logBytes)
mapM_
(\value ->
assert ("runtime log exposed prohibited value " <> value) $
Text.toCaseFold (Text.pack value) `Text.isInfixOf` folded == False)
[ "Bearer "
, "\"authorization\":"
, "client_secret"
, "NUTHATCH_"
, "private-a"
, "runtime-coherence"
, "first-personal"
, "second-personal"
]
configured <- mapMaybe id <$> traverse lookupEnv
[ "NUTHATCH_JWT_SECRET"
, "NUTHATCH_PG_CONN"
, "NUTHATCH_S3_ACCESS_KEY"
, "NUTHATCH_S3_SECRET_KEY"
, "NUTHATCH_OIDC_CLIENT_SECRET"
]
mapM_
(\value ->
assert "runtime log exposed a configured secret" $
not (B8.pack value `BS.isInfixOf` logBytes))
(filter (not . null) (nub configured))
textField :: String -> KeyMap.KeyMap Value -> Maybe String
textField name record =
case KeyMap.lookup (Key.fromString name) record of
Just (String value) -> Just (Text.unpack value)
_ -> Nothing

189
test/RuntimeHttpProbe.hs Normal file
View file

@ -0,0 +1,189 @@
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)

386
test/StreamingProbe.hs Normal file
View file

@ -0,0 +1,386 @@
module Main (main) where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently)
import Control.Exception (SomeException, try)
import Control.Monad (replicateM_, unless)
import Crypto.Hash
( Digest
, SHA256
, hashFinalize
, hashInit
, hashUpdate
)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as B8
import System.Directory (getFileSize)
import System.Environment (getArgs)
import System.Exit (ExitCode (..))
import System.IO
( IOMode (..)
, hClose
, withBinaryFile
)
import System.IO.Temp
( withSystemTempDirectory
, withSystemTempFile
)
import System.Process (readProcessWithExitCode)
import Text.Read (readMaybe)
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
import Nuthatch.Probe.Oidc
import Nuthatch.Probe.ProductClient
main :: IO ()
main =
withSystemTempDirectory "nuthatch-streaming-probe" $ \directory -> do
context <- newProbeContext directory
user <- requireEnv "NUTHATCH_OIDC_USER_A"
session <- login context False user "streaming-a"
getArgs >>= \case
["large"] -> verifyLarge context session directory
["throttle"] -> verifyThrottle context session directory
["refill"] -> verifyRefill context session directory
["unavailable"] -> verifyUnavailable context session
_ -> fail "expected large, throttle, refill, or unavailable mode"
verifyLarge :: ProbeContext -> Session -> FilePath -> IO ()
verifyLarge context session directory = do
largeBytes <- readEnvInteger "NUTHATCH_STREAMING_LARGE_BYTES"
overLimit <- readEnvInteger "NUTHATCH_STREAMING_OVER_LIMIT_BYTES"
let largePath = directory <> "/large.bin"
downloadPath = directory <> "/large-download.bin"
writeZeros largePath largeBytes
largeDigest <- hashFile largePath
uploaded <- uploadFileDeclared
context session "streaming-large.bin"
"70000000-0000-4000-8000-000000000001"
largeBytes largeDigest largePath []
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)
hashFile downloadPath >>= assertEqual "large download digest" largeDigest
let tiny = "x"
mapM_
(\label -> do
replay <- uploadBytesDeclared
context session "streaming-large.bin"
"70000000-0000-4000-8000-000000000007"
largeBytes largeDigest tiny []
requireSucceeded ("prior/desired observation " <> label) replay)
["first", "replay"]
sizeMismatch <- uploadBytesDeclared
context session "size-mismatch.bin"
"70000000-0000-4000-8000-000000000002"
2 (sha256Hex tiny) tiny []
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 []
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"]
requireError "object size limit" 413 "object_too_large" tooLarge
aborted <- interruptedUpload
context session "aborted-upload.bin"
"70000000-0000-4000-8000-000000000005"
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)
replayAfterAbort <- uploadBytesDeclared
context session "aborted-upload.bin"
"70000000-0000-4000-8000-000000000005"
largeBytes largeDigest tiny []
assertEqual "aborted upload replay status" 200 (curlStatus replayAfterAbort)
assert "aborted upload replay lost active or failed identity" $
any (`BS.isInfixOf` curlBody replayAfterAbort)
["\"result\":\"pending\"", "\"result\":\"failed\""]
abortedOverwrite <- interruptedUpload
context session "streaming-large.bin"
"70000000-0000-4000-8000-000000000006"
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)
hashFile preservedPath >>= assertEqual "preserved object digest" largeDigest
let partialPath = directory <> "/partial-download.bin"
partial <- interruptedDownload context session partialPath
assert "aborted download unexpectedly completed" (not partial)
partialBytes <- getFileSize partialPath
assert "aborted download emitted no bytes" (partialBytes > 0)
assert "aborted download emitted the complete object" $
partialBytes < largeBytes
ready <- curl [probeBase context <> "/readyz"]
requireStatus "readiness after aborts" 200 ready
assertContains "readiness after aborts" "\"ready\":true" (curlBody ready)
putStrLn "Large streaming and abort behavior passed"
verifyThrottle :: ProbeContext -> Session -> FilePath -> IO ()
verifyThrottle context session directory = do
userB <- requireEnv "NUTHATCH_OIDC_USER_B"
sessionB <- login context False userB "streaming-b"
let jointPath = directory <> "/joint-upload.bin"
throttlePath = directory <> "/throttle-upload.bin"
writeZeros jointPath 65536
jointDigest <- hashFile jointPath
joint <- uploadFileDeclared
context session "joint-throttle.bin"
"70000000-0000-4000-8000-000000000013"
65536 jointDigest jointPath []
requireSucceeded "joint throttle setup" joint
writeZeros throttlePath 1048576
uploadDigest <- hashFile throttlePath
throttled <- uploadFileDeclared
context sessionB "throttled-upload.bin"
"71000000-0000-4000-8000-000000000001"
1048576 uploadDigest throttlePath []
requireError "incremental upload throttle"
429 "bandwidth_exceeded" throttled
prestart <- uploadBytesDeclared
context sessionB "prestart.bin"
"71000000-0000-4000-8000-000000000002"
1 uploadDigest "x" []
assertEqual "pre-start upload throttle" 429 (curlStatus 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)
(first, second) <- concurrently (downloadTo firstPath) (downloadTo secondPath)
assert "first throttled download completed" (isLeft first)
assert "second throttled download completed" (isLeft second)
firstBytes <- getFileSize firstPath
secondBytes <- getFileSize secondPath
burst <- readEnvInteger "NUTHATCH_STREAMING_THROTTLE_BURST_BYTES"
let moved = firstBytes + secondBytes
jointLimit = burst - 65536 + 4096
assert "parallel throttled downloads emitted no bytes" (moved > 0)
assert "parallel downloads exceeded their joint token budget" $
moved <= jointLimit
exhausted <- download context session "personal" "streaming-large.bin"
requireStatus "post-exhaustion download" 429 exhausted
putStrLn "Shared incremental throttle behavior passed"
verifyRefill :: ProbeContext -> Session -> FilePath -> IO ()
verifyRefill context session directory = do
let bodyPath = directory <> "/refill-upload.bin"
writeZeros bodyPath 65536
digest <- hashFile bodyPath
initial <- uploadFileDeclared
context session "refill-initial.bin"
"72000000-0000-4000-8000-000000000001"
65536 digest bodyPath []
requireSucceeded "initial token use" initial
exhausted <- uploadFileDeclared
context session "refill-exhausted.bin"
"72000000-0000-4000-8000-000000000003"
65536 digest bodyPath []
requireStatus "exhausted token bucket" 429 exhausted
threadDelay 2000000
refilled <- uploadFileDeclared
context session "refill-refilled.bin"
"72000000-0000-4000-8000-000000000002"
65536 digest bodyPath []
requireSucceeded "refilled token bucket" refilled
putStrLn "Token-bucket refill behavior passed"
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)
let path =
if "cross-user.txt" `BS.isInfixOf` curlBody 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)
unavailableUpload <- upload context session "personal" "unavailable.bin"
"72000000-0000-4000-8000-000000000001" "x"
requireError "upload without Redis"
503 "throttle_unavailable" unavailableUpload
unavailableDownload <-
retryTransport 4 (download context session "personal" path)
requireError "download without Redis"
503 "throttle_unavailable" unavailableDownload
putStrLn "Redis-unavailable transfer behavior passed"
retryTransport :: Int -> IO value -> IO value
retryTransport attempts action = do
result <- try action
case result of
Right value -> pure value
Left exception
| attempts > 1 -> do
threadDelay 100000
retryTransport (attempts - 1) action
| otherwise -> fail (show (exception :: SomeException))
uploadFileDeclared
:: ProbeContext
-> Session
-> String
-> String
-> 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]
)
uploadBytesDeclared
:: ProbeContext
-> Session
-> String
-> String
-> 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
uploadArguments
:: ProbeContext
-> Session
-> String
-> 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
]
interruptedUpload
:: ProbeContext
-> Session
-> String
-> String
-> Integer
-> BS.ByteString
-> FilePath
-> IO Bool
interruptedUpload context session path operationId size digest bodyPath = do
let arguments =
[ "--insecure"
, "--silent"
, "--show-error"
, "--max-time", "1"
, "--limit-rate", "64k"
, "--request", "POST"
, "--upload-file", bodyPath
]
<> uploadArguments context session path operationId size digest
(exitCode, _, _) <- readProcessWithExitCode "curl" arguments ""
pure (exitCode == ExitSuccess)
interruptedDownload
:: ProbeContext
-> Session
-> FilePath
-> IO Bool
interruptedDownload context session outputPath = do
let arguments =
[ "--insecure"
, "--silent"
, "--show-error"
, "--max-time", "1"
, "--limit-rate", "64k"
, "--cookie", sessionCookies session
, "--output", outputPath
, probeBase context
<> "/api/download?root=personal&path=streaming-large.bin"
]
(exitCode, _, _) <- readProcessWithExitCode "curl" arguments ""
pure (exitCode == ExitSuccess)
writeZeros :: FilePath -> Integer -> IO ()
writeZeros path byteCount =
withBinaryFile path WriteMode $ \handle -> do
let chunk = BS.replicate 1048576 0
(fullChunks, remainder) = byteCount `divMod` 1048576
replicateM_ (fromIntegral fullChunks) (BS.hPut handle chunk)
unless (remainder == 0) $
BS.hPut handle (BS.take (fromIntegral remainder) chunk)
hashFile :: FilePath -> IO BS.ByteString
hashFile path =
withBinaryFile path ReadMode $ \handle ->
go handle hashInit
where
go handle context = do
chunk <- BS.hGetSome handle 1048576
if BS.null chunk
then
pure
(B16.encode
(BA.convert (hashFinalize context :: Digest SHA256)))
else do
let updated = hashUpdate context chunk
updated `seq` go handle updated
readEnvInteger :: String -> IO Integer
readEnvInteger name = do
value <- requireEnv name
maybe (fail ("invalid " <> name)) pure (readMaybe value)
requireSucceeded :: String -> CurlResponse -> IO ()
requireSucceeded label response = do
requireStatus label 200 response
assertContains label "\"result\":\"succeeded\"" (curlBody response)
requireError :: String -> Int -> BS.ByteString -> CurlResponse -> IO ()
requireError label status code response = do
requireStatus label status response
assertContains label ("\"error\":\"" <> code <> "\"") (curlBody response)
requireStatus :: String -> Int -> CurlResponse -> IO ()
requireStatus label expected response =
assertEqual (label <> " status") expected (curlStatus response)
isLeft :: Either left right -> Bool
isLeft (Left _) = True
isLeft (Right _) = False

View file

@ -9,7 +9,6 @@ if ! git diff --quiet || ! git diff --cached --quiet || [[ -n "$(git ls-files --
fi
unset NUTHATCH_APP_INTERACTIVE
unset NUTHATCH_PRODUCT_GATE
unset NUTHATCH_STREAMING_LANE
unset NUTHATCH_STREAMING_FIRST_LANE_ONLY
unset NUTHATCH_IDEMPOTENCY_LANE

View file

@ -0,0 +1,47 @@
apiVersion: batch/v1
kind: Job
metadata:
name: @@JOB_NAME@@
namespace: nuthatch-testbed
spec:
activeDeadlineSeconds: @@DEADLINE_SECONDS@@
backoffLimit: 0
ttlSecondsAfterFinished: 300
template:
spec:
automountServiceAccountToken: false
enableServiceLinks: false
dnsPolicy: None
dnsConfig:
nameservers: [10.96.0.53]
searches:
- nuthatch-testbed.svc.cluster.local
- svc.cluster.local
- cluster.local
options:
- {name: ndots, value: "5"}
restartPolicy: Never
containers:
- name: @@COMPONENT@@-probe
image: @@TEST_IMAGE@@
imagePullPolicy: Never
command: [@@PROBE@@]
args: [@@PROBE_ARGS@@]
envFrom:
- configMapRef: {name: @@PROFILE_NAME@@}
env:
- name: GHCRTS
value: "-N2 -A1m -M192m"
- name: NUTHATCH_OIDC_CLIENT_SECRET
valueFrom:
secretKeyRef:
name: nuthatch-@@LANE@@
key: NUTHATCH_OIDC_CLIENT_SECRET
- name: NUTHATCH_OIDC_LOGIN_PAT
valueFrom:
secretKeyRef:
name: nuthatch-oidc-automation-@@LANE@@
key: NUTHATCH_OIDC_LOGIN_PAT
resources:
requests: {cpu: 50m, memory: 32Mi}
limits: {cpu: "1", memory: 256Mi}

Some files were not shown because too many files have changed in this diff Show more