nuthatch/test/ProductProbe.hs

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)