ms2k/nuthatch
SHA256
Watch
0
Code Releases Activity

Type ordinary integration probe HTTP traffic

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

7
Dockerfile
View file

@ -49,7 +49,6 @@ RUN apt-get update \
&& apt-get install -y --no-install-recommends \ && apt-get install -y --no-install-recommends \
libpq5 \ libpq5 \
ca-certificates \ ca-certificates \
curl \
openssl \ openssl \
&& rm -rf /var/lib/apt/lists/* \ && rm -rf /var/lib/apt/lists/* \
&& groupadd --system --gid 10001 nuthatch \ && groupadd --system --gid 10001 nuthatch \
@ -62,6 +61,12 @@ USER 10001:10001
FROM runtime-base AS test-runtime FROM runtime-base AS test-runtime
USER root
RUN apt-get update \
&& apt-get install -y --no-install-recommends curl \
&& rm -rf /var/lib/apt/lists/*
USER 10001:10001
COPY --from=build /out/nuthatch /usr/local/bin/nuthatch COPY --from=build /out/nuthatch /usr/local/bin/nuthatch
COPY --from=build /out/nuthatch-storage-integration /usr/local/bin/nuthatch-storage-integration COPY --from=build /out/nuthatch-storage-integration /usr/local/bin/nuthatch-storage-integration
COPY --from=build /out/nuthatch-recovery-probe /usr/local/bin/nuthatch-recovery-probe COPY --from=build /out/nuthatch-recovery-probe /usr/local/bin/nuthatch-recovery-probe

12
nuthatch.cabal
View file

@ -57,6 +57,7 @@ common shared
, containers >= 0.6 && < 0.8 , containers >= 0.6 && < 0.8
, conduit >= 1.3 && < 1.4 , conduit >= 1.3 && < 1.4
, cookie >= 0.5.1 && < 0.6 , cookie >= 0.5.1 && < 0.6
, crypton-connection >= 0.4 && < 0.5
, crypton >= 0.34 && < 1.1 , crypton >= 0.34 && < 1.1
, directory >= 1.3 && < 1.4 , directory >= 1.3 && < 1.4
, entropy >= 0.4 && < 0.5 , entropy >= 0.4 && < 0.5
@ -88,6 +89,7 @@ common shared
, temporary >= 1.3 && < 1.4 , temporary >= 1.3 && < 1.4
, text >= 2.0 && < 2.2 , text >= 2.0 && < 2.2
, time >= 1.12 && < 1.15 , time >= 1.12 && < 1.15
, tls >= 2.2 && < 2.3
, transformers >= 0.6 && < 0.7 , transformers >= 0.6 && < 0.7
, unicode-transforms >= 0.4 && < 0.5 , unicode-transforms >= 0.4 && < 0.5
, unordered-containers >= 0.2 && < 0.3 , unordered-containers >= 0.2 && < 0.3
@ -242,6 +244,7 @@ executable nuthatch-auth-probe
other-modules: other-modules:
Nuthatch.Probe.Assert Nuthatch.Probe.Assert
Nuthatch.Probe.Curl Nuthatch.Probe.Curl
Nuthatch.Probe.Http
Nuthatch.Probe.Oidc Nuthatch.Probe.Oidc
Nuthatch.Probe.ProductClient Nuthatch.Probe.ProductClient
build-depends: build-depends:
@ -264,7 +267,7 @@ executable nuthatch-product-probe
hs-source-dirs: test hs-source-dirs: test
other-modules: other-modules:
Nuthatch.Probe.Assert Nuthatch.Probe.Assert
Nuthatch.Probe.Curl Nuthatch.Probe.Http
Nuthatch.Probe.Oidc Nuthatch.Probe.Oidc
Nuthatch.Probe.ProductClient Nuthatch.Probe.ProductClient
build-depends: build-depends:
@ -288,6 +291,7 @@ executable nuthatch-idempotency-probe
other-modules: other-modules:
Nuthatch.Probe.Assert Nuthatch.Probe.Assert
Nuthatch.Probe.Curl Nuthatch.Probe.Curl
Nuthatch.Probe.Http
Nuthatch.Probe.Oidc Nuthatch.Probe.Oidc
Nuthatch.Probe.ProductClient Nuthatch.Probe.ProductClient
build-depends: build-depends:
@ -312,6 +316,7 @@ executable nuthatch-streaming-probe
other-modules: other-modules:
Nuthatch.Probe.Assert Nuthatch.Probe.Assert
Nuthatch.Probe.Curl Nuthatch.Probe.Curl
Nuthatch.Probe.Http
Nuthatch.Probe.Oidc Nuthatch.Probe.Oidc
Nuthatch.Probe.ProductClient Nuthatch.Probe.ProductClient
build-depends: build-depends:
@ -336,7 +341,7 @@ executable nuthatch-runtime-http-probe
hs-source-dirs: test hs-source-dirs: test
other-modules: other-modules:
Nuthatch.Probe.Assert Nuthatch.Probe.Assert
Nuthatch.Probe.Curl Nuthatch.Probe.Http
Nuthatch.Probe.Oidc Nuthatch.Probe.Oidc
Nuthatch.Probe.ProductClient Nuthatch.Probe.ProductClient
build-depends: build-depends:
@ -372,7 +377,7 @@ executable nuthatch-fixture-probe
hs-source-dirs: test hs-source-dirs: test
other-modules: other-modules:
Nuthatch.Probe.Assert Nuthatch.Probe.Assert
Nuthatch.Probe.Curl Nuthatch.Probe.Http
build-depends: build-depends:
, nuthatch , nuthatch
, base , base
@ -391,6 +396,7 @@ executable nuthatch-dependency-probe
other-modules: other-modules:
Nuthatch.Probe.Assert Nuthatch.Probe.Assert
Nuthatch.Probe.Curl Nuthatch.Probe.Curl
Nuthatch.Probe.Http
build-depends: build-depends:
, nuthatch , nuthatch
, base , base

239
test/AuthProbe.hs
View file

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

31
test/DependencyProbe.hs
View file

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

9
test/FixtureProbe.hs
View file

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

91
test/IdempotencyProbe.hs
View file

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

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

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

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

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

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

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

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

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

249
test/ProductProbe.hs
View file

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

134
test/RuntimeHttpProbe.hs
View file

@ -4,37 +4,35 @@ import Control.Concurrent (threadDelay)
import qualified Data.ByteString as BS import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Char8 as B8
import Nuthatch.Probe.Assert import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl import Nuthatch.Probe.Http
import Nuthatch.Probe.Oidc import Nuthatch.Probe.Oidc
import Nuthatch.Probe.ProductClient import Nuthatch.Probe.ProductClient
import System.Environment (getArgs) import System.Environment (getArgs)
import System.IO (hFlush, stdout) import System.IO (hFlush, stdout)
import System.IO.Temp (withSystemTempDirectory)
import Text.Read (readMaybe) import Text.Read (readMaybe)
main :: IO () main :: IO ()
main = main = do
withSystemTempDirectory "nuthatch-runtime-http-probe" $ \directory -> do context <- newProbeContext
context <- newProbeContext directory getArgs >>= \case
getArgs >>= \case ["health", expectedText] ->
["health", expectedText] -> maybe
maybe (fail "invalid expected readiness status")
(fail "invalid expected readiness status") (verifyHealth context)
(verifyHealth context) (readMaybe expectedText)
(readMaybe expectedText) ["baseline"] -> withSession context True "runtime-baseline" $
["baseline"] -> withSession context True "runtime-baseline" $ verifyBaseline context
verifyBaseline context ["coherence"] -> verifyCoherence context
["coherence"] -> verifyCoherence context ["redis-unavailable"] ->
["redis-unavailable"] -> withSession context False "runtime-redis" $
withSession context False "runtime-redis" $ verifyRedisUnavailable context
verifyRedisUnavailable context ["database-unavailable"] ->
["database-unavailable"] -> withSession context False "runtime-database" $
withSession context False "runtime-database" $ verifyDatabaseUnavailable context
verifyDatabaseUnavailable context _ ->
_ -> fail
fail "expected health STATUS, baseline, coherence, redis-unavailable, \
"expected health STATUS, baseline, coherence, redis-unavailable, \ \or database-unavailable"
\or database-unavailable"
withSession withSession
:: ProbeContext :: ProbeContext
@ -48,20 +46,20 @@ withSession context verifyBoundary suffix action = do
verifyHealth :: ProbeContext -> Int -> IO () verifyHealth :: ProbeContext -> Int -> IO ()
verifyHealth context expectedReady = do verifyHealth context expectedReady = do
health <- curl [probeBase context <> "/healthz"] health <- get (probeClient context) (probeBase context <> "/healthz")
assertEqual "runtime health status" 200 (curlStatus health) assertEqual "runtime health status" 200 (probeStatus health)
assertContains "runtime health body" "\"ok\":true" (curlBody health) assertContains "runtime health body" "\"ok\":true" (probeBody health)
ready <- curl [probeBase context <> "/readyz"] ready <- get (probeClient context) (probeBase context <> "/readyz")
assertEqual "runtime readiness status" expectedReady (curlStatus ready) assertEqual "runtime readiness status" expectedReady (probeStatus ready)
_ <- curl [probeBase context <> "/app"] _ <- get (probeClient context) (probeBase context <> "/app")
session <- curl [probeBase context <> "/api/session"] session <- get (probeClient context) (probeBase context <> "/api/session")
assertEqual "runtime unauthenticated session" 303 (curlStatus session) assertEqual "runtime unauthenticated session" 303 (probeStatus session)
putStrLn "Runtime health semantics passed" putStrLn "Runtime health semantics passed"
verifyBaseline :: ProbeContext -> Session -> IO () verifyBaseline :: ProbeContext -> Session -> IO ()
verifyBaseline context sessionA = do verifyBaseline context sessionA = do
browsed <- browse context sessionA "" browsed <- browse context sessionA ""
assertEqual "runtime baseline browse" 200 (curlStatus browsed) assertEqual "runtime baseline browse" 200 (probeStatus browsed)
uploaded <- upload context sessionA "personal" "cross-user.txt" uploaded <- upload context sessionA "personal" "cross-user.txt"
"76000000-0000-4000-8000-000000000001" "private-a" "76000000-0000-4000-8000-000000000001" "private-a"
requireSucceeded "runtime baseline put" uploaded requireSucceeded "runtime baseline put" uploaded
@ -69,30 +67,34 @@ verifyBaseline context sessionA = do
sessionB <- login context False userB "runtime-baseline-b" sessionB <- login context False userB "runtime-baseline-b"
personalB <- browse context sessionB "?root=personal" personalB <- browse context sessionB "?root=personal"
assert "runtime personal cache crossed users" $ assert "runtime personal cache crossed users" $
not ("cross-user.txt" `BS.isInfixOf` curlBody personalB) not ("cross-user.txt" `BS.isInfixOf` probeBody personalB)
wrongLogout <- curl wrongLogout <- postWith
[ "--cookie", sessionCookies sessionA (probeClient context)
, "--header" defaultRequestOptions
, "X-CSRF-Token: bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" { optionCookies = Just (sessionCookies sessionA)
, "--request", "POST" , optionHeaders =
, probeBase context <> "/logout" [ ( "X-CSRF-Token"
] , "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
)
]
}
(probeBase context <> "/logout")
assert "runtime baseline accepted wrong logout CSRF" $ assert "runtime baseline accepted wrong logout CSRF" $
curlStatus wrongLogout >= 400 probeStatus wrongLogout >= 400
deleted <- deleteObject context sessionA "personal" "cross-user.txt" deleted <- deleteObject context sessionA "personal" "cross-user.txt"
"76000000-0000-4000-8000-000000000002" "76000000-0000-4000-8000-000000000002"
requireSucceeded "runtime baseline delete" deleted requireSucceeded "runtime baseline delete" deleted
restored <- upload context sessionA "personal" "cross-user.txt" restored <- upload context sessionA "personal" "cross-user.txt"
"76000000-0000-4000-8000-000000000003" "private-a" "76000000-0000-4000-8000-000000000003" "private-a"
requireSucceeded "runtime unavailable fixture" restored requireSucceeded "runtime unavailable fixture" restored
loggedOut <- curl loggedOut <- postWith
[ "--cookie", sessionCookies sessionA (probeClient context)
, "--cookie-jar", sessionCookies sessionA defaultRequestOptions
, "--header", "X-CSRF-Token: " <> B8.unpack (sessionCsrf sessionA) { optionCookies = Just (sessionCookies sessionA)
, "--request", "POST" , optionHeaders = [("X-CSRF-Token", sessionCsrf sessionA)]
, probeBase context <> "/logout" }
] (probeBase context <> "/logout")
assertEqual "runtime baseline logout" 200 (curlStatus loggedOut) assertEqual "runtime baseline logout" 200 (probeStatus loggedOut)
putStrLn "Runtime audit baseline passed" putStrLn "Runtime audit baseline passed"
verifyCoherence :: ProbeContext -> IO () verifyCoherence :: ProbeContext -> IO ()
@ -113,33 +115,33 @@ verifyCoherence context = do
rootListing <- browse context sessionB "?root=shared" rootListing <- browse context sessionB "?root=shared"
assertContains "shared root cache invalidation" assertContains "shared root cache invalidation"
"runtime" "runtime"
(curlBody rootListing) (probeBody rootListing)
prefixListing <- browse context sessionB "?root=shared&prefix=runtime" prefixListing <- browse context sessionB "?root=shared&prefix=runtime"
assertContains "shared prefix cache invalidation" assertContains "shared prefix cache invalidation"
"coherence.txt" "coherence.txt"
(curlBody prefixListing) (probeBody prefixListing)
deleted <- deleteObject context sessionA "shared" "runtime/coherence.txt" deleted <- deleteObject context sessionA "shared" "runtime/coherence.txt"
"74000000-0000-4000-8000-000000000002" "74000000-0000-4000-8000-000000000002"
requireSucceeded "shared coherence delete" deleted requireSucceeded "shared coherence delete" deleted
afterDelete <- browse context sessionB "?root=shared&prefix=runtime" afterDelete <- browse context sessionB "?root=shared&prefix=runtime"
assert "shared deletion remained in another replica cache" $ assert "shared deletion remained in another replica cache" $
not ("coherence.txt" `BS.isInfixOf` curlBody afterDelete) not ("coherence.txt" `BS.isInfixOf` probeBody afterDelete)
threadDelay 2000000 threadDelay 2000000
browse context sessionB "?root=shared" >>= \response -> browse context sessionB "?root=shared" >>= \response ->
assertEqual "cache TTL browse" 200 (curlStatus response) assertEqual "cache TTL browse" 200 (probeStatus response)
putStrLn "Cross-user cache coherence and TTL passed" putStrLn "Cross-user cache coherence and TTL passed"
verifyRedisUnavailable :: ProbeContext -> Session -> IO () verifyRedisUnavailable :: ProbeContext -> Session -> IO ()
verifyRedisUnavailable context session = do verifyRedisUnavailable context session = do
listing <- browse context session "?root=personal" listing <- browse context session "?root=personal"
assertEqual "Redis-unavailable browse" 200 (curlStatus listing) assertEqual "Redis-unavailable browse" 200 (probeStatus listing)
assertContains "Redis-unavailable browse fixture" assertContains "Redis-unavailable browse fixture"
"cross-user.txt" "cross-user.txt"
(curlBody listing) (probeBody listing)
searched <- browse context session "?root=personal&q=CROSS-USER" searched <- browse context session "?root=personal&q=CROSS-USER"
assertContains "Redis-unavailable search" assertContains "Redis-unavailable search"
"cross-user.txt" "cross-user.txt"
(curlBody searched) (probeBody searched)
unavailableUpload <- upload context session "personal" "unavailable.bin" unavailableUpload <- upload context session "personal" "unavailable.bin"
"72000000-0000-4000-8000-000000000001" "x" "72000000-0000-4000-8000-000000000001" "x"
requireError "Redis-unavailable upload" requireError "Redis-unavailable upload"
@ -168,22 +170,22 @@ verifyDatabaseUnavailable context session = do
503 "mutation_rejected" unavailableDelete 503 "mutation_rejected" unavailableDelete
putStrLn "Database-unavailable mutation behavior passed" putStrLn "Database-unavailable mutation behavior passed"
retryPastThrottle :: Int -> IO CurlResponse -> IO CurlResponse retryPastThrottle :: Int -> IO ProbeResponse -> IO ProbeResponse
retryPastThrottle attempts action = do retryPastThrottle attempts action = do
response <- action response <- action
if attempts > 1 if attempts > 1
&& "\"error\":\"throttle_unavailable\"" `BS.isInfixOf` curlBody response && "\"error\":\"throttle_unavailable\"" `BS.isInfixOf` probeBody response
then threadDelay 250000 >> retryPastThrottle (attempts - 1) action then threadDelay 250000 >> retryPastThrottle (attempts - 1) action
else pure response else pure response
requireSucceeded :: String -> CurlResponse -> IO () requireSucceeded :: String -> ProbeResponse -> IO ()
requireSucceeded label response = do requireSucceeded label response = do
assertEqual (label <> " status") 200 (curlStatus response) assertEqual (label <> " status") 200 (probeStatus response)
assertContains label "\"result\":\"succeeded\"" (curlBody response) assertContains label "\"result\":\"succeeded\"" (probeBody response)
requireError :: String -> Int -> BS.ByteString -> CurlResponse -> IO () requireError :: String -> Int -> BS.ByteString -> ProbeResponse -> IO ()
requireError label status code response = do requireError label status code response = do
assertEqual (label <> " status") status (curlStatus response) assertEqual (label <> " status") status (probeStatus response)
assert assert
(label <> " body: " <> B8.unpack (curlBody response)) (label <> " body: " <> B8.unpack (probeBody response))
(("\"error\":\"" <> code <> "\"") `BS.isInfixOf` curlBody response) (("\"error\":\"" <> code <> "\"") `BS.isInfixOf` probeBody response)

237
test/StreamingProbe.hs
View file

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