Type ordinary integration probe HTTP traffic

2026-07-20 23:06:01 +09:00 · 2026-07-20 23:06:01 +09:00 · cc5c47f2ce
commit cc5c47f2ce
parent 390434bed1
1 changed files with 1022 additions and 661 deletions
--- a/test/ProductProbe.hs
+++ b/test/ProductProbe.hs
@ -7,34 +7,33 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.Text as Text
 import           Nuthatch.Probe.Assert
-import           Nuthatch.Probe.Curl
+import           Nuthatch.Probe.Http
 import           Nuthatch.Probe.Oidc
 import           Nuthatch.Probe.ProductClient
 import           System.Environment (getArgs)
-import           System.IO.Temp (withSystemTempDirectory)

 main :: IO ()
-main =
-  withSystemTempDirectory "nuthatch-product-probe" $ \directory -> do
-    context <- newProbeContext directory
-    user <- requireEnv "NUTHATCH_OIDC_USER_A"
-    session <- login context False user "product"
-    getArgs >>= \case
-      ["verify"] -> verifyProduct context session
-      ["timeout"] -> verifyTimeout context session
-      _ -> fail "expected verify or timeout mode"
+main = do
+  context <- newProbeContext
+  user <- requireEnv "NUTHATCH_OIDC_USER_A"
+  session <- login context False user "product"
+  getArgs >>= \case
+    ["verify"] -> verifyProduct context session
+    ["timeout"] -> verifyTimeout context session
+    _ -> fail "expected verify or timeout mode"

 verifyTimeout :: ProbeContext -> Session -> IO ()
 verifyTimeout context session = do
-  response <- curl
-    [ "--get"
-    , "--cookie", sessionCookies session
-    , "--data-urlencode", "root=personal"
-    , "--data-urlencode", "q=timeout-probe"
-    , probeBase context <> "/api/browse"
-    ]
-  assertEqual "timed search status" 200 (curlStatus response)
-  assertContains "timed search bound" "\"partial\":true" (curlBody response)
+  response <- authenticatedGetWith context session
+    defaultRequestOptions
+      { optionQuery =
+          [ ("root", Just "personal")
+          , ("q", Just "timeout-probe")
+          ]
+      }
+    (probeBase context <> "/api/browse")
+  assertEqual "timed search status" 200 (probeStatus response)
+  assertContains "timed search bound" "\"partial\":true" (probeBody response)
  putStrLn "Timed search bound passed"

 verifyProduct :: ProbeContext -> Session -> IO ()
@ -48,20 +47,15 @@ verifyProduct context session = do

 verifyApplicationAssets :: ProbeContext -> Session -> IO ()
 verifyApplicationAssets context session = do
-  sessionResponse <- curl
-    [ "--cookie", sessionCookies session
-    , probeBase context <> "/api/session"
-    ]
-  assertEqual "session endpoint status" 200 (curlStatus sessionResponse)
-  assertContains "session user" "\"user_id\":" (curlBody sessionResponse)
+  sessionResponse <- authenticatedGet context session
+    (probeBase context <> "/api/session")
+  assertEqual "session endpoint status" 200 (probeStatus sessionResponse)
+  assertContains "session user" "\"user_id\":" (probeBody sessionResponse)
  assertContains "session CSRF"
    ("\"csrf\":\"" <> sessionCsrf session <> "\"")
-    (curlBody sessionResponse)
-  application <- curl
-    [ "--cookie", sessionCookies session
-    , probeBase context <> "/app"
-    ]
-  assertEqual "application status" 200 (curlStatus application)
+    (probeBody sessionResponse)
+  application <- authenticatedGet context session (probeBase context <> "/app")
+  assertEqual "application status" 200 (probeStatus application)
  csp <- maybe (fail "application omitted CSP") pure $
    headerValue "content-security-policy" application
  mapM_
@ -70,18 +64,16 @@ verifyApplicationAssets context session = do
        directive
        csp)
    ["default-src 'none'", "script-src 'self'", "frame-ancestors 'none'"]
-  asset <- between "src=\"/assets/" "\"" (B8.unpack (curlBody application))
-  javascript <- curl
-    [ "--cookie", sessionCookies session
-    , probeBase context <> "/assets/" <> asset
-    ]
-  assertEqual "asset status" 200 (curlStatus javascript)
+  asset <- between "src=\"/assets/" "\"" (B8.unpack (probeBody application))
+  javascript <- authenticatedGet context session
+    (probeBase context <> "/assets/" <> asset)
+  assertEqual "asset status" 200 (probeStatus javascript)
  assertContains "asset content type" "javascript" $
    maybe BS.empty id (headerValue "content-type" javascript)
  assertEqual "asset nosniff"
    (Just "nosniff")
    (headerValue "x-content-type-options" javascript)
-  let visible = curlBody application <> curlBody javascript
+  let visible = probeBody application <> probeBody javascript
  mapM_
    (\value ->
      assert ("browser artifact exposed " <> value) $
@ -95,7 +87,7 @@ verifyApplicationAssets context session = do
    (\marker ->
      assertContains ("asset omitted " <> marker)
        (B8.pack marker)
-        (curlBody javascript))
+        (probeBody javascript))
    [ "Drop a file here"
    , "Shared root"
    , "Retry same upload"
@ -103,10 +95,12 @@ verifyApplicationAssets context session = do
    , "nuthatch-recursive-delete"
    , "URLSearchParams"
    ]
-  unauthenticatedApp <- curl [probeBase context <> "/app"]
-  assertEqual "unauthenticated application" 303 (curlStatus unauthenticatedApp)
-  unauthenticatedAsset <- curl [probeBase context <> "/assets/" <> asset]
-  assertEqual "unauthenticated asset" 303 (curlStatus unauthenticatedAsset)
+  unauthenticatedApp <- get (probeClient context) (probeBase context <> "/app")
+  assertEqual "unauthenticated application" 303 (probeStatus unauthenticatedApp)
+  unauthenticatedAsset <- get
+    (probeClient context)
+    (probeBase context <> "/assets/" <> asset)
+  assertEqual "unauthenticated asset" 303 (probeStatus unauthenticatedAsset)

 verifyPaginationAndSearch :: ProbeContext -> Session -> IO ()
 verifyPaginationAndSearch context session = do
@ -119,34 +113,36 @@ verifyPaginationAndSearch context session = do
    "81000000-0000-4000-8000-000000000002" "beta"
  uploadSucceeded context session "product-browse/gamma.txt"
    "81000000-0000-4000-8000-000000000003" "gamma"
-  firstPage <- curl
-    [ "--get"
-    , "--cookie", sessionCookies session
-    , "--data-urlencode", "root=personal"
-    , "--data-urlencode", "prefix=product-browse"
-    , probeBase context <> "/api/browse"
-    ]
+  firstPage <- authenticatedGetWith context session
+    defaultRequestOptions
+      { optionQuery =
+          [ ("root", Just "personal")
+          , ("prefix", Just "product-browse")
+          ]
+      }
+    (probeBase context <> "/api/browse")
  requireStatus "first browse page" 200 firstPage
  assertContains "first page Alpha"
    "\"path\":\"product-browse/Alpha.txt\""
-    (curlBody firstPage)
+    (probeBody firstPage)
  assertContains "first page beta"
    "\"path\":\"product-browse/beta.txt\""
-    (curlBody firstPage)
+    (probeBody firstPage)
  assert "first page exceeded configured size" $
-    not ("product-browse/gamma.txt" `BS.isInfixOf` curlBody firstPage)
-  continuation <- stringField "continuation" (curlBody firstPage)
-  secondPage <- curl
-    [ "--get"
-    , "--cookie", sessionCookies session
-    , "--data-urlencode", "root=personal"
-    , "--data-urlencode", "prefix=product-browse"
-    , "--data-urlencode", "continuation=" <> continuation
-    , probeBase context <> "/api/browse"
-    ]
+    not ("product-browse/gamma.txt" `BS.isInfixOf` probeBody firstPage)
+  continuation <- stringField "continuation" (probeBody firstPage)
+  secondPage <- authenticatedGetWith context session
+    defaultRequestOptions
+      { optionQuery =
+          [ ("root", Just "personal")
+          , ("prefix", Just "product-browse")
+          , ("continuation", Just (B8.pack continuation))
+          ]
+      }
+    (probeBase context <> "/api/browse")
  assertContains "second browse page"
    "\"path\":\"product-browse/gamma.txt\""
-    (curlBody secondPage)
+    (probeBody secondPage)
  mapM_
    (\(path, operationId, body) ->
      uploadSucceeded context session path operationId body)
@ -155,49 +151,48 @@ verifyPaginationAndSearch context session = do
    , ("002-filler.txt", "81000000-0000-4000-8000-000000000006", "three")
    , ("003-needle-after-bound.txt", "81000000-0000-4000-8000-000000000007", "four")
    ]
-  searched <- curl
-    [ "--get"
-    , "--cookie", sessionCookies session
-    , "--data-urlencode", "root=personal"
-    , "--data-urlencode", "q=NEEDLE"
-    , probeBase context <> "/api/browse"
-    ]
+  searched <- authenticatedGetWith context session
+    defaultRequestOptions
+      { optionQuery =
+          [ ("root", Just "personal")
+          , ("q", Just "NEEDLE")
+          ]
+      }
+    (probeBase context <> "/api/browse")
  mapM_
-    (\value -> assertContains "bounded case-insensitive search" value (curlBody searched))
+    (\value -> assertContains "bounded case-insensitive search" value (probeBody searched))
    [ "\"path\":\"000-Needle-A.txt\""
    , "\"path\":\"001-needle-b.txt\""
    , "\"partial\":true"
    ]
  assert "search crossed the configured scan bound" $
-    not ("003-needle-after-bound.txt" `BS.isInfixOf` curlBody searched)
+    not ("003-needle-after-bound.txt" `BS.isInfixOf` probeBody searched)

 verifyCanonicalPaths :: ProbeContext -> Session -> IO ()
 verifyCanonicalPaths context session = do
  mapM_
-    (\url -> curl ["--cookie", sessionCookies session, url] >>=
+    (\url -> authenticatedGet context session url >>=
      requireStatus "non-canonical path" 400)
    [ probeBase context <> "/api/browse?root=Personal"
    , probeBase context <> "/api/browse?root=personal&prefix=a//b"
    , probeBase context <> "/api/download?root=personal&path=./file"
    ]
-  decomposed <- curl
-    [ "--cookie", sessionCookies session
-    , probeBase context
+  decomposed <- authenticatedGet context session
+    (probeBase context
      <> "/api/download?root=personal&path=cafe%CC%81.txt"
-    ]
+    )
  requireStatus "non-NFC path" 400 decomposed
  uploadSucceeded context session "encoded%2Fname.txt"
    "81000000-0000-4000-8000-000000000008" "encoded"
-  encoded <- curl
-    [ "--cookie", sessionCookies session
-    , probeBase context
+  encoded <- authenticatedGet context session
+    (probeBase context
      <> "/api/download?root=personal&path=encoded%252Fname.txt"
-    ]
-  assertEqual "encoded path body" "encoded" (curlBody encoded)
+    )
+  assertEqual "encoded path body" "encoded" (probeBody encoded)
  uploadSucceeded context session "café.txt"
    "81000000-0000-4000-8000-000000000014" "unicode"
  unicode <- download context session "personal" "café.txt"
-  assertEqual "Unicode path body" "unicode" (curlBody unicode)
+  assertEqual "Unicode path body" "unicode" (probeBody unicode)
  assertContains "Unicode filename"
    "filename*=UTF-8''caf%C3%A9.txt"
    (maybe BS.empty id (headerValue "content-disposition" unicode))
@ -207,15 +202,13 @@ verifySafeDownload context session = do
  let svg = "<svg onload=\"alert(1)\"></svg>"
  uploadSucceeded context session "active.svg"
    "81000000-0000-4000-8000-000000000009" svg
-  ranged <- curl
-    [ "--cookie", sessionCookies session
-    , "--header", "Range: bytes=0-1"
-    , probeBase context <> "/api/download?root=personal&path=active.svg"
-    ]
+  ranged <- authenticatedGetWith context session
+    defaultRequestOptions { optionHeaders = [("Range", "bytes=0-1")] }
+    (probeBase context <> "/api/download?root=personal&path=active.svg")
  requireStatus "unsupported range" 416 ranged
  assertContains "range error"
    "\"error\":\"range_not_supported\""
-    (curlBody ranged)
+    (probeBody ranged)
  downloaded <- download context session "personal" "active.svg"
  requireStatus "safe download" 200 downloaded
  let disposition =
@ -228,7 +221,7 @@ verifySafeDownload context session = do
  assertContains "download sandbox"
    "sandbox"
    (maybe BS.empty id (headerValue "content-security-policy" downloaded))
-  assertEqual "download body" svg (curlBody downloaded)
+  assertEqual "download body" svg (probeBody downloaded)

 verifyRecursiveDelete :: ProbeContext -> Session -> IO ()
 verifyRecursiveDelete context session = do
@ -242,9 +235,9 @@ verifyRecursiveDelete context session = do
  planned <- deletePlan context session
  assertContains "first delete plan"
    "\"paths\":[\"delete-tree/a.txt\",\"delete-tree/b.txt\"]"
-    (curlBody planned)
+    (probeBody planned)
  assert "first delete plan omitted continuation" $
-    not ("\"continuation\":null" `BS.isInfixOf` curlBody planned)
+    not ("\"continuation\":null" `BS.isInfixOf` probeBody planned)
  let firstBatch =
        "{\"root\":\"personal\",\"csrf\":\""
        <> B8.unpack (sessionCsrf session)
@ -262,7 +255,7 @@ verifyRecursiveDelete context session = do
  restarted <- deletePlan context session
  assertContains "restarted delete plan"
    "\"paths\":[\"delete-tree/c.txt\",\"delete-tree/d-concurrent.txt\"]"
-    (curlBody restarted)
+    (probeBody restarted)
  let secondBatch =
        "{\"root\":\"personal\",\"csrf\":\""
        <> B8.unpack (sessionCsrf session)
@ -274,39 +267,42 @@ verifyRecursiveDelete context session = do
  second <- deleteBatch context session secondBatch
  requireBatchSucceeded "second delete batch" second
  empty <- deletePlan context session
-  assertContains "empty delete plan" "\"paths\":[]" (curlBody empty)
+  assertContains "empty delete plan" "\"paths\":[]" (probeBody empty)
  assertContains "empty delete continuation"
    "\"continuation\":null"
-    (curlBody empty)
+    (probeBody empty)

-deletePlan :: ProbeContext -> Session -> IO CurlResponse
+deletePlan :: ProbeContext -> Session -> IO ProbeResponse
 deletePlan context session =
-  curl
-    [ "--get"
-    , "--cookie", sessionCookies session
-    , "--data-urlencode", "root=personal"
-    , "--data-urlencode", "path=delete-tree"
-    , probeBase context <> "/api/delete-plan"
-    ]
+  authenticatedGetWith context session
+    defaultRequestOptions
+      { optionQuery =
+          [ ("root", Just "personal")
+          , ("path", Just "delete-tree")
+          ]
+      }
+    (probeBase context <> "/api/delete-plan")

 deleteBatch
  :: ProbeContext
  -> Session
  -> String
-  -> IO CurlResponse
+  -> IO ProbeResponse
 deleteBatch context session body =
-  curl
-    [ "--cookie", sessionCookies session
-    , "--header", "Content-Type: application/json"
-    , "--data", body
-    , probeBase context <> "/api/delete-batch"
-    ]
+  postWith
+    (probeClient context)
+    defaultRequestOptions
+      { optionCookies = Just (sessionCookies session)
+      , optionHeaders = [("Content-Type", "application/json")]
+      , optionBody = ByteBody (B8.pack body)
+      }
+    (probeBase context <> "/api/delete-batch")

-requireBatchSucceeded :: String -> CurlResponse -> IO ()
+requireBatchSucceeded :: String -> ProbeResponse -> IO ()
 requireBatchSucceeded label response = do
  requireStatus label 200 response
  assertEqual label 2 $
-    countOccurrences "\"result\":\"succeeded\"" (curlBody response)
+    countOccurrences "\"result\":\"succeeded\"" (probeBody response)

 uploadSucceeded
  :: ProbeContext
@ -319,14 +315,33 @@ uploadSucceeded context session path operationId body =
  upload context session "personal" path operationId body >>=
    requireSucceeded ("upload " <> path)

-requireSucceeded :: String -> CurlResponse -> IO ()
+requireSucceeded :: String -> ProbeResponse -> IO ()
 requireSucceeded label response = do
  requireStatus label 200 response
-  assertContains label "\"result\":\"succeeded\"" (curlBody response)
+  assertContains label "\"result\":\"succeeded\"" (probeBody response)

-requireStatus :: String -> Int -> CurlResponse -> IO ()
+requireStatus :: String -> Int -> ProbeResponse -> IO ()
 requireStatus label expected response =
-  assertEqual (label <> " status") expected (curlStatus response)
+  assertEqual (label <> " status") expected (probeStatus response)
+
+authenticatedGet
+  :: ProbeContext
+  -> Session
+  -> String
+  -> IO ProbeResponse
+authenticatedGet context session =
+  authenticatedGetWith context session defaultRequestOptions
+
+authenticatedGetWith
+  :: ProbeContext
+  -> Session
+  -> RequestOptions
+  -> String
+  -> IO ProbeResponse
+authenticatedGetWith context session options =
+  getWith
+    (probeClient context)
+    options { optionCookies = Just (sessionCookies session) }

 stringField :: String -> BS.ByteString -> IO String
 stringField name bytes =