Complete runtime resilience and audit controls

test/RuntimeProbe.hs

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