ms2k/nuthatch
SHA256
Watch
0
Code Releases Activity

Complete runtime resilience and audit controls

Browse source
This commit is contained in:
ms2k 2026-07-19 03:41:01 +09:00
commit 728abdbbf1
3 changed files with 1466 additions and 251 deletions
Download patch file Download diff file Expand all files Collapse all files

11
test/Integration.hs
View file

@ -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) ->

127
test/RuntimeProbe.hs Normal file
View file

@ -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)

80
test/Spec.hs
View file

@ -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 }