73 lines
3.2 KiB
Haskell
73 lines
3.2 KiB
Haskell
|
module Nuthatch.Test.Runtime
|
||
|
|
( tests
|
||
|
|
) where
|
||
|
|
|
||
|
|
import Control.Exception (SomeException, try)
|
||
|
|
import qualified Data.Aeson as A
|
||
|
|
import qualified Data.Aeson.KeyMap as KM
|
||
|
|
import Data.Either (isLeft)
|
||
|
|
import Data.IORef (modifyIORef', newIORef, readIORef)
|
||
|
|
import Data.Text (Text)
|
||
|
|
import Data.Time.Clock (getCurrentTime)
|
||
|
|
import Nuthatch.Audit (auditValue, objectKeyFields)
|
||
|
|
import Nuthatch.Config (parseRedisUri, validateAbsoluteUri)
|
||
|
|
import Nuthatch.Runtime (retryStartup)
|
||
|
|
import Test.Tasty (TestTree, testGroup)
|
||
|
|
import Test.Tasty.HUnit ((@?=), assertBool, assertFailure, testCase)
|
||
|
|
|
||
|
|
tests :: TestTree
|
||
|
|
tests = 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")]
|
||
|
|
]
|