Complete runtime resilience and audit controls

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"
-  , cfgS3SecretKey = "test"
+  , cfgS3AccessKey = secret "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 }