427 lines
15 KiB
Haskell
427 lines
15 KiB
Haskell
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 (..), HttpConfig)
|
|
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"
|
|
]
|
|
|
|
httpConfig :: HttpConfig
|
|
httpConfig = cfgHttp testConfig
|
|
|
|
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 httpConfig "issuer" "subject" Nothing
|
|
token <- either (fail . T.unpack) pure tokenResult
|
|
let csrf = CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
|
responseHeaders = getHeaders
|
|
(loginResponse httpConfig 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 httpConfig 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 :: HttpConfig -> IORef Int -> Application
|
|
productionAuthTestApplication cfg calls =
|
|
utf8Boundary $
|
|
serveWithContext
|
|
api
|
|
(authenticationHandler cfg :. EmptyContext)
|
|
(typedTestServer calls)
|