nuthatch/test/Spec.hs

module Main (main) where

import           Control.Monad.IO.Class (liftIO)
import qualified Data.Aeson as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import           Data.Either (isLeft)
import           Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
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
  , status400
  , status404
  , status405
  )
import           Network.Wai (Request (..))
import           Network.Wai.Test
  ( SRequest (..)
  , SResponse (..)
  , defaultRequest
  , runSession
  , setPath
  , srequest
  )
import           Nuthatch.Api
import           Nuthatch.App
  ( authenticationHandler
  , loginResponse
  , utf8Boundary
  )
import           Nuthatch.Config (AuthMode (..), Config (..))
import           Nuthatch.Paths
  ( buildObjectKey
  , encodeUserId
  , listCacheAncestorPrefixes
  )
import           Nuthatch.Protocol
  ( MutationRecord (..)
  , ObjectObservation (..)
  , desiredMatches
  , growthBytes
  , priorMatches
  , quotaAllows
  , recoveryEligible
  , sameFingerprint
  , terminalExpiryEligible
  )
import           Nuthatch.Types
import           Nuthatch.Session (mintSession)
import           Nuthatch.Ui (browsePage, browserScript, loginPage)
import           Servant
import           Servant.Server.Experimental.Auth (AuthHandler, mkAuthHandler)
import           Servant.Types.SourceT (source)
import           Test.Tasty (TestTree, defaultMain, testGroup)
import           Test.Tasty.HUnit ((@?=), assertBool, testCase)
import           Test.Tasty.Hedgehog (testProperty)

main :: IO ()
main = defaultMain tests

tests :: TestTree
tests = testGroup "nuthatch-unit"
  [ pathTests
  , identityTests
  , protocolTests
  , apiTests
  ]

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
  , 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 "only stale active records are recovery eligible" propRecoveryTiming
  ]

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 InvalidUsername
          deleteError = A.encode (DeleteMutationRejected "locked")
          prefixError = A.encode (DeletePrefixMutationRejected "partial")
      assertBool "login errors carry the login-specific code"
        ("invalid_username" `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 login emits both cookies"
      testAuthenticationBoundary
  , testCase "retained browser forms are wired to the typed API bridge"
      testBrowserBridge
  , 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
    "/?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 "/?root=PERSONAL" [] ""
  simpleStatus invalidRoot @?= status400
  invalidPath <- apiRequest calls methodGet "/?prefix=docs%2F..%2Fprivate" [] ""
  simpleStatus invalidPath @?= status400
  readIORef calls >>= (@?= 0)

testMalformedUtf8 :: IO ()
testMalformedUtf8 = do
  calls <- newIORef 0
  response <- apiRequest calls methodGet "/?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
    "/upload?root=personal&path=docs%2Ffile.txt&operation_id=bad%20id"
    headers
    "body"
  simpleStatus response @?= status400
  invalidSize <- apiRequest calls methodPost
    "/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 "/?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
    "/upload?root=personal&path=docs%2Ffile.txt&operation_id=upload-1"
    headers
    "body"
  simpleStatus upload @?= status200
  download <- apiRequest calls methodGet
    "/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 methodPost
    "/login"
    [ ("Content-Type", "application/json")
    , ("Accept", "application/json")
    ]
    "{\"username\":\"alice\"}"
  simpleStatus login @?= status200
  assertBool "login response must carry a user identity"
    ("user_id" `BS.isInfixOf` BL.toStrict (simpleBody login))
  formLogin <- apiRequest calls methodPost
    "/login"
    [("Content-Type", "application/x-www-form-urlencoded")]
    "username=bob"
  simpleStatus formLogin @?= status200
  assertBool "browser login response navigates into the UI"
    ("continue" `BS.isInfixOf` BL.toStrict (simpleBody formLogin))
  invalidLogin <- apiRequest calls methodPost
    "/login"
    [("Content-Type", "application/json")]
    "{\"username\":\"two words\"}"
  simpleStatus invalidLogin @?= status400
  deletion <- apiRequest calls methodPost
    "/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))
  malformed <- apiRequest calls methodPost
    "/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 (HtmlPage "login")
  :<|> counted (BrowserScript "script")
  :<|> (\_ -> counted
        (addHeader "session=cookie"
          (addHeader "csrf=cookie"
            (addHeader (CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
              (LoginView
                (HtmlPage "continue")
                (LoginResponse (UserId "user")))))))
  :<|> (\_ _ -> counted
        (addHeader "session=expired"
          (addHeader "csrf=expired" NoContent)))
  :<|> (\_ _ _ _ _ -> counted
        (BrowseView
          (HtmlPage "browse")
          BrowseResponse
            { browseEntries = []
            , browseContinuation = Nothing
            , browsePartial = False
            }))
  :<|> (\_ _ _ -> counted
        (addHeader "attachment; filename=\"file.txt\""
          (addHeader "nosniff" (source ["body"]))))
  :<|> (\_ _ _ operation _ _ _ _ -> counted UploadResponse
        { uploadResponseOperationId = operation
        , uploadResponseResult = MutationSucceeded
        })
  :<|> (\_ request -> counted DeleteResponse
        { deleteResponseOperationId = deleteOperationId request
        , deleteResponseResult = MutationSucceeded
        })
  :<|> (\_ _ -> counted (DeletePrefixResponse 1))
  where
    counted :: a -> Handler a
    counted value = liftIO (modifyIORef' calls (+ 1)) >> pure value

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 (UserId "user") token csrf)
      cookieHeaders =
        [ value
        | (name, value) <- responseHeaders
        , name == "Set-Cookie"
        ]
  length cookieHeaders @?= 2
  assertBool "login sets the session cookie"
    (any ("nuthatch_session=" `BS.isPrefixOf`) cookieHeaders)
  assertBool "login sets the CSRF cookie"
    (any ("nuthatch_csrf=" `BS.isPrefixOf`) cookieHeaders)

  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
    "/?root=personal"
    [("Cookie", cookie)]
    ""
  simpleStatus authenticated @?= status200
  readIORef calls >>= (@?= 1)

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

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

testBrowserBridge :: IO ()
testBrowserBridge = do
  let csrf = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
      user = SessionUser
        { suIssuer = "issuer"
        , suSubject = "subject"
        , suUserId = UserId "user"
        , suDisplay = Just "User"
        }
      entry = ListEntry
        { leName = "folder"
        , leIsPrefix = True
        , leSize = Nothing
        , leRelativePath = "folder"
        }
      browse = browsePage
        user
        Personal
        ""
        csrf
        "upload-1"
        ["delete-1"]
        [entry]
        Nothing
        ""
  assertBool "login page loads the external bridge"
    ("/nuthatch.js" `T.isInfixOf` loginPage "")
  mapM_
    (\marker -> assertBool ("browse page includes " <> T.unpack marker)
      (marker `T.isInfixOf` browse))
    [ "data-nuthatch=\"upload\""
    , "data-nuthatch=\"delete\""
    , "data-nuthatch=\"logout\""
    ]
  mapM_
    (\endpoint -> assertBool ("bridge calls " <> T.unpack endpoint)
      (endpoint `T.isInfixOf` browserScript))
    [ "/upload"
    , "/delete-prefix"
    , "/logout"
    ]

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
  , cfgPublicBaseUrl = "https://nuthatch.example"
  , cfgJwtSecret = "unit-test-secret-material"
  , cfgSessionHours = 1
  , cfgCookieName = "nuthatch_session"
  , cfgCsrfCookieName = "nuthatch_csrf"
  , cfgPgConn = ""
  , cfgRedisHost = ""
  , cfgRedisPort = 6379
  , cfgRedisDb = 0
  , cfgS3Endpoint = "https://s3.example"
  , cfgS3Region = "test"
  , cfgS3Bucket = "test"
  , cfgS3AccessKey = "test"
  , cfgS3SecretKey = "test"
  , cfgS3PathStyle = True
  , cfgPersonalQuotaBytes = 1024
  , cfgSharedQuotaBytes = 1024
  , cfgMaxObjectBytes = 1024
  , cfgThrottleBytesPerSec = 1024
  , cfgThrottleBurstBytes = 1024
  , cfgListCacheTtlSec = 30
  , cfgSearchMaxKeys = 100
  , cfgRecoveryGraceSec = 30
  , cfgAuthMode = AuthDev
  }

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)

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)

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
  }