Complete runtime resilience and audit controls

Dockerfile

@@ -27,12 +27,13 @@ COPY app ./app
 COPY src ./src
 COPY test ./test
 
-RUN cabal build exe:nuthatch exe:nuthatch-wp04-integration exe:nuthatch-wp09-phase exe:nuthatch-wp10-conformance \
+RUN cabal build exe:nuthatch exe:nuthatch-wp04-integration exe:nuthatch-wp09-phase exe:nuthatch-wp10-conformance exe:nuthatch-wp12-runtime \
   && mkdir -p /out \
   && cp "$(cabal list-bin exe:nuthatch)" /out/nuthatch \
   && cp "$(cabal list-bin exe:nuthatch-wp04-integration)" /out/nuthatch-wp04-integration \
   && cp "$(cabal list-bin exe:nuthatch-wp09-phase)" /out/nuthatch-wp09-phase \
-  && cp "$(cabal list-bin exe:nuthatch-wp10-conformance)" /out/nuthatch-wp10-conformance
+  && cp "$(cabal list-bin exe:nuthatch-wp10-conformance)" /out/nuthatch-wp10-conformance \
+  && cp "$(cabal list-bin exe:nuthatch-wp12-runtime)" /out/nuthatch-wp12-runtime
 
 FROM debian:bookworm-slim AS runtime-base
 
@@ -57,6 +58,7 @@ COPY --from=build /out/nuthatch /usr/local/bin/nuthatch
 COPY --from=build /out/nuthatch-wp04-integration /usr/local/bin/nuthatch-wp04-integration
 COPY --from=build /out/nuthatch-wp09-phase /usr/local/bin/nuthatch-wp09-phase
 COPY --from=build /out/nuthatch-wp10-conformance /usr/local/bin/nuthatch-wp10-conformance
+COPY --from=build /out/nuthatch-wp12-runtime /usr/local/bin/nuthatch-wp12-runtime
 CMD ["nuthatch"]
 
 FROM runtime-base AS runtime

Makefile

@@ -1,7 +1,7 @@
-.PHONY: test check-dependencies check-fixture-lib check-kind-matrix check-storage-foundation check-auth check-app check-streaming check-idempotency check-recovery check-protocol check-product app-up app-down test-frontend check-frontend build-frontend
+.PHONY: test check-dependencies check-fixture-lib check-kind-matrix check-storage-foundation check-auth check-app check-streaming check-idempotency check-recovery check-protocol check-product check-runtime app-up app-down test-frontend check-frontend build-frontend
 
 test:
-	cabal test --offline nuthatch-unit
+	./tests/run-host-tests.sh
 
 check-dependencies:
 	./tests/kind/run.sh
@@ -36,6 +36,10 @@ check-protocol:
 check-product: test-frontend check-frontend build-frontend
 	NUTHATCH_PRODUCT_GATE=1 ./tests/kind/wp05-run.sh
 
+check-runtime: test check-recovery
+	./tests/runtime-static.sh
+	./tests/kind/wp12-run.sh
+
 app-up:
 	NUTHATCH_APP_INTERACTIVE=1 ./tests/kind/wp05-run.sh
 

app/Main.hs

@@ -1,7 +1,5 @@
 module Main (main) where
 
-import           Control.Concurrent (threadDelay)
-import           Control.Exception (SomeException, try)
 import           Data.String (fromString)
 import           Database.PostgreSQL.Simple (Only (..))
 import           Network.Wai.Handler.Warp
@@ -15,6 +13,7 @@ import           Nuthatch
 import           Nuthatch.Db (migrate, query_, withDb)
 import           Nuthatch.Redis (withRedis)
 import           Nuthatch.Recovery (withLinkedWorker)
+import           Nuthatch.Runtime (retryStartup)
 import           Nuthatch.S3 (newS3)
 import           System.Directory (doesDirectoryExist)
 import           System.FilePath ((</>))
@@ -24,10 +23,20 @@ main :: IO ()
 main = do
   hSetBuffering stdout LineBuffering
   cfg <- loadConfig
-  waitForPostgres cfg
+  retryStartup
+    (cfgStartupAttempts cfg)
+    (cfgStartupDelayMs cfg)
+    "postgresql"
+    (withDb cfg $ \db -> do
+      _ <- query_ db "SELECT 1" :: IO [Only Int]
+      pure ())
   withDb cfg $ \db -> do
     schemaPath <- findSchema
-    migrate db schemaPath cfg
+    retryStartup
+      (cfgStartupAttempts cfg)
+      (cfgStartupDelayMs cfg)
+      "migration"
+      (migrate db schemaPath cfg)
     withRedis cfg $ \redis -> do
       s3 <- newS3 cfg
       let env = newEnv cfg db redis s3
@@ -45,21 +54,6 @@ main = do
           settings
           (application env)
 
-waitForPostgres :: Config -> IO ()
-waitForPostgres cfg = go (60 :: Int)
-  where
-    go 0 = fail "postgres did not become ready"
-    go n = do
-      result <- try $ withDb cfg $ \db -> do
-        _ <- query_ db "SELECT 1" :: IO [Only Int]
-        pure ()
-      case result of
-        Right () -> pure ()
-        Left (e :: SomeException) -> do
-          putStrLn $ "waiting for postgres (" <> show n <> "): " <> show e
-          threadDelay 1000000
-          go (n - 1)
-
 findSchema :: IO FilePath
 findSchema = do
   let candidates =

deploy/kubernetes/nuthatch.yaml.in

@@ -19,8 +19,12 @@ data:
   NUTHATCH_SEARCH_MAX_KEYS: "500"
   NUTHATCH_SEARCH_TIMEOUT_MS: "2000"
   NUTHATCH_DELETE_PAGE_SIZE: "100"
+  NUTHATCH_LIST_CACHE_TTL_SEC: "30"
   NUTHATCH_IDEMPOTENCY_WINDOW_SEC: "86400"
   NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC: "300"
+  NUTHATCH_STARTUP_ATTEMPTS: "60"
+  NUTHATCH_STARTUP_DELAY_MS: "1000"
+  NUTHATCH_AUDIT_OBJECT_KEYS: "false"
 ---
 apiVersion: v1
 kind: Secret

nuthatch.cabal

@@ -57,6 +57,7 @@ common shared
     , crypton               >= 0.34 && < 1.1
     , directory             >= 1.3 && < 1.4
     , entropy               >= 0.4 && < 0.5
+    , envparse              >= 0.6 && < 0.7
     , filepath              >= 1.4 && < 1.6
     , hedis                 >= 0.15 && < 0.16
     , http-client           >= 0.7 && < 0.8
@@ -69,6 +70,7 @@ common shared
     , lens                  >= 5.2 && < 5.4
     , memory                >= 0.18 && < 0.19
     , mime-types            >= 0.1 && < 0.2
+    , modern-uri            >= 0.3.6 && < 0.4
     , mtl                   >= 2.3 && < 2.4
     , network-uri           >= 2.6 && < 2.8
     , postgresql-simple     >= 0.7 && < 0.8
@@ -108,6 +110,7 @@ library
     Nuthatch.Protocol
     Nuthatch.Redis
     Nuthatch.Recovery
+    Nuthatch.Runtime
     Nuthatch.S3
     Nuthatch.Session
     Nuthatch.Streaming
@@ -172,6 +175,18 @@ executable nuthatch-wp10-conformance
     -rtsopts
     -with-rtsopts=-N
 
+executable nuthatch-wp12-runtime
+  import:         shared
+  main-is:        RuntimeProbe.hs
+  hs-source-dirs: test
+  build-depends:
+    , nuthatch
+    , base
+  ghc-options:
+    -threaded
+    -rtsopts
+    -with-rtsopts=-N
+
 test-suite nuthatch-unit
   import:         shared
   type:           exitcode-stdio-1.0

src/Nuthatch/Api.hs

@@ -105,7 +105,7 @@ data SessionContext = SessionContext
   { sessionUser :: SessionUser
   , sessionCsrf :: Maybe CsrfToken
   }
-  deriving stock (Eq, Show)
+  deriving stock (Eq)
 
 data SessionAuth
 
@@ -170,7 +170,7 @@ data DeleteRequest = DeleteRequest
   , deleteOperationId :: OperationId
   , deleteCsrf        :: CsrfToken
   }
-  deriving stock (Eq, Show)
+  deriving stock (Eq)
 
 instance FromJSON DeleteRequest where
   parseJSON = withObject "DeleteRequest" $ \o ->
@@ -185,7 +185,7 @@ data DeletePrefixRequest = DeletePrefixRequest
   , deletePrefixPath :: RelativePath
   , deletePrefixCsrf :: CsrfToken
   }
-  deriving stock (Eq, Show)
+  deriving stock (Eq)
 
 instance FromJSON DeletePrefixRequest where
   parseJSON = withObject "DeletePrefixRequest" $ \o ->
@@ -378,7 +378,7 @@ data SessionResponse = SessionResponse
   , sessionResponseDisplay :: Maybe Text
   , sessionResponseCsrf    :: CsrfToken
   }
-  deriving stock (Eq, Show)
+  deriving stock (Eq)
 
 instance ToJSON SessionResponse where
   toJSON response = object
@@ -416,7 +416,7 @@ data DeleteBatchRequest = DeleteBatchRequest
   , deleteBatchCsrf  :: CsrfToken
   , deleteBatchItems :: [DeleteBatchItem]
   }
-  deriving stock (Eq, Show)
+  deriving stock (Eq)
 
 instance FromJSON DeleteBatchRequest where
   parseJSON = withObject "DeleteBatchRequest" $ \o ->

src/Nuthatch/App.hs

@@ -16,11 +16,13 @@ module Nuthatch.App
 import           Control.Concurrent (threadDelay)
 import           Control.Concurrent.Async (mapConcurrently_)
 import           Control.Exception
-  ( SomeException
+  ( IOException
+  , SomeException
+  , fromException
   , throwIO
-  , try
+  , tryJust
   )
-import           Control.Monad (forM, forever, when)
+import           Control.Monad (forM, forM_, forever, when)
 import           Control.Monad.IO.Class (liftIO)
 import           Control.Retry
   ( retrying )
@@ -35,7 +37,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import qualified Data.Text.IO as TIO
 import           Data.Word (Word64)
-import           Database.PostgreSQL.Simple (Only (..))
+import           Database.PostgreSQL.Simple (Only (..), SqlError)
 import           GHC.Clock (getMonotonicTimeNSec)
 import           Network.HTTP.Types
   ( hContentType
@@ -51,7 +53,7 @@ import           Network.HTTP.Types
 import qualified Network.HTTP.Types.URI as URI
 import           Network.Wai (Request (..), responseFile, responseLBS)
 import           Nuthatch.Api
-import           Nuthatch.Audit (audit)
+import           Nuthatch.Audit (audit, objectKeyFields)
 import           Nuthatch.Config (Config (..))
 import           Nuthatch.Db (Db, ensurePersonalPool, withTransaction)
 import qualified Nuthatch.Db as Db
@@ -60,6 +62,7 @@ import           Nuthatch.Paths
 import           Nuthatch.Protocol
 import           Nuthatch.Redis
   ( Redis
+  , cacheGeneration
   , cacheGet
   , cacheInvalidatePrefixes
   , cacheSet
@@ -68,6 +71,7 @@ import           Nuthatch.Redis
   )
 import           Nuthatch.Recovery
   ( recoveryRetryPolicy
+  , trySynchronous
   )
 import           Nuthatch.S3
   ( ListPage (..)
@@ -242,10 +246,20 @@ authenticationHandler cfg = mkAuthHandler $ \request -> do
   let cookies = requestCookies request
       sessionName = TE.encodeUtf8 (cfgCookieName cfg)
       csrfName = TE.encodeUtf8 (cfgCsrfCookieName cfg)
-  token <- maybe (throwError loginRequired) pure (lookup sessionName cookies)
+  token <- case lookup sessionName cookies of
+    Nothing -> do
+      liftIO $ audit "authentication" "rejected" Nothing
+        [("reason", A.String "missing_session")]
+      throwError loginRequired
+    Just value -> pure value
   sessionToken <- parseCookieValue validateSessionToken token
   verified <- liftIO (verifySession cfg sessionToken)
-  user <- either (const (throwError loginRequired)) pure verified
+  user <- case verified of
+    Left _ -> do
+      liftIO $ audit "authentication" "rejected" Nothing
+        [("reason", A.String "invalid_session")]
+      throwError loginRequired
+    Right value -> pure value
   csrf <- traverse
     (parseCookieValue validateCsrfToken)
     (lookup csrfName cookies)
@@ -260,17 +274,19 @@ authenticationHandler cfg = mkAuthHandler $ \request -> do
       }
     parseCookieValue validate bytes =
       case TE.decodeUtf8' bytes of
-        Left _ -> throwOperationError err400 MalformedAuthentication
+        Left _ -> rejectMalformed
         Right value ->
-          either
+          either (const rejectMalformed) pure (validate value)
-            (const (throwOperationError err400 MalformedAuthentication))
+    rejectMalformed = do
-            pure
+      liftIO $ audit "authentication" "rejected" Nothing
-            (validate value)
+        [("reason", A.String "malformed_credential")]
+      throwOperationError err400 MalformedAuthentication
 
 handleReady :: Env -> Handler ReadyResponse
 handleReady env = do
   pg <- liftIO $
-    try (Db.query_ (envDb env) "SELECT 1") :: Handler (Either SomeException [Only Int])
+    trySynchronous (Db.query_ (envDb env) "SELECT 1")
+      :: Handler (Either SomeException [Only Int])
   case pg of
     Right _ -> pure (ReadyResponse True)
     Left _ -> throwOperationError err503 ReadyDependencyUnavailable
@@ -281,10 +297,13 @@ handleLoginRequest
 handleLoginRequest env = do
   let cfg = envConfig env
   authorizationResult <- liftIO (beginAuthorization cfg)
-  authorization <- either
+  authorization <- case authorizationResult of
-    (const (throwOperationError err502 OidcAuthorizationFailed))
+    Left _ -> do
-    pure
+      liftIO $ audit "login_start" "rejected" Nothing
-    authorizationResult
+        [("reason", A.String "provider_unavailable")]
+      throwOperationError err502 OidcAuthorizationFailed
+    Right value -> pure value
+  liftIO $ audit "login_start" "ok" Nothing []
   pure $
     addHeader
       (cookieValue
@@ -304,10 +323,12 @@ handleOidcCallback env code state cookieHeader = do
   let cfg = envConfig env
       cookies = parseCookies (TE.encodeUtf8 cookieHeader)
       transactionName = TE.encodeUtf8 (cfgOidcTransactionCookieName cfg)
-  transaction <- maybe
+  transactionBytes <- case lookup transactionName cookies of
-    (throwOperationError err400 OidcCallbackRejected)
+    Nothing -> rejectCallback "missing_transaction"
-    (parseCookieValueText OidcCallbackRejected)
+    Just value -> pure value
-    (lookup transactionName cookies)
+  transaction <- case TE.decodeUtf8' transactionBytes of
+    Right value | not (T.null value) && T.length value <= 8192 -> pure value
+    _ -> rejectCallback "malformed_transaction"
   identityResult <- liftIO (redeemAuthorizationCode cfg transaction state code)
   identity <- case identityResult of
     Left reason -> do
@@ -323,12 +344,21 @@ handleOidcCallback env code state cookieHeader = do
       (identitySubject identity)
       (identityDisplay identity)
   token <- either
-    (const (throwOperationError err500 (SessionCreationFailed "session creation failed")))
+    (\_ -> do
+      liftIO $ audit "login" "rejected" (Just (unUserId uid))
+        [("reason", A.String "session_creation_failed")]
+      throwOperationError err500
+        (SessionCreationFailed "session creation failed"))
     pure
     tokenResult
   csrf <- liftIO newCsrfToken
   liftIO $ audit "login" "ok" (Just (unUserId uid)) []
   pure (loginResponse cfg token csrf)
+  where
+    rejectCallback reason = do
+      liftIO $ audit "login" "rejected" Nothing
+        [("reason", A.String reason)]
+      throwOperationError err400 OidcCallbackRejected
 
 loginResponse :: Config -> SessionToken -> CsrfToken -> LoginSuccess
 loginResponse cfg token csrf =
@@ -346,8 +376,10 @@ handleLogoutRequest
   -> CsrfToken
   -> Handler LogoutSuccess
 handleLogoutRequest env session providedCsrf = do
-  requireCsrf LogoutCsrfRejected session providedCsrf
+  requireCsrf "logout" LogoutCsrfRejected session providedCsrf
   let cfg = envConfig env
+  liftIO $ audit "logout" "ok"
+    (Just (unUserId (suUserId (sessionUser session)))) []
   pure $
     addHeader (expiredCookieValue (cfgCookieName cfg) "/") $
       addHeader (expiredCookieValue (cfgCsrfCookieName cfg) "/") $
@@ -414,9 +446,9 @@ handleDownloadRequest env session root path requestedRange = do
   let inspect = inspectBandwidth env user
       body = getObjectSource (envS3 env) key (transferPieceSize env) inspect
   liftIO $ audit "download" "ok" (Just (unUserId (suUserId user)))
-    [ ("root", A.toJSON (rootLabel root))
+    ([ ("root", A.toJSON (rootLabel root))
-    , ("bytes", A.toJSON (oiSize info))
+     , ("bytes", A.toJSON (oiSize info))
-    ]
+     ] <> objectKeyAudit (envConfig env) path)
   let filename = basename path
   pure $
     addHeader (contentDisposition filename) $
@@ -436,24 +468,49 @@ handleUploadRequest
   -> SourceIO BS.ByteString
   -> Handler UploadResponse
 handleUploadRequest env session root path operation declaredSize contentIdentity providedCsrf bodySource = do
-  requireCsrf UploadCsrfRejected session providedCsrf
+  requireCsrf "put" UploadCsrfRejected session providedCsrf
   let user = sessionUser session
       size = unDeclaredSize declaredSize
       configuredMaximum = cfgMaxObjectBytes (envConfig env)
-  when (size > configuredMaximum) $
+  when (size > configuredMaximum) $ do
+    liftIO $ audit "put" "rejected" (Just (unUserId (suUserId user)))
+      ([ ("root", A.toJSON (rootLabel root))
+       , ("bytes", A.toJSON size)
+       , ("operation_id", A.toJSON (unOperationId operation))
+       , ("reason", A.String "object_too_large")
+       ] <> objectKeyAudit (envConfig env) path)
     throwOperationError err413 UploadTooLarge
-  requireUploadBandwidth env user size
+  requireUploadBandwidth env user root path operation size
-  outcome <- liftIO $
+  putAttempt <- liftIO $
-    runPut env user root path operation size contentIdentity bodySource
+    tryRecoveryDependency
-  result <- either
+      (runPut env user root path operation size contentIdentity bodySource)
-    throwPutFailure
+  outcome <- case putAttempt of
-    pure
+    Left _ -> do
-    outcome
+      liftIO $ audit "put" "failed" (Just (unUserId (suUserId user)))
+        ([ ("root", A.toJSON (rootLabel root))
+         , ("bytes", A.toJSON size)
+         , ("operation_id", A.toJSON (unOperationId operation))
+         , ("reason", A.String "database_unavailable")
+         ] <> objectKeyAudit (envConfig env) path)
+      throwOperationError err503
+        (UploadMutationRejected "database unavailable")
+    Right value -> pure value
+  result <- case outcome of
+    Left failure -> do
+      liftIO $ audit "put" "failed" (Just (unUserId (suUserId user)))
+        ([ ("root", A.toJSON (rootLabel root))
+         , ("bytes", A.toJSON size)
+         , ("operation_id", A.toJSON (unOperationId operation))
+         , ("reason", A.String (putFailureReason failure))
+         ] <> objectKeyAudit (envConfig env) path)
+      throwPutFailure failure
+    Right value -> pure value
   liftIO $ audit "put" (mutationAuditResult result) (Just (unUserId (suUserId user)))
-    [ ("root", A.toJSON (rootLabel root))
+    ([ ("root", A.toJSON (rootLabel root))
-    , ("bytes", A.toJSON size)
+     , ("bytes", A.toJSON size)
-    , ("operation_id", A.toJSON (unOperationId operation))
+     , ("operation_id", A.toJSON (unOperationId operation))
-    ]
+     ] <> mutationReasonFields result
+       <> objectKeyAudit (envConfig env) path)
   pure UploadResponse
     { uploadResponseOperationId = operation
     , uploadResponseResult = result
@@ -474,8 +531,15 @@ requireDownloadBandwidth env user size = do
     Right False -> throwOperationError err429 DownloadBandwidthExceeded
     Right True -> pure ()
 
-requireUploadBandwidth :: Env -> SessionUser -> Integer -> Handler ()
+requireUploadBandwidth
-requireUploadBandwidth env user size = do
+  :: Env
+  -> SessionUser
+  -> Root
+  -> RelativePath
+  -> OperationId
+  -> Integer
+  -> Handler ()
+requireUploadBandwidth env user root path operation size = do
   available <- liftIO $
     throttleCheck
       (envRedis env)
@@ -483,9 +547,19 @@ requireUploadBandwidth env user size = do
       (suUserId user)
       (min size (toInteger (transferPieceSize env)))
   case available of
-    Left _ -> throwOperationError err503 UploadThrottleUnavailable
+    Left _ -> reject "throttle_unavailable" err503 UploadThrottleUnavailable
-    Right False -> throwOperationError err429 UploadBandwidthExceeded
+    Right False ->
+      reject "bandwidth_exceeded" err429 UploadBandwidthExceeded
     Right True -> pure ()
+  where
+    reject reason status response = do
+      liftIO $ audit "put" "rejected" (Just (unUserId (suUserId user)))
+        ([ ("root", A.toJSON (rootLabel root))
+         , ("bytes", A.toJSON size)
+         , ("operation_id", A.toJSON (unOperationId operation))
+         , ("reason", A.String reason)
+         ] <> objectKeyAudit (envConfig env) path)
+      throwOperationError status response
 
 inspectBandwidth :: Env -> SessionUser -> BS.ByteString -> IO ()
 inspectBandwidth env user chunk = do
@@ -509,21 +583,40 @@ handleDeleteRequest
   -> DeleteRequest
   -> Handler DeleteResponse
 handleDeleteRequest env session request = do
-  requireCsrf DeleteCsrfRejected session (deleteCsrf request)
+  requireCsrf "delete" DeleteCsrfRejected session (deleteCsrf request)
   let user = sessionUser session
       operation = deleteOperationId request
       root = deleteRoot request
-  outcome <- liftIO $
+  deleteAttempt <- liftIO $
-    runDelete env user root (deletePath request) operation
+    tryRecoveryDependency
-  result <- either
+      (runDelete env user root (deletePath request) operation)
-    (throwOperationError err409 . DeleteMutationRejected)
+  outcome <- case deleteAttempt of
-    pure
+    Left _ -> do
-    outcome
+      liftIO $ audit "delete" "failed"
+        (Just (unUserId (suUserId user)))
+        ([ ("root", A.toJSON (rootLabel root))
+         , ("operation_id", A.toJSON (unOperationId operation))
+         , ("reason", A.String "database_unavailable")
+         ] <> objectKeyAudit (envConfig env) (deletePath request))
+      throwOperationError err503
+        (DeleteMutationRejected "database unavailable")
+    Right value -> pure value
+  result <- case outcome of
+    Left reason -> do
+      liftIO $ audit "delete" "failed"
+        (Just (unUserId (suUserId user)))
+        ([ ("root", A.toJSON (rootLabel root))
+         , ("operation_id", A.toJSON (unOperationId operation))
+         , ("reason", A.String "object_store_unavailable")
+         ] <> objectKeyAudit (envConfig env) (deletePath request))
+      throwOperationError err409 (DeleteMutationRejected reason)
+    Right value -> pure value
   liftIO $ audit "delete" (mutationAuditResult result)
     (Just (unUserId (suUserId user)))
-    [ ("root", A.toJSON (rootLabel root))
+    ([ ("root", A.toJSON (rootLabel root))
-    , ("operation_id", A.toJSON (unOperationId operation))
+     , ("operation_id", A.toJSON (unOperationId operation))
-    ]
+     ] <> mutationReasonFields result
+       <> objectKeyAudit (envConfig env) (deletePath request))
   pure DeleteResponse
     { deleteResponseOperationId = operation
     , deleteResponseResult = result
@@ -536,8 +629,13 @@ handleDeletePrefixRequest
   -> SessionContext
   -> DeletePrefixRequest
   -> Handler DeletePrefixResponse
-handleDeletePrefixRequest _env session request = do
+handleDeletePrefixRequest env session request = do
-  requireCsrf DeletePrefixCsrfRejected session (deletePrefixCsrf request)
+  requireCsrf "delete_prefix" DeletePrefixCsrfRejected session (deletePrefixCsrf request)
+  liftIO $ audit "delete_prefix" "rejected"
+    (Just (unUserId (suUserId (sessionUser session))))
+    ([ ("root", A.toJSON (rootLabel (deletePrefixRoot request)))
+     , ("reason", A.String "paged_delete_required")
+     ] <> objectKeyAudit (envConfig env) (deletePrefixPath request))
   throwOperationError err409
     (DeletePrefixMutationRejected
       "use delete-plan and delete-batch with client operation ids")
@@ -585,18 +683,41 @@ handleDeleteBatchRequest
   -> DeleteBatchRequest
   -> Handler DeleteBatchResponse
 handleDeleteBatchRequest env session request = do
-  requireCsrf DeletePrefixCsrfRejected session (deleteBatchCsrf request)
+  requireCsrf "delete_batch" DeletePrefixCsrfRejected session (deleteBatchCsrf request)
   let items = deleteBatchItems request
-  when (null items || length items > cfgDeletePageSize (envConfig env)) $
+  when (null items || length items > cfgDeletePageSize (envConfig env)) $ do
+    liftIO $ audit "delete_batch" "rejected"
+      (Just (unUserId (suUserId (sessionUser session))))
+      [ ("root", A.toJSON (rootLabel (deleteBatchRoot request)))
+      , ("reason", A.String "invalid_batch_size")
+      ]
     throwOperationError err409
       (DeletePrefixMutationRejected "delete batch size is invalid")
-  results <- liftIO $ forM items $ \item -> do
+  results <- forM items $ \item -> do
-    outcome <- runDelete
+    deleteAttempt <- liftIO $ tryRecoveryDependency $
-      env
+      runDelete
-      (sessionUser session)
+        env
-      (deleteBatchRoot request)
+        (sessionUser session)
-      (deleteBatchPath item)
+        (deleteBatchRoot request)
-      (deleteBatchOperationId item)
+        (deleteBatchPath item)
+        (deleteBatchOperationId item)
+    let outcome = case deleteAttempt of
+          Left _ -> Left "database unavailable"
+          Right value -> value
+        failureReason = case deleteAttempt of
+          Left _ -> "database_unavailable"
+          Right (Left _) -> "object_store_unavailable"
+          Right (Right _) -> ""
+    liftIO $ audit "delete" (either (const "failed") mutationAuditResult outcome)
+      (Just (unUserId (suUserId (sessionUser session))))
+      ([ ("root", A.toJSON (rootLabel (deleteBatchRoot request)))
+       , ("operation_id", A.toJSON
+          (unOperationId (deleteBatchOperationId item)))
+       ] <> either
+          (const [("reason", A.String failureReason)])
+          mutationReasonFields
+          outcome
+        <> objectKeyAudit (envConfig env) (deleteBatchPath item))
     pure $ case outcome of
       Left message -> DeleteItemResponse
         { deleteItemPath = deleteBatchPath item
@@ -612,11 +733,23 @@ handleDeleteBatchRequest env session request = do
         }
   pure (DeleteBatchResponse results)
 
-requireCsrf :: A.ToJSON error => error -> SessionContext -> CsrfToken -> Handler ()
+requireCsrf
-requireCsrf csrfError session provided =
+  :: A.ToJSON error
+  => Text
+  -> error
+  -> SessionContext
+  -> CsrfToken
+  -> Handler ()
+requireCsrf action csrfError session provided =
   case sessionCsrf session of
     Just expected | constantTimeEq expected provided -> pure ()
-    _ -> throwOperationError err403 csrfError
+    _ -> do
+      liftIO $ audit "authorization" "rejected"
+        (Just (unUserId (suUserId (sessionUser session))))
+        [ ("reason", A.String "csrf_rejected")
+        , ("operation", A.String action)
+        ]
+      throwOperationError err403 csrfError
 
 throwOperationError :: A.ToJSON error => ServerError -> error -> Handler a
 throwOperationError serverError operationError =
@@ -671,6 +804,34 @@ mutationAuditResult MutationFailed    = "failed"
 mutationAuditResult MutationRejected  = "rejected"
 mutationAuditResult MutationConflict  = "conflict"
 
+mutationReasonFields :: MutationResult -> [(Text, A.Value)]
+mutationReasonFields MutationSucceeded = []
+mutationReasonFields MutationPending =
+  [("reason", A.String "settlement_pending")]
+mutationReasonFields MutationFailed =
+  [("reason", A.String "store_effect_failed")]
+mutationReasonFields MutationRejected =
+  [("reason", A.String "admission_rejected")]
+mutationReasonFields MutationConflict =
+  [("reason", A.String "operation_conflict")]
+
+putFailureReason :: PutFailure -> Text
+putFailureReason (PutDispatchFailed (PutObjectStreamError streamError)) =
+  case streamError of
+    UploadStreamInvalid _ -> "invalid_body"
+    UploadStreamSizeMismatch -> "size_mismatch"
+    UploadStreamIdentityMismatch -> "content_identity_mismatch"
+putFailureReason (PutDispatchFailed (PutObjectBandwidthError bandwidthError)) =
+  case bandwidthError of
+    BandwidthUnavailable -> "throttle_unavailable"
+    BandwidthExceeded -> "bandwidth_exceeded"
+putFailureReason (PutDispatchFailed (PutObjectStoreError _)) =
+  "object_store_unavailable"
+
+objectKeyAudit :: Config -> RelativePath -> [(Text, A.Value)]
+objectKeyAudit cfg =
+  objectKeyFields (cfgAuditObjectKeys cfg) . unRelativePath
+
 contentDisposition :: Text -> Text
 contentDisposition filename =
   "attachment; filename=\"" <> fallback <> "\"; filename*=UTF-8''" <> encoded
@@ -866,9 +1027,13 @@ listEntries
   -> Maybe Text
   -> IO (Either Text ([ListEntry], Maybe Text))
 listEntries env user root prefix continuation = do
-  let cacheKey =
+  generation <- cacheGeneration (envRedis env) (suUserId user) root
+  let cacheOwner = case root of
+        Personal -> unUserId (suUserId user)
+        Shared   -> "shared"
+      cacheKey =
         "nuthatch:list:"
-          <> unUserId (suUserId user)
+          <> cacheOwner
           <> ":"
           <> rootLabel root
           <> ":"
@@ -876,6 +1041,7 @@ listEntries env user root prefix continuation = do
           <> ":"
           <> T.pack (show (cfgBrowsePageSize (envConfig env)))
           <> ":"
+          <> maybe "unavailable" TE.decodeUtf8 generation
       s3Prefix =
         case root of
           Personal -> "users/" <> unUserId (suUserId user) <> "/" <> prefixSlash
@@ -884,9 +1050,9 @@ listEntries env user root prefix continuation = do
         | T.null prefix = ""
         | T.isSuffixOf "/" prefix = prefix
         | otherwise = prefix <> "/"
-  cached <- case continuation of
+  cached <- case (continuation, generation) of
-    Nothing -> cacheGet (envRedis env) cacheKey
+    (Nothing, Just _) -> cacheGet (envRedis env) cacheKey
-    Just _ -> pure Nothing
+    _ -> pure Nothing
   case cached >>= A.decodeStrict of
     Just result -> pure (Right result)
     Nothing -> do
@@ -928,8 +1094,11 @@ listEntries env user root prefix continuation = do
                 ]
               entries = folders <> files
               result = (entries, lpContinuationToken lp)
-          when (continuation == Nothing) $
+          when (continuation == Nothing && generation /= Nothing) $
-            cacheSet (envRedis env) cacheKey (cfgListCacheTtlSec (envConfig env))
+            cacheSet
+              (envRedis env)
+              cacheKey
+              (cfgListCacheTtlSec (envConfig env))
               (BL.toStrict (A.encode result))
           pure (Right result)
 
@@ -1018,9 +1187,26 @@ collectKeysBoundedWith currentTime listPage maxKeys deadline =
 
 runRecovery :: Env -> IO ()
 runRecovery env = forever $ do
-  recoverOnce env
+  recovered <- tryRecoveryDependency (recoverOnce env)
+  case recovered of
+    Left _ ->
+      audit "dependency_runtime" "unavailable" Nothing
+        [ ("dependency", A.String "postgresql")
+        , ("reason", A.String "recovery_cycle_failed")
+        ]
+    Right () -> pure ()
   threadDelay (5 * 1000000)
 
+tryRecoveryDependency :: IO value -> IO (Either SomeException value)
+tryRecoveryDependency =
+  tryJust $ \exception ->
+    case ( fromException exception :: Maybe SqlError
+         , fromException exception :: Maybe IOException
+         ) of
+      (Just _, _) -> Just exception
+      (_, Just _) -> Just exception
+      _ -> Nothing
+
 recoverOnce :: Env -> IO ()
 recoverOnce env = do
   let grace = cfgRecoveryGraceSec (envConfig env)
@@ -1051,6 +1237,15 @@ finalizeRecovered env rec = do
   observed <- observeObjectWithRetry env rec
   result <- withTransaction (envDb env) $ \conn ->
     finalizeFromObservation conn rec observed
+  forM_ result $ \mutationResult ->
+    audit "recovery_mutation" (mutationAuditResult mutationResult)
+      (Just (unUserId (mrUserId rec)))
+      ([ ("root", A.toJSON (rootLabel (recordRoot rec)))
+       , ("operation_id", A.toJSON (unOperationId (mrOperationId rec)))
+       ] <> mutationReasonFields mutationResult
+         <> objectKeyAudit
+           (envConfig env)
+           (mrRelativePath rec))
   when (result == Just MutationSucceeded) $
     cacheInvalidatePrefixes
       (envRedis env)
@@ -1098,13 +1293,3 @@ lastSeg t =
 requestCookies :: Request -> [(BS.ByteString, BS.ByteString)]
 requestCookies request =
   maybe [] parseCookies (lookup hCookie (requestHeaders request))
-
-parseCookieValueText
-  :: A.ToJSON error
-  => error
-  -> BS.ByteString
-  -> Handler Text
-parseCookieValueText operationError bytes =
-  case TE.decodeUtf8' bytes of
-    Right value | not (T.null value) && T.length value <= 8192 -> pure value
-    _ -> throwOperationError err400 operationError

src/Nuthatch/Audit.hs

@@ -1,22 +1,52 @@
 module Nuthatch.Audit
   ( audit
+  , auditValue
+  , objectKeyFields
   ) where
 
-import           Data.Aeson (Value, encode, object, (.=))
+import           Data.Aeson (Value (String), encode, object, (.=))
 import qualified Data.Aeson.Key as Key
 import qualified Data.ByteString.Lazy.Char8 as L8
+import           Data.Set (Set)
+import qualified Data.Set as Set
 import           Data.Text (Text)
-import           Data.Time.Clock (getCurrentTime)
+import           Data.Time.Clock (UTCTime, getCurrentTime)
 import           Data.Time.Format.ISO8601 (iso8601Show)
 
 audit :: Text -> Text -> Maybe Text -> [(Text, Value)] -> IO ()
 audit action result mUser extra = do
   now <- getCurrentTime
+  L8.putStrLn (encode (auditValue now action result mUser extra))
+
+auditValue :: UTCTime -> Text -> Text -> Maybe Text -> [(Text, Value)] -> Value
+auditValue now action result mUser extra =
   let pairs =
         [ "ts" .= iso8601Show now
         , "action" .= action
         , "result" .= result
-        ]
+          ]
           <> maybe [] (\u -> ["user_id" .= u]) mUser
-          <> [ Key.fromText k .= v | (k, v) <- extra ]
+          <>
-  L8.putStrLn (encode (object pairs))
+            [ Key.fromText k .= v
+            | (k, v) <- extra
+            , k `Set.member` allowedExtraFields
+            ]
+  in object pairs
+
+objectKeyFields :: Bool -> Text -> [(Text, Value)]
+objectKeyFields includeObjectKey objectKey
+  | includeObjectKey = [("object_key", String objectKey)]
+  | otherwise = []
+
+allowedExtraFields :: Set Text
+allowedExtraFields = Set.fromList
+  [ "attempt"
+  , "attempts"
+  , "bytes"
+  , "dependency"
+  , "object_key"
+  , "operation"
+  , "operation_id"
+  , "reason"
+  , "root"
+  ]

src/Nuthatch/Config.hs

@@ -1,18 +1,32 @@
 module Nuthatch.Config
   ( Config (..)
+  , Secret
+  , secret
+  , revealSecret
   , loadConfig
+  , parseRedisUri
+  , validateAbsoluteUri
   ) where
 
+import           Control.Exception (SomeException, try)
 import           Control.Monad (when)
 import qualified Data.ByteString as BS
 import           Data.List (nub)
-import           Data.Maybe (fromMaybe)
+import           Data.List.NonEmpty (NonEmpty (..))
 import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
+import qualified Env
 import           Nuthatch.Streaming (maximumMultipartBytes)
-import           System.Environment (lookupEnv)
+import qualified Text.URI as URI
-import           Text.Read (readMaybe)
+
+newtype Secret value = Secret value
+
+secret :: value -> Secret value
+secret = Secret
+
+revealSecret :: Secret value -> value
+revealSecret (Secret value) = value
 
 data Config = Config
   { cfgListenHost          :: String
@@ -20,7 +34,7 @@ data Config = Config
   , cfgTlsCertPath         :: FilePath
   , cfgTlsKeyPath          :: FilePath
   , cfgPublicBaseUrl       :: Text
-  , cfgJwtSecret           :: Text
+  , cfgJwtSecret           :: Secret Text
   , cfgSessionHours        :: Integer
   , cfgCookieName          :: Text
   , cfgCsrfCookieName      :: Text
@@ -28,19 +42,19 @@ data Config = Config
   , cfgOidcIssuer          :: Text
   , cfgOidcClientId        :: Text
   , cfgOidcAdditionalAudiences :: [Text]
-  , cfgOidcClientSecret    :: Text
+  , cfgOidcClientSecret    :: Secret Text
   , cfgOidcRedirectUri     :: Text
   , cfgOidcTransactionMinutes :: Integer
   , cfgOidcMaxIdTokenSeconds :: Integer
-  , cfgPgConn              :: String
+  , cfgPgConn              :: Secret String
   , cfgRedisHost           :: String
   , cfgRedisPort           :: Int
   , cfgRedisDb             :: Integer
   , cfgS3Endpoint          :: Text
   , cfgS3Region            :: Text
   , cfgS3Bucket            :: Text
-  , cfgS3AccessKey         :: Text
+  , cfgS3AccessKey         :: Secret Text
-  , cfgS3SecretKey         :: Text
+  , cfgS3SecretKey         :: Secret Text
   , cfgS3PathStyle         :: Bool
   , cfgPersonalQuotaBytes  :: Integer
   , cfgSharedQuotaBytes    :: Integer
@@ -55,53 +69,62 @@ data Config = Config
   , cfgRecoveryGraceSec    :: Integer
   , cfgIdempotencyWindowSec :: Integer
   , cfgObjectRequestTimeoutSec :: Integer
+  , cfgStartupAttempts     :: Int
+  , cfgStartupDelayMs      :: Int
+  , cfgAuditObjectKeys     :: Bool
   }
 
 loadConfig :: IO Config
 loadConfig = do
-  listen <- fromMaybe "127.0.0.1:8080" <$> lookupEnv "NUTHATCH_LISTEN"
+  listen <- envString "NUTHATCH_LISTEN" "127.0.0.1:8080"
   let (host, portText) = splitHostPort listen
-  port <- requireRead "NUTHATCH_LISTEN port" portText
+  port <- parseValue "NUTHATCH_LISTEN port" portText
-  tlsCertPath <- fromMaybe "/tls/tls.crt" <$> lookupEnv "NUTHATCH_TLS_CERT_PATH"
+  when (T.null (T.pack host) || port <= 0 || port > 65535) $
-  tlsKeyPath <- fromMaybe "/tls/tls.key" <$> lookupEnv "NUTHATCH_TLS_KEY_PATH"
+    fail "NUTHATCH_LISTEN must contain a host and port between 1 and 65535"
-  publicBase <- T.pack <$> requireEnv "NUTHATCH_PUBLIC_BASE_URL"
+  tlsCertPath <- envString "NUTHATCH_TLS_CERT_PATH" "/tls/tls.crt"
-  when (not ("https://" `T.isPrefixOf` publicBase)) $
+  tlsKeyPath <- envString "NUTHATCH_TLS_KEY_PATH" "/tls/tls.key"
-    fail "NUTHATCH_PUBLIC_BASE_URL must use https"
+  publicBase <- requireText "NUTHATCH_PUBLIC_BASE_URL"
-  jwtSecret <- T.pack <$> requireEnv "NUTHATCH_JWT_SECRET"
+    >>= validateAbsoluteUri "NUTHATCH_PUBLIC_BASE_URL" ["https"]
-  when (BS.length (TE.encodeUtf8 jwtSecret) < 32) $
+  jwtSecretText <- requireTextSecret "NUTHATCH_JWT_SECRET"
+  when (BS.length (TE.encodeUtf8 jwtSecretText) < 32) $
     fail "NUTHATCH_JWT_SECRET must be at least 32 bytes"
+  let jwtSecret = secret jwtSecretText
   sessionHours <- envInteger "NUTHATCH_SESSION_HOURS" 12
-  cookieName <- T.pack . fromMaybe "nuthatch_session" <$> lookupEnv "NUTHATCH_COOKIE_NAME"
+  cookieName <- T.pack <$> envString "NUTHATCH_COOKIE_NAME" "nuthatch_session"
-  csrfCookie <- T.pack . fromMaybe "nuthatch_csrf" <$> lookupEnv "NUTHATCH_CSRF_COOKIE_NAME"
+  csrfCookie <- T.pack <$> envString "NUTHATCH_CSRF_COOKIE_NAME" "nuthatch_csrf"
-  transactionCookie <- T.pack . fromMaybe "nuthatch_oidc" <$> lookupEnv "NUTHATCH_OIDC_TRANSACTION_COOKIE_NAME"
+  transactionCookie <- T.pack <$>
-  oidcIssuer <- T.dropWhileEnd (== '/') . T.pack <$> requireEnv "NUTHATCH_OIDC_ISSUER"
+    envString "NUTHATCH_OIDC_TRANSACTION_COOKIE_NAME" "nuthatch_oidc"
-  oidcClientId <- T.pack <$> requireEnv "NUTHATCH_OIDC_CLIENT_ID"
+  oidcIssuerValue <- requireText "NUTHATCH_OIDC_ISSUER"
-  additionalAudienceValue <- lookupEnv "NUTHATCH_OIDC_ADDITIONAL_AUDIENCES"
+  oidcIssuer <- T.dropWhileEnd (== '/') <$>
-  let oidcAdditionalAudiences =
+    validateAbsoluteUri "NUTHATCH_OIDC_ISSUER" ["http", "https"] oidcIssuerValue
-        case T.strip . T.pack <$> additionalAudienceValue of
+  oidcClientId <- requireText "NUTHATCH_OIDC_CLIENT_ID"
-          Nothing -> []
+  additionalAudienceValue <- T.strip . T.pack <$>
-          Just "" -> []
+    envString "NUTHATCH_OIDC_ADDITIONAL_AUDIENCES" ""
-          Just value -> map T.strip (T.splitOn "," value)
+  let oidcAdditionalAudiences
+        | T.null additionalAudienceValue = []
+        | otherwise = map T.strip (T.splitOn "," additionalAudienceValue)
   when
     ( any T.null oidcAdditionalAudiences
       || oidcClientId `elem` oidcAdditionalAudiences
       || length oidcAdditionalAudiences /= length (nub oidcAdditionalAudiences)
     ) $
     fail "NUTHATCH_OIDC_ADDITIONAL_AUDIENCES must contain unique non-client values"
-  oidcClientSecret <- T.pack <$> requireEnv "NUTHATCH_OIDC_CLIENT_SECRET"
+  oidcClientSecret <- secret <$> requireTextSecret "NUTHATCH_OIDC_CLIENT_SECRET"
-  oidcRedirectUri <- T.pack <$> requireEnv "NUTHATCH_OIDC_REDIRECT_URI"
+  oidcRedirectUri <- requireText "NUTHATCH_OIDC_REDIRECT_URI"
+    >>= validateAbsoluteUri "NUTHATCH_OIDC_REDIRECT_URI" ["https"]
   when (oidcRedirectUri /= publicBase <> "/oidc/callback") $
     fail "NUTHATCH_OIDC_REDIRECT_URI must equal the public callback URL"
   oidcTransactionMinutes <- envInteger "NUTHATCH_OIDC_TRANSACTION_MINUTES" 5
   oidcMaxIdTokenSeconds <- envInteger "NUTHATCH_OIDC_MAX_ID_TOKEN_SECONDS" 3600
-  pgConn <- requireEnv "NUTHATCH_PG_CONN"
+  pgConn <- secret <$> requireStringSecret "NUTHATCH_PG_CONN"
-  redisUrl <- requireEnv "NUTHATCH_REDIS_URL"
+  redisUrl <- requireText "NUTHATCH_REDIS_URL"
-  (redisHost, redisPort, redisDb) <- parseRedisUrl redisUrl
+  (redisHost, redisPort, redisDb) <- parseRedisUri redisUrl
-  s3Endpoint <- T.pack <$> requireEnv "NUTHATCH_S3_ENDPOINT"
+  s3Endpoint <- requireText "NUTHATCH_S3_ENDPOINT"
-  s3Region <- T.pack . fromMaybe "us-east-1" <$> lookupEnv "NUTHATCH_S3_REGION"
+    >>= validateOriginUri "NUTHATCH_S3_ENDPOINT" ["http", "https"]
-  s3Bucket <- T.pack <$> requireEnv "NUTHATCH_S3_BUCKET"
+  s3Region <- T.pack <$> envString "NUTHATCH_S3_REGION" "us-east-1"
-  s3Access <- T.pack <$> requireEnv "NUTHATCH_S3_ACCESS_KEY"
+  s3Bucket <- requireText "NUTHATCH_S3_BUCKET"
-  s3Secret <- T.pack <$> requireEnv "NUTHATCH_S3_SECRET_KEY"
+  s3Access <- secret <$> requireTextSecret "NUTHATCH_S3_ACCESS_KEY"
+  s3Secret <- secret <$> requireTextSecret "NUTHATCH_S3_SECRET_KEY"
   pathStyle <- envBool "NUTHATCH_S3_PATH_STYLE" True
   personalQuota <- envInteger "NUTHATCH_PERSONAL_QUOTA_BYTES" (1024 * 1024 * 1024)
   sharedQuota <- envInteger "NUTHATCH_SHARED_QUOTA_BYTES" (10 * 1024 * 1024 * 1024)
@@ -115,27 +138,34 @@ loadConfig = do
   when (throttleBurst <= 0 || throttleBurst > luaExactIntegerMax) $
     fail "NUTHATCH_THROTTLE_BURST_BYTES exceeds the exact throttle range"
   listTtl <- envInteger "NUTHATCH_LIST_CACHE_TTL_SEC" 30
-  browsePageSize <- fromInteger <$> envInteger "NUTHATCH_BROWSE_PAGE_SIZE" 200
+  browsePageSize <- envBoundedInt "NUTHATCH_BROWSE_PAGE_SIZE" 200 1 1000
-  searchMax <- fromInteger <$> envInteger "NUTHATCH_SEARCH_MAX_KEYS" 500
+  searchMax <- envBoundedInt "NUTHATCH_SEARCH_MAX_KEYS" 500 1 100000
   searchTimeoutMs <- envInteger "NUTHATCH_SEARCH_TIMEOUT_MS" 2000
-  deletePageSize <- fromInteger <$> envInteger "NUTHATCH_DELETE_PAGE_SIZE" 100
+  deletePageSize <- envBoundedInt "NUTHATCH_DELETE_PAGE_SIZE" 100 1 1000
   recoveryGrace <- envInteger "NUTHATCH_RECOVERY_GRACE_SEC" 90
   idempotencyWindow <- envInteger "NUTHATCH_IDEMPOTENCY_WINDOW_SEC" 86400
   objectRequestTimeout <- envInteger "NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC" 300
+  startupAttempts <- envBoundedInt "NUTHATCH_STARTUP_ATTEMPTS" 60 1 1000
+  startupDelayMs <- envBoundedInt "NUTHATCH_STARTUP_DELAY_MS" 1000 1 60000
+  auditObjectKeys <- envBool "NUTHATCH_AUDIT_OBJECT_KEYS" False
   when (recoveryGrace <= 0) $
     fail "NUTHATCH_RECOVERY_GRACE_SEC must be positive"
   when (idempotencyWindow <= 0) $
     fail "NUTHATCH_IDEMPOTENCY_WINDOW_SEC must be positive"
   when (objectRequestTimeout <= 0) $
     fail "NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC must be positive"
-  when (browsePageSize <= 0 || browsePageSize > 1000) $
+  when (sessionHours <= 0 || sessionHours > 168) $
-    fail "NUTHATCH_BROWSE_PAGE_SIZE must be between 1 and 1000"
+    fail "NUTHATCH_SESSION_HOURS must be between 1 and 168"
-  when (searchMax <= 0 || searchMax > 100000) $
+  when (oidcTransactionMinutes <= 0 || oidcTransactionMinutes > 60) $
-    fail "NUTHATCH_SEARCH_MAX_KEYS must be between 1 and 100000"
+    fail "NUTHATCH_OIDC_TRANSACTION_MINUTES must be between 1 and 60"
+  when (oidcMaxIdTokenSeconds <= 0 || oidcMaxIdTokenSeconds > 86400) $
+    fail "NUTHATCH_OIDC_MAX_ID_TOKEN_SECONDS must be between 1 and 86400"
+  when (personalQuota <= 0 || sharedQuota <= 0) $
+    fail "configured quotas must be positive"
+  when (listTtl <= 0 || listTtl > 86400) $
+    fail "NUTHATCH_LIST_CACHE_TTL_SEC must be between 1 and 86400"
   when (searchTimeoutMs <= 0 || searchTimeoutMs > 60000) $
     fail "NUTHATCH_SEARCH_TIMEOUT_MS must be between 1 and 60000"
-  when (deletePageSize <= 0 || deletePageSize > 1000) $
-    fail "NUTHATCH_DELETE_PAGE_SIZE must be between 1 and 1000"
   pure Config
     { cfgListenHost = host
     , cfgListenPort = port
@@ -177,6 +207,9 @@ loadConfig = do
     , cfgRecoveryGraceSec = recoveryGrace
     , cfgIdempotencyWindowSec = idempotencyWindow
     , cfgObjectRequestTimeoutSec = objectRequestTimeout
+    , cfgStartupAttempts = startupAttempts
+    , cfgStartupDelayMs = startupDelayMs
+    , cfgAuditObjectKeys = auditObjectKeys
     }
 
 luaExactIntegerMax :: Integer
@@ -184,56 +217,117 @@ luaExactIntegerMax = 9007199254740991
 
 splitHostPort :: String -> (String, String)
 splitHostPort s =
-  case break (== ':') s of
+  case span (/= ':') s of
-    (h, ':' : p) -> (h, p)
+    (h, ':' : p) | not (null h) && not (null p) -> (h, p)
-    _            -> ("127.0.0.1", "8080")
+    _ -> ("", "")
-
-requireEnv :: String -> IO String
-requireEnv name = do
-  value <- lookupEnv name
-  case value of
-    Just present | not (null present) -> pure present
-    _ -> fail $ name <> " is required"
 
 envInteger :: String -> Integer -> IO Integer
-envInteger name def = do
+envInteger name defaultValue =
-  m <- lookupEnv name
+  Env.parse configInfo (Env.var Env.auto name (Env.def defaultValue))
-  case m of
+
-    Nothing -> pure def
+envBoundedInt :: String -> Integer -> Integer -> Integer -> IO Int
-    Just v  -> requireRead name v
+envBoundedInt name defaultValue minimumValue maximumValue = do
+  value <- envInteger name defaultValue
+  when (value < minimumValue || value > maximumValue) $
+    fail
+      (name <> " must be between "
+        <> show minimumValue <> " and " <> show maximumValue)
+  pure (fromInteger value)
 
 envBool :: String -> Bool -> IO Bool
-envBool name def = do
+envBool name defaultValue =
-  m <- lookupEnv name
+  Env.parse configInfo $
-  case fmap T.toLower (T.pack <$> m) of
+    Env.var (Env.eitherReader parseBoolean) name (Env.def defaultValue)
-    Nothing      -> pure def
+  where
-    Just "1"     -> pure True
+    parseBoolean value =
-    Just "true"  -> pure True
+      case map toLowerAscii value of
-    Just "yes"   -> pure True
+        "1"     -> Right True
-    Just "0"     -> pure False
+        "true"  -> Right True
-    Just "false" -> pure False
+        "yes"   -> Right True
-    Just "no"    -> pure False
+        "0"     -> Right False
-    Just other   -> fail $ name <> ": invalid boolean " <> T.unpack other
+        "false" -> Right False
+        "no"    -> Right False
+        _        -> Left "expected true or false"
+    toLowerAscii c
+      | c >= 'A' && c <= 'Z' = toEnum (fromEnum c + 32)
+      | otherwise = c
 
-requireRead :: (Read a) => String -> String -> IO a
+envString :: String -> String -> IO String
-requireRead name v =
+envString name defaultValue =
-  case readMaybe v of
+  Env.parse configInfo (Env.var Env.str name (Env.def defaultValue))
-    Just x  -> pure x
-    Nothing -> fail $ name <> ": cannot parse " <> v
 
-parseRedisUrl :: String -> IO (String, Int, Integer)
+requireText :: String -> IO Text
-parseRedisUrl url =
+requireText name = T.pack <$>
-  case T.stripPrefix "redis://" (T.pack url) of
+  Env.parse configInfo (Env.var Env.nonempty name mempty)
-    Nothing -> fail "NUTHATCH_REDIS_URL must start with redis://"
+
-    Just rest -> do
+requireTextSecret :: String -> IO Text
-      let (hostPort, dbPart) =
+requireTextSecret name = T.pack <$>
-            case T.breakOn "/" rest of
+  Env.parse configInfo (Env.sensitive (Env.var Env.nonempty name mempty))
-              (hp, d) | T.null d -> (hp, "/0")
+
-              (hp, d)            -> (hp, d)
+requireStringSecret :: String -> IO String
-          (hostText, portText) =
+requireStringSecret name =
-            case T.breakOn ":" hostPort of
+  Env.parse configInfo (Env.sensitive (Env.var Env.nonempty name mempty))
-              (h, p) | T.null p -> (h, "6379")
+
-              (h, p)            -> (h, T.drop 1 p)
+parseValue :: Read value => String -> String -> IO value
-      port <- requireRead "redis port" (T.unpack portText)
+parseValue name value =
-      db <- requireRead "redis db" (T.unpack (T.drop 1 dbPart))
+  case reads value of
-      pure (T.unpack hostText, port, db)
+    [(parsed, "")] -> pure parsed
+    _ -> fail (name <> " is invalid")
+
+configInfo :: Env.Info Env.Error -> Env.Info Env.Error
+configInfo = Env.header "Nuthatch configuration"
+
+validateAbsoluteUri :: String -> [Text] -> Text -> IO Text
+validateAbsoluteUri name allowedSchemes value = do
+  parsed <- try (URI.mkURI value) :: IO (Either SomeException URI.URI)
+  uri <- either (const (fail (name <> " is not a valid URI"))) pure parsed
+  scheme <- maybe (fail (name <> " must be absolute"))
+    (pure . T.toLower . URI.unRText)
+    (URI.uriScheme uri)
+  when (scheme `notElem` allowedSchemes) $
+    fail (name <> " uses an unsupported scheme")
+  authority <- either
+    (const (fail (name <> " must contain an authority")))
+    pure
+    (URI.uriAuthority uri)
+  when (URI.authUserInfo authority /= Nothing) $
+    fail (name <> " must not contain credentials")
+  when (T.null (URI.unRText (URI.authHost authority))) $
+    fail (name <> " must contain a host")
+  pure (URI.render uri)
+
+validateOriginUri :: String -> [Text] -> Text -> IO Text
+validateOriginUri name allowedSchemes value = do
+  rendered <- validateAbsoluteUri name allowedSchemes value
+  parsed <- URI.mkURI rendered
+  when
+    (URI.uriPath parsed /= Nothing
+      || not (null (URI.uriQuery parsed))
+      || URI.uriFragment parsed /= Nothing) $
+    fail (name <> " must be an origin without path, query, or fragment")
+  pure rendered
+
+parseRedisUri :: Text -> IO (String, Int, Integer)
+parseRedisUri value = do
+  rendered <- validateAbsoluteUri "NUTHATCH_REDIS_URL" ["redis"] value
+  parsed <- URI.mkURI rendered
+  authority <- either
+    (const (fail "NUTHATCH_REDIS_URL must contain an authority"))
+    pure
+    (URI.uriAuthority parsed)
+  when (not (null (URI.uriQuery parsed)) || URI.uriFragment parsed /= Nothing) $
+    fail "NUTHATCH_REDIS_URL must not contain a query or fragment"
+  database <- case URI.uriPath parsed of
+    Nothing -> pure 0
+    Just (_, segment :| []) ->
+      parseValue "NUTHATCH_REDIS_URL database" (T.unpack (URI.unRText segment))
+    _ -> fail "NUTHATCH_REDIS_URL must contain at most one database path segment"
+  let port = maybe 6379 fromIntegral (URI.authPort authority)
+  when (database < 0 || database > 15) $
+    fail "NUTHATCH_REDIS_URL database must be between 0 and 15"
+  let renderedHost = URI.unRText (URI.authHost authority)
+      connectionHost =
+        fromMaybeText renderedHost (T.stripPrefix "[" renderedHost >>= T.stripSuffix "]")
+  pure (T.unpack connectionHost, port, database)
+  where
+    fromMaybeText fallback = maybe fallback id

src/Nuthatch/Db.hs

@@ -12,7 +12,8 @@ module Nuthatch.Db
   , executeMany
   ) where
 
-import           Control.Exception (bracket, throwIO)
+import           Control.Exception (bracket, finally, throwIO)
+import           Control.Monad (void)
 import qualified Data.ByteString.Char8 as BS8
 import           Data.Pool
   ( Pool
@@ -22,7 +23,12 @@ import           Data.Pool
   , setNumStripes
   , withResource
   )
-import           Database.PostgreSQL.Simple (Connection, close, connectPostgreSQL)
+import           Database.PostgreSQL.Simple
+  ( Connection
+  , Only
+  , close
+  , connectPostgreSQL
+  )
 import qualified Database.PostgreSQL.Simple as PG
 import           Database.PostgreSQL.Simple.Migration
   ( MigrationCommand (..)
@@ -31,14 +37,14 @@ import           Database.PostgreSQL.Simple.Migration
   , runMigration
   )
 import qualified Database.PostgreSQL.Simple.Transaction as PGT
-import           Nuthatch.Config (Config (..))
+import           Nuthatch.Config (Config (..), revealSecret)
 import           Nuthatch.Types
 
 type Db = Pool Connection
 
 withDb :: Config -> (Db -> IO a) -> IO a
 withDb cfg action = do
-  let mk = connectPostgreSQL (BS8.pack (cfgPgConn cfg))
+  let mk = connectPostgreSQL (BS8.pack (revealSecret (cfgPgConn cfg)))
       poolCfg =
         setNumStripes (Just 1) $
           defaultPoolConfig mk close 30 10
@@ -46,10 +52,20 @@ withDb cfg action = do
 
 migrate :: Db -> FilePath -> Config -> IO ()
 migrate db migrationDirectory cfg = withResource db $ \conn -> do
-  result <- runMigration conn defaultOptions $
+  void
-    MigrationInitialization
+    (PG.query_ conn
-      <> MigrationDirectory migrationDirectory
+      "SELECT pg_advisory_lock(564741953576419031) IS NULL"
-      <> MigrationValidation (MigrationDirectory migrationDirectory)
+      :: IO [Only Bool])
+  result <-
+    runMigration conn defaultOptions
+      ( MigrationInitialization
+          <> MigrationDirectory migrationDirectory
+          <> MigrationValidation (MigrationDirectory migrationDirectory)
+      )
+      `finally` void
+        (PG.query_ conn
+          "SELECT pg_advisory_unlock(564741953576419031)"
+          :: IO [Only Bool])
   case result of
     MigrationSuccess ->
       PGT.withTransaction conn $

src/Nuthatch/Oidc.hs

@@ -66,14 +66,14 @@ import           Network.HTTP.Simple
   , setRequestMethod
   )
 import           Network.HTTP.Types.URI (renderQuery)
-import           Nuthatch.Config (Config (..))
+import           Nuthatch.Config (Config (..), revealSecret)
 import           System.Entropy (getEntropy)
 
 data AuthorizationRequest = AuthorizationRequest
   { authorizationLocation    :: Text
   , authorizationTransaction :: Text
   }
-  deriving stock (Eq, Show)
+  deriving stock (Eq)
 
 data OidcIdentity = OidcIdentity
   { identityIssuer  :: Text
@@ -115,7 +115,7 @@ data TransactionClaims = TransactionClaims
   , transactionRedirectUri :: Text
   , transactionReturnTarget :: Text
   }
-  deriving stock (Eq, Show)
+  deriving stock (Eq)
 
 instance HasClaimsSet TransactionClaims where
   claimsSet update claims =
@@ -157,7 +157,7 @@ data IdTokenClaims = IdTokenClaims
   , idTokenName       :: Maybe Text
   , idTokenPreferred  :: Maybe Text
   }
-  deriving stock (Eq, Show)
+  deriving stock (Eq)
 
 instance HasClaimsSet IdTokenClaims where
   claimsSet update claims =
@@ -281,7 +281,7 @@ exchangeCode cfg discovery transaction code = do
     let request =
           applyBasicAuth
             (TE.encodeUtf8 (cfgOidcClientId cfg))
-            (TE.encodeUtf8 (cfgOidcClientSecret cfg)) $
+            (TE.encodeUtf8 (revealSecret (cfgOidcClientSecret cfg))) $
           setRequestMethod "POST" $
           setRequestBodyURLEncoded
             [ ("grant_type", "authorization_code")
@@ -410,7 +410,7 @@ mintTransaction cfg state nonce verifier = do
         , transactionRedirectUri = cfgOidcRedirectUri cfg
         , transactionReturnTarget = "/"
         }
-      key = fromOctets (TE.encodeUtf8 (cfgJwtSecret cfg))
+      key = fromOctets (TE.encodeUtf8 (revealSecret (cfgJwtSecret cfg)))
   result <- runJOSE $
     encodeCompact <$> signJWT key (newJWSHeaderProtected HS256) claims
   pure $ case result of
@@ -419,7 +419,7 @@ mintTransaction cfg state nonce verifier = do
 
 verifyTransaction :: Config -> Text -> IO (Either Text TransactionClaims)
 verifyTransaction cfg compact = do
-  let key = fromOctets (TE.encodeUtf8 (cfgJwtSecret cfg))
+  let key = fromOctets (TE.encodeUtf8 (revealSecret (cfgJwtSecret cfg)))
       settings =
         defaultJWTValidationSettings (== "nuthatch-oidc-callback")
           & issuerPredicate .~ (== "nuthatch")

src/Nuthatch/Redis.hs

@@ -3,6 +3,7 @@ module Nuthatch.Redis
   , withRedis
   , cacheGet
   , cacheSet
+  , cacheGeneration
   , cacheInvalidatePrefixes
   , throttleCheck
   , throttleTake
@@ -18,10 +19,11 @@ import           Database.Redis
   ( ConnectInfo (..)
   , Connection
   , Reply
-  , checkedConnect
+  , connect
   , defaultConnectInfo
   , del
   , get
+  , incr
   , runRedis
   , setex
   )
@@ -34,7 +36,7 @@ type Redis = Connection
 
 withRedis :: Config -> (Redis -> IO a) -> IO a
 withRedis cfg action = do
-  conn <- checkedConnect defaultConnectInfo
+  conn <- connect defaultConnectInfo
     { connectHost = cfgRedisHost cfg
     , connectPort = R.PortNumber (fromIntegral (cfgRedisPort cfg))
     , connectDatabase = cfgRedisDb cfg
@@ -56,6 +58,16 @@ cacheSet conn key ttl value = do
         :: IO (Either SomeException (Either Reply R.Status))
   pure ()
 
+cacheGeneration :: Redis -> UserId -> Root -> IO (Maybe ByteString)
+cacheGeneration conn uid root = do
+  let key = TE.encodeUtf8 (cacheGenerationKey uid root)
+  result <- trySynchronous (runRedis conn (get key))
+              :: IO (Either SomeException (Either Reply (Maybe ByteString)))
+  pure $ case result of
+    Right (Right Nothing) -> Just "0"
+    Right (Right value) -> value
+    _ -> Nothing
+
 cacheInvalidatePrefixes :: Redis -> UserId -> Root -> [Text] -> IO ()
 cacheInvalidatePrefixes conn uid root prefixes = do
   let ks =
@@ -69,6 +81,17 @@ cacheInvalidatePrefixes conn uid root prefixes = do
       _ <- trySynchronous (runRedis conn (del ks))
             :: IO (Either SomeException (Either Reply Integer))
       pure ()
+  _ <- trySynchronous $
+    runRedis conn (incr (TE.encodeUtf8 (cacheGenerationKey uid root)))
+      :: IO (Either SomeException (Either Reply Integer))
+  pure ()
+
+cacheGenerationKey :: UserId -> Root -> Text
+cacheGenerationKey uid root =
+  "nuthatch:list-generation:"
+    <> case root of
+      Personal -> unUserId uid <> ":personal"
+      Shared   -> "shared"
 
 throttleCheck :: Redis -> Config -> UserId -> Integer -> IO (Either Text Bool)
 throttleCheck conn cfg uid bytes =

src/Nuthatch/Runtime.hs

@@ -0,0 +1,45 @@
+module Nuthatch.Runtime
+  ( retryStartup
+  ) where
+
+import           Control.Exception (SomeException)
+import           Control.Retry
+  ( RetryStatus (..)
+  , constantDelay
+  , limitRetries
+  , retrying
+  )
+import           Data.Aeson (Value (String), toJSON)
+import           Data.Either (isLeft)
+import           Data.Text (Text)
+import qualified Data.Text as T
+import           Nuthatch.Audit (audit)
+import           Nuthatch.Recovery (trySynchronous)
+
+retryStartup :: Int -> Int -> Text -> IO value -> IO value
+retryStartup attempts delayMs dependency action = do
+  result <- retrying policy shouldRetry $ \_ ->
+    tryStartup action
+  case result of
+    Right value -> pure value
+    Left _ -> do
+      audit "dependency_startup" "exhausted" Nothing
+        [ ("dependency", String dependency)
+        , ("attempts", toJSON attempts)
+        ]
+      fail ("startup dependency unavailable: " <> T.unpack dependency)
+  where
+    policy =
+      limitRetries (max 0 (attempts - 1))
+        <> constantDelay (max 1 delayMs * 1000)
+    shouldRetry status outcome = do
+      if isLeft outcome
+        then audit "dependency_startup" "retry" Nothing
+          [ ("dependency", String dependency)
+          , ("attempt", toJSON (rsIterNumber status + 1))
+          ]
+        else pure ()
+      pure (isLeft outcome)
+
+tryStartup :: IO value -> IO (Either SomeException value)
+tryStartup = trySynchronous

src/Nuthatch/S3.hs

@@ -61,7 +61,7 @@ import qualified Network.HTTP.Client as HTTP
 import           Network.HTTP.Client.TLS (tlsManagerSettings)
 import           Network.HTTP.Types.Status (statusCode)
 import           Network.URI (URI (..), URIAuth (..), parseURI)
-import           Nuthatch.Config (Config (..))
+import           Nuthatch.Config (Config (..), revealSecret)
 import           Nuthatch.Streaming
   ( BandwidthError (..)
   , UploadStreamError (..)
@@ -116,8 +116,8 @@ newS3 :: Config -> IO S3
 newS3 cfg = do
   (protocol, endpointHost, endpointPort) <- parseEndpoint (cfgS3Endpoint cfg)
   credentials <- Aws.makeCredentials
-    (TE.encodeUtf8 (cfgS3AccessKey cfg))
+    (TE.encodeUtf8 (revealSecret (cfgS3AccessKey cfg)))
-    (TE.encodeUtf8 (cfgS3SecretKey cfg))
+    (TE.encodeUtf8 (revealSecret (cfgS3SecretKey cfg)))
   let defaultPort = case protocol of
         AwsCore.HTTP  -> 80
         AwsCore.HTTPS -> 443

src/Nuthatch/Session.hs

@@ -45,7 +45,7 @@ import           Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import           Data.Time.Clock (addUTCTime, getCurrentTime)
-import           Nuthatch.Config (Config (..))
+import           Nuthatch.Config (Config (..), revealSecret)
 import           Nuthatch.Paths (encodeUserId)
 import           Nuthatch.Types
 import           System.Entropy (getEntropy)
@@ -108,7 +108,7 @@ mintSession cfg issuer subject display = do
           , oidcSubject = subject
           , displayName = display
           }
-        key = fromOctets (TE.encodeUtf8 (cfgJwtSecret cfg))
+        key = fromOctets (TE.encodeUtf8 (revealSecret (cfgJwtSecret cfg)))
         header = newJWSHeaderProtected HS256
     encodeCompact <$> signJWT key header claims
   pure $ case result of
@@ -126,7 +126,7 @@ verifySession cfg (SessionToken token) = do
           defaultJWTValidationSettings (== applicationAudience)
             & issuerPredicate .~ (== applicationIssuer)
             & algorithms .~ singleton HS256
-        key = fromOctets (TE.encodeUtf8 (cfgJwtSecret cfg))
+        key = fromOctets (TE.encodeUtf8 (revealSecret (cfgJwtSecret cfg)))
     verifyJWT settings key (jwt :: SignedJWT)
   pure $ case result of
     Left (_ :: JWTError) -> Left "session token validation failed"

src/Nuthatch/Types.hs

@@ -125,10 +125,10 @@ instance FromJSON OperationId where
     either (fail . T.unpack) pure . validateOperationId
 
 newtype SessionToken = SessionToken { unSessionToken :: Text }
-  deriving stock (Eq, Ord, Show)
+  deriving stock (Eq, Ord)
 
 newtype CsrfToken = CsrfToken { unCsrfToken :: Text }
-  deriving stock (Eq, Ord, Show)
+  deriving stock (Eq, Ord)
   deriving newtype (ToJSON)
 
 instance FromJSON CsrfToken where

test/Integration.hs

@@ -11,7 +11,12 @@ import           Data.List (sort)
 import           Data.Text (Text)
 import qualified Data.Text.Encoding as TE
 import           Database.PostgreSQL.Simple (Only (..))
-import           Nuthatch.Config (Config (..), loadConfig)
+import           Nuthatch.Config
+  ( Config (..)
+  , loadConfig
+  , revealSecret
+  , secret
+  )
 import           Nuthatch.Db
   ( Db
   , configurePoolLimit
@@ -356,7 +361,9 @@ verifyStorage config store = do
   missing <- getObjectBytes store (ObjectKey "shared/missing")
   assertEqual "typed not-found error" (Left S3NotFound) missing
   deniedStore <- newS3 config
-    { cfgS3SecretKey = cfgS3SecretKey config <> "-invalid" }
+    { cfgS3SecretKey =
+        secret (revealSecret (cfgS3SecretKey config) <> "-invalid")
+    }
   denied <- listObjects deniedStore "" Nothing Nothing 1
   case denied of
     Left (S3ServiceError code) ->

test/RuntimeProbe.hs

@@ -0,0 +1,127 @@
+module Main (main) where
+
+import           Control.Concurrent (threadDelay)
+import           Control.Exception (SomeException, try)
+import           Control.Monad (unless)
+import           Data.Foldable (traverse_)
+import           Nuthatch.Config (Config (..), loadConfig)
+import           Nuthatch.Redis
+import           Nuthatch.Types
+import           System.Environment
+  ( getArgs
+  , lookupEnv
+  , setEnv
+  , unsetEnv
+  )
+
+main :: IO ()
+main = do
+  mode <- getArgs
+  case mode of
+    ["config"] -> verifyConfiguration
+    ["available"] -> withConfiguration $ \config ->
+      withRedis config (verifyAvailable config)
+    ["unavailable"] -> withConfiguration $ \config ->
+      withRedis config (verifyUnavailable config)
+    _ -> fail "expected config, available, or unavailable mode"
+
+withConfiguration :: (Config -> IO ()) -> IO ()
+withConfiguration action = loadConfig >>= action
+
+verifyConfiguration :: IO ()
+verifyConfiguration = do
+  baseValues <- traverse
+    (\name -> (name,) <$> lookupEnv name)
+    [ "NUTHATCH_JWT_SECRET"
+    , "NUTHATCH_OIDC_CLIENT_SECRET"
+    , "NUTHATCH_PG_CONN"
+    , "NUTHATCH_S3_ACCESS_KEY"
+    , "NUTHATCH_S3_SECRET_KEY"
+    , "NUTHATCH_S3_ENDPOINT"
+    , "NUTHATCH_BROWSE_PAGE_SIZE"
+    , "NUTHATCH_PUBLIC_BASE_URL"
+    , "NUTHATCH_REDIS_URL"
+    ]
+  let load changes = do
+        traverse_ (uncurry setVariable) baseValues
+        traverse_ (uncurry setVariable) changes
+        loadConfig
+  expectAccepted (load []) "valid configuration"
+  expectRejected
+    (load [("NUTHATCH_PG_CONN", Nothing)])
+    "missing required configuration"
+  expectRejected
+    (load [("NUTHATCH_S3_ENDPOINT", Just "not a URI")])
+    "malformed URI configuration"
+  expectRejected
+    (load [("NUTHATCH_S3_ENDPOINT", Just "https://store.invalid/path")])
+    "non-origin S3 configuration"
+  expectRejected
+    (load
+      [("NUTHATCH_BROWSE_PAGE_SIZE", Just "18446744073709551617")])
+    "out-of-range configuration"
+  expectRejected
+    (load
+      [ ( "NUTHATCH_PUBLIC_BASE_URL"
+        , Just "https://user:[email protected]"
+        )
+      ])
+    "credential-bearing URI configuration"
+  expectAccepted
+    (load [("NUTHATCH_REDIS_URL", Just "redis://[::1]:6379/0")])
+    "IPv6 URI configuration"
+  putStrLn "runtime configuration cases passed"
+
+expectAccepted :: IO Config -> String -> IO ()
+expectAccepted load label = do
+  result <- try load :: IO (Either SomeException Config)
+  case result of
+    Left _ -> fail (label <> " was rejected")
+    Right _ -> pure ()
+
+expectRejected :: IO Config -> String -> IO ()
+expectRejected load label = do
+  result <- try load :: IO (Either SomeException Config)
+  case result of
+    Left _ -> pure ()
+    Right _ -> fail (label <> " was accepted")
+
+setVariable :: String -> Maybe String -> IO ()
+setVariable name = maybe (unsetEnv name) (setEnv name)
+
+verifyAvailable :: Config -> Redis -> IO ()
+verifyAvailable config redis = do
+  cacheSet redis "nuthatch:wp12:ttl" (cfgListCacheTtlSec config) "cached"
+  cacheGet redis "nuthatch:wp12:ttl" >>= requireEqual (Just "cached")
+  threadDelay (fromInteger ((cfgListCacheTtlSec config + 1) * 1000000))
+  cacheGet redis "nuthatch:wp12:ttl" >>= requireEqual Nothing
+  let userA = UserId "runtime-user-a"
+      userB = UserId "runtime-user-b"
+  sharedBeforeA <- cacheGeneration redis userA Shared
+  sharedBeforeB <- cacheGeneration redis userB Shared
+  requireEqual sharedBeforeA sharedBeforeB
+  cacheInvalidatePrefixes redis userA Shared [""]
+  sharedAfterB <- cacheGeneration redis userB Shared
+  unless (sharedAfterB /= sharedBeforeB) $
+    fail "shared cache generation did not change across users"
+  personalBeforeB <- cacheGeneration redis userB Personal
+  cacheInvalidatePrefixes redis userA Personal [""]
+  personalAfterB <- cacheGeneration redis userB Personal
+  requireEqual personalBeforeB personalAfterB
+  putStrLn "runtime cache coherence passed"
+
+verifyUnavailable :: Config -> Redis -> IO ()
+verifyUnavailable config redis = do
+  cacheGet redis "nuthatch:wp12:missing" >>= requireEqual Nothing
+  cacheSet redis "nuthatch:wp12:missing" 1 "ignored"
+  cacheInvalidatePrefixes redis (UserId "runtime-user") Shared [""]
+  throttled <- throttleCheck redis config (UserId "runtime-user") 1
+  case throttled of
+    Left _ -> pure ()
+    Right _ -> fail "transfer throttle did not fail closed"
+  putStrLn "runtime Redis degradation passed"
+
+requireEqual :: (Eq value, Show value) => value -> value -> IO ()
+requireEqual expected actual =
+  unless (actual == expected) $
+    fail ("expected " <> show expected <> ", got " <> show actual)

test/Spec.hs

@@ -80,13 +80,19 @@ import           Network.Wai.Test
   , srequest
   )
 import           Nuthatch.Api
+import           Nuthatch.Audit (auditValue, objectKeyFields)
 import           Nuthatch.App
   ( authenticationHandler
   , collectKeysBoundedWith
   , loginResponse
   , utf8Boundary
   )
-import           Nuthatch.Config (Config (..))
+import           Nuthatch.Config
+  ( Config (..)
+  , parseRedisUri
+  , secret
+  , validateAbsoluteUri
+  )
 import           Nuthatch.Oidc (OidcIdentity (..), verifyIdToken)
 import           Nuthatch.Paths
   ( buildObjectKey
@@ -114,6 +120,7 @@ import           Nuthatch.Recovery
   , withLinkedWorker
   )
 import           Nuthatch.S3 (ListPage (..))
+import           Nuthatch.Runtime (retryStartup)
 import           Nuthatch.Types
 import           Nuthatch.Session (mintSession)
 import           Nuthatch.Streaming
@@ -147,10 +154,68 @@ tests = testGroup "nuthatch-unit"
   , 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
@@ -939,7 +1004,7 @@ testConfig = Config
   , cfgTlsCertPath = "/tls/tls.crt"
   , cfgTlsKeyPath = "/tls/tls.key"
   , cfgPublicBaseUrl = "https://nuthatch.example"
-  , cfgJwtSecret = "unit-test-session-secret-material-32"
+  , cfgJwtSecret = secret "unit-test-session-secret-material-32"
   , cfgSessionHours = 1
   , cfgCookieName = "nuthatch_session"
   , cfgCsrfCookieName = "nuthatch_csrf"
@@ -947,19 +1012,19 @@ testConfig = Config
   , cfgOidcIssuer = "https://issuer.example"
   , cfgOidcClientId = "nuthatch"
   , cfgOidcAdditionalAudiences = []
-  , cfgOidcClientSecret = "unit-test-client-secret"
+  , cfgOidcClientSecret = secret "unit-test-client-secret"
   , cfgOidcRedirectUri = "https://nuthatch.example/oidc/callback"
   , cfgOidcTransactionMinutes = 5
   , cfgOidcMaxIdTokenSeconds = 3600
-  , cfgPgConn = ""
+  , cfgPgConn = secret ""
   , cfgRedisHost = ""
   , cfgRedisPort = 6379
   , cfgRedisDb = 0
   , cfgS3Endpoint = "https://s3.example"
   , cfgS3Region = "test"
   , cfgS3Bucket = "test"
-  , cfgS3AccessKey = "test"
+  , cfgS3AccessKey = secret "test"
-  , cfgS3SecretKey = "test"
+  , cfgS3SecretKey = secret "test"
   , cfgS3PathStyle = True
   , cfgPersonalQuotaBytes = 1024
   , cfgSharedQuotaBytes = 1024
@@ -974,6 +1039,9 @@ testConfig = Config
   , cfgRecoveryGraceSec = 30
   , cfgIdempotencyWindowSec = 3600
   , cfgObjectRequestTimeoutSec = 300
+  , cfgStartupAttempts = 3
+  , cfgStartupDelayMs = 10
+  , cfgAuditObjectKeys = False
   }
 
 newtype ValidPath = ValidPath { getValidPath :: Text }

tests/kind/wp05-job.yaml.in

@@ -362,6 +362,100 @@ spec:
                 exit 1
               fi
 
+              if [ "${NUTHATCH_RUNTIME_MODE:-}" = coherence ]; then
+                csrf_b="$(login "$NUTHATCH_OIDC_USER_B" b)"
+                test -n "$csrf_b"
+                for _ in 1 2 3 4; do
+                  curl --fail --silent --show-error \
+                    --cookie /tmp/cookies-b \
+                    --header 'Accept: application/json' \
+                    "$base/api/browse?root=shared" >/tmp/shared-warm.json
+                  curl --fail --silent --show-error \
+                    --cookie /tmp/cookies-b \
+                    --header 'Accept: application/json' \
+                    "$base/api/browse?root=shared&prefix=runtime" \
+                    >/tmp/shared-prefix-warm.json
+                done
+                printf runtime-coherence >/tmp/runtime-body
+                runtime_size="$(wc -c </tmp/runtime-body | tr -d ' ')"
+                runtime_digest="$(
+                  sha256sum /tmp/runtime-body | cut -d' ' -f1
+                )"
+                curl --fail --silent --show-error \
+                  --cookie "$cookies" \
+                  --header 'Content-Type: application/octet-stream' \
+                  --header "X-Declared-Size: $runtime_size" \
+                  --header "X-Content-SHA256: $runtime_digest" \
+                  --header "X-CSRF-Token: $csrf" \
+                  --data-binary @/tmp/runtime-body \
+                  "$base/api/upload?root=shared&path=runtime%2Fcoherence.txt&operation_id=74000000-0000-4000-8000-000000000001" \
+                  | grep -F '"result":"succeeded"'
+                curl --fail --silent --show-error \
+                  --cookie /tmp/cookies-b \
+                  --header 'Accept: application/json' \
+                  "$base/api/browse?root=shared" |
+                  grep -F 'runtime'
+                curl --fail --silent --show-error \
+                  --cookie /tmp/cookies-b \
+                  --header 'Accept: application/json' \
+                  "$base/api/browse?root=shared&prefix=runtime" |
+                  grep -F 'coherence.txt'
+                curl --fail --silent --show-error \
+                  --cookie "$cookies" \
+                  --header 'Content-Type: application/json' \
+                  --data "{\"root\":\"shared\",\"path\":\"runtime/coherence.txt\",\"operation_id\":\"74000000-0000-4000-8000-000000000002\",\"csrf\":\"$csrf\"}" \
+                  "$base/api/delete" |
+                  grep -F '"result":"succeeded"'
+                if curl --fail --silent --show-error \
+                  --cookie /tmp/cookies-b \
+                  --header 'Accept: application/json' \
+                  "$base/api/browse?root=shared&prefix=runtime" |
+                  grep -F 'coherence.txt'; then
+                  exit 1
+                fi
+                sleep 2
+                curl --fail --silent --show-error \
+                  --cookie /tmp/cookies-b \
+                  --header 'Accept: application/json' \
+                  "$base/api/browse?root=shared" >/dev/null
+                printf 'Cross-user cache coherence and TTL probes passed\n'
+                exit 0
+              fi
+
+              if [ "${NUTHATCH_RUNTIME_MODE:-}" = database-unavailable ]; then
+                printf 'Database fault checkpoint\n'
+                sleep 10
+                printf x >/tmp/database-body
+                database_digest="$(
+                  sha256sum /tmp/database-body | cut -d' ' -f1
+                )"
+                test "$(
+                  curl --silent --output /tmp/database-upload.json \
+                    --write-out '%{http_code}' \
+                    --cookie "$cookies" \
+                    --header 'Content-Type: application/octet-stream' \
+                    --header 'X-Declared-Size: 1' \
+                    --header "X-Content-SHA256: $database_digest" \
+                    --header "X-CSRF-Token: $csrf" \
+                    --data-binary @/tmp/database-body \
+                    "$base/api/upload?root=personal&path=database-unavailable.txt&operation_id=75000000-0000-4000-8000-000000000001"
+                )" = 503
+                grep -F '"error":"mutation_rejected"' \
+                  /tmp/database-upload.json
+                test "$(
+                  curl --silent --output /tmp/database-delete.json \
+                    --write-out '%{http_code}' \
+                    --cookie "$cookies" \
+                    --header 'Content-Type: application/json' \
+                    --data "{\"root\":\"personal\",\"path\":\"cross-user.txt\",\"operation_id\":\"75000000-0000-4000-8000-000000000002\",\"csrf\":\"$csrf\"}" \
+                    "$base/api/delete"
+                )" = 503
+                grep -F '"error":"mutation_rejected"' \
+                  /tmp/database-delete.json
+                printf 'Database-unavailable mutation probes passed\n'
+                exit 0
+              fi
+
               if [ "${NUTHATCH_PRODUCT_MODE:-}" = timeout ]; then
                 curl --insecure --fail --silent --show-error \
                   --get \
@@ -1204,6 +1298,16 @@ spec:
               fi
 
               if [ "${NUTHATCH_STREAMING_MODE:-}" = unavailable ]; then
+                curl --fail --silent --show-error \
+                  --cookie "$cookies" \
+                  --header 'Accept: application/json' \
+                  "$base/api/browse?root=personal" |
+                  grep -F 'cross-user.txt'
+                curl --fail --silent --show-error \
+                  --cookie "$cookies" \
+                  --header 'Accept: application/json' \
+                  "$base/api/browse?root=personal&q=CROSS-USER" |
+                  grep -F 'cross-user.txt'
                 printf x >/tmp/tiny
                 tiny_digest="$(sha256sum /tmp/tiny | cut -d' ' -f1)"
                 test "$(
@@ -1223,11 +1327,11 @@ spec:
                   curl --silent --output /tmp/unavailable-download.json \
                     --write-out '%{http_code}' \
                     --cookie "$cookies" \
-                    "$base/download?root=personal&path=streaming-large.bin"
+                    "$base/download?root=personal&path=cross-user.txt"
                 )" = 503
                 grep -F '"error":"throttle_unavailable"' \
                   /tmp/unavailable-download.json
-                printf 'Unavailable coordination probes passed\n'
+                printf 'Redis-unavailable product probes passed\n'
                 exit 0
               fi
 
@@ -1370,7 +1474,7 @@ spec:
 
               if curl --insecure --fail --silent \
                 --cookie "$cookies" \
-                --header 'X-CSRF-Token: invalid' \
+                --header 'X-CSRF-Token: bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb' \
                 --request POST \
                 "$base/logout" >/dev/null; then
                 exit 1
@@ -1468,6 +1572,12 @@ spec:
                   name: @@PROFILE_NAME@@
                   key: NUTHATCH_PRODUCT_MODE
                   optional: true
+            - name: NUTHATCH_RUNTIME_MODE
+              valueFrom:
+                configMapKeyRef:
+                  name: @@PROFILE_NAME@@
+                  key: NUTHATCH_RUNTIME_MODE
+                  optional: true
             - name: NUTHATCH_IDEMPOTENCY_IP_A
               valueFrom:
                 configMapKeyRef: