nuthatch/test/Spec.hs

module Main (main) where

import           Control.Concurrent (threadDelay)
import           Control.Concurrent.MVar
  ( newEmptyMVar
  , putMVar
  , takeMVar
  )
import           Control.Exception
  ( AsyncException (ThreadKilled)
  , SomeException
  , finally
  , throwIO
  , try
  )
import           Control.Monad (forM_)
import           Control.Monad.IO.Class (liftIO)
import           Control.Retry (simulatePolicy)
import           Control.Lens ((&), (?~))
import           Crypto.JOSE (runJOSE)
import           Crypto.JOSE.Compact (encodeCompact)
import           Crypto.JOSE.JWA.JWS (Alg (RS256, RS384))
import           Crypto.JOSE.JWK
  ( JWK
  , JWKSet (..)
  , KeyMaterialGenParam (RSAGenParam)
  , genJWK
  )
import           Crypto.JOSE.JWS (newJWSHeaderProtected)
import           Crypto.Hash (Digest, SHA256, hash)
import           Crypto.JWT
  ( Audience (..)
  , ClaimsSet
  , HasClaimsSet (..)
  , JWTError
  , NumericDate (..)
  , emptyClaimsSet
  , signJWT
  )
import qualified Data.Aeson as A
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Lazy as BL
import           Data.Either (isLeft, isRight)
import           Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
import           Data.String (fromString)
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import           Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
import           GHC.Clock (getMonotonicTimeNSec)
import           Hedgehog
  ( Gen
  , Property
  , assert
  , forAll
  , property
  , (===)
  )
import qualified Hedgehog.Gen as Gen
import qualified Hedgehog.Range as Range
import           Network.HTTP.Types
  ( HeaderName
  , methodGet
  , methodPost
  , status200
  , status303
  , status400
  , status404
  , status405
  )
import           Network.Wai (Request (..), responseLBS)
import           Network.Wai.Test
  ( SRequest (..)
  , SResponse (..)
  , defaultRequest
  , runSession
  , setPath
  , srequest
  )
import           Nuthatch.Api
import           Nuthatch.Audit (auditValue, objectKeyFields)
import           Nuthatch.App
  ( authenticationHandler
  , collectKeysBoundedWith
  , loginResponse
  , utf8Boundary
  )
import           Nuthatch.Config
  ( Config (..)
  , parseRedisUri
  , secret
  , validateAbsoluteUri
  )
import           Nuthatch.Oidc (OidcIdentity (..), verifyIdToken)
import           Nuthatch.Paths
  ( buildObjectKey
  , encodeUserId
  , listCacheAncestorPrefixes
  )
import           Nuthatch.Protocol
  ( ExistingDisposition (..)
  , MutationRecord (..)
  , ObjectObservation (..)
  , desiredMatches
  , existingDisposition
  , growthBytes
  , priorMatches
  , quotaAllows
  , recoveryEligible
  , sameFingerprint
  , terminalExpiryEligible
  , terminalExpired
  )
import           Nuthatch.Recovery
  ( recoveryClaimEligible
  , recoveryRetryPolicy
  , trySynchronous
  , withLinkedWorker
  )
import           Nuthatch.S3 (ListPage (..))
import           Nuthatch.Runtime (retryStartup)
import           Nuthatch.Types
import           Nuthatch.Session (mintSession)
import           Nuthatch.Streaming
  ( UploadStreamError (..)
  , consumeUploadParts
  , maximumMultipartBytes
  , multipartPartBytes
  )
import           Servant
import           Servant.Server.Experimental.Auth (AuthHandler, mkAuthHandler)
import           Servant.Types.SourceT
  ( SourceT
  , StepT (..)
  , fromStepT
  , source
  )
import qualified System.Timeout as Timeout
import           Test.Tasty (TestTree, defaultMain, testGroup)
import           Test.Tasty.HUnit ((@?=), assertBool, assertFailure, testCase)
import           Test.Tasty.Hedgehog (testProperty)

main :: IO ()
main = defaultMain tests

tests :: TestTree
tests = testGroup "nuthatch-unit"
  [ pathTests
  , identityTests
  , protocolTests
  , recoveryTests
  , streamingTests
  , productBehaviorTests
  , runtimeTests
  , oidcTests
  , apiTests
  ]

runtimeTests :: TestTree
runtimeTests = testGroup "runtime"
  [ testCase "URI parsing accepts IPv6 and rejects credentials" $ do
      parseRedisUri "redis://[2001:db8::1]:6380/4"
        >>= (@?= ("2001:db8::1", 6380, 4))
      redisCredential <- try
        (parseRedisUri "redis://user:[email protected]/0")
          :: IO (Either SomeException (String, Int, Integer))
      assertBool "credential-bearing Redis URI rejected" (isLeft redisCredential)
      endpointCredential <- try
        (validateAbsoluteUri
          "endpoint"
          ["https"]
          "https://user:[email protected]")
          :: IO (Either SomeException Text)
      assertBool "credential-bearing endpoint rejected"
        (isLeft endpointCredential)
  , testCase "startup retry is bounded and succeeds within its budget" $ do
      calls <- newIORef (0 :: Int)
      result <- retryStartup 3 1 "synthetic" $ do
        modifyIORef' calls (+ 1)
        count <- readIORef calls
        if count < 3 then fail "not ready" else pure count
      result @?= 3
      readIORef calls >>= (@?= 3)
  , testCase "startup retry exhausts its configured budget" $ do
      calls <- newIORef (0 :: Int)
      result <- try $
        retryStartup 2 1 "synthetic" $ do
          modifyIORef' calls (+ 1)
          fail "not ready"
        :: IO (Either SomeException ())
      assertBool "retry exhaustion fails startup" (isLeft result)
      readIORef calls >>= (@?= 2)
  , testCase "audit records retain required fields and drop prohibited fields" $ do
      now <- getCurrentTime
      let record = auditValue now "put" "rejected" (Just "user")
            [ ("root", A.String "shared")
            , ("authorization", A.String "Bearer prohibited")
            , ("token", A.String "prohibited")
            ]
      case record of
        A.Object fields -> do
          assertBool "required timestamp present" (KM.member "ts" fields)
          KM.lookup "action" fields @?= Just (A.String "put")
          KM.lookup "result" fields @?= Just (A.String "rejected")
          KM.lookup "user_id" fields @?= Just (A.String "user")
          KM.lookup "root" fields @?= Just (A.String "shared")
          assertBool "authorization omitted" (not (KM.member "authorization" fields))
          assertBool "token omitted" (not (KM.member "token" fields))
        _ -> assertFailure "audit record was not an object"
  , testCase "audit object keys follow the configured privacy policy" $ do
      objectKeyFields False "private/name" @?= []
      objectKeyFields True "private/name"
        @?= [("object_key", A.String "private/name")]
  ]

productBehaviorTests :: TestTree
productBehaviorTests = testGroup "product behavior"
  [ testCase "search deadline cancels an in-flight listing" $ do
      started <- getMonotonicTimeNSec
      result <- collectKeysBoundedWith
        getMonotonicTimeNSec
        (\_ _ -> do
          threadDelay 100000
          pure (Right (ListPage [] [] Nothing False)))
        100
        (started + 5000000)
      finished <- getMonotonicTimeNSec
      result @?= Right ([], True)
      assertBool "listing returns inside the configured deadline margin"
        (finished - started < 50000000)
  ]

streamingTests :: TestTree
streamingTests = testGroup "streaming"
  [ testCase "upload bodies are inspected and emitted in bounded parts" $ do
      inspected <- newIORef []
      emitted <- newIORef []
      consumeUploadParts
        6
        (strictSha256 "abcdef")
        2
        4
        (\piece -> modifyIORef' inspected (<> [piece]))
        (source ["abcdef"])
        (\part -> modifyIORef' emitted (<> [part]))
      readIORef inspected >>= (@?= ["ab", "cd", "ef"])
      readIORef emitted >>= (@?= ["abcd", "ef"])
  , testCase "multipart buffering has a fixed part-count bound" $
      maximumMultipartBytes @?= toInteger multipartPartBytes * 10000
  , testCase "upload rejects early end, surplus bytes, and identity mismatch" $ do
      short <- uploadFailure 4 (strictSha256 "body") (source ["bod"])
      short @?= UploadStreamSizeMismatch
      long <- uploadFailure 4 (strictSha256 "body") (source ["body!"])
      long @?= UploadStreamSizeMismatch
      identity <- uploadFailure 4 (strictSha256 "else") (source ["body"])
      identity @?= UploadStreamIdentityMismatch
  , testCase "upload preserves source errors" $ do
      failure <- uploadFailure
        4
        (strictSha256 "body")
        (fromStepT (Error "request failed"))
      failure @?= UploadStreamInvalid "request failed"
  ]

uploadFailure
  :: Integer
  -> ContentSha256
  -> SourceT IO BS.ByteString
  -> IO UploadStreamError
uploadFailure size identity body = do
  result <- try $
    consumeUploadParts
      size identity 2 4 (const (pure ())) body (const (pure ()))
  case result of
    Left failure -> pure failure
    Right _ -> fail "expected upload stream rejection"

strictSha256 :: BS.ByteString -> ContentSha256
strictSha256 bytes =
  ContentSha256 . TE.decodeUtf8 . B16.encode . BA.convert $
    (hash bytes :: Digest SHA256)

pathTests :: TestTree
pathTests = testGroup "canonical paths"
  [ testProperty "valid paths parse and render without rewriting" propPathRoundTrip
  , testProperty "invalid paths are rejected" propInvalidPaths
  , testProperty "constructed object keys remain under their root" propRootConfinement
  , testCase "nested cache ancestors include every containing listing" $
      listCacheAncestorPrefixes (RelativePath "docs/a/b.txt")
        @?= ["", "docs", "docs/a"]
  , testCase "root files invalidate the root listing" $
      listCacheAncestorPrefixes (RelativePath "file.txt") @?= [""]
  ]

identityTests :: TestTree
identityTests = testGroup "identities"
  [ testProperty "root labels parse back to the same root" propRootLabels
  , testProperty "mutation kind labels parse back to the same kind" propKindLabels
  , testCase "issuer and subject identity encoding remains stable" $
      encodeUserId "https://issuer.example" "subject-α"
        @?= UserId "e0240ab33521a1882fb647a79f7fd3c74c9b6348b29bdb14e572204517882859"
  , testProperty "issuer and subject inputs are separated" propUserIdentitySeparation
  ]

protocolTests :: TestTree
protocolTests = testGroup "mutation protocol decisions"
  [ testProperty "request fingerprints distinguish every bound field" propFingerprintDistinction
  , testCase "removed terminal identity starts a new mutation epoch" $ do
      let rec = sampleMutation
            Put
            (ObjectKey "users/u/file")
            4
            (Just (ContentSha256 "content"))
      case existingDisposition Nothing Put (mrObjectKey rec) 4 (mrContentSha256 rec) of
        NewMutationEpoch -> pure ()
        other -> assertFailure ("expected new epoch, got " <> show other)
      case existingDisposition (Just rec) Put (mrObjectKey rec) 4 (mrContentSha256 rec) of
        ExistingReplay MutationPending _ -> pure ()
        other -> assertFailure ("expected replay, got " <> show other)
      case existingDisposition (Just rec) Put (mrObjectKey rec) 5 (mrContentSha256 rec) of
        ExistingConflict -> pure ()
        other -> assertFailure ("expected conflict, got " <> show other)
  , testProperty "quota growth and admission preserve the limit" propQuotaInvariant
  , testProperty "object observations match the independent classifier" propObservations
  , testCase "unavailable observations match no terminal state" $ do
      let rec = sampleMutation Put (ObjectKey "shared/file") 10
            (Just (ContentSha256 "desired"))
          observation = ObjectUnavailable "timeout"
      desiredMatches rec observation @?= False
      priorMatches rec observation @?= False
  , testCase "ambiguous same-size content matches no terminal state" $ do
      let rec = (sampleMutation Put (ObjectKey "shared/file") 10
            (Just (ContentSha256 "desired")))
            { mrPriorSize = 10
            , mrPriorSha256 = Just (ContentSha256 "prior")
            }
          observation = ObjectPresent 10 (Just (ContentSha256 "other"))
      desiredMatches rec observation @?= False
      priorMatches rec observation @?= False
  , testProperty "only settled terminal records are expiry eligible" propExpiryEligibility
  , testProperty "terminal identities expire only after the window" propTerminalExpiry
  , testProperty "only stale active records are recovery eligible" propRecoveryTiming
  ]

recoveryTests :: TestTree
recoveryTests = testGroup "recovery"
  [ testProperty "worker lease and settlement independently gate recovery"
      propRecoveryClaim
  , testCase "asynchronous cancellation is not converted to failure" $ do
      result <- try (trySynchronous (throwIO ThreadKilled))
        :: IO (Either AsyncException (Either SomeException ()))
      case result of
        Left ThreadKilled -> pure ()
        other -> assertFailure ("asynchronous exception was swallowed: " <> show other)
  , testCase "linked worker failure interrupts the foreground" $ do
      result <- Timeout.timeout 1000000 $
        try (withLinkedWorker
          (threadDelay 10000 >> fail "worker failed")
          (threadDelay 5000000))
          :: IO (Maybe (Either SomeException ()))
      case result of
        Just (Left _) -> pure ()
        other -> assertFailure ("linked worker did not fail promptly: " <> show other)
  , testCase "structured worker scope cancels and joins the worker" $ do
      started <- newEmptyMVar
      stopped <- newEmptyMVar
      withLinkedWorker
        (putMVar started () >>
          (threadDelay 5000000 `finally` putMVar stopped ()))
        (takeMVar started)
      takeMVar stopped
  , testCase "recovery retry policy has bounded exponential decisions" $ do
      schedule <- simulatePolicy 8 recoveryRetryPolicy
      let decisions = map snd schedule
          retries = length [() | Just _ <- decisions]
      assertBool "retry policy must retry" (retries > 0)
      assertBool "retry policy must be bounded" (retries <= 5)
      assertBool "retry policy must exhaust" (Nothing `elem` decisions)
  ]

oidcTests :: TestTree
oidcTests = testGroup "OIDC validation"
  [ testCase "accepts an exact RS256 ID token" testValidIdToken
  , testCase "accepts an exact configured audience set" testConfiguredAudiences
  , testCase "rejects invalid nonce, algorithm, issuer, signature, and audience"
      testIdTokenCryptographicRejections
  , testCase "rejects malformed, missing-time, future, expired, and overlong tokens"
      testIdTokenTimeAndSerializationRejections
  ]

data TestIdTokenClaims = TestIdTokenClaims
  { testIdTokenRegistered :: ClaimsSet
  , testIdTokenNonce      :: Text
  , testIdTokenAuthorizedParty :: Maybe Text
  , testIdTokenName       :: Maybe Text
  }
  deriving stock (Eq, Show)

instance HasClaimsSet TestIdTokenClaims where
  claimsSet update claims =
    fmap
      (\registered -> claims { testIdTokenRegistered = registered })
      (update (testIdTokenRegistered claims))

instance A.FromJSON TestIdTokenClaims where
  parseJSON value = A.withObject "test ID token" (\object ->
    TestIdTokenClaims
      <$> A.parseJSON value
      <*> object A..: "nonce"
      <*> object A..:? "azp"
      <*> object A..:? "name") value

instance A.ToJSON TestIdTokenClaims where
  toJSON claims =
    case A.toJSON (testIdTokenRegistered claims) of
      A.Object object ->
        let withName =
              maybe
                object
                (\name -> KM.insert "name" (A.String name) object)
                (testIdTokenName claims)
            withAuthorizedParty =
              maybe
                withName
                (\authorizedParty ->
                  KM.insert "azp" (A.String authorizedParty) withName)
                (testIdTokenAuthorizedParty claims)
        in A.Object $
          KM.insert
            "nonce"
            (A.String (testIdTokenNonce claims))
            withAuthorizedParty
      value -> value

testValidIdToken :: IO ()
testValidIdToken = do
  key <- genJWK (RSAGenParam 256)
  now <- getCurrentTime
  compact <- signTestIdToken key RS256
    (testIdClaims now "https://issuer.example" ["nuthatch"] "nonce")
  result <- verifyIdToken
    testConfig
    (JWKSet [key])
    now
    "nonce"
    compact
  result @?= Right OidcIdentity
    { identityIssuer = "https://issuer.example"
    , identitySubject = "upstream-subject"
    , identityDisplay = Just "Example User"
    }

testConfiguredAudiences :: IO ()
testConfiguredAudiences = do
  key <- genJWK (RSAGenParam 256)
  now <- getCurrentTime
  compact <- signTestIdToken key RS256
    ((testIdClaims now "https://issuer.example" ["project", "nuthatch"] "nonce")
      { testIdTokenAuthorizedParty = Just "nuthatch" })
  missingAuthorizedParty <- signTestIdToken key RS256
    (testIdClaims now "https://issuer.example" ["project", "nuthatch"] "nonce")
  result <- verifyIdToken
    testConfig { cfgOidcAdditionalAudiences = ["project"] }
    (JWKSet [key])
    now
    "nonce"
    compact
  rejected <- verifyIdToken
    testConfig { cfgOidcAdditionalAudiences = ["project"] }
    (JWKSet [key])
    now
    "nonce"
    missingAuthorizedParty
  assertBool "the configured audience set is accepted" (isRight result)
  assertBool "a multi-audience token without azp is rejected" (isLeft rejected)

testIdTokenCryptographicRejections :: IO ()
testIdTokenCryptographicRejections = do
  key <- genJWK (RSAGenParam 256)
  otherKey <- genJWK (RSAGenParam 256)
  now <- getCurrentTime
  valid <- signTestIdToken key RS256
    (testIdClaims now "https://issuer.example" ["nuthatch"] "nonce")
  wrongAlgorithm <- signTestIdToken key RS384
    (testIdClaims now "https://issuer.example" ["nuthatch"] "nonce")
  wrongIssuer <- signTestIdToken key RS256
    (testIdClaims now "https://other.example" ["nuthatch"] "nonce")
  wrongSignature <- signTestIdToken otherKey RS256
    (testIdClaims now "https://issuer.example" ["nuthatch"] "nonce")
  wrongAudience <- signTestIdToken key RS256
    (testIdClaims now "https://issuer.example" ["other"] "nonce")
  multipleAudience <- signTestIdToken key RS256
    (testIdClaims now "https://issuer.example" ["nuthatch", "other"] "nonce")
  let rejected =
        [ verifyIdToken testConfig (JWKSet [key]) now "other-nonce" valid
        , verifyIdToken testConfig (JWKSet [key]) now "nonce" wrongAlgorithm
        , verifyIdToken testConfig (JWKSet [key]) now "nonce" wrongIssuer
        , verifyIdToken testConfig (JWKSet [key]) now "nonce" wrongSignature
        , verifyIdToken testConfig (JWKSet [key]) now "nonce" wrongAudience
        , verifyIdToken testConfig (JWKSet [key]) now "nonce" multipleAudience
        ]
  results <- sequence rejected
  assertBool "every invalid cryptographic or binding case is rejected"
    (all isLeft results)

testIdTokenTimeAndSerializationRejections :: IO ()
testIdTokenTimeAndSerializationRejections = do
  key <- genJWK (RSAGenParam 256)
  now <- getCurrentTime
  missingIssuedAt <- signTestIdToken key RS256
    ((testIdClaims now "https://issuer.example" ["nuthatch"] "nonce")
      { testIdTokenRegistered =
          emptyClaimsSet
            & claimIss ?~ "https://issuer.example"
            & claimSub ?~ "upstream-subject"
            & claimAud ?~ Audience ["nuthatch"]
            & claimExp ?~ NumericDate (addUTCTime 300 now)
      })
  future <- signTestIdToken key RS256
    (testIdClaimsAt
      (addUTCTime 60 now)
      (addUTCTime 300 now)
      "https://issuer.example"
      ["nuthatch"]
      "nonce")
  expired <- signTestIdToken key RS256
    (testIdClaimsAt
      (addUTCTime (-600) now)
      (addUTCTime (-300) now)
      "https://issuer.example"
      ["nuthatch"]
      "nonce")
  overlong <- signTestIdToken key RS256
    (testIdClaimsAt
      now
      (addUTCTime 7200 now)
      "https://issuer.example"
      ["nuthatch"]
      "nonce")
  results <- sequence
    [ verifyIdToken testConfig (JWKSet [key]) now "nonce" "not.compact"
    , verifyIdToken testConfig (JWKSet [key]) now "nonce" missingIssuedAt
    , verifyIdToken testConfig (JWKSet [key]) now "nonce" future
    , verifyIdToken testConfig (JWKSet [key]) now "nonce" expired
    , verifyIdToken testConfig (JWKSet [key]) now "nonce" overlong
    ]
  assertBool "every invalid serialization or time case is rejected"
    (all isLeft results)

testIdClaims
  :: UTCTime
  -> Text
  -> [Text]
  -> Text
  -> TestIdTokenClaims
testIdClaims now issuer audiences nonce =
  testIdClaimsAt
    now
    (addUTCTime 300 now)
    issuer
    audiences
    nonce

testIdClaimsAt
  :: UTCTime
  -> UTCTime
  -> Text
  -> [Text]
  -> Text
  -> TestIdTokenClaims
testIdClaimsAt issuedAt expiresAt issuer audiences nonce =
  TestIdTokenClaims
    { testIdTokenRegistered =
        emptyClaimsSet
          & claimIss ?~ fromString (T.unpack issuer)
          & claimSub ?~ "upstream-subject"
          & claimAud ?~ Audience (map (fromString . T.unpack) audiences)
          & claimIat ?~ NumericDate issuedAt
          & claimExp ?~ NumericDate expiresAt
    , testIdTokenNonce = nonce
    , testIdTokenAuthorizedParty = Nothing
    , testIdTokenName = Just "Example User"
    }

signTestIdToken
  :: JWK
  -> Alg
  -> TestIdTokenClaims
  -> IO Text
signTestIdToken key algorithm claims = do
  result <- runJOSE $
    encodeCompact <$> signJWT key (newJWSHeaderProtected algorithm) claims
  case result of
    Left (err :: JWTError) -> fail (show err)
    Right compact -> pure (TE.decodeUtf8 (BL.toStrict compact))

apiTests :: TestTree
apiTests = testGroup "typed HTTP boundary"
  [ testCase "Servant selects routes and methods" testRouteSelection
  , testCase "valid query values reach a typed handler" testValidDecoding
  , testCase "invalid roots and paths fail before handler execution" testInvalidDomains
  , testCase "malformed UTF-8 fails before handler execution" testMalformedUtf8
  , testCase "upload headers and operation ids decode before streaming handler execution"
      testUploadDecoding
  , testCase "upload and download bodies use Servant streaming endpoints"
      testStreamingEndpoints
  , testCase "operation-specific JSON requests and responses remain distinct"
      testOperationRepresentations
  , testCase "operation-specific errors have closed distinct representations" $ do
      let loginError = A.encode OidcCallbackRejected
          deleteError = A.encode (DeleteMutationRejected "locked")
          prefixError = A.encode (DeletePrefixMutationRejected "partial")
      assertBool "login errors carry the login-specific code"
        ("oidc_callback_rejected" `BS.isInfixOf` BL.toStrict loginError)
      assertBool "delete errors carry the mutation-specific code"
        ("mutation_rejected" `BS.isInfixOf` BL.toStrict deleteError)
      assertBool "operation errors must not share one representation"
        (loginError /= deleteError && deleteError /= prefixError)
      assertBool "prefix errors carry their operation-specific code"
        ("prefix_mutation_rejected" `BS.isInfixOf` BL.toStrict prefixError)
  , testCase "production authentication validates cookies and callback emits secure cookies"
      testAuthenticationBoundary
  , testCase "only canonical product routes are exposed"
      testCanonicalProductRoutes
  , testCase "links derive from the type-level API" $
      show (linkURI (safeLink api (Proxy :: Proxy HealthEndpoint)))
        @?= "healthz"
  ]

testRouteSelection :: IO ()
testRouteSelection = do
  calls <- newIORef 0
  response <- apiRequest calls methodGet "/healthz" [] ""
  simpleStatus response @?= status200
  readIORef calls >>= (@?= 1)
  writeIORef calls 0
  wrongMethod <- apiRequest calls methodPost "/healthz" [] ""
  simpleStatus wrongMethod @?= status405
  readIORef calls >>= (@?= 0)
  missing <- apiRequest calls methodGet "/missing" [] ""
  simpleStatus missing @?= status404
  readIORef calls >>= (@?= 0)

testValidDecoding :: IO ()
testValidDecoding = do
  calls <- newIORef 0
  response <- apiRequest calls methodGet
    "/api/browse?root=personal&prefix=docs%2Freports&q=quarterly&continuation=next"
    []
    ""
  simpleStatus response @?= status200
  readIORef calls >>= (@?= 1)

testInvalidDomains :: IO ()
testInvalidDomains = do
  calls <- newIORef 0
  invalidRoot <- apiRequest calls methodGet "/api/browse?root=PERSONAL" [] ""
  simpleStatus invalidRoot @?= status400
  invalidPath <- apiRequest calls methodGet
    "/api/browse?prefix=docs%2F..%2Fprivate" [] ""
  simpleStatus invalidPath @?= status400
  readIORef calls >>= (@?= 0)

testMalformedUtf8 :: IO ()
testMalformedUtf8 = do
  calls <- newIORef 0
  response <- apiRequest calls methodGet "/api/browse?q=%FF" [] ""
  simpleStatus response @?= status400
  readIORef calls >>= (@?= 0)

testUploadDecoding :: IO ()
testUploadDecoding = do
  calls <- newIORef 0
  let csrf = BS.replicate 43 97
  let headers =
        [ ("Content-Type", "application/octet-stream")
        , ("X-Declared-Size", "4")
        , ("X-Content-SHA256", BS.replicate 64 97)
        , ("X-CSRF-Token", csrf)
        ]
  response <- apiRequest calls methodPost
    "/api/upload?root=personal&path=docs%2Ffile.txt&operation_id=bad%20id"
    headers
    "body"
  simpleStatus response @?= status400
  invalidSize <- apiRequest calls methodPost
    "/api/upload?root=personal&path=docs%2Ffile.txt&operation_id=upload-1"
    (replaceHeader "X-Declared-Size" "zero" headers)
    "body"
  simpleStatus invalidSize @?= status400
  invalidPagination <- apiRequest calls methodGet
    "/api/browse?continuation=" [] ""
  simpleStatus invalidPagination @?= status400
  readIORef calls >>= (@?= 0)

testStreamingEndpoints :: IO ()
testStreamingEndpoints = do
  calls <- newIORef 0
  let csrf = BS.replicate 43 97
  let headers =
        [ ("Content-Type", "application/octet-stream")
        , ("X-Declared-Size", "4")
        , ("X-Content-SHA256", BS.replicate 64 97)
        , ("X-CSRF-Token", csrf)
        ]
  upload <- apiRequest calls methodPost
    "/api/upload?root=personal&path=docs%2Ffile.txt&operation_id=upload-1"
    headers
    "body"
  simpleStatus upload @?= status200
  assertBool "upload advertises the idempotency window"
    ("\"idempotency_window_seconds\":3600"
      `BS.isInfixOf` BL.toStrict (simpleBody upload))
  download <- apiRequest calls methodGet
    "/api/download?root=shared&path=docs%2Ffile.txt"
    []
    ""
  simpleStatus download @?= status200
  simpleBody download @?= "body"
  lookup "Content-Disposition" (simpleHeaders download)
    @?= Just "attachment; filename=\"file.txt\""
  lookup "X-Content-Type-Options" (simpleHeaders download)
    @?= Just "nosniff"
  readIORef calls >>= (@?= 2)

testOperationRepresentations :: IO ()
testOperationRepresentations = do
  calls <- newIORef 0
  login <- apiRequest calls methodGet "/login" [] ""
  simpleStatus login @?= status303
  lookup "Location" (simpleHeaders login) @?= Just "https://issuer.example/authorize"
  callback <- apiRequest calls methodGet
    "/oidc/callback?code=code&state=state"
    [("Cookie", "nuthatch_oidc=transaction")]
    ""
  simpleStatus callback @?= status303
  wrongLoginMethod <- apiRequest calls methodPost "/login" [] ""
  simpleStatus wrongLoginMethod @?= status405
  deletion <- apiRequest calls methodPost
    "/api/delete"
    [("Content-Type", "application/json")]
    "{\"root\":\"shared\",\"path\":\"docs/file.txt\",\"operation_id\":\"delete-1\",\"csrf\":\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"}"
  simpleStatus deletion @?= status200
  assertBool "delete response must carry a mutation result"
    ("succeeded" `BS.isInfixOf` BL.toStrict (simpleBody deletion))
  assertBool "delete advertises the idempotency window"
    ("\"idempotency_window_seconds\":3600"
      `BS.isInfixOf` BL.toStrict (simpleBody deletion))
  malformed <- apiRequest calls methodPost
    "/api/delete"
    [("Content-Type", "application/json")]
    "{\"root\":\"shared\",\"path\":\"../escape\"}"
  simpleStatus malformed @?= status400
  readIORef calls >>= (@?= 3)

replaceHeader
  :: HeaderName
  -> BS.ByteString
  -> [(HeaderName, BS.ByteString)]
  -> [(HeaderName, BS.ByteString)]
replaceHeader name value =
  map $ \(headerName, headerValue) ->
    if headerName == name
      then (headerName, value)
      else (headerName, headerValue)

apiRequest
  :: IORef Int
  -> BS.ByteString
  -> BS.ByteString
  -> [(HeaderName, BS.ByteString)]
  -> BL.ByteString
  -> IO SResponse
apiRequest calls method path headers body =
  apiRequestWith (typedTestApplication calls) method path headers body

apiRequestWith
  :: Application
  -> BS.ByteString
  -> BS.ByteString
  -> [(HeaderName, BS.ByteString)]
  -> BL.ByteString
  -> IO SResponse
apiRequestWith app method path headers body =
  runSession
    (srequest
      (SRequest
        (setPath defaultRequest
          { requestMethod = method
          , requestHeaders = headers
          }
          path)
        body))
    app

typedTestApplication :: IORef Int -> Application
typedTestApplication calls =
  utf8Boundary $
    serveWithContext api (auth :. EmptyContext) (typedTestServer calls)
  where
    auth :: AuthHandler Request SessionContext
    auth = mkAuthHandler $ \_ -> pure SessionContext
      { sessionUser = SessionUser
          { suIssuer = "issuer"
          , suSubject = "subject"
          , suUserId = UserId "user"
          , suDisplay = Nothing
          }
      , sessionCsrf = Just
          (CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
      }

typedTestServer :: IORef Int -> Server Api
typedTestServer calls =
       counted (HealthResponse True)
  :<|> counted (ReadyResponse True)
  :<|> (\_ -> counted (addHeader "default-src 'none'" (HtmlPage "app")))
  :<|> (\_ -> Tagged $ \_ sendResponse ->
        sendResponse (responseLBS status404 [] ""))
  :<|> counted
        (addHeader "transaction=cookie"
          (addHeader "https://issuer.example/authorize" NoContent))
  :<|> (\_ _ _ -> counted
        (addHeader "session=cookie"
          (addHeader "csrf=cookie"
            (addHeader "transaction=expired"
              (addHeader "/app" NoContent)))))
  :<|> (\_ _ -> counted
        (addHeader "session=expired"
          (addHeader "csrf=expired"
            (addHeader "transaction=expired" NoContent))))
  :<|>
    (    (\session -> counted SessionResponse
            { sessionResponseUserId = suUserId (sessionUser session)
            , sessionResponseDisplay = Nothing
            , sessionResponseCsrf =
                CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
            })
    :<|> (\_ _ _ _ _ -> counted emptyBrowse)
    :<|> (\_ _ _ _ -> counted downloadResponse)
    :<|> (\_ _ _ operation _ _ _ _ -> counted UploadResponse
          { uploadResponseOperationId = operation
          , uploadResponseResult = MutationSucceeded
          , uploadResponseIdempotencyWindowSeconds = 3600
          })
    :<|> (\_ request -> counted DeleteResponse
          { deleteResponseOperationId = deleteOperationId request
          , deleteResponseResult = MutationSucceeded
          , deleteResponseIdempotencyWindowSeconds = 3600
          })
    :<|> (\_ _ _ _ -> counted DeletePlanResponse
          { deletePlanPaths = []
          , deletePlanContinuation = Nothing
          })
    :<|> (\_ _ -> counted (DeleteBatchResponse []))
    )
  where
    counted :: a -> Handler a
    counted value = liftIO (modifyIORef' calls (+ 1)) >> pure value
    emptyBrowse =
      BrowseResponse
        { browseEntries = []
        , browseContinuation = Nothing
        , browsePartial = False
        }
    downloadResponse =
      addHeader "attachment; filename=\"file.txt\"" $
        addHeader "nosniff" $
          addHeader "sandbox" $
            addHeader 4 (source ["body"])

testAuthenticationBoundary :: IO ()
testAuthenticationBoundary = do
  tokenResult <- mintSession testConfig "issuer" "subject" Nothing
  token <- either (fail . T.unpack) pure tokenResult
  let csrf = CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
      responseHeaders = getHeaders
        (loginResponse testConfig token csrf)
      cookieHeaders =
        [ value
        | (name, value) <- responseHeaders
        , name == "Set-Cookie"
        ]
  lookup "Location" responseHeaders @?= Just "/app"
  length cookieHeaders @?= 3
  assertBool "login sets the session cookie"
    (any ("nuthatch_session=" `BS.isPrefixOf`) cookieHeaders)
  assertBool "login sets the CSRF cookie"
    (any ("nuthatch_csrf=" `BS.isPrefixOf`) cookieHeaders)
  assertBool "cookies are secure and same-site"
    (all ("Secure" `BS.isInfixOf`) cookieHeaders
      && all ("SameSite=Lax" `BS.isInfixOf`) cookieHeaders)
  assertBool "cookies are host-only"
    (all (not . ("Domain=" `BS.isInfixOf`)) cookieHeaders)
  assertBool "session and CSRF cookies use the root path"
    (length (filter ("Path=/;" `BS.isInfixOf`) cookieHeaders) == 2)
  assertBool "the transaction cookie uses the callback path"
    (any ("Path=/oidc/callback;" `BS.isInfixOf`) cookieHeaders)
  assertBool "session and transaction cookies are HTTP-only"
    (length (filter ("HttpOnly" `BS.isInfixOf`) cookieHeaders) == 2)

  calls <- newIORef 0
  let app = productionAuthTestApplication testConfig calls
      cookie =
        "nuthatch_session=" <> TE.encodeUtf8 (unSessionToken token)
          <> "; nuthatch_csrf=" <> TE.encodeUtf8 (unCsrfToken csrf)
  authenticated <- apiRequestWith app methodGet
    "/api/browse?root=personal"
    [("Cookie", cookie)]
    ""
  simpleStatus authenticated @?= status200
  readIORef calls >>= (@?= 1)

  writeIORef calls 0
  malformed <- apiRequestWith app methodGet
    "/api/browse?root=personal"
    [("Cookie", "nuthatch_session=" <> BS.singleton 255
      <> "; nuthatch_csrf=" <> TE.encodeUtf8 (unCsrfToken csrf))]
    ""
  simpleStatus malformed @?= status400
  readIORef calls >>= (@?= 0)

  malformedGrammar <- apiRequestWith app methodGet
    "/api/browse?root=personal"
    [("Cookie", "nuthatch_session")]
    ""
  simpleStatus malformedGrammar @?= status400
  readIORef calls >>= (@?= 0)

  let tamperedToken =
        case T.unsnoc (unSessionToken token) of
          Just (prefix, final)
            | final == 'a' -> prefix <> "b"
            | otherwise -> prefix <> "a"
          Nothing -> "invalid"
  tampered <- apiRequestWith app methodGet
    "/api/browse?root=personal"
    [("Cookie", "nuthatch_session=" <> TE.encodeUtf8 tamperedToken)]
    ""
  simpleStatus tampered @?= status303
  readIORef calls >>= (@?= 0)

  missingCsrf <- apiRequestWith app methodGet
    "/api/browse?root=personal"
    [("Cookie", "nuthatch_session=" <> TE.encodeUtf8 (unSessionToken token))]
    ""
  simpleStatus missingCsrf @?= status200
  readIORef calls >>= (@?= 1)

testCanonicalProductRoutes :: IO ()
testCanonicalProductRoutes = do
  calls <- newIORef 0
  forM_
    [ (methodGet, "/")
    , (methodGet, "/nuthatch.js")
    , (methodGet, "/download?root=personal&path=file")
    , (methodPost, "/upload")
    , (methodPost, "/delete")
    , (methodPost, "/delete-prefix")
    ] $ \(method, path) -> do
      response <- apiRequest calls method path [] ""
      simpleStatus response @?= status404
  readIORef calls >>= (@?= 0)

productionAuthTestApplication :: Config -> IORef Int -> Application
productionAuthTestApplication cfg calls =
  utf8Boundary $
    serveWithContext
      api
      (authenticationHandler cfg :. EmptyContext)
      (typedTestServer calls)

testConfig :: Config
testConfig = Config
  { cfgListenHost = "127.0.0.1"
  , cfgListenPort = 8080
  , cfgTlsCertPath = "/tls/tls.crt"
  , cfgTlsKeyPath = "/tls/tls.key"
  , cfgPublicBaseUrl = "https://nuthatch.example"
  , cfgJwtSecret = secret "unit-test-session-secret-material-32"
  , cfgSessionHours = 1
  , cfgCookieName = "nuthatch_session"
  , cfgCsrfCookieName = "nuthatch_csrf"
  , cfgOidcTransactionCookieName = "nuthatch_oidc"
  , cfgOidcIssuer = "https://issuer.example"
  , cfgOidcClientId = "nuthatch"
  , cfgOidcAdditionalAudiences = []
  , cfgOidcClientSecret = secret "unit-test-client-secret"
  , cfgOidcRedirectUri = "https://nuthatch.example/oidc/callback"
  , cfgOidcTransactionMinutes = 5
  , cfgOidcMaxIdTokenSeconds = 3600
  , cfgPgConn = secret ""
  , cfgRedisHost = ""
  , cfgRedisPort = 6379
  , cfgRedisDb = 0
  , cfgS3Endpoint = "https://s3.example"
  , cfgS3Region = "test"
  , cfgS3Bucket = "test"
  , cfgS3AccessKey = secret "test"
  , cfgS3SecretKey = secret "test"
  , cfgS3PathStyle = True
  , cfgPersonalQuotaBytes = 1024
  , cfgSharedQuotaBytes = 1024
  , cfgMaxObjectBytes = 1024
  , cfgThrottleBytesPerSec = 1024
  , cfgThrottleBurstBytes = 1024
  , cfgListCacheTtlSec = 30
  , cfgBrowsePageSize = 100
  , cfgSearchMaxKeys = 100
  , cfgSearchTimeoutMs = 1000
  , cfgDeletePageSize = 100
  , cfgRecoveryGraceSec = 30
  , cfgIdempotencyWindowSec = 3600
  , cfgObjectRequestTimeoutSec = 300
  , cfgStartupAttempts = 3
  , cfgStartupDelayMs = 10
  , cfgAuditObjectKeys = False
  }

newtype ValidPath = ValidPath { getValidPath :: Text }
  deriving stock (Show)

newtype InvalidPath = InvalidPath { getInvalidPath :: Text }
  deriving stock (Show)

genValidPath :: Gen ValidPath
genValidPath = do
  segments <- Gen.list (Range.linear 1 6) genSegment
  pure (ValidPath (T.intercalate "/" segments))
  where
    genSegment =
      Gen.filter (`notElem` [".", ".."]) $
        Gen.text (Range.linear 1 16) $
          Gen.choice [Gen.alphaNum, Gen.element ("_-. " :: String)]

genInvalidPath :: Gen InvalidPath
genInvalidPath = do
  ValidPath valid <- genValidPath
  InvalidPath <$> Gen.element
    [ ""
    , "/" <> valid
    , valid <> "/"
    , valid <> "//tail"
    , valid <> "/../tail"
    , valid <> "/./tail"
    , valid <> "/back\\slash"
    , valid <> "/control\NUL"
    , "e\x0301"
    ]

propPathRoundTrip :: Property
propPathRoundTrip = property $ do
  ValidPath raw <- forAll genValidPath
  validateRelativePath raw === Right (RelativePath raw)

propInvalidPaths :: Property
propInvalidPaths = property $ do
  InvalidPath raw <- forAll genInvalidPath
  assert (isLeft (validateRelativePath raw))

propRootConfinement :: Property
propRootConfinement = property $ do
  ValidPath raw <- forAll genValidPath
  let path = RelativePath raw
      uid = encodeUserId "https://issuer.example" "subject"
      personalPrefix = "users/" <> unUserId uid <> "/"
      personalKey = unObjectKey (buildObjectKey Personal uid path)
      sharedKey = unObjectKey (buildObjectKey Shared uid path)
  assert (personalPrefix `T.isPrefixOf` personalKey)
  assert ("shared/" `T.isPrefixOf` sharedKey)
  assert (not ("shared/" `T.isPrefixOf` personalKey))
  assert (not ("users/" `T.isPrefixOf` sharedKey))

propRootLabels :: Property
propRootLabels = property $ do
  root <- forAll (Gen.element [Personal, Shared])
  parseRoot (rootLabel root) === Just root

propKindLabels :: Property
propKindLabels = property $ do
  kind <- forAll (Gen.element [Put, Delete])
  parseKind (kindLabel kind) === Just kind

propUserIdentitySeparation :: Property
propUserIdentitySeparation = property $ do
  issuer <- forAll genIdentityPart
  subject <- forAll genIdentityPart
  otherIssuer <- forAll (Gen.filter (/= issuer) genIdentityPart)
  other <- forAll (Gen.filter (/= subject) genIdentityPart)
  assert (encodeUserId issuer subject /= encodeUserId otherIssuer subject)
  assert (encodeUserId issuer subject /= encodeUserId issuer other)
  where
    genIdentityPart = Gen.text (Range.linear 1 32) Gen.alphaNum

propFingerprintDistinction :: Property
propFingerprintDistinction = property $ do
  ValidPath raw <- forAll genValidPath
  size <- forAll (Gen.integral (Range.linear 1 1000000))
  let uid = encodeUserId "issuer" "subject"
      key = buildObjectKey Personal uid (RelativePath raw)
      otherRootKey = buildObjectKey Shared uid (RelativePath raw)
      otherPathKey = buildObjectKey Personal uid (RelativePath ("other/" <> raw))
      sha = Just (ContentSha256 "content-a")
      rec = sampleMutation Put key size sha
  assert (sameFingerprint rec Put key size sha)
  assert (not (sameFingerprint rec Delete key size sha))
  assert (not (sameFingerprint rec Put otherRootKey size sha))
  assert (not (sameFingerprint rec Put otherPathKey size sha))
  assert (not (sameFingerprint rec Put key (size + 1) sha))
  assert (not (sameFingerprint rec Put key size (Just (ContentSha256 "content-b"))))

propQuotaInvariant :: Property
propQuotaInvariant = property $ do
  prior <- forAll nonNegativeBytes
  desired <- forAll nonNegativeBytes
  used <- forAll nonNegativeBytes
  reserved <- forAll nonNegativeBytes
  limit <- forAll nonNegativeBytes
  let growth = growthBytes prior desired
      modelGrowth = max 0 (desired - prior)
      allowed = quotaAllows limit used reserved growth
  growth === modelGrowth
  assert (growth >= 0)
  allowed === (used + reserved + modelGrowth <= limit)
  if allowed
    then assert (used + reserved + growth <= limit)
    else assert (used + reserved + growth > limit)
  where
    nonNegativeBytes = Gen.integral (Range.linear 0 1000000000)

propObservations :: Property
propObservations = property $ do
  kind <- forAll (Gen.element [Put, Delete])
  desiredSize <- forAll (Gen.integral (Range.linear 1 1000000))
  priorSize <- forAll (Gen.integral (Range.linear 0 1000000))
  observation <- forAll genObservation
  let desiredSha = Just (ContentSha256 "desired")
      priorSha = if priorSize == 0 then Nothing else Just (ContentSha256 "prior")
      rec = (sampleMutation kind (ObjectKey "users/u/file") desiredSize desiredSha)
        { mrPriorSize = priorSize
        , mrPriorSha256 = priorSha
        }
  desiredMatches rec observation === modelDesired kind desiredSize desiredSha observation
  priorMatches rec observation === modelPrior priorSize priorSha observation

propExpiryEligibility :: Property
propExpiryEligibility = property $ do
  state <- forAll genMutationState
  external <- forAll genExternalState
  terminalExpiryEligible state external
    === (state `elem` [Succeeded, Failed, Rejected] && external == ExtIdle)

propTerminalExpiry :: Property
propTerminalExpiry = property $ do
  state <- forAll genMutationState
  external <- forAll genExternalState
  elapsed <- forAll (Gen.integral (Range.linear 0 10000))
  window <- forAll (Gen.integral (Range.linear 1 10000))
  terminalExpired state external elapsed window
    === ( state `elem` [Succeeded, Failed, Rejected]
          && external == ExtIdle
          && elapsed > window
        )

propRecoveryTiming :: Property
propRecoveryTiming = property $ do
  state <- forAll genMutationState
  elapsed <- forAll (Gen.integral (Range.linear 0 10000))
  grace <- forAll (Gen.integral (Range.linear 0 10000))
  recoveryEligible state elapsed grace
    === (state `elem` [Prepared, Applying] && elapsed > grace)

propRecoveryClaim :: Property
propRecoveryClaim = property $ do
  state <- forAll genMutationState
  external <- forAll genExternalState
  elapsed <- forAll (Gen.integral (Range.linear 0 10000))
  grace <- forAll (Gen.integral (Range.linear 0 10000))
  leaseExpired <- forAll Gen.bool
  deadlineExpired <- forAll Gen.bool
  recoveryClaimEligible
    state
    external
    elapsed
    grace
    leaseExpired
    deadlineExpired
    === ( state `elem` [Prepared, Applying]
          && case external of
               ExtIdle -> elapsed > grace
               ExtSettled -> elapsed > grace
               ExtPending -> leaseExpired && deadlineExpired
        )

genObservation :: Gen ObjectObservation
genObservation = Gen.choice
  [ pure ObjectAbsent
  , pure (ObjectUnavailable "dependency unavailable")
  , ObjectPresent
      <$> Gen.integral (Range.linear 0 1000000)
      <*> Gen.element
        [ Nothing
        , Just (ContentSha256 "desired")
        , Just (ContentSha256 "prior")
        , Just (ContentSha256 "other")
        ]
  ]

modelDesired
  :: MutationKind
  -> Integer
  -> Maybe ContentSha256
  -> ObjectObservation
  -> Bool
modelDesired kind size sha observation =
  case (kind, observation) of
    (Delete, ObjectAbsent) -> True
    (Put, ObjectPresent observedSize observedSha) ->
      observedSize == size
        && case (sha, observedSha) of
             (Just expected, Just actual) -> expected == actual
             (Just _, Nothing)            -> False
             (Nothing, _)                 -> True
    _ -> False

modelPrior
  :: Integer
  -> Maybe ContentSha256
  -> ObjectObservation
  -> Bool
modelPrior size sha observation =
  case observation of
    ObjectUnavailable _ -> False
    ObjectAbsent -> size == 0 && sha == Nothing
    ObjectPresent observedSize observedSha ->
      observedSize == size
        && case (sha, observedSha) of
             (Just expected, Just actual) -> expected == actual
             (Nothing, Nothing)           -> True
             (Just _, Nothing)            -> False
             (Nothing, Just _)            -> True

genMutationState :: Gen MutationState
genMutationState =
  Gen.element [Prepared, Applying, Succeeded, Failed, Rejected]

genExternalState :: Gen ExternalState
genExternalState = Gen.element [ExtIdle, ExtPending, ExtSettled]

sampleMutation
  :: MutationKind
  -> ObjectKey
  -> Integer
  -> Maybe ContentSha256
  -> MutationRecord
sampleMutation kind key size sha = MutationRecord
  { mrUserId = UserId "u"
  , mrKind = kind
  , mrOperationId = OperationId "op"
  , mrPoolId = PoolId "personal:u"
  , mrObjectKey = key
  , mrRelativePath = RelativePath "file"
  , mrDeclaredSize = size
  , mrContentSha256 = sha
  , mrPriorSize = 0
  , mrPriorSha256 = Nothing
  , mrGrowth = size
  , mrState = Applying
  , mrExternal = ExtSettled
  }