Split kind tests into component-owned probes

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

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

docs/spec/contracts.md

@@ -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;
+Kubernetes manifest supplies the scoped credential through the secret boundary.
-`tests/kind/lib.sh` provisions equivalent fixture principals, and
+`tests/kind/fixture/target.sh` provisions equivalent fixture principals, and
-`tests/kind/product-matrix-job.yaml.in` verifies denial against a different
+`test/AuthProbe.hs` verifies denial against a different bucket.
-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

docs/spec/testing.md

@@ -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
+`make check-dependencies` creates the complete fixture, runs the Haskell
-dependency image through its product interface, and destroys the fixture.
+dependency probe against each released product interface, and destroys the
-`make check-kind-matrix` runs a fixture-consumer Job sequentially across 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.

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

test/AuthProbe.hs

@@ -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)

test/DependencyProbe.hs

@@ -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

test/FixtureProbe.hs

@@ -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))

test/IdempotencyProbe.hs

@@ -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\"}}"
+    ]

test/Nuthatch/Probe/Assert.hs

@@ -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

test/Nuthatch/Probe/Curl.hs

@@ -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

test/Nuthatch/Probe/Oidc.hs

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

test/Nuthatch/Probe/ProductClient.hs

@@ -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

test/ProductProbe.hs

@@ -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)

test/RecoveryPhase.hs

@@ -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 =

test/RuntimeAuditProbe.hs

@@ -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

test/RuntimeHttpProbe.hs

@@ -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)

test/StreamingProbe.hs

@@ -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

tests/check-v1.sh

@@ -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

tests/kind/application-probe-job.yaml.in

@@ -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}