127 lines
4.4 KiB
Haskell
127 lines
4.4 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: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)
|