ms2k
15eb0038d2
Use descriptive test and executable names so implementation surfaces do not depend on journal organization. Consolidate the unreleased migration history into the authoritative initial schema because no deployed database requires an upgrade path.
127 lines
4.5 KiB
Haskell
127 lines
4.5 KiB
Haskell
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:runtime:ttl" (cfgListCacheTtlSec config) "cached"
|
|
cacheGet redis "nuthatch:runtime:ttl" >>= requireEqual (Just "cached")
|
|
threadDelay (fromInteger ((cfgListCacheTtlSec config + 1) * 1000000))
|
|
cacheGet redis "nuthatch:runtime: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: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
|
|
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)
|