nuthatch/test/AuthProbe.hs

module Main (main) where

import           Control.Concurrent (threadDelay)
import           Control.Exception (throwIO, try)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Char8 as B8
import           Data.List (find)
import           Nuthatch.Probe.Assert
import           Nuthatch.Probe.Curl
import           Nuthatch.Probe.Http
import           Nuthatch.Probe.Oidc
import           Nuthatch.Probe.ProductClient
import           System.Entropy (getEntropy)

main :: IO ()
main = do
  context <- newProbeContext
  runId <- B8.unpack . B16.encode <$> getEntropy 8
  verifyCredentialScope
  waitForApplication context
  verifyPublicBoundary context
  userA <- requireEnv "NUTHATCH_OIDC_USER_A"
  sessionA <- login context True userA "a"
  verifyPkceBoundary context userA
  verifyAuthenticatedBoundary context sessionA
  exerciseRoot context sessionA runId "personal" "01"
  exerciseRoot context sessionA runId "shared" "02"
  verifyCrossUserBoundary context sessionA runId
  verifyLogout context sessionA
  putStrLn "OIDC application boundary passed"

waitForApplication :: ProbeContext -> IO ()
waitForApplication context = go 30
  where
    go :: Int -> IO ()
    go remaining = do
      result <-
        try
          (getWith
            (probeClient context)
            defaultRequestOptions { optionTimeoutMicros = Just 2000000 }
            (probeBase context <> "/readyz"))
          :: IO (Either HttpException ProbeResponse)
      case result of
        Right _ -> pure ()
        Left failure
          | isConnectionFailure failure && remaining > 1 ->
              threadDelay 1000000 >> go (remaining - 1)
          | otherwise -> throwIO failure

verifyCredentialScope :: IO ()
verifyCredentialScope = do
  endpoint <- requireEnv "NUTHATCH_S3_ENDPOINT"
  region <- requireEnv "NUTHATCH_S3_REGION"
  accessKey <- requireEnv "NUTHATCH_S3_ACCESS_KEY"
  secretKey <- requireEnv "NUTHATCH_S3_SECRET_KEY"
  let signed =
        [ "--aws-sigv4", "aws:amz:" <> region <> ":s3"
        , "--user", accessKey <> ":" <> secretKey
        ]
      denied label arguments = do
        response <- curl (signed <> arguments)
        assertEqual
          (label <> ": " <> B8.unpack (probeBody response))
          403
          (probeStatus response)
      emptyPayload =
        "X-Amz-Content-Sha256:e3b0c44298fc1c149afbf4c8996fb924"
          <> "27ae41e4649b934ca495991b7852b855"
  denied "unscoped bucket head"
    [ "--head"
    , "--header", emptyPayload
    , endpoint <> "/nuthatch-fixture"
    ]
  denied "unscoped bucket listing"
    [ "--header", emptyPayload
    , endpoint <> "/nuthatch-fixture?list-type=2"
    ]
  denied "unscoped object read"
    [ "--header", emptyPayload
    , endpoint <> "/nuthatch-fixture/scope-canary"
    ]
  denied "unscoped object write"
    [ "--request", "PUT"
    , "--header"
    , "X-Amz-Content-Sha256:16d02fe317ec0615c2039631cc72bdf9"
        <> "e6c8b7a2cb32895d6235c5775522bbc6"
    , "--data-binary", "denied-write"
    , endpoint <> "/nuthatch-fixture/denied-write"
    ]

verifyPublicBoundary :: ProbeContext -> IO ()
verifyPublicBoundary context = do
  health <- get (probeClient context) (probeBase context <> "/healthz")
  assertEqual "health status" 200 (probeStatus health)
  assertContains "health response" "\"ok\":true" (probeBody health)
  ready <- get (probeClient context) (probeBase context <> "/readyz")
  assertEqual "readiness status" 200 (probeStatus ready)
  assertContains "readiness response" "\"ready\":true" (probeBody ready)
  loginPost <- postWith
    (probeClient context)
    defaultRequestOptions
    (probeBase context <> "/login")
  assertEqual "login method boundary" 405 (probeStatus loginPost)
  root <- get (probeClient context) (probeBase context <> "/")
  assertEqual "root route boundary" 404 (probeStatus root)
  downloadResponse <- get
    (probeClient context)
    (probeBase context <> "/api/download?root=personal&path=unauthenticated")
  assertEqual "unauthenticated download" 303 (probeStatus downloadResponse)
  uploadResponse <- postWith
    (probeClient context)
    defaultRequestOptions
      { optionHeaders =
          [ ("X-Declared-Size", "1")
          , ("X-Content-SHA256", sha256Hex "x")
          , ( "X-CSRF-Token"
            , "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
            )
          ]
      , optionBody = ByteBody "x"
      }
    (probeBase context
      <> "/api/upload?root=personal&path=unauthenticated"
      <> "&operation_id=40000000-0000-4000-8000-000000000001")
  assertEqual "unauthenticated upload" 303 (probeStatus uploadResponse)
  deleteResponse <- postWith
    (probeClient context)
    defaultRequestOptions
      { optionHeaders = [("Content-Type", "application/json")]
      , optionBody = ByteBody $
          "{\"root\":\"personal\",\"path\":\"unauthenticated\","
      <> "\"operation_id\":\"40000000-0000-4000-8000-000000000002\","
      <> "\"csrf\":\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"}"
      }
    (probeBase context <> "/api/delete")
  assertEqual "unauthenticated delete" 303 (probeStatus deleteResponse)
  removedCompatibility <- postWith
    (probeClient context)
    defaultRequestOptions
      { optionHeaders = [("Content-Type", "application/json")]
      , optionBody = ByteBody $
          "{\"root\":\"personal\",\"path\":\"unauthenticated\","
      <> "\"csrf\":\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"}"
      }
    (probeBase context <> "/delete-prefix")
  assertEqual "removed compatibility route" 404 (probeStatus removedCompatibility)
  logoutResponse <- postWith
    (probeClient context)
    defaultRequestOptions
      { optionHeaders =
          [ ( "X-CSRF-Token"
            , "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
            )
          ]
      }
    (probeBase context <> "/logout")
  assertEqual "unauthenticated logout" 303 (probeStatus logoutResponse)

verifyAuthenticatedBoundary :: ProbeContext -> Session -> IO ()
verifyAuthenticatedBoundary context session = do
  html <- getWith
    (probeClient context)
    defaultRequestOptions
      { optionCookies = Just (sessionCookies session) }
    (probeBase context <> "/api/browse")
  assertEqual "authenticated HTML browse" 200 (probeStatus html)
  json <- browse context session ""
  assertEqual "authenticated JSON browse" 200 (probeStatus json)
  let prohibited =
        [ "NUTHATCH_S3"
        , "AWS_ACCESS_KEY"
        , "AWS_SECRET_ACCESS_KEY"
        , "client_secret"
        ]
      bodies = probeBody html <> probeBody json
  mapM_
    (\value ->
      assert ("browser response exposed " <> value) $
        not (B8.pack value `BS.isInfixOf` bodies))
    prohibited

exerciseRoot
  :: ProbeContext
  -> Session
  -> String
  -> String
  -> String
  -> IO ()
exerciseRoot context session runId root suffix = do
  let path = "smoke-" <> suffix <> ".txt"
      first = B8.pack ("first-" <> root)
      second = B8.pack ("second-" <> root)
      operation prefix =
        runId <> "-" <> prefix <> "-" <> suffix
  firstUpload <- upload context session root path (operation "0") first
  requireSucceeded "first upload" firstUpload
  listing <- browse context session ("?root=" <> root)
  assertContains "uploaded object listing" (B8.pack path) (probeBody listing)
  firstDownload <- download context session root path
  assertEqual "first download status" 200 (probeStatus firstDownload)
  assertEqual "first download body" first (probeBody firstDownload)
  overwrite <- upload context session root path (operation "1") second
  requireSucceeded "overwrite" overwrite
  secondDownload <- download context session root path
  assertEqual "overwrite body" second (probeBody secondDownload)
  deleted <- deleteObject context session root path (operation "2")
  requireSucceeded "delete" deleted
  missing <- download context session root path
  assertEqual "deleted object" 404 (probeStatus missing)

verifyCrossUserBoundary :: ProbeContext -> Session -> String -> IO ()
verifyCrossUserBoundary context sessionA runId = do
  let body = "private-a"
  personal <- upload context sessionA "personal" "cross-user.txt"
    (runId <> "-cross-personal") body
  requireSucceeded "personal cross-user setup" personal
  shared <- upload context sessionA "shared" "cross-user.txt"
    (runId <> "-cross-shared") body
  requireSucceeded "shared cross-user setup" shared
  userB <- requireEnv "NUTHATCH_OIDC_USER_B"
  sessionB <- login context False userB "b"
  personalB <- browse context sessionB "?root=personal"
  assert "another user observed a personal object" $
    not ("cross-user.txt" `BS.isInfixOf` probeBody personalB)
  sharedB <- browse context sessionB "?root=shared"
  assertContains "shared object visibility" "cross-user.txt" (probeBody sharedB)

verifyLogout :: ProbeContext -> Session -> IO ()
verifyLogout context session = do
  rejected <- postWith
    (probeClient context)
    defaultRequestOptions
      { optionCookies = Just (sessionCookies session)
      , optionHeaders =
          [ ( "X-CSRF-Token"
            , "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
            )
          ]
      }
    (probeBase context <> "/logout")
  assert "logout accepted the wrong CSRF token" (probeStatus rejected >= 400)
  completed <- postWith
    (probeClient context)
    defaultRequestOptions
      { optionCookies = Just (sessionCookies session)
      , optionHeaders = [("X-CSRF-Token", sessionCsrf session)]
      }
    (probeBase context <> "/logout")
  assertEqual "logout status" 200 (probeStatus completed)
  mapM_
    (\name ->
      let matching =
            find
              (BS.isPrefixOf (name <> "="))
              (headerValues "set-cookie" completed)
      in assert (B8.unpack name <> " was not expired") $
          maybe False
            (BS.isInfixOf "Max-Age=0")
            matching)
    ["nuthatch_session", "nuthatch_csrf", "nuthatch_oidc"]
  after <- getWith
    (probeClient context)
    defaultRequestOptions
      { optionHeaders = [("Accept", "application/json")] }
    (probeBase context <> "/api/browse")
  assertEqual "session after logout" 303 (probeStatus after)

requireSucceeded :: String -> ProbeResponse -> IO ()
requireSucceeded label response = do
  assertEqual (label <> " status") 200 (probeStatus response)
  assertContains label "\"result\":\"succeeded\"" (probeBody response)