Split kind tests into component-owned probes
This commit is contained in:
parent
b3c0f6d58a
commit
691ad92e30
47 changed files with 4269 additions and 3108 deletions
20
Dockerfile
20
Dockerfile
|
|
@ -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
|
||||
|
|
|
|||
8
Makefile
8
Makefile
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
|
|
|||
165
nuthatch.cabal
165
nuthatch.cabal
|
|
@ -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
230
test/AuthProbe.hs
Normal 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
199
test/DependencyProbe.hs
Normal 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
81
test/FixtureProbe.hs
Normal 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
285
test/IdempotencyProbe.hs
Normal 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\"}}"
|
||||
]
|
||||
27
test/Nuthatch/Probe/Assert.hs
Normal file
27
test/Nuthatch/Probe/Assert.hs
Normal 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
125
test/Nuthatch/Probe/Curl.hs
Normal 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
399
test/Nuthatch/Probe/Oidc.hs
Normal 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 "&" "&"
|
||||
$ 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
|
||||
136
test/Nuthatch/Probe/ProductClient.hs
Normal file
136
test/Nuthatch/Probe/ProductClient.hs
Normal 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
373
test/ProductProbe.hs
Normal 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)
|
||||
|
|
@ -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
108
test/RuntimeAuditProbe.hs
Normal 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
189
test/RuntimeHttpProbe.hs
Normal 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
386
test/StreamingProbe.hs
Normal 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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
47
tests/kind/application-probe-job.yaml.in
Normal file
47
tests/kind/application-probe-job.yaml.in
Normal 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
Loading…
Reference in a new issue