Split host tests by component ownership
This commit is contained in:
parent
68a92662c0
commit
48a5b8a433
11 changed files with 1435 additions and 1309 deletions
52
test/Nuthatch/Test/Config.hs
Normal file
52
test/Nuthatch/Test/Config.hs
Normal file
|
|
@ -0,0 +1,52 @@
|
|||
module Nuthatch.Test.Config
|
||||
( testConfig
|
||||
) where
|
||||
|
||||
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
|
||||
}
|
||||
424
test/Nuthatch/Test/Http.hs
Normal file
424
test/Nuthatch/Test/Http.hs
Normal file
|
|
@ -0,0 +1,424 @@
|
|||
module Nuthatch.Test.Http
|
||||
( tests
|
||||
) where
|
||||
|
||||
import Control.Monad (forM_)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Network.HTTP.Types
|
||||
( HeaderName
|
||||
, methodGet
|
||||
, methodPost
|
||||
, status200
|
||||
, status303
|
||||
, status400
|
||||
, status404
|
||||
, status405
|
||||
)
|
||||
import Network.Wai (Request (..), responseLBS)
|
||||
import Network.Wai.Test
|
||||
( SRequest (..)
|
||||
, SResponse (..)
|
||||
, defaultRequest
|
||||
, runSession
|
||||
, setPath
|
||||
, srequest
|
||||
)
|
||||
import Nuthatch.Api
|
||||
import Nuthatch.Config (Config)
|
||||
import Nuthatch.Http.Auth
|
||||
( authenticationHandler
|
||||
, loginResponse
|
||||
)
|
||||
import Nuthatch.Http.Server (utf8Boundary)
|
||||
import Nuthatch.Session (mintSession)
|
||||
import Nuthatch.Test.Config (testConfig)
|
||||
import Nuthatch.Types
|
||||
import Servant
|
||||
import Servant.Server.Experimental.Auth (AuthHandler, mkAuthHandler)
|
||||
import Servant.Types.SourceT (source)
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.HUnit ((@?=), assertBool, testCase)
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "typed HTTP boundary"
|
||||
[ testCase "Servant selects routes and methods" testRouteSelection
|
||||
, testCase "valid query values reach a typed handler" testValidDecoding
|
||||
, testCase "invalid roots and paths fail before handler execution"
|
||||
testInvalidDomains
|
||||
, testCase "malformed UTF-8 fails before handler execution" testMalformedUtf8
|
||||
, testCase "upload headers and operation ids decode before streaming handler execution"
|
||||
testUploadDecoding
|
||||
, testCase "upload and download bodies use Servant streaming endpoints"
|
||||
testStreamingEndpoints
|
||||
, testCase "operation-specific JSON requests and responses remain distinct"
|
||||
testOperationRepresentations
|
||||
, testCase "operation-specific errors have closed distinct representations" $ do
|
||||
let loginError = A.encode OidcCallbackRejected
|
||||
deleteError = A.encode (DeleteMutationRejected "locked")
|
||||
prefixError = A.encode (DeletePrefixMutationRejected "partial")
|
||||
assertBool "login errors carry the login-specific code"
|
||||
("oidc_callback_rejected" `BS.isInfixOf` BL.toStrict loginError)
|
||||
assertBool "delete errors carry the mutation-specific code"
|
||||
("mutation_rejected" `BS.isInfixOf` BL.toStrict deleteError)
|
||||
assertBool "operation errors must not share one representation"
|
||||
(loginError /= deleteError && deleteError /= prefixError)
|
||||
assertBool "prefix errors carry their operation-specific code"
|
||||
("prefix_mutation_rejected" `BS.isInfixOf` BL.toStrict prefixError)
|
||||
, testCase "production authentication validates cookies and callback emits secure cookies"
|
||||
testAuthenticationBoundary
|
||||
, testCase "only canonical product routes are exposed"
|
||||
testCanonicalProductRoutes
|
||||
, testCase "links derive from the type-level API" $
|
||||
show (linkURI (safeLink api (Proxy :: Proxy HealthEndpoint)))
|
||||
@?= "healthz"
|
||||
]
|
||||
|
||||
testRouteSelection :: IO ()
|
||||
testRouteSelection = do
|
||||
calls <- newIORef 0
|
||||
response <- apiRequest calls methodGet "/healthz" [] ""
|
||||
simpleStatus response @?= status200
|
||||
readIORef calls >>= (@?= 1)
|
||||
writeIORef calls 0
|
||||
wrongMethod <- apiRequest calls methodPost "/healthz" [] ""
|
||||
simpleStatus wrongMethod @?= status405
|
||||
readIORef calls >>= (@?= 0)
|
||||
missing <- apiRequest calls methodGet "/missing" [] ""
|
||||
simpleStatus missing @?= status404
|
||||
readIORef calls >>= (@?= 0)
|
||||
|
||||
testValidDecoding :: IO ()
|
||||
testValidDecoding = do
|
||||
calls <- newIORef 0
|
||||
response <- apiRequest calls methodGet
|
||||
"/api/browse?root=personal&prefix=docs%2Freports&q=quarterly&continuation=next"
|
||||
[]
|
||||
""
|
||||
simpleStatus response @?= status200
|
||||
readIORef calls >>= (@?= 1)
|
||||
|
||||
testInvalidDomains :: IO ()
|
||||
testInvalidDomains = do
|
||||
calls <- newIORef 0
|
||||
invalidRoot <- apiRequest calls methodGet "/api/browse?root=PERSONAL" [] ""
|
||||
simpleStatus invalidRoot @?= status400
|
||||
invalidPath <- apiRequest calls methodGet
|
||||
"/api/browse?prefix=docs%2F..%2Fprivate" [] ""
|
||||
simpleStatus invalidPath @?= status400
|
||||
readIORef calls >>= (@?= 0)
|
||||
|
||||
testMalformedUtf8 :: IO ()
|
||||
testMalformedUtf8 = do
|
||||
calls <- newIORef 0
|
||||
response <- apiRequest calls methodGet "/api/browse?q=%FF" [] ""
|
||||
simpleStatus response @?= status400
|
||||
readIORef calls >>= (@?= 0)
|
||||
|
||||
testUploadDecoding :: IO ()
|
||||
testUploadDecoding = do
|
||||
calls <- newIORef 0
|
||||
let csrf = BS.replicate 43 97
|
||||
headers =
|
||||
[ ("Content-Type", "application/octet-stream")
|
||||
, ("X-Declared-Size", "4")
|
||||
, ("X-Content-SHA256", BS.replicate 64 97)
|
||||
, ("X-CSRF-Token", csrf)
|
||||
]
|
||||
response <- apiRequest calls methodPost
|
||||
"/api/upload?root=personal&path=docs%2Ffile.txt&operation_id=bad%20id"
|
||||
headers
|
||||
"body"
|
||||
simpleStatus response @?= status400
|
||||
invalidSize <- apiRequest calls methodPost
|
||||
"/api/upload?root=personal&path=docs%2Ffile.txt&operation_id=upload-1"
|
||||
(replaceHeader "X-Declared-Size" "zero" headers)
|
||||
"body"
|
||||
simpleStatus invalidSize @?= status400
|
||||
invalidPagination <- apiRequest calls methodGet
|
||||
"/api/browse?continuation=" [] ""
|
||||
simpleStatus invalidPagination @?= status400
|
||||
readIORef calls >>= (@?= 0)
|
||||
|
||||
testStreamingEndpoints :: IO ()
|
||||
testStreamingEndpoints = do
|
||||
calls <- newIORef 0
|
||||
let csrf = BS.replicate 43 97
|
||||
headers =
|
||||
[ ("Content-Type", "application/octet-stream")
|
||||
, ("X-Declared-Size", "4")
|
||||
, ("X-Content-SHA256", BS.replicate 64 97)
|
||||
, ("X-CSRF-Token", csrf)
|
||||
]
|
||||
upload <- apiRequest calls methodPost
|
||||
"/api/upload?root=personal&path=docs%2Ffile.txt&operation_id=upload-1"
|
||||
headers
|
||||
"body"
|
||||
simpleStatus upload @?= status200
|
||||
assertBool "upload advertises the idempotency window"
|
||||
("\"idempotency_window_seconds\":3600"
|
||||
`BS.isInfixOf` BL.toStrict (simpleBody upload))
|
||||
download <- apiRequest calls methodGet
|
||||
"/api/download?root=shared&path=docs%2Ffile.txt"
|
||||
[]
|
||||
""
|
||||
simpleStatus download @?= status200
|
||||
simpleBody download @?= "body"
|
||||
lookup "Content-Disposition" (simpleHeaders download)
|
||||
@?= Just "attachment; filename=\"file.txt\""
|
||||
lookup "X-Content-Type-Options" (simpleHeaders download)
|
||||
@?= Just "nosniff"
|
||||
readIORef calls >>= (@?= 2)
|
||||
|
||||
testOperationRepresentations :: IO ()
|
||||
testOperationRepresentations = do
|
||||
calls <- newIORef 0
|
||||
login <- apiRequest calls methodGet "/login" [] ""
|
||||
simpleStatus login @?= status303
|
||||
lookup "Location" (simpleHeaders login)
|
||||
@?= Just "https://issuer.example/authorize"
|
||||
callback <- apiRequest calls methodGet
|
||||
"/oidc/callback?code=code&state=state"
|
||||
[("Cookie", "nuthatch_oidc=transaction")]
|
||||
""
|
||||
simpleStatus callback @?= status303
|
||||
wrongLoginMethod <- apiRequest calls methodPost "/login" [] ""
|
||||
simpleStatus wrongLoginMethod @?= status405
|
||||
deletion <- apiRequest calls methodPost
|
||||
"/api/delete"
|
||||
[("Content-Type", "application/json")]
|
||||
"{\"root\":\"shared\",\"path\":\"docs/file.txt\",\"operation_id\":\"delete-1\",\"csrf\":\"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa\"}"
|
||||
simpleStatus deletion @?= status200
|
||||
assertBool "delete response must carry a mutation result"
|
||||
("succeeded" `BS.isInfixOf` BL.toStrict (simpleBody deletion))
|
||||
assertBool "delete advertises the idempotency window"
|
||||
("\"idempotency_window_seconds\":3600"
|
||||
`BS.isInfixOf` BL.toStrict (simpleBody deletion))
|
||||
malformed <- apiRequest calls methodPost
|
||||
"/api/delete"
|
||||
[("Content-Type", "application/json")]
|
||||
"{\"root\":\"shared\",\"path\":\"../escape\"}"
|
||||
simpleStatus malformed @?= status400
|
||||
readIORef calls >>= (@?= 3)
|
||||
|
||||
replaceHeader
|
||||
:: HeaderName
|
||||
-> BS.ByteString
|
||||
-> [(HeaderName, BS.ByteString)]
|
||||
-> [(HeaderName, BS.ByteString)]
|
||||
replaceHeader name value =
|
||||
map $ \(headerName, headerValue) ->
|
||||
if headerName == name
|
||||
then (headerName, value)
|
||||
else (headerName, headerValue)
|
||||
|
||||
apiRequest
|
||||
:: IORef Int
|
||||
-> BS.ByteString
|
||||
-> BS.ByteString
|
||||
-> [(HeaderName, BS.ByteString)]
|
||||
-> BL.ByteString
|
||||
-> IO SResponse
|
||||
apiRequest calls method path headers body =
|
||||
apiRequestWith (typedTestApplication calls) method path headers body
|
||||
|
||||
apiRequestWith
|
||||
:: Application
|
||||
-> BS.ByteString
|
||||
-> BS.ByteString
|
||||
-> [(HeaderName, BS.ByteString)]
|
||||
-> BL.ByteString
|
||||
-> IO SResponse
|
||||
apiRequestWith app method path headers body =
|
||||
runSession
|
||||
(srequest
|
||||
(SRequest
|
||||
(setPath defaultRequest
|
||||
{ requestMethod = method
|
||||
, requestHeaders = headers
|
||||
}
|
||||
path)
|
||||
body))
|
||||
app
|
||||
|
||||
typedTestApplication :: IORef Int -> Application
|
||||
typedTestApplication calls =
|
||||
utf8Boundary $
|
||||
serveWithContext api (auth :. EmptyContext) (typedTestServer calls)
|
||||
where
|
||||
auth :: AuthHandler Request SessionContext
|
||||
auth = mkAuthHandler $ \_ -> pure SessionContext
|
||||
{ sessionUser = SessionUser
|
||||
{ suIssuer = "issuer"
|
||||
, suSubject = "subject"
|
||||
, suUserId = UserId "user"
|
||||
, suDisplay = Nothing
|
||||
}
|
||||
, sessionCsrf = Just
|
||||
(CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
|
||||
}
|
||||
|
||||
typedTestServer :: IORef Int -> Server Api
|
||||
typedTestServer calls =
|
||||
counted (HealthResponse True)
|
||||
:<|> counted (ReadyResponse True)
|
||||
:<|> (\_ -> counted (addHeader "default-src 'none'" (HtmlPage "app")))
|
||||
:<|> (\_ -> Tagged $ \_ sendResponse ->
|
||||
sendResponse (responseLBS status404 [] ""))
|
||||
:<|> counted
|
||||
(addHeader "transaction=cookie"
|
||||
(addHeader "https://issuer.example/authorize" NoContent))
|
||||
:<|> (\_ _ _ -> counted
|
||||
(addHeader "session=cookie"
|
||||
(addHeader "csrf=cookie"
|
||||
(addHeader "transaction=expired"
|
||||
(addHeader "/app" NoContent)))))
|
||||
:<|> (\_ _ -> counted
|
||||
(addHeader "session=expired"
|
||||
(addHeader "csrf=expired"
|
||||
(addHeader "transaction=expired" NoContent))))
|
||||
:<|>
|
||||
( (\session -> counted SessionResponse
|
||||
{ sessionResponseUserId = suUserId (sessionUser session)
|
||||
, sessionResponseDisplay = Nothing
|
||||
, sessionResponseCsrf =
|
||||
CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
||||
})
|
||||
:<|> (\_ _ _ _ _ -> counted emptyBrowse)
|
||||
:<|> (\_ _ _ _ -> counted downloadResponse)
|
||||
:<|> (\_ _ _ operation _ _ _ _ -> counted UploadResponse
|
||||
{ uploadResponseOperationId = operation
|
||||
, uploadResponseResult = MutationSucceeded
|
||||
, uploadResponseIdempotencyWindowSeconds = 3600
|
||||
})
|
||||
:<|> (\_ request -> counted DeleteResponse
|
||||
{ deleteResponseOperationId = deleteOperationId request
|
||||
, deleteResponseResult = MutationSucceeded
|
||||
, deleteResponseIdempotencyWindowSeconds = 3600
|
||||
})
|
||||
:<|> (\_ _ _ _ -> counted DeletePlanResponse
|
||||
{ deletePlanPaths = []
|
||||
, deletePlanContinuation = Nothing
|
||||
})
|
||||
:<|> (\_ _ -> counted (DeleteBatchResponse []))
|
||||
)
|
||||
where
|
||||
counted :: a -> Handler a
|
||||
counted value = liftIO (modifyIORef' calls (+ 1)) >> pure value
|
||||
emptyBrowse =
|
||||
BrowseResponse
|
||||
{ browseEntries = []
|
||||
, browseContinuation = Nothing
|
||||
, browsePartial = False
|
||||
}
|
||||
downloadResponse =
|
||||
addHeader "attachment; filename=\"file.txt\"" $
|
||||
addHeader "nosniff" $
|
||||
addHeader "sandbox" $
|
||||
addHeader 4 (source ["body"])
|
||||
|
||||
testAuthenticationBoundary :: IO ()
|
||||
testAuthenticationBoundary = do
|
||||
tokenResult <- mintSession testConfig "issuer" "subject" Nothing
|
||||
token <- either (fail . T.unpack) pure tokenResult
|
||||
let csrf = CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
||||
responseHeaders = getHeaders
|
||||
(loginResponse testConfig token csrf)
|
||||
cookieHeaders =
|
||||
[ value
|
||||
| (name, value) <- responseHeaders
|
||||
, name == "Set-Cookie"
|
||||
]
|
||||
lookup "Location" responseHeaders @?= Just "/app"
|
||||
length cookieHeaders @?= 3
|
||||
assertBool "login sets the session cookie"
|
||||
(any ("nuthatch_session=" `BS.isPrefixOf`) cookieHeaders)
|
||||
assertBool "login sets the CSRF cookie"
|
||||
(any ("nuthatch_csrf=" `BS.isPrefixOf`) cookieHeaders)
|
||||
assertBool "cookies are secure and same-site"
|
||||
(all ("Secure" `BS.isInfixOf`) cookieHeaders
|
||||
&& all ("SameSite=Lax" `BS.isInfixOf`) cookieHeaders)
|
||||
assertBool "cookies are host-only"
|
||||
(all (not . ("Domain=" `BS.isInfixOf`)) cookieHeaders)
|
||||
assertBool "session and CSRF cookies use the root path"
|
||||
(length (filter ("Path=/;" `BS.isInfixOf`) cookieHeaders) == 2)
|
||||
assertBool "the transaction cookie uses the callback path"
|
||||
(any ("Path=/oidc/callback;" `BS.isInfixOf`) cookieHeaders)
|
||||
assertBool "session and transaction cookies are HTTP-only"
|
||||
(length (filter ("HttpOnly" `BS.isInfixOf`) cookieHeaders) == 2)
|
||||
|
||||
calls <- newIORef 0
|
||||
let app = productionAuthTestApplication testConfig calls
|
||||
cookie =
|
||||
"nuthatch_session=" <> TE.encodeUtf8 (unSessionToken token)
|
||||
<> "; nuthatch_csrf=" <> TE.encodeUtf8 (unCsrfToken csrf)
|
||||
authenticated <- apiRequestWith app methodGet
|
||||
"/api/browse?root=personal"
|
||||
[("Cookie", cookie)]
|
||||
""
|
||||
simpleStatus authenticated @?= status200
|
||||
readIORef calls >>= (@?= 1)
|
||||
|
||||
writeIORef calls 0
|
||||
malformed <- apiRequestWith app methodGet
|
||||
"/api/browse?root=personal"
|
||||
[("Cookie", "nuthatch_session=" <> BS.singleton 255
|
||||
<> "; nuthatch_csrf=" <> TE.encodeUtf8 (unCsrfToken csrf))]
|
||||
""
|
||||
simpleStatus malformed @?= status400
|
||||
readIORef calls >>= (@?= 0)
|
||||
|
||||
malformedGrammar <- apiRequestWith app methodGet
|
||||
"/api/browse?root=personal"
|
||||
[("Cookie", "nuthatch_session")]
|
||||
""
|
||||
simpleStatus malformedGrammar @?= status400
|
||||
readIORef calls >>= (@?= 0)
|
||||
|
||||
let tamperedToken =
|
||||
case T.unsnoc (unSessionToken token) of
|
||||
Just (prefix, final)
|
||||
| final == 'a' -> prefix <> "b"
|
||||
| otherwise -> prefix <> "a"
|
||||
Nothing -> "invalid"
|
||||
tampered <- apiRequestWith app methodGet
|
||||
"/api/browse?root=personal"
|
||||
[("Cookie", "nuthatch_session=" <> TE.encodeUtf8 tamperedToken)]
|
||||
""
|
||||
simpleStatus tampered @?= status303
|
||||
readIORef calls >>= (@?= 0)
|
||||
|
||||
missingCsrf <- apiRequestWith app methodGet
|
||||
"/api/browse?root=personal"
|
||||
[("Cookie", "nuthatch_session=" <> TE.encodeUtf8 (unSessionToken token))]
|
||||
""
|
||||
simpleStatus missingCsrf @?= status200
|
||||
readIORef calls >>= (@?= 1)
|
||||
|
||||
testCanonicalProductRoutes :: IO ()
|
||||
testCanonicalProductRoutes = do
|
||||
calls <- newIORef 0
|
||||
forM_
|
||||
[ (methodGet, "/")
|
||||
, (methodGet, "/nuthatch.js")
|
||||
, (methodGet, "/download?root=personal&path=file")
|
||||
, (methodPost, "/upload")
|
||||
, (methodPost, "/delete")
|
||||
, (methodPost, "/delete-prefix")
|
||||
] $ \(method, path) -> do
|
||||
response <- apiRequest calls method path [] ""
|
||||
simpleStatus response @?= status404
|
||||
readIORef calls >>= (@?= 0)
|
||||
|
||||
productionAuthTestApplication :: Config -> IORef Int -> Application
|
||||
productionAuthTestApplication cfg calls =
|
||||
utf8Boundary $
|
||||
serveWithContext
|
||||
api
|
||||
(authenticationHandler cfg :. EmptyContext)
|
||||
(typedTestServer calls)
|
||||
43
test/Nuthatch/Test/Identity.hs
Normal file
43
test/Nuthatch/Test/Identity.hs
Normal file
|
|
@ -0,0 +1,43 @@
|
|||
module Nuthatch.Test.Identity
|
||||
( tests
|
||||
) where
|
||||
|
||||
import Hedgehog (Property, assert, forAll, property, (===))
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import qualified Hedgehog.Range as Range
|
||||
import Nuthatch.Paths (encodeUserId)
|
||||
import Nuthatch.Types
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.HUnit ((@?=), testCase)
|
||||
import Test.Tasty.Hedgehog (testProperty)
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "identities"
|
||||
[ testProperty "root labels parse back to the same root" propRootLabels
|
||||
, testProperty "mutation kind labels parse back to the same kind" propKindLabels
|
||||
, testCase "issuer and subject identity encoding remains stable" $
|
||||
encodeUserId "https://issuer.example" "subject-α"
|
||||
@?= UserId "e0240ab33521a1882fb647a79f7fd3c74c9b6348b29bdb14e572204517882859"
|
||||
, testProperty "issuer and subject inputs are separated" propUserIdentitySeparation
|
||||
]
|
||||
|
||||
propRootLabels :: Property
|
||||
propRootLabels = property $ do
|
||||
root <- forAll (Gen.element [Personal, Shared])
|
||||
parseRoot (rootLabel root) === Just root
|
||||
|
||||
propKindLabels :: Property
|
||||
propKindLabels = property $ do
|
||||
kind <- forAll (Gen.element [Put, Delete])
|
||||
parseKind (kindLabel kind) === Just kind
|
||||
|
||||
propUserIdentitySeparation :: Property
|
||||
propUserIdentitySeparation = property $ do
|
||||
issuer <- forAll genIdentityPart
|
||||
subject <- forAll genIdentityPart
|
||||
otherIssuer <- forAll (Gen.filter (/= issuer) genIdentityPart)
|
||||
other <- forAll (Gen.filter (/= subject) genIdentityPart)
|
||||
assert (encodeUserId issuer subject /= encodeUserId otherIssuer subject)
|
||||
assert (encodeUserId issuer subject /= encodeUserId issuer other)
|
||||
where
|
||||
genIdentityPart = Gen.text (Range.linear 1 32) Gen.alphaNum
|
||||
254
test/Nuthatch/Test/Oidc.hs
Normal file
254
test/Nuthatch/Test/Oidc.hs
Normal file
|
|
@ -0,0 +1,254 @@
|
|||
module Nuthatch.Test.Oidc
|
||||
( tests
|
||||
) where
|
||||
|
||||
import Control.Lens ((&), (?~))
|
||||
import Crypto.JOSE (runJOSE)
|
||||
import Crypto.JOSE.Compact (encodeCompact)
|
||||
import Crypto.JOSE.JWA.JWS (Alg (RS256, RS384))
|
||||
import Crypto.JOSE.JWK
|
||||
( JWK
|
||||
, JWKSet (..)
|
||||
, KeyMaterialGenParam (RSAGenParam)
|
||||
, genJWK
|
||||
)
|
||||
import Crypto.JOSE.JWS (newJWSHeaderProtected)
|
||||
import Crypto.JWT
|
||||
( Audience (..)
|
||||
, ClaimsSet
|
||||
, HasClaimsSet (..)
|
||||
, JWTError
|
||||
, NumericDate (..)
|
||||
, emptyClaimsSet
|
||||
, signJWT
|
||||
)
|
||||
import qualified Data.Aeson as A
|
||||
import qualified Data.Aeson.KeyMap as KM
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.Either (isLeft, isRight)
|
||||
import Data.String (fromString)
|
||||
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.Oidc (OidcIdentity (..), verifyIdToken)
|
||||
import Nuthatch.Test.Config (testConfig)
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.HUnit ((@?=), assertBool, testCase)
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "OIDC validation"
|
||||
[ testCase "accepts an exact RS256 ID token" testValidIdToken
|
||||
, testCase "accepts an exact configured audience set" testConfiguredAudiences
|
||||
, testCase "rejects invalid nonce, algorithm, issuer, signature, and audience"
|
||||
testIdTokenCryptographicRejections
|
||||
, testCase "rejects malformed, missing-time, future, expired, and overlong tokens"
|
||||
testIdTokenTimeAndSerializationRejections
|
||||
]
|
||||
|
||||
data TestIdTokenClaims = TestIdTokenClaims
|
||||
{ testIdTokenRegistered :: ClaimsSet
|
||||
, testIdTokenNonce :: Text
|
||||
, testIdTokenAuthorizedParty :: Maybe Text
|
||||
, testIdTokenName :: Maybe Text
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
instance HasClaimsSet TestIdTokenClaims where
|
||||
claimsSet update claims =
|
||||
fmap
|
||||
(\registered -> claims { testIdTokenRegistered = registered })
|
||||
(update (testIdTokenRegistered claims))
|
||||
|
||||
instance A.FromJSON TestIdTokenClaims where
|
||||
parseJSON value = A.withObject "test ID token" (\object ->
|
||||
TestIdTokenClaims
|
||||
<$> A.parseJSON value
|
||||
<*> object A..: "nonce"
|
||||
<*> object A..:? "azp"
|
||||
<*> object A..:? "name") value
|
||||
|
||||
instance A.ToJSON TestIdTokenClaims where
|
||||
toJSON claims =
|
||||
case A.toJSON (testIdTokenRegistered claims) of
|
||||
A.Object object ->
|
||||
let withName =
|
||||
maybe
|
||||
object
|
||||
(\name -> KM.insert "name" (A.String name) object)
|
||||
(testIdTokenName claims)
|
||||
withAuthorizedParty =
|
||||
maybe
|
||||
withName
|
||||
(\authorizedParty ->
|
||||
KM.insert "azp" (A.String authorizedParty) withName)
|
||||
(testIdTokenAuthorizedParty claims)
|
||||
in A.Object $
|
||||
KM.insert
|
||||
"nonce"
|
||||
(A.String (testIdTokenNonce claims))
|
||||
withAuthorizedParty
|
||||
value -> value
|
||||
|
||||
testValidIdToken :: IO ()
|
||||
testValidIdToken = do
|
||||
key <- genJWK (RSAGenParam 256)
|
||||
now <- getCurrentTime
|
||||
compact <- signTestIdToken key RS256
|
||||
(testIdClaims now "https://issuer.example" ["nuthatch"] "nonce")
|
||||
result <- verifyIdToken
|
||||
testConfig
|
||||
(JWKSet [key])
|
||||
now
|
||||
"nonce"
|
||||
compact
|
||||
result @?= Right OidcIdentity
|
||||
{ identityIssuer = "https://issuer.example"
|
||||
, identitySubject = "upstream-subject"
|
||||
, identityDisplay = Just "Example User"
|
||||
}
|
||||
|
||||
testConfiguredAudiences :: IO ()
|
||||
testConfiguredAudiences = do
|
||||
key <- genJWK (RSAGenParam 256)
|
||||
now <- getCurrentTime
|
||||
compact <- signTestIdToken key RS256
|
||||
((testIdClaims now "https://issuer.example" ["project", "nuthatch"] "nonce")
|
||||
{ testIdTokenAuthorizedParty = Just "nuthatch" })
|
||||
missingAuthorizedParty <- signTestIdToken key RS256
|
||||
(testIdClaims now "https://issuer.example" ["project", "nuthatch"] "nonce")
|
||||
result <- verifyIdToken
|
||||
testConfig { cfgOidcAdditionalAudiences = ["project"] }
|
||||
(JWKSet [key])
|
||||
now
|
||||
"nonce"
|
||||
compact
|
||||
rejected <- verifyIdToken
|
||||
testConfig { cfgOidcAdditionalAudiences = ["project"] }
|
||||
(JWKSet [key])
|
||||
now
|
||||
"nonce"
|
||||
missingAuthorizedParty
|
||||
assertBool "the configured audience set is accepted" (isRight result)
|
||||
assertBool "a multi-audience token without azp is rejected" (isLeft rejected)
|
||||
|
||||
testIdTokenCryptographicRejections :: IO ()
|
||||
testIdTokenCryptographicRejections = do
|
||||
key <- genJWK (RSAGenParam 256)
|
||||
otherKey <- genJWK (RSAGenParam 256)
|
||||
now <- getCurrentTime
|
||||
valid <- signTestIdToken key RS256
|
||||
(testIdClaims now "https://issuer.example" ["nuthatch"] "nonce")
|
||||
wrongAlgorithm <- signTestIdToken key RS384
|
||||
(testIdClaims now "https://issuer.example" ["nuthatch"] "nonce")
|
||||
wrongIssuer <- signTestIdToken key RS256
|
||||
(testIdClaims now "https://other.example" ["nuthatch"] "nonce")
|
||||
wrongSignature <- signTestIdToken otherKey RS256
|
||||
(testIdClaims now "https://issuer.example" ["nuthatch"] "nonce")
|
||||
wrongAudience <- signTestIdToken key RS256
|
||||
(testIdClaims now "https://issuer.example" ["other"] "nonce")
|
||||
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
|
||||
]
|
||||
results <- sequence rejected
|
||||
assertBool "every invalid cryptographic or binding case is rejected"
|
||||
(all isLeft results)
|
||||
|
||||
testIdTokenTimeAndSerializationRejections :: IO ()
|
||||
testIdTokenTimeAndSerializationRejections = do
|
||||
key <- genJWK (RSAGenParam 256)
|
||||
now <- getCurrentTime
|
||||
missingIssuedAt <- signTestIdToken key RS256
|
||||
((testIdClaims now "https://issuer.example" ["nuthatch"] "nonce")
|
||||
{ testIdTokenRegistered =
|
||||
emptyClaimsSet
|
||||
& claimIss ?~ "https://issuer.example"
|
||||
& claimSub ?~ "upstream-subject"
|
||||
& claimAud ?~ Audience ["nuthatch"]
|
||||
& claimExp ?~ NumericDate (addUTCTime 300 now)
|
||||
})
|
||||
future <- signTestIdToken key RS256
|
||||
(testIdClaimsAt
|
||||
(addUTCTime 60 now)
|
||||
(addUTCTime 300 now)
|
||||
"https://issuer.example"
|
||||
["nuthatch"]
|
||||
"nonce")
|
||||
expired <- signTestIdToken key RS256
|
||||
(testIdClaimsAt
|
||||
(addUTCTime (-600) now)
|
||||
(addUTCTime (-300) now)
|
||||
"https://issuer.example"
|
||||
["nuthatch"]
|
||||
"nonce")
|
||||
overlong <- signTestIdToken key RS256
|
||||
(testIdClaimsAt
|
||||
now
|
||||
(addUTCTime 7200 now)
|
||||
"https://issuer.example"
|
||||
["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
|
||||
]
|
||||
assertBool "every invalid serialization or time case is rejected"
|
||||
(all isLeft results)
|
||||
|
||||
testIdClaims
|
||||
:: UTCTime
|
||||
-> Text
|
||||
-> [Text]
|
||||
-> Text
|
||||
-> TestIdTokenClaims
|
||||
testIdClaims now issuer audiences nonce =
|
||||
testIdClaimsAt
|
||||
now
|
||||
(addUTCTime 300 now)
|
||||
issuer
|
||||
audiences
|
||||
nonce
|
||||
|
||||
testIdClaimsAt
|
||||
:: UTCTime
|
||||
-> UTCTime
|
||||
-> Text
|
||||
-> [Text]
|
||||
-> Text
|
||||
-> TestIdTokenClaims
|
||||
testIdClaimsAt issuedAt expiresAt issuer audiences nonce =
|
||||
TestIdTokenClaims
|
||||
{ testIdTokenRegistered =
|
||||
emptyClaimsSet
|
||||
& claimIss ?~ fromString (T.unpack issuer)
|
||||
& claimSub ?~ "upstream-subject"
|
||||
& claimAud ?~ Audience (map (fromString . T.unpack) audiences)
|
||||
& claimIat ?~ NumericDate issuedAt
|
||||
& claimExp ?~ NumericDate expiresAt
|
||||
, testIdTokenNonce = nonce
|
||||
, testIdTokenAuthorizedParty = Nothing
|
||||
, testIdTokenName = Just "Example User"
|
||||
}
|
||||
|
||||
signTestIdToken
|
||||
:: JWK
|
||||
-> Alg
|
||||
-> TestIdTokenClaims
|
||||
-> IO Text
|
||||
signTestIdToken key algorithm claims = do
|
||||
result <- runJOSE $
|
||||
encodeCompact <$> signJWT key (newJWSHeaderProtected algorithm) claims
|
||||
case result of
|
||||
Left (err :: JWTError) -> fail (show err)
|
||||
Right compact -> pure (TE.decodeUtf8 (BL.toStrict compact))
|
||||
79
test/Nuthatch/Test/Path.hs
Normal file
79
test/Nuthatch/Test/Path.hs
Normal file
|
|
@ -0,0 +1,79 @@
|
|||
module Nuthatch.Test.Path
|
||||
( tests
|
||||
) where
|
||||
|
||||
import Data.Either (isLeft)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Hedgehog
|
||||
( Gen
|
||||
, Property
|
||||
, assert
|
||||
, forAll
|
||||
, property
|
||||
, (===)
|
||||
)
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import Nuthatch.Paths
|
||||
( buildObjectKey
|
||||
, encodeUserId
|
||||
, listCacheAncestorPrefixes
|
||||
)
|
||||
import Nuthatch.Test.PathFixture
|
||||
import Nuthatch.Types
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.HUnit ((@?=), testCase)
|
||||
import Test.Tasty.Hedgehog (testProperty)
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "canonical paths"
|
||||
[ testProperty "valid paths parse and render without rewriting" propPathRoundTrip
|
||||
, testProperty "invalid paths are rejected" propInvalidPaths
|
||||
, testProperty "constructed object keys remain under their root" propRootConfinement
|
||||
, testCase "nested cache ancestors include every containing listing" $
|
||||
listCacheAncestorPrefixes (RelativePath "docs/a/b.txt")
|
||||
@?= ["", "docs", "docs/a"]
|
||||
, testCase "root files invalidate the root listing" $
|
||||
listCacheAncestorPrefixes (RelativePath "file.txt") @?= [""]
|
||||
]
|
||||
|
||||
newtype InvalidPath = InvalidPath { getInvalidPath :: Text }
|
||||
deriving stock (Show)
|
||||
|
||||
genInvalidPath :: Gen InvalidPath
|
||||
genInvalidPath = do
|
||||
ValidPath valid <- genValidPath
|
||||
InvalidPath <$> Gen.element
|
||||
[ ""
|
||||
, "/" <> valid
|
||||
, valid <> "/"
|
||||
, valid <> "//tail"
|
||||
, valid <> "/../tail"
|
||||
, valid <> "/./tail"
|
||||
, valid <> "/back\\slash"
|
||||
, valid <> "/control\NUL"
|
||||
, "e\x0301"
|
||||
]
|
||||
|
||||
propPathRoundTrip :: Property
|
||||
propPathRoundTrip = property $ do
|
||||
ValidPath raw <- forAll genValidPath
|
||||
validateRelativePath raw === Right (RelativePath raw)
|
||||
|
||||
propInvalidPaths :: Property
|
||||
propInvalidPaths = property $ do
|
||||
InvalidPath raw <- forAll genInvalidPath
|
||||
assert (isLeft (validateRelativePath raw))
|
||||
|
||||
propRootConfinement :: Property
|
||||
propRootConfinement = property $ do
|
||||
ValidPath raw <- forAll genValidPath
|
||||
let path = RelativePath raw
|
||||
uid = encodeUserId "https://issuer.example" "subject"
|
||||
personalPrefix = "users/" <> unUserId uid <> "/"
|
||||
personalKey = unObjectKey (buildObjectKey Personal uid path)
|
||||
sharedKey = unObjectKey (buildObjectKey Shared uid path)
|
||||
assert (personalPrefix `T.isPrefixOf` personalKey)
|
||||
assert ("shared/" `T.isPrefixOf` sharedKey)
|
||||
assert (not ("shared/" `T.isPrefixOf` personalKey))
|
||||
assert (not ("users/" `T.isPrefixOf` sharedKey))
|
||||
23
test/Nuthatch/Test/PathFixture.hs
Normal file
23
test/Nuthatch/Test/PathFixture.hs
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
module Nuthatch.Test.PathFixture
|
||||
( ValidPath (..)
|
||||
, genValidPath
|
||||
) where
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Hedgehog (Gen)
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import qualified Hedgehog.Range as Range
|
||||
|
||||
newtype ValidPath = ValidPath { getValidPath :: Text }
|
||||
deriving stock (Show)
|
||||
|
||||
genValidPath :: Gen ValidPath
|
||||
genValidPath = do
|
||||
segments <- Gen.list (Range.linear 1 6) genSegment
|
||||
pure (ValidPath (T.intercalate "/" segments))
|
||||
where
|
||||
genSegment =
|
||||
Gen.filter (`notElem` [".", ".."]) $
|
||||
Gen.text (Range.linear 1 16) $
|
||||
Gen.choice [Gen.alphaNum, Gen.element ("_-. " :: String)]
|
||||
27
test/Nuthatch/Test/Product.hs
Normal file
27
test/Nuthatch/Test/Product.hs
Normal file
|
|
@ -0,0 +1,27 @@
|
|||
module Nuthatch.Test.Product
|
||||
( tests
|
||||
) where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import GHC.Clock (getMonotonicTimeNSec)
|
||||
import Nuthatch.Browse (collectKeysBoundedWith)
|
||||
import Nuthatch.S3 (ListPage (..))
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.HUnit ((@?=), assertBool, testCase)
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "product behavior"
|
||||
[ testCase "search deadline cancels an in-flight listing" $ do
|
||||
started <- getMonotonicTimeNSec
|
||||
result <- collectKeysBoundedWith
|
||||
getMonotonicTimeNSec
|
||||
(\_ _ -> do
|
||||
threadDelay 100000
|
||||
pure (Right (ListPage [] [] Nothing False)))
|
||||
100
|
||||
(started + 5000000)
|
||||
finished <- getMonotonicTimeNSec
|
||||
result @?= Right ([], True)
|
||||
assertBool "listing returns inside the configured deadline margin"
|
||||
(finished - started < 50000000)
|
||||
]
|
||||
252
test/Nuthatch/Test/Protocol.hs
Normal file
252
test/Nuthatch/Test/Protocol.hs
Normal file
|
|
@ -0,0 +1,252 @@
|
|||
module Nuthatch.Test.Protocol
|
||||
( tests
|
||||
) where
|
||||
|
||||
import Hedgehog
|
||||
( Gen
|
||||
, Property
|
||||
, assert
|
||||
, forAll
|
||||
, property
|
||||
, (===)
|
||||
)
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import qualified Hedgehog.Range as Range
|
||||
import Nuthatch.Paths (buildObjectKey, encodeUserId)
|
||||
import Nuthatch.Protocol
|
||||
import Nuthatch.Test.PathFixture
|
||||
import Nuthatch.Types
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.HUnit ((@?=), assertFailure, testCase)
|
||||
import Test.Tasty.Hedgehog (testProperty)
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "mutation protocol decisions"
|
||||
[ testCase "protocol phases round-trip through persisted state labels" $
|
||||
mapM_
|
||||
(\phase -> do
|
||||
let (state, external) = encodeMutationPhase phase
|
||||
decodeMutationPhase state external @?= Just phase)
|
||||
[ PhasePrepared
|
||||
, PhaseApplying ExtIdle
|
||||
, PhaseApplying ExtPending
|
||||
, PhaseApplying ExtSettled
|
||||
, PhaseTerminal TerminalSucceeded
|
||||
, PhaseTerminal TerminalFailed
|
||||
, PhaseTerminal TerminalRejected
|
||||
]
|
||||
, testCase "invalid persisted protocol phase combinations are rejected" $
|
||||
mapM_
|
||||
(\(state, external) ->
|
||||
decodeMutationPhase state external @?= Nothing)
|
||||
[ (Prepared, ExtPending)
|
||||
, (Prepared, ExtSettled)
|
||||
, (Succeeded, ExtPending)
|
||||
, (Succeeded, ExtSettled)
|
||||
, (Failed, ExtPending)
|
||||
, (Failed, ExtSettled)
|
||||
, (Rejected, ExtPending)
|
||||
, (Rejected, ExtSettled)
|
||||
]
|
||||
, testProperty "request fingerprints distinguish every bound field"
|
||||
propFingerprintDistinction
|
||||
, testCase "removed terminal identity starts a new mutation epoch" $ do
|
||||
let rec = sampleMutation
|
||||
Put
|
||||
(ObjectKey "users/u/file")
|
||||
4
|
||||
(Just (ContentSha256 "content"))
|
||||
fingerprint =
|
||||
MutationFingerprint Put (mrObjectKey rec) 4 (mrContentSha256 rec)
|
||||
case existingDisposition Nothing fingerprint of
|
||||
NewMutationEpoch -> pure ()
|
||||
other -> assertFailure ("expected new epoch, got " <> show other)
|
||||
case existingDisposition (Just rec) fingerprint of
|
||||
ExistingReplay MutationPending _ -> pure ()
|
||||
other -> assertFailure ("expected replay, got " <> show other)
|
||||
case existingDisposition
|
||||
(Just rec)
|
||||
(fingerprint { fingerprintDeclaredSize = 5 }) of
|
||||
ExistingConflict -> pure ()
|
||||
other -> assertFailure ("expected conflict, got " <> show other)
|
||||
, testProperty "quota growth and admission preserve the limit" propQuotaInvariant
|
||||
, testProperty "object observations match the independent classifier"
|
||||
propObservations
|
||||
, testCase "unavailable observations match no terminal state" $ do
|
||||
let rec = sampleMutation Put (ObjectKey "shared/file") 10
|
||||
(Just (ContentSha256 "desired"))
|
||||
observation = ObjectUnavailable "timeout"
|
||||
desiredMatches rec observation @?= False
|
||||
priorMatches rec observation @?= False
|
||||
, testCase "ambiguous same-size content matches no terminal state" $ do
|
||||
let rec = (sampleMutation Put (ObjectKey "shared/file") 10
|
||||
(Just (ContentSha256 "desired")))
|
||||
{ mrPriorObject =
|
||||
PriorObject 10 (Just (ContentSha256 "prior"))
|
||||
}
|
||||
observation = ObjectPresent 10 (Just (ContentSha256 "other"))
|
||||
desiredMatches rec observation @?= False
|
||||
priorMatches rec observation @?= False
|
||||
, testProperty "only settled terminal records are expiry eligible"
|
||||
propExpiryEligibility
|
||||
, testProperty "terminal identities expire only after the window"
|
||||
propTerminalExpiry
|
||||
, testProperty "only stale active records are recovery eligible"
|
||||
propRecoveryTiming
|
||||
]
|
||||
|
||||
propFingerprintDistinction :: Property
|
||||
propFingerprintDistinction = property $ do
|
||||
ValidPath raw <- forAll genValidPath
|
||||
size <- forAll (Gen.integral (Range.linear 1 1000000))
|
||||
let uid = encodeUserId "issuer" "subject"
|
||||
key = buildObjectKey Personal uid (RelativePath raw)
|
||||
otherRootKey = buildObjectKey Shared uid (RelativePath raw)
|
||||
otherPathKey = buildObjectKey Personal uid (RelativePath ("other/" <> raw))
|
||||
sha = Just (ContentSha256 "content-a")
|
||||
rec = sampleMutation Put key size sha
|
||||
fingerprint = MutationFingerprint Put key size sha
|
||||
assert (sameFingerprint rec fingerprint)
|
||||
assert (not (sameFingerprint rec
|
||||
(fingerprint { fingerprintKind = Delete })))
|
||||
assert (not (sameFingerprint rec
|
||||
(fingerprint { fingerprintObjectKey = otherRootKey })))
|
||||
assert (not (sameFingerprint rec
|
||||
(fingerprint { fingerprintObjectKey = otherPathKey })))
|
||||
assert (not (sameFingerprint rec
|
||||
(fingerprint { fingerprintDeclaredSize = size + 1 })))
|
||||
assert (not (sameFingerprint rec
|
||||
(fingerprint
|
||||
{ fingerprintContentSha256 = Just (ContentSha256 "content-b") })))
|
||||
|
||||
propQuotaInvariant :: Property
|
||||
propQuotaInvariant = property $ do
|
||||
prior <- forAll nonNegativeBytes
|
||||
desired <- forAll nonNegativeBytes
|
||||
used <- forAll nonNegativeBytes
|
||||
reserved <- forAll nonNegativeBytes
|
||||
limit <- forAll nonNegativeBytes
|
||||
let growth = growthBytes prior desired
|
||||
modelGrowth = max 0 (desired - prior)
|
||||
allowed = quotaAllows limit used reserved growth
|
||||
growth === modelGrowth
|
||||
assert (growth >= 0)
|
||||
allowed === (used + reserved + modelGrowth <= limit)
|
||||
if allowed
|
||||
then assert (used + reserved + growth <= limit)
|
||||
else assert (used + reserved + growth > limit)
|
||||
where
|
||||
nonNegativeBytes = Gen.integral (Range.linear 0 1000000000)
|
||||
|
||||
propObservations :: Property
|
||||
propObservations = property $ do
|
||||
kind <- forAll (Gen.element [Put, Delete])
|
||||
desiredSize <- forAll (Gen.integral (Range.linear 1 1000000))
|
||||
priorSize <- forAll (Gen.integral (Range.linear 0 1000000))
|
||||
observation <- forAll genObservation
|
||||
let desiredSha = Just (ContentSha256 "desired")
|
||||
priorSha = if priorSize == 0 then Nothing else Just (ContentSha256 "prior")
|
||||
rec = (sampleMutation kind (ObjectKey "users/u/file") desiredSize desiredSha)
|
||||
{ mrPriorObject = PriorObject priorSize priorSha }
|
||||
desiredMatches rec observation
|
||||
=== modelDesired kind desiredSize desiredSha observation
|
||||
priorMatches rec observation === modelPrior priorSize priorSha observation
|
||||
|
||||
propExpiryEligibility :: Property
|
||||
propExpiryEligibility = property $ do
|
||||
state <- forAll genMutationState
|
||||
external <- forAll genExternalState
|
||||
terminalExpiryEligible state external
|
||||
=== (state `elem` [Succeeded, Failed, Rejected] && external == ExtIdle)
|
||||
|
||||
propTerminalExpiry :: Property
|
||||
propTerminalExpiry = property $ do
|
||||
state <- forAll genMutationState
|
||||
external <- forAll genExternalState
|
||||
elapsed <- forAll (Gen.integral (Range.linear 0 10000))
|
||||
window <- forAll (Gen.integral (Range.linear 1 10000))
|
||||
terminalExpired state external elapsed window
|
||||
=== ( state `elem` [Succeeded, Failed, Rejected]
|
||||
&& external == ExtIdle
|
||||
&& elapsed > window
|
||||
)
|
||||
|
||||
propRecoveryTiming :: Property
|
||||
propRecoveryTiming = property $ do
|
||||
state <- forAll genMutationState
|
||||
elapsed <- forAll (Gen.integral (Range.linear 0 10000))
|
||||
grace <- forAll (Gen.integral (Range.linear 0 10000))
|
||||
recoveryEligible state elapsed grace
|
||||
=== (state `elem` [Prepared, Applying] && elapsed > grace)
|
||||
|
||||
genObservation :: Gen ObjectObservation
|
||||
genObservation = Gen.choice
|
||||
[ pure ObjectAbsent
|
||||
, pure (ObjectUnavailable "dependency unavailable")
|
||||
, ObjectPresent
|
||||
<$> Gen.integral (Range.linear 0 1000000)
|
||||
<*> Gen.element
|
||||
[ Nothing
|
||||
, Just (ContentSha256 "desired")
|
||||
, Just (ContentSha256 "prior")
|
||||
, Just (ContentSha256 "other")
|
||||
]
|
||||
]
|
||||
|
||||
modelDesired
|
||||
:: MutationKind
|
||||
-> Integer
|
||||
-> Maybe ContentSha256
|
||||
-> ObjectObservation
|
||||
-> Bool
|
||||
modelDesired kind size sha observation =
|
||||
case (kind, observation) of
|
||||
(Delete, ObjectAbsent) -> True
|
||||
(Put, ObjectPresent observedSize observedSha) ->
|
||||
observedSize == size
|
||||
&& case (sha, observedSha) of
|
||||
(Just expected, Just actual) -> expected == actual
|
||||
(Just _, Nothing) -> False
|
||||
(Nothing, _) -> True
|
||||
_ -> False
|
||||
|
||||
modelPrior
|
||||
:: Integer
|
||||
-> Maybe ContentSha256
|
||||
-> ObjectObservation
|
||||
-> Bool
|
||||
modelPrior size sha observation =
|
||||
case observation of
|
||||
ObjectUnavailable _ -> False
|
||||
ObjectAbsent -> size == 0 && sha == Nothing
|
||||
ObjectPresent observedSize observedSha ->
|
||||
observedSize == size
|
||||
&& case (sha, observedSha) of
|
||||
(Just expected, Just actual) -> expected == actual
|
||||
(Nothing, Nothing) -> True
|
||||
(Just _, Nothing) -> False
|
||||
(Nothing, Just _) -> True
|
||||
|
||||
genMutationState :: Gen MutationState
|
||||
genMutationState =
|
||||
Gen.element [Prepared, Applying, Succeeded, Failed, Rejected]
|
||||
|
||||
genExternalState :: Gen ExternalState
|
||||
genExternalState = Gen.element [ExtIdle, ExtPending, ExtSettled]
|
||||
|
||||
sampleMutation
|
||||
:: MutationKind
|
||||
-> ObjectKey
|
||||
-> Integer
|
||||
-> Maybe ContentSha256
|
||||
-> MutationRecord
|
||||
sampleMutation kind key size sha = MutationRecord
|
||||
{ mrAdmissionIdentity =
|
||||
AdmissionIdentity (UserId "u") kind (OperationId "op")
|
||||
, mrPoolId = PoolId "personal:u"
|
||||
, mrRelativePath = RelativePath "file"
|
||||
, mrFingerprint = MutationFingerprint kind key size sha
|
||||
, mrPriorObject = PriorObject 0 Nothing
|
||||
, mrGrowth = size
|
||||
, mrPhase = PhaseApplying ExtSettled
|
||||
}
|
||||
97
test/Nuthatch/Test/Recovery.hs
Normal file
97
test/Nuthatch/Test/Recovery.hs
Normal file
|
|
@ -0,0 +1,97 @@
|
|||
module Nuthatch.Test.Recovery
|
||||
( tests
|
||||
) where
|
||||
|
||||
import Control.Concurrent (threadDelay)
|
||||
import Control.Concurrent.MVar
|
||||
( newEmptyMVar
|
||||
, putMVar
|
||||
, takeMVar
|
||||
)
|
||||
import Control.Exception
|
||||
( AsyncException (ThreadKilled)
|
||||
, SomeException
|
||||
, finally
|
||||
, throwIO
|
||||
, try
|
||||
)
|
||||
import Control.Retry (simulatePolicy)
|
||||
import Hedgehog (Gen, Property, forAll, property, (===))
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import qualified Hedgehog.Range as Range
|
||||
import Nuthatch.Recovery
|
||||
( recoveryClaimEligible
|
||||
, recoveryRetryPolicy
|
||||
, trySynchronous
|
||||
, withLinkedWorker
|
||||
)
|
||||
import Nuthatch.Types (ExternalState (..), MutationState (..))
|
||||
import qualified System.Timeout as Timeout
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.HUnit (assertBool, assertFailure, testCase)
|
||||
import Test.Tasty.Hedgehog (testProperty)
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "recovery"
|
||||
[ testProperty "worker lease and settlement independently gate recovery"
|
||||
propRecoveryClaim
|
||||
, testCase "asynchronous cancellation is not converted to failure" $ do
|
||||
result <- try (trySynchronous (throwIO ThreadKilled))
|
||||
:: IO (Either AsyncException (Either SomeException ()))
|
||||
case result of
|
||||
Left ThreadKilled -> pure ()
|
||||
other -> assertFailure ("asynchronous exception was swallowed: " <> show other)
|
||||
, testCase "linked worker failure interrupts the foreground" $ do
|
||||
result <- Timeout.timeout 1000000 $
|
||||
try (withLinkedWorker
|
||||
(threadDelay 10000 >> fail "worker failed")
|
||||
(threadDelay 5000000))
|
||||
:: IO (Maybe (Either SomeException ()))
|
||||
case result of
|
||||
Just (Left _) -> pure ()
|
||||
other -> assertFailure ("linked worker did not fail promptly: " <> show other)
|
||||
, testCase "structured worker scope cancels and joins the worker" $ do
|
||||
started <- newEmptyMVar
|
||||
stopped <- newEmptyMVar
|
||||
withLinkedWorker
|
||||
(putMVar started () >>
|
||||
(threadDelay 5000000 `finally` putMVar stopped ()))
|
||||
(takeMVar started)
|
||||
takeMVar stopped
|
||||
, testCase "recovery retry policy has bounded exponential decisions" $ do
|
||||
schedule <- simulatePolicy 8 recoveryRetryPolicy
|
||||
let decisions = map snd schedule
|
||||
retries = length [() | Just _ <- decisions]
|
||||
assertBool "retry policy must retry" (retries > 0)
|
||||
assertBool "retry policy must be bounded" (retries <= 5)
|
||||
assertBool "retry policy must exhaust" (Nothing `elem` decisions)
|
||||
]
|
||||
|
||||
propRecoveryClaim :: Property
|
||||
propRecoveryClaim = property $ do
|
||||
state <- forAll genMutationState
|
||||
external <- forAll genExternalState
|
||||
elapsed <- forAll (Gen.integral (Range.linear 0 10000))
|
||||
grace <- forAll (Gen.integral (Range.linear 0 10000))
|
||||
leaseExpired <- forAll Gen.bool
|
||||
deadlineExpired <- forAll Gen.bool
|
||||
recoveryClaimEligible
|
||||
state
|
||||
external
|
||||
elapsed
|
||||
grace
|
||||
leaseExpired
|
||||
deadlineExpired
|
||||
=== ( state `elem` [Prepared, Applying]
|
||||
&& case external of
|
||||
ExtIdle -> elapsed > grace
|
||||
ExtSettled -> elapsed > grace
|
||||
ExtPending -> leaseExpired && deadlineExpired
|
||||
)
|
||||
|
||||
genMutationState :: Gen MutationState
|
||||
genMutationState =
|
||||
Gen.element [Prepared, Applying, Succeeded, Failed, Rejected]
|
||||
|
||||
genExternalState :: Gen ExternalState
|
||||
genExternalState = Gen.element [ExtIdle, ExtPending, ExtSettled]
|
||||
73
test/Nuthatch/Test/Runtime.hs
Normal file
73
test/Nuthatch/Test/Runtime.hs
Normal file
|
|
@ -0,0 +1,73 @@
|
|||
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")]
|
||||
]
|
||||
76
test/Nuthatch/Test/Streaming.hs
Normal file
76
test/Nuthatch/Test/Streaming.hs
Normal file
|
|
@ -0,0 +1,76 @@
|
|||
module Nuthatch.Test.Streaming
|
||||
( tests
|
||||
) where
|
||||
|
||||
import Control.Exception (try)
|
||||
import Crypto.Hash (Digest, SHA256, hash)
|
||||
import qualified Data.ByteArray as BA
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Base16 as B16
|
||||
import Data.IORef (modifyIORef', newIORef, readIORef)
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Nuthatch.Streaming
|
||||
( UploadStreamError (..)
|
||||
, consumeUploadParts
|
||||
, maximumMultipartBytes
|
||||
, multipartPartBytes
|
||||
)
|
||||
import Nuthatch.Types (ContentSha256 (..))
|
||||
import Servant.Types.SourceT
|
||||
( SourceT
|
||||
, StepT (..)
|
||||
, fromStepT
|
||||
, source
|
||||
)
|
||||
import Test.Tasty (TestTree, testGroup)
|
||||
import Test.Tasty.HUnit ((@?=), testCase)
|
||||
|
||||
tests :: TestTree
|
||||
tests = testGroup "streaming"
|
||||
[ testCase "upload bodies are inspected and emitted in bounded parts" $ do
|
||||
inspected <- newIORef []
|
||||
emitted <- newIORef []
|
||||
consumeUploadParts
|
||||
6
|
||||
(strictSha256 "abcdef")
|
||||
2
|
||||
4
|
||||
(\piece -> modifyIORef' inspected (<> [piece]))
|
||||
(source ["abcdef"])
|
||||
(\part -> modifyIORef' emitted (<> [part]))
|
||||
readIORef inspected >>= (@?= ["ab", "cd", "ef"])
|
||||
readIORef emitted >>= (@?= ["abcd", "ef"])
|
||||
, testCase "multipart buffering has a fixed part-count bound" $
|
||||
maximumMultipartBytes @?= toInteger multipartPartBytes * 10000
|
||||
, testCase "upload rejects early end, surplus bytes, and identity mismatch" $ do
|
||||
short <- uploadFailure 4 (strictSha256 "body") (source ["bod"])
|
||||
short @?= UploadStreamSizeMismatch
|
||||
long <- uploadFailure 4 (strictSha256 "body") (source ["body!"])
|
||||
long @?= UploadStreamSizeMismatch
|
||||
identity <- uploadFailure 4 (strictSha256 "else") (source ["body"])
|
||||
identity @?= UploadStreamIdentityMismatch
|
||||
, testCase "upload preserves source errors" $ do
|
||||
failure <- uploadFailure
|
||||
4
|
||||
(strictSha256 "body")
|
||||
(fromStepT (Error "request failed"))
|
||||
failure @?= UploadStreamInvalid "request failed"
|
||||
]
|
||||
|
||||
uploadFailure
|
||||
:: Integer
|
||||
-> ContentSha256
|
||||
-> SourceT IO BS.ByteString
|
||||
-> IO UploadStreamError
|
||||
uploadFailure size identity body = do
|
||||
result <- try $
|
||||
consumeUploadParts
|
||||
size identity 2 4 (const (pure ())) body (const (pure ()))
|
||||
case result of
|
||||
Left failure -> pure failure
|
||||
Right _ -> fail "expected upload stream rejection"
|
||||
|
||||
strictSha256 :: BS.ByteString -> ContentSha256
|
||||
strictSha256 bytes =
|
||||
ContentSha256 . TE.decodeUtf8 . B16.encode . BA.convert $
|
||||
(hash bytes :: Digest SHA256)
|
||||
Loading…
Reference in a new issue