373 lines
14 KiB
Haskell
373 lines
14 KiB
Haskell
module Main (main) where
|
|
|
|
import Data.Aeson (Value (..), eitherDecodeStrict')
|
|
import qualified Data.Aeson.Key as Key
|
|
import qualified Data.Aeson.KeyMap as KeyMap
|
|
import qualified Data.ByteString as BS
|
|
import qualified Data.ByteString.Char8 as B8
|
|
import qualified Data.Text as Text
|
|
import Nuthatch.Probe.Assert
|
|
import Nuthatch.Probe.Curl
|
|
import Nuthatch.Probe.Oidc
|
|
import Nuthatch.Probe.ProductClient
|
|
import System.Environment (getArgs)
|
|
import System.IO.Temp (withSystemTempDirectory)
|
|
|
|
main :: IO ()
|
|
main =
|
|
withSystemTempDirectory "nuthatch-product-probe" $ \directory -> do
|
|
context <- newProbeContext directory
|
|
user <- requireEnv "NUTHATCH_OIDC_USER_A"
|
|
session <- login context False user "product"
|
|
getArgs >>= \case
|
|
["verify"] -> verifyProduct context session
|
|
["timeout"] -> verifyTimeout context session
|
|
_ -> fail "expected verify or timeout mode"
|
|
|
|
verifyTimeout :: ProbeContext -> Session -> IO ()
|
|
verifyTimeout context session = do
|
|
response <- curl
|
|
[ "--get"
|
|
, "--cookie", sessionCookies session
|
|
, "--data-urlencode", "root=personal"
|
|
, "--data-urlencode", "q=timeout-probe"
|
|
, probeBase context <> "/api/browse"
|
|
]
|
|
assertEqual "timed search status" 200 (curlStatus response)
|
|
assertContains "timed search bound" "\"partial\":true" (curlBody response)
|
|
putStrLn "Timed search bound passed"
|
|
|
|
verifyProduct :: ProbeContext -> Session -> IO ()
|
|
verifyProduct context session = do
|
|
verifyApplicationAssets context session
|
|
verifyPaginationAndSearch context session
|
|
verifyCanonicalPaths context session
|
|
verifySafeDownload context session
|
|
verifyRecursiveDelete context session
|
|
putStrLn "Product behavior passed"
|
|
|
|
verifyApplicationAssets :: ProbeContext -> Session -> IO ()
|
|
verifyApplicationAssets context session = do
|
|
sessionResponse <- curl
|
|
[ "--cookie", sessionCookies session
|
|
, probeBase context <> "/api/session"
|
|
]
|
|
assertEqual "session endpoint status" 200 (curlStatus sessionResponse)
|
|
assertContains "session user" "\"user_id\":" (curlBody sessionResponse)
|
|
assertContains "session CSRF"
|
|
("\"csrf\":\"" <> sessionCsrf session <> "\"")
|
|
(curlBody sessionResponse)
|
|
application <- curl
|
|
[ "--cookie", sessionCookies session
|
|
, probeBase context <> "/app"
|
|
]
|
|
assertEqual "application status" 200 (curlStatus application)
|
|
csp <- maybe (fail "application omitted CSP") pure $
|
|
headerValue "content-security-policy" application
|
|
mapM_
|
|
(\directive ->
|
|
assertContains ("application CSP omitted " <> B8.unpack directive)
|
|
directive
|
|
csp)
|
|
["default-src 'none'", "script-src 'self'", "frame-ancestors 'none'"]
|
|
asset <- between "src=\"/assets/" "\"" (B8.unpack (curlBody application))
|
|
javascript <- curl
|
|
[ "--cookie", sessionCookies session
|
|
, probeBase context <> "/assets/" <> asset
|
|
]
|
|
assertEqual "asset status" 200 (curlStatus javascript)
|
|
assertContains "asset content type" "javascript" $
|
|
maybe BS.empty id (headerValue "content-type" javascript)
|
|
assertEqual "asset nosniff"
|
|
(Just "nosniff")
|
|
(headerValue "x-content-type-options" javascript)
|
|
let visible = curlBody application <> curlBody javascript
|
|
mapM_
|
|
(\value ->
|
|
assert ("browser artifact exposed " <> value) $
|
|
not (B8.pack value `BS.isInfixOf` visible))
|
|
[ "NUTHATCH_S3"
|
|
, "AWS_ACCESS_KEY"
|
|
, "AWS_SECRET_ACCESS_KEY"
|
|
, "client_secret"
|
|
]
|
|
mapM_
|
|
(\marker ->
|
|
assertContains ("asset omitted " <> marker)
|
|
(B8.pack marker)
|
|
(curlBody javascript))
|
|
[ "Drop a file here"
|
|
, "Shared root"
|
|
, "Retry same upload"
|
|
, "Retry same delete"
|
|
, "nuthatch-recursive-delete"
|
|
, "URLSearchParams"
|
|
]
|
|
unauthenticatedApp <- curl [probeBase context <> "/app"]
|
|
assertEqual "unauthenticated application" 303 (curlStatus unauthenticatedApp)
|
|
unauthenticatedAsset <- curl [probeBase context <> "/assets/" <> asset]
|
|
assertEqual "unauthenticated asset" 303 (curlStatus unauthenticatedAsset)
|
|
|
|
verifyPaginationAndSearch :: ProbeContext -> Session -> IO ()
|
|
verifyPaginationAndSearch context session = do
|
|
uploadSucceeded context session "product-browse/Alpha.txt"
|
|
"81000000-0000-4000-8000-000000000001" "alpha"
|
|
replay <- upload context session "personal" "product-browse/Alpha.txt"
|
|
"81000000-0000-4000-8000-000000000001" "alpha"
|
|
requireSucceeded "product upload replay" replay
|
|
uploadSucceeded context session "product-browse/beta.txt"
|
|
"81000000-0000-4000-8000-000000000002" "beta"
|
|
uploadSucceeded context session "product-browse/gamma.txt"
|
|
"81000000-0000-4000-8000-000000000003" "gamma"
|
|
firstPage <- curl
|
|
[ "--get"
|
|
, "--cookie", sessionCookies session
|
|
, "--data-urlencode", "root=personal"
|
|
, "--data-urlencode", "prefix=product-browse"
|
|
, probeBase context <> "/api/browse"
|
|
]
|
|
requireStatus "first browse page" 200 firstPage
|
|
assertContains "first page Alpha"
|
|
"\"path\":\"product-browse/Alpha.txt\""
|
|
(curlBody firstPage)
|
|
assertContains "first page beta"
|
|
"\"path\":\"product-browse/beta.txt\""
|
|
(curlBody firstPage)
|
|
assert "first page exceeded configured size" $
|
|
not ("product-browse/gamma.txt" `BS.isInfixOf` curlBody firstPage)
|
|
continuation <- stringField "continuation" (curlBody firstPage)
|
|
secondPage <- curl
|
|
[ "--get"
|
|
, "--cookie", sessionCookies session
|
|
, "--data-urlencode", "root=personal"
|
|
, "--data-urlencode", "prefix=product-browse"
|
|
, "--data-urlencode", "continuation=" <> continuation
|
|
, probeBase context <> "/api/browse"
|
|
]
|
|
assertContains "second browse page"
|
|
"\"path\":\"product-browse/gamma.txt\""
|
|
(curlBody secondPage)
|
|
mapM_
|
|
(\(path, operationId, body) ->
|
|
uploadSucceeded context session path operationId body)
|
|
[ ("000-Needle-A.txt", "81000000-0000-4000-8000-000000000004", "one")
|
|
, ("001-needle-b.txt", "81000000-0000-4000-8000-000000000005", "two")
|
|
, ("002-filler.txt", "81000000-0000-4000-8000-000000000006", "three")
|
|
, ("003-needle-after-bound.txt", "81000000-0000-4000-8000-000000000007", "four")
|
|
]
|
|
searched <- curl
|
|
[ "--get"
|
|
, "--cookie", sessionCookies session
|
|
, "--data-urlencode", "root=personal"
|
|
, "--data-urlencode", "q=NEEDLE"
|
|
, probeBase context <> "/api/browse"
|
|
]
|
|
mapM_
|
|
(\value -> assertContains "bounded case-insensitive search" value (curlBody searched))
|
|
[ "\"path\":\"000-Needle-A.txt\""
|
|
, "\"path\":\"001-needle-b.txt\""
|
|
, "\"partial\":true"
|
|
]
|
|
assert "search crossed the configured scan bound" $
|
|
not ("003-needle-after-bound.txt" `BS.isInfixOf` curlBody searched)
|
|
|
|
verifyCanonicalPaths :: ProbeContext -> Session -> IO ()
|
|
verifyCanonicalPaths context session = do
|
|
mapM_
|
|
(\url -> curl ["--cookie", sessionCookies session, url] >>=
|
|
requireStatus "non-canonical path" 400)
|
|
[ probeBase context <> "/api/browse?root=Personal"
|
|
, probeBase context <> "/api/browse?root=personal&prefix=a//b"
|
|
, probeBase context <> "/api/download?root=personal&path=./file"
|
|
]
|
|
decomposed <- curl
|
|
[ "--cookie", sessionCookies session
|
|
, probeBase context
|
|
<> "/api/download?root=personal&path=cafe%CC%81.txt"
|
|
]
|
|
requireStatus "non-NFC path" 400 decomposed
|
|
uploadSucceeded context session "encoded%2Fname.txt"
|
|
"81000000-0000-4000-8000-000000000008" "encoded"
|
|
encoded <- curl
|
|
[ "--cookie", sessionCookies session
|
|
, probeBase context
|
|
<> "/api/download?root=personal&path=encoded%252Fname.txt"
|
|
]
|
|
assertEqual "encoded path body" "encoded" (curlBody encoded)
|
|
uploadSucceeded context session "café.txt"
|
|
"81000000-0000-4000-8000-000000000014" "unicode"
|
|
unicode <- download context session "personal" "café.txt"
|
|
assertEqual "Unicode path body" "unicode" (curlBody unicode)
|
|
assertContains "Unicode filename"
|
|
"filename*=UTF-8''caf%C3%A9.txt"
|
|
(maybe BS.empty id (headerValue "content-disposition" unicode))
|
|
|
|
verifySafeDownload :: ProbeContext -> Session -> IO ()
|
|
verifySafeDownload context session = do
|
|
let svg = "<svg onload=\"alert(1)\"></svg>"
|
|
uploadSucceeded context session "active.svg"
|
|
"81000000-0000-4000-8000-000000000009" svg
|
|
ranged <- curl
|
|
[ "--cookie", sessionCookies session
|
|
, "--header", "Range: bytes=0-1"
|
|
, probeBase context <> "/api/download?root=personal&path=active.svg"
|
|
]
|
|
requireStatus "unsupported range" 416 ranged
|
|
assertContains "range error"
|
|
"\"error\":\"range_not_supported\""
|
|
(curlBody ranged)
|
|
downloaded <- download context session "personal" "active.svg"
|
|
requireStatus "safe download" 200 downloaded
|
|
let disposition =
|
|
maybe BS.empty id (headerValue "content-disposition" downloaded)
|
|
assertContains "download attachment" "attachment;" disposition
|
|
assertContains "download filename" "filename*=UTF-8''active.svg" disposition
|
|
assertEqual "download nosniff"
|
|
(Just "nosniff")
|
|
(headerValue "x-content-type-options" downloaded)
|
|
assertContains "download sandbox"
|
|
"sandbox"
|
|
(maybe BS.empty id (headerValue "content-security-policy" downloaded))
|
|
assertEqual "download body" svg (curlBody downloaded)
|
|
|
|
verifyRecursiveDelete :: ProbeContext -> Session -> IO ()
|
|
verifyRecursiveDelete context session = do
|
|
mapM_
|
|
(\(path, operationId, body) ->
|
|
uploadSucceeded context session path operationId body)
|
|
[ ("delete-tree/a.txt", "81000000-0000-4000-8000-000000000010", "a")
|
|
, ("delete-tree/b.txt", "81000000-0000-4000-8000-000000000011", "b")
|
|
, ("delete-tree/c.txt", "81000000-0000-4000-8000-000000000012", "c")
|
|
]
|
|
planned <- deletePlan context session
|
|
assertContains "first delete plan"
|
|
"\"paths\":[\"delete-tree/a.txt\",\"delete-tree/b.txt\"]"
|
|
(curlBody planned)
|
|
assert "first delete plan omitted continuation" $
|
|
not ("\"continuation\":null" `BS.isInfixOf` curlBody planned)
|
|
let firstBatch =
|
|
"{\"root\":\"personal\",\"csrf\":\""
|
|
<> B8.unpack (sessionCsrf session)
|
|
<> "\",\"items\":["
|
|
<> "{\"path\":\"delete-tree/a.txt\",\"operation_id\":"
|
|
<> "\"82000000-0000-4000-8000-000000000001\"},"
|
|
<> "{\"path\":\"delete-tree/b.txt\",\"operation_id\":"
|
|
<> "\"82000000-0000-4000-8000-000000000002\"}]}"
|
|
first <- deleteBatch context session firstBatch
|
|
requireBatchSucceeded "first delete batch" first
|
|
replay <- deleteBatch context session firstBatch
|
|
requireBatchSucceeded "delete batch replay" replay
|
|
uploadSucceeded context session "delete-tree/d-concurrent.txt"
|
|
"81000000-0000-4000-8000-000000000013" "d"
|
|
restarted <- deletePlan context session
|
|
assertContains "restarted delete plan"
|
|
"\"paths\":[\"delete-tree/c.txt\",\"delete-tree/d-concurrent.txt\"]"
|
|
(curlBody restarted)
|
|
let secondBatch =
|
|
"{\"root\":\"personal\",\"csrf\":\""
|
|
<> B8.unpack (sessionCsrf session)
|
|
<> "\",\"items\":["
|
|
<> "{\"path\":\"delete-tree/c.txt\",\"operation_id\":"
|
|
<> "\"82000000-0000-4000-8000-000000000003\"},"
|
|
<> "{\"path\":\"delete-tree/d-concurrent.txt\",\"operation_id\":"
|
|
<> "\"82000000-0000-4000-8000-000000000004\"}]}"
|
|
second <- deleteBatch context session secondBatch
|
|
requireBatchSucceeded "second delete batch" second
|
|
empty <- deletePlan context session
|
|
assertContains "empty delete plan" "\"paths\":[]" (curlBody empty)
|
|
assertContains "empty delete continuation"
|
|
"\"continuation\":null"
|
|
(curlBody empty)
|
|
|
|
deletePlan :: ProbeContext -> Session -> IO CurlResponse
|
|
deletePlan context session =
|
|
curl
|
|
[ "--get"
|
|
, "--cookie", sessionCookies session
|
|
, "--data-urlencode", "root=personal"
|
|
, "--data-urlencode", "path=delete-tree"
|
|
, probeBase context <> "/api/delete-plan"
|
|
]
|
|
|
|
deleteBatch
|
|
:: ProbeContext
|
|
-> Session
|
|
-> String
|
|
-> IO CurlResponse
|
|
deleteBatch context session body =
|
|
curl
|
|
[ "--cookie", sessionCookies session
|
|
, "--header", "Content-Type: application/json"
|
|
, "--data", body
|
|
, probeBase context <> "/api/delete-batch"
|
|
]
|
|
|
|
requireBatchSucceeded :: String -> CurlResponse -> IO ()
|
|
requireBatchSucceeded label response = do
|
|
requireStatus label 200 response
|
|
assertEqual label 2 $
|
|
countOccurrences "\"result\":\"succeeded\"" (curlBody response)
|
|
|
|
uploadSucceeded
|
|
:: ProbeContext
|
|
-> Session
|
|
-> String
|
|
-> String
|
|
-> BS.ByteString
|
|
-> IO ()
|
|
uploadSucceeded context session path operationId body =
|
|
upload context session "personal" path operationId body >>=
|
|
requireSucceeded ("upload " <> path)
|
|
|
|
requireSucceeded :: String -> CurlResponse -> IO ()
|
|
requireSucceeded label response = do
|
|
requireStatus label 200 response
|
|
assertContains label "\"result\":\"succeeded\"" (curlBody response)
|
|
|
|
requireStatus :: String -> Int -> CurlResponse -> IO ()
|
|
requireStatus label expected response =
|
|
assertEqual (label <> " status") expected (curlStatus response)
|
|
|
|
stringField :: String -> BS.ByteString -> IO String
|
|
stringField name bytes =
|
|
case eitherDecodeStrict' bytes of
|
|
Right (Object object) ->
|
|
case KeyMap.lookup (Key.fromString name) object of
|
|
Just (String value) -> pure (Text.unpack value)
|
|
_ -> fail ("JSON omitted string field " <> name)
|
|
Right _ -> fail "expected JSON object"
|
|
Left reason -> fail ("invalid JSON: " <> reason)
|
|
|
|
between :: String -> String -> String -> IO String
|
|
between start end value =
|
|
case dropUntil start value of
|
|
Nothing -> fail ("value omitted " <> start)
|
|
Just afterStart ->
|
|
case takeUntil end afterStart of
|
|
Nothing -> fail ("value omitted " <> end)
|
|
Just result -> pure result
|
|
|
|
dropUntil :: String -> String -> Maybe String
|
|
dropUntil needle value
|
|
| needle `prefixOf` value = Just (drop (length needle) value)
|
|
dropUntil _ [] = Nothing
|
|
dropUntil needle (_ : rest) = dropUntil needle rest
|
|
|
|
takeUntil :: String -> String -> Maybe String
|
|
takeUntil needle = go []
|
|
where
|
|
go prefix value
|
|
| needle `prefixOf` value = Just (reverse prefix)
|
|
go _ [] = Nothing
|
|
go prefix (next : rest) = go (next : prefix) rest
|
|
|
|
prefixOf :: String -> String -> Bool
|
|
prefixOf prefix value =
|
|
take (length prefix) value == prefix
|
|
|
|
countOccurrences :: BS.ByteString -> BS.ByteString -> Int
|
|
countOccurrences needle input
|
|
| BS.null input = 0
|
|
| needle `BS.isPrefixOf` input =
|
|
1 + countOccurrences needle (BS.drop (BS.length needle) input)
|
|
| otherwise = countOccurrences needle (BS.drop 1 input)
|