ms2k/nuthatch
SHA256
Watch
0
Code Releases Activity

Group configuration by component ownership

Browse source
This commit is contained in:
ms2k 2026-07-20 02:21:33 +09:00
commit 67cc0cb802
8 changed files with 486 additions and 258 deletions
Download patch file Download diff file Expand all files Collapse all files

8
test/FixtureProbe.hs
View file

@ -8,7 +8,7 @@ import qualified Data.ByteString.Base16 as B16
import qualified Data.Text as Text
import qualified Data.Text.Encoding as TextEncoding
import Database.PostgreSQL.Simple (Only (..))
import Nuthatch.Config (loadConfig)
import Nuthatch.Config (Config (..), loadConfig)
import qualified Nuthatch.Db as Db
import Nuthatch.Probe.Assert
import Nuthatch.Probe.Curl
@ -27,14 +27,14 @@ main = do
setEnv "NUTHATCH_OIDC_CLIENT_SECRET" "synthetic-fixture-client-secret"
config <- loadConfig
verifyProfileFile profile lane pgConnection
Db.withDb config $ \database -> do
Db.withDb (cfgPostgres config) $ \database -> do
_ <- Db.execute_ database
"CREATE TEMP TABLE lane_canary (value text NOT NULL)"
_ <- Db.execute database
"INSERT INTO lane_canary VALUES (?)"
(Only (Text.pack profile))
pure ()
withRedis config $ \redis -> do
withRedis (cfgRedis config) $ \redis -> do
cacheSet redis "lane-canary" 60 (B8.pack profile)
cacheGet redis "lane-canary" >>=
assertEqual "coordination lane canary" (Just (B8.pack profile))
@ -42,7 +42,7 @@ main = do
discovery <- curl [issuer <> "/.well-known/openid-configuration"]
assertEqual "OIDC discovery status" 200 (curlStatus discovery)
assertContains "OIDC discovery issuer" "\"issuer\"" (curlBody discovery)
store <- newS3 config
store <- newS3 (cfgS3 config)
let key = ObjectKey "lane-canary"
body = BL.fromStrict (B8.pack profile)
digest =

22
test/Integration.hs
View file

@ -13,6 +13,8 @@ import qualified Data.Text.Encoding as TE
import Database.PostgreSQL.Simple (Only (..))
import Nuthatch.Config
( Config (..)
, ProductConfig (..)
, S3Config (..)
, loadConfig
, revealSecret
, secret
@ -33,13 +35,13 @@ import Nuthatch.Types
main :: IO ()
main = do
config <- loadConfig
withDb config $ \database -> do
migrate database "sql" config
migrate database "sql" config
withDb (cfgPostgres config) $ \database -> do
migrate database "sql" (cfgProduct config)
migrate database "sql" (cfgProduct config)
verifySchema database
verifyAdmission database config
verifyRowDecoder database
store <- newS3 config
store <- newS3 (cfgS3 config)
verifyStorage config store
putStrLn "Storage foundation integration gate passed"
@ -112,18 +114,19 @@ verifyAdmission database config = do
let personalUser = UserId "personal-limit-user"
personal = personalPool personalUser
productCfg = cfgProduct config
ensurePersonalPool database
config { cfgPersonalQuotaBytes = 30 }
productCfg { cfgPersonalQuotaBytes = 30 }
personalUser
ensurePersonalPool database
config { cfgPersonalQuotaBytes = 40 }
productCfg { cfgPersonalQuotaBytes = 40 }
personalUser
_ <- Db.execute database
"UPDATE pools SET reserved_bytes = 35 WHERE pool_id = ?"
(Only (unPoolId personal))
personalLower <- try
(ensurePersonalPool database
config { cfgPersonalQuotaBytes = 34 }
productCfg { cfgPersonalQuotaBytes = 34 }
personalUser)
:: IO (Either SomeException ())
assert "unsafe personal limit reduction rejected" (isLeft personalLower)
@ -326,9 +329,10 @@ verifyStorage config store = do
missing <- getObjectBytes store (ObjectKey "shared/missing")
assertEqual "typed not-found error" (Left S3NotFound) missing
deniedStore <- newS3 config
let s3Cfg = cfgS3 config
deniedStore <- newS3 s3Cfg
{ cfgS3SecretKey =
secret (revealSecret (cfgS3SecretKey config) <> "-invalid")
secret (revealSecret (cfgS3SecretKey s3Cfg) <> "-invalid")
}
denied <- listObjects deniedStore "" Nothing Nothing 1
case denied of

106
test/Nuthatch/Test/Config.hs
View file

@ -6,47 +6,67 @@ import Nuthatch.Config
testConfig :: Config
testConfig = Config
{ cfgListenHost = "127.0.0.1"
, cfgListenPort = 8080
, cfgTlsCertPath = "/tls/tls.crt"
, cfgTlsKeyPath = "/tls/tls.key"
, cfgPublicBaseUrl = "https://nuthatch.example"
, cfgJwtSecret = secret "unit-test-session-secret-material-32"
, cfgSessionHours = 1
, cfgCookieName = "nuthatch_session"
, cfgCsrfCookieName = "nuthatch_csrf"
, cfgOidcTransactionCookieName = "nuthatch_oidc"
, cfgOidcIssuer = "https://issuer.example"
, cfgOidcClientId = "nuthatch"
, cfgOidcAdditionalAudiences = []
, cfgOidcClientSecret = secret "unit-test-client-secret"
, cfgOidcRedirectUri = "https://nuthatch.example/oidc/callback"
, cfgOidcTransactionMinutes = 5
, cfgOidcMaxIdTokenSeconds = 3600
, cfgPgConn = secret ""
, cfgRedisHost = ""
, cfgRedisPort = 6379
, cfgRedisDb = 0
, cfgS3Endpoint = "https://s3.example"
, cfgS3Region = "test"
, cfgS3Bucket = "test"
, cfgS3AccessKey = secret "test"
, cfgS3SecretKey = secret "test"
, cfgS3PathStyle = True
, cfgPersonalQuotaBytes = 1024
, cfgSharedQuotaBytes = 1024
, cfgMaxObjectBytes = 1024
, cfgThrottleBytesPerSec = 1024
, cfgThrottleBurstBytes = 1024
, cfgListCacheTtlSec = 30
, cfgBrowsePageSize = 100
, cfgSearchMaxKeys = 100
, cfgSearchTimeoutMs = 1000
, cfgDeletePageSize = 100
, cfgRecoveryGraceSec = 30
, cfgIdempotencyWindowSec = 3600
, cfgObjectRequestTimeoutSec = 300
, cfgStartupAttempts = 3
, cfgStartupDelayMs = 10
, cfgAuditObjectKeys = False
{ cfgRuntime = RuntimeConfig
{ cfgStartupAttempts = 3
, cfgStartupDelayMs = 10
}
, cfgHttp = HttpConfig
{ cfgListenHost = "127.0.0.1"
, cfgListenPort = 8080
, cfgTlsCertPath = "/tls/tls.crt"
, cfgTlsKeyPath = "/tls/tls.key"
, cfgPublicBaseUrl = "https://nuthatch.example"
, cfgJwtSecret = sessionSecret
, cfgSessionHours = 1
, cfgCookieName = "nuthatch_session"
, cfgCsrfCookieName = "nuthatch_csrf"
, cfgOidcTransactionCookieName = "nuthatch_oidc"
}
, cfgOidc = OidcConfig
{ cfgOidcIssuer = "https://issuer.example"
, cfgOidcClientId = "nuthatch"
, cfgOidcAdditionalAudiences = []
, cfgOidcClientSecret = secret "unit-test-client-secret"
, cfgOidcRedirectUri = "https://nuthatch.example/oidc/callback"
, cfgOidcTransactionMinutes = 5
, cfgOidcMaxIdTokenSeconds = 3600
, cfgOidcTransactionSecret = sessionSecret
}
, cfgPostgres = PostgresConfig
{ cfgPgConn = secret ""
}
, cfgRedis = RedisConfig
{ cfgRedisHost = ""
, cfgRedisPort = 6379
, cfgRedisDb = 0
, cfgThrottleBytesPerSec = 1024
, cfgThrottleBurstBytes = 1024
}
, cfgS3 = S3Config
{ cfgS3Endpoint = "https://s3.example"
, cfgS3Region = "test"
, cfgS3Bucket = "test"
, cfgS3AccessKey = secret "test"
, cfgS3SecretKey = secret "test"
, cfgS3PathStyle = True
, cfgS3RequestTimeoutSec = 300
}
, cfgProduct = ProductConfig
{ cfgPersonalQuotaBytes = 1024
, cfgSharedQuotaBytes = 1024
, cfgMaxObjectBytes = 1024
, cfgListCacheTtlSec = 30
, cfgBrowsePageSize = 100
, cfgSearchMaxKeys = 100
, cfgSearchTimeoutMs = 1000
, cfgDeletePageSize = 100
, cfgIdempotencyWindowSec = 3600
, cfgAuditObjectKeys = False
}
, cfgRecovery = RecoveryConfig
{ cfgRecoveryGraceSec = 30
, cfgObjectRequestTimeoutSec = 300
}
}
where
sessionSecret = secret "unit-test-session-secret-material-32"

13
test/Nuthatch/Test/Http.hs
View file

@ -30,7 +30,7 @@ import Network.Wai.Test
, srequest
)
import Nuthatch.Api
import Nuthatch.Config (Config)
import Nuthatch.Config (Config (..), HttpConfig)
import Nuthatch.Http.Auth
( authenticationHandler
, loginResponse
@ -79,6 +79,9 @@ tests = testGroup "typed HTTP boundary"
@?= "healthz"
]
httpConfig :: HttpConfig
httpConfig = cfgHttp testConfig
testRouteSelection :: IO ()
testRouteSelection = do
calls <- newIORef 0
@ -324,11 +327,11 @@ typedTestServer calls =
testAuthenticationBoundary :: IO ()
testAuthenticationBoundary = do
tokenResult <- mintSession testConfig "issuer" "subject" Nothing
tokenResult <- mintSession httpConfig "issuer" "subject" Nothing
token <- either (fail . T.unpack) pure tokenResult
let csrf = CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
responseHeaders = getHeaders
(loginResponse testConfig token csrf)
(loginResponse httpConfig token csrf)
cookieHeaders =
[ value
| (name, value) <- responseHeaders
@ -353,7 +356,7 @@ testAuthenticationBoundary = do
(length (filter ("HttpOnly" `BS.isInfixOf`) cookieHeaders) == 2)
calls <- newIORef 0
let app = productionAuthTestApplication testConfig calls
let app = productionAuthTestApplication httpConfig calls
cookie =
"nuthatch_session=" <> TE.encodeUtf8 (unSessionToken token)
<> "; nuthatch_csrf=" <> TE.encodeUtf8 (unCsrfToken csrf)
@ -415,7 +418,7 @@ testCanonicalProductRoutes = do
simpleStatus response @?= status404
readIORef calls >>= (@?= 0)
productionAuthTestApplication :: Config -> IORef Int -> Application
productionAuthTestApplication :: HttpConfig -> IORef Int -> Application
productionAuthTestApplication cfg calls =
utf8Boundary $
serveWithContext

33
test/Nuthatch/Test/Oidc.hs
View file

@ -31,7 +31,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Time.Clock (UTCTime, addUTCTime, getCurrentTime)
import Nuthatch.Config (Config (..))
import Nuthatch.Config (Config (..), OidcConfig (..))
import Nuthatch.Oidc (OidcIdentity (..), verifyIdToken)
import Nuthatch.Test.Config (testConfig)
import Test.Tasty (TestTree, testGroup)
@ -47,6 +47,9 @@ tests = testGroup "OIDC validation"
testIdTokenTimeAndSerializationRejections
]
oidcConfig :: OidcConfig
oidcConfig = cfgOidc testConfig
data TestIdTokenClaims = TestIdTokenClaims
{ testIdTokenRegistered :: ClaimsSet
, testIdTokenNonce :: Text
@ -98,7 +101,7 @@ testValidIdToken = do
compact <- signTestIdToken key RS256
(testIdClaims now "https://issuer.example" ["nuthatch"] "nonce")
result <- verifyIdToken
testConfig
oidcConfig
(JWKSet [key])
now
"nonce"
@ -119,13 +122,13 @@ testConfiguredAudiences = do
missingAuthorizedParty <- signTestIdToken key RS256
(testIdClaims now "https://issuer.example" ["project", "nuthatch"] "nonce")
result <- verifyIdToken
testConfig { cfgOidcAdditionalAudiences = ["project"] }
oidcConfig { cfgOidcAdditionalAudiences = ["project"] }
(JWKSet [key])
now
"nonce"
compact
rejected <- verifyIdToken
testConfig { cfgOidcAdditionalAudiences = ["project"] }
oidcConfig { cfgOidcAdditionalAudiences = ["project"] }
(JWKSet [key])
now
"nonce"
@ -151,12 +154,12 @@ testIdTokenCryptographicRejections = do
multipleAudience <- signTestIdToken key RS256
(testIdClaims now "https://issuer.example" ["nuthatch", "other"] "nonce")
let rejected =
[ verifyIdToken testConfig (JWKSet [key]) now "other-nonce" valid
, verifyIdToken testConfig (JWKSet [key]) now "nonce" wrongAlgorithm
, verifyIdToken testConfig (JWKSet [key]) now "nonce" wrongIssuer
, verifyIdToken testConfig (JWKSet [key]) now "nonce" wrongSignature
, verifyIdToken testConfig (JWKSet [key]) now "nonce" wrongAudience
, verifyIdToken testConfig (JWKSet [key]) now "nonce" multipleAudience
[ verifyIdToken oidcConfig (JWKSet [key]) now "other-nonce" valid
, verifyIdToken oidcConfig (JWKSet [key]) now "nonce" wrongAlgorithm
, verifyIdToken oidcConfig (JWKSet [key]) now "nonce" wrongIssuer
, verifyIdToken oidcConfig (JWKSet [key]) now "nonce" wrongSignature
, verifyIdToken oidcConfig (JWKSet [key]) now "nonce" wrongAudience
, verifyIdToken oidcConfig (JWKSet [key]) now "nonce" multipleAudience
]
results <- sequence rejected
assertBool "every invalid cryptographic or binding case is rejected"
@ -197,11 +200,11 @@ testIdTokenTimeAndSerializationRejections = do
["nuthatch"]
"nonce")
results <- sequence
[ verifyIdToken testConfig (JWKSet [key]) now "nonce" "not.compact"
, verifyIdToken testConfig (JWKSet [key]) now "nonce" missingIssuedAt
, verifyIdToken testConfig (JWKSet [key]) now "nonce" future
, verifyIdToken testConfig (JWKSet [key]) now "nonce" expired
, verifyIdToken testConfig (JWKSet [key]) now "nonce" overlong
[ verifyIdToken oidcConfig (JWKSet [key]) now "nonce" "not.compact"
, verifyIdToken oidcConfig (JWKSet [key]) now "nonce" missingIssuedAt
, verifyIdToken oidcConfig (JWKSet [key]) now "nonce" future
, verifyIdToken oidcConfig (JWKSet [key]) now "nonce" expired
, verifyIdToken oidcConfig (JWKSet [key]) now "nonce" overlong
]
assertBool "every invalid serialization or time case is rejected"
(all isLeft results)

30
test/ProtocolConformance.hs
View file

@ -74,10 +74,10 @@ main = do
case mode of
["pg-fence"] -> verifyPostgresUnavailable cfg
_ ->
withDb cfg $ \database -> do
migrate database "sql" cfg
withRedis cfg $ \redis -> do
store <- newS3 cfg
withDb (cfgPostgres cfg) $ \database -> do
migrate database "sql" (cfgProduct cfg)
withRedis (cfgRedis cfg) $ \redis -> do
store <- newS3 (cfgS3 cfg)
case mode of
["fence"] -> verifyStoreFence cfg database redis store
["restored"] -> verifyStoreRestored store
@ -297,7 +297,7 @@ verifyStoreFence cfg database redis store = do
"UPDATE mutations \
\SET updated_at = now() - (? * interval '1 second') \
\WHERE operation_id = 'expired-delete-store-down'"
(Only (cfgIdempotencyWindowSec cfg + 1))
(Only (cfgIdempotencyWindowSec (cfgProduct cfg) + 1))
beforeExpiredDelete <-
mutationSnapshot database "expired-delete-store-down"
expiredDeleteResult <- runDelete
@ -335,7 +335,7 @@ verifyStoreFence cfg database redis store = do
"UPDATE mutations \
\SET updated_at = now() - (? * interval '1 second') \
\WHERE operation_id = 'expired-store-down'"
(Only (cfgIdempotencyWindowSec cfg + 1))
(Only (cfgIdempotencyWindowSec (cfgProduct cfg) + 1))
beforeExpired <- mutationSnapshot database "expired-store-down"
expiredResult <- runPut
env
@ -430,7 +430,7 @@ verifyPostgresUnavailable :: Config -> IO ()
verifyPostgresUnavailable cfg = do
attempt <-
(try $
withDb cfg $ \database ->
withDb (cfgPostgres cfg) $ \database ->
(Db.query_ database "SELECT 1" :: IO [Only Int]))
:: IO (Either SomeException [Only Int])
assert "PostgreSQL lane service is unavailable" (isLeft attempt)
@ -506,8 +506,8 @@ admitPut cfg database operation path size identity =
(Just identity)
}
AdmissionLimits
{ admissionMaxObjectBytes = cfgMaxObjectBytes cfg
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
{ admissionMaxObjectBytes = cfgMaxObjectBytes (cfgProduct cfg)
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec (cfgProduct cfg)
}
admitDelete :: Config -> Db -> Text -> Text -> IO AdmitOutcome
@ -524,8 +524,8 @@ admitDelete cfg database operation path =
MutationFingerprint Delete (ObjectKey ("shared/" <> path)) 0 Nothing
}
AdmissionLimits
{ admissionMaxObjectBytes = cfgMaxObjectBytes cfg
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
{ admissionMaxObjectBytes = cfgMaxObjectBytes (cfgProduct cfg)
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec (cfgProduct cfg)
}
admitPersonal :: Config -> Db -> UserId -> Text -> IO AdmitOutcome
@ -546,8 +546,8 @@ admitPersonal cfg database user operation =
(Just identityA)
}
AdmissionLimits
{ admissionMaxObjectBytes = cfgMaxObjectBytes cfg
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
{ admissionMaxObjectBytes = cfgMaxObjectBytes (cfgProduct cfg)
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec (cfgProduct cfg)
}
seedObject :: Db -> S3 -> Text -> BL.ByteString -> IO ()
@ -605,7 +605,7 @@ bounded cfg label action = do
action
finished <- getMonotonicTimeNSec
let elapsedMicros = (finished - started) `div` 1000
boundMicros = fromInteger ((cfgObjectRequestTimeoutSec cfg + 1) * 1000000)
boundMicros = fromInteger ((cfgObjectRequestTimeoutSec (cfgRecovery cfg) + 1) * 1000000)
assert (label <> " exceeded configured settlement bound")
(elapsedMicros <= boundMicros)
@ -613,7 +613,7 @@ stableForSettlementBound :: Config -> IO () -> IO ()
stableForSettlementBound cfg action = do
started <- getMonotonicTimeNSec
let duration =
fromInteger ((cfgObjectRequestTimeoutSec cfg + 1) * 1000000000)
fromInteger ((cfgObjectRequestTimeoutSec (cfgRecovery cfg) + 1) * 1000000000)
observe = do
action
now <- getMonotonicTimeNSec

16
test/RecoveryPhase.hs
View file

@ -30,10 +30,10 @@ main :: IO ()
main = do
hSetBuffering stdout LineBuffering
cfg <- loadConfig
withDb cfg $ \database -> do
migrate database "sql" cfg
withRedis cfg $ \redis -> do
store <- newS3 cfg
withDb (cfgPostgres cfg) $ \database -> do
migrate database "sql" (cfgProduct cfg)
withRedis (cfgRedis cfg) $ \redis -> do
store <- newS3 (cfgS3 cfg)
getArgs >>= \case
[] -> getEnv "NUTHATCH_RECOVERY_PHASE" >>=
runPhase cfg database redis store
@ -253,8 +253,8 @@ prepareDelete cfg database redis store = do
MutationFingerprint Delete key 0 Nothing
}
AdmissionLimits
{ admissionMaxObjectBytes = cfgMaxObjectBytes cfg
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec cfg
{ admissionMaxObjectBytes = cfgMaxObjectBytes (cfgProduct cfg)
, admissionIdempotencyWindowSec = cfgIdempotencyWindowSec (cfgProduct cfg)
}
prepared outcome
@ -266,8 +266,8 @@ beginDispatch cfg database rec = do
connection
rec
DispatchTiming
{ dispatchSettlementBoundSec = cfgObjectRequestTimeoutSec cfg * 2
, dispatchWorkerGraceSec = cfgRecoveryGraceSec cfg
{ dispatchSettlementBoundSec = cfgObjectRequestTimeoutSec (cfgRecovery cfg) * 2
, dispatchWorkerGraceSec = cfgRecoveryGraceSec (cfgRecovery cfg)
}
pure (applying && pending)
unless started (fail "could not begin dispatch")

79
test/RuntimeProbe.hs
View file

@ -4,7 +4,7 @@ import Control.Concurrent (threadDelay)
import Control.Exception (SomeException, try)
import Control.Monad (unless)
import Data.Foldable (traverse_)
import Nuthatch.Config (Config (..), loadConfig)
import Nuthatch.Config
import Nuthatch.Redis
import Nuthatch.Types
import System.Environment
@ -20,9 +20,9 @@ main = do
case mode of
["config"] -> verifyConfiguration
["available"] -> withConfiguration $ \config ->
withRedis config (verifyAvailable config)
withRedis (cfgRedis config) (verifyAvailable config)
["unavailable"] -> withConfiguration $ \config ->
withRedis config (verifyUnavailable config)
withRedis (cfgRedis config) (verifyUnavailable config)
_ -> fail "expected config, available, or unavailable mode"
withConfiguration :: (Config -> IO ()) -> IO ()
@ -41,12 +41,47 @@ verifyConfiguration = do
, "NUTHATCH_BROWSE_PAGE_SIZE"
, "NUTHATCH_PUBLIC_BASE_URL"
, "NUTHATCH_REDIS_URL"
, "NUTHATCH_LISTEN"
, "NUTHATCH_SESSION_HOURS"
, "NUTHATCH_OIDC_ADDITIONAL_AUDIENCES"
, "NUTHATCH_OIDC_MAX_ID_TOKEN_SECONDS"
, "NUTHATCH_S3_REGION"
, "NUTHATCH_PERSONAL_QUOTA_BYTES"
, "NUTHATCH_MAX_OBJECT_BYTES"
, "NUTHATCH_THROTTLE_BYTES_PER_SEC"
, "NUTHATCH_RECOVERY_GRACE_SEC"
, "NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC"
, "NUTHATCH_STARTUP_ATTEMPTS"
, "NUTHATCH_STARTUP_DELAY_MS"
]
let load changes = do
traverse_ (uncurry setVariable) baseValues
traverse_ (uncurry setVariable) changes
loadConfig
expectAccepted (load []) "valid configuration"
grouped <- load
[ ("NUTHATCH_LISTEN", Just "127.0.0.2:9090")
, ("NUTHATCH_SESSION_HOURS", Just "6")
, ("NUTHATCH_OIDC_MAX_ID_TOKEN_SECONDS", Just "1800")
, ("NUTHATCH_S3_REGION", Just "group-test")
, ("NUTHATCH_PERSONAL_QUOTA_BYTES", Just "2048")
, ("NUTHATCH_THROTTLE_BYTES_PER_SEC", Just "4096")
, ("NUTHATCH_RECOVERY_GRACE_SEC", Just "45")
, ("NUTHATCH_OBJECT_REQUEST_TIMEOUT_SEC", Just "120")
, ("NUTHATCH_STARTUP_ATTEMPTS", Just "7")
, ("NUTHATCH_STARTUP_DELAY_MS", Just "25")
]
requireEqual "127.0.0.2" (cfgListenHost (cfgHttp grouped))
requireEqual 6 (cfgSessionHours (cfgHttp grouped))
requireEqual 1800 (cfgOidcMaxIdTokenSeconds (cfgOidc grouped))
requireEqual "group-test" (cfgS3Region (cfgS3 grouped))
requireEqual 2048 (cfgPersonalQuotaBytes (cfgProduct grouped))
requireEqual 4096 (cfgThrottleBytesPerSec (cfgRedis grouped))
requireEqual 45 (cfgRecoveryGraceSec (cfgRecovery grouped))
requireEqual 120 (cfgObjectRequestTimeoutSec (cfgRecovery grouped))
requireEqual 120 (cfgS3RequestTimeoutSec (cfgS3 grouped))
requireEqual 7 (cfgStartupAttempts (cfgRuntime grouped))
requireEqual 25 (cfgStartupDelayMs (cfgRuntime grouped))
expectRejected
(load [("NUTHATCH_PG_CONN", Nothing)])
"missing required configuration"
@ -60,6 +95,30 @@ verifyConfiguration = do
(load
[("NUTHATCH_BROWSE_PAGE_SIZE", Just "18446744073709551617")])
"out-of-range configuration"
expectRejected
(load [("NUTHATCH_LISTEN", Just "127.0.0.1:0")])
"invalid HTTP listener configuration"
expectRejected
(load [("NUTHATCH_JWT_SECRET", Just "too-short")])
"short session secret"
expectRejected
(load [("NUTHATCH_OIDC_ADDITIONAL_AUDIENCES", Just "extra,extra")])
"duplicate OIDC audiences"
expectRejected
(load [("NUTHATCH_REDIS_URL", Just "redis://user:secret@redis:6379/0")])
"credential-bearing Redis configuration"
expectRejected
(load [("NUTHATCH_MAX_OBJECT_BYTES", Just "999999999999999")])
"unsupported product object limit"
expectRejected
(load [("NUTHATCH_THROTTLE_BYTES_PER_SEC", Just "0")])
"invalid Redis throttle configuration"
expectRejected
(load [("NUTHATCH_RECOVERY_GRACE_SEC", Just "0")])
"invalid recovery configuration"
expectRejected
(load [("NUTHATCH_STARTUP_ATTEMPTS", Just "0")])
"invalid runtime startup configuration"
expectRejected
(load
[ ( "NUTHATCH_PUBLIC_BASE_URL"
@ -91,9 +150,13 @@ setVariable name = maybe (unsetEnv name) (setEnv name)
verifyAvailable :: Config -> Redis -> IO ()
verifyAvailable config redis = do
cacheSet redis "nuthatch:runtime:ttl" (cfgListCacheTtlSec config) "cached"
let productCfg = cfgProduct config
cacheSet redis "nuthatch:runtime:ttl"
(cfgListCacheTtlSec productCfg)
"cached"
cacheGet redis "nuthatch:runtime:ttl" >>= requireEqual (Just "cached")
threadDelay (fromInteger ((cfgListCacheTtlSec config + 1) * 1000000))
threadDelay
(fromInteger ((cfgListCacheTtlSec productCfg + 1) * 1000000))
cacheGet redis "nuthatch:runtime:ttl" >>= requireEqual Nothing
let userA = UserId "runtime-user-a"
userB = UserId "runtime-user-b"
@ -115,7 +178,11 @@ verifyUnavailable config redis = do
cacheGet redis "nuthatch:runtime:missing" >>= requireEqual Nothing
cacheSet redis "nuthatch:runtime:missing" 1 "ignored"
cacheInvalidatePrefixes redis (UserId "runtime-user") Shared [""]
throttled <- throttleCheck redis config (UserId "runtime-user") 1
throttled <- throttleCheck
redis
(cfgRedis config)
(UserId "runtime-user")
1
case throttled of
Left _ -> pure ()
Right _ -> fail "transfer throttle did not fail closed"