Replace raw HTTP dispatch with typed Servant API
This commit is contained in:
parent
06d1383456
commit
435d4fea4c
1 changed files with 1625 additions and 445 deletions
425
test/Spec.hs
425
test/Spec.hs
|
|
@ -1,8 +1,14 @@
|
|||
module Main (main) where
|
||||
|
||||
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.Either (isLeft)
|
||||
import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as TE
|
||||
import Hedgehog
|
||||
( Gen
|
||||
, Property
|
||||
|
|
@ -13,11 +19,35 @@ import Hedgehog
|
|||
)
|
||||
import qualified Hedgehog.Gen as Gen
|
||||
import qualified Hedgehog.Range as Range
|
||||
import Network.HTTP.Types
|
||||
( HeaderName
|
||||
, methodGet
|
||||
, methodPost
|
||||
, status200
|
||||
, status400
|
||||
, status404
|
||||
, status405
|
||||
)
|
||||
import Network.Wai (Request (..))
|
||||
import Network.Wai.Test
|
||||
( SRequest (..)
|
||||
, SResponse (..)
|
||||
, defaultRequest
|
||||
, runSession
|
||||
, setPath
|
||||
, srequest
|
||||
)
|
||||
import Nuthatch.Api
|
||||
import Nuthatch.App
|
||||
( authenticationHandler
|
||||
, loginResponse
|
||||
, utf8Boundary
|
||||
)
|
||||
import Nuthatch.Config (AuthMode (..), Config (..))
|
||||
import Nuthatch.Paths
|
||||
( buildObjectKey
|
||||
, encodeUserId
|
||||
, listCacheAncestorPrefixes
|
||||
, validateRelativePath
|
||||
)
|
||||
import Nuthatch.Protocol
|
||||
( MutationRecord (..)
|
||||
|
|
@ -31,8 +61,13 @@ import Nuthatch.Protocol
|
|||
, terminalExpiryEligible
|
||||
)
|
||||
import Nuthatch.Types
|
||||
import Nuthatch.Session (mintSession)
|
||||
import Nuthatch.Ui (browsePage, browserScript, loginPage)
|
||||
import Servant
|
||||
import Servant.Server.Experimental.Auth (AuthHandler, mkAuthHandler)
|
||||
import Servant.Types.SourceT (source)
|
||||
import Test.Tasty (TestTree, defaultMain, testGroup)
|
||||
import Test.Tasty.HUnit ((@?=), testCase)
|
||||
import Test.Tasty.HUnit ((@?=), assertBool, testCase)
|
||||
import Test.Tasty.Hedgehog (testProperty)
|
||||
|
||||
main :: IO ()
|
||||
|
|
@ -43,6 +78,7 @@ tests = testGroup "nuthatch-unit"
|
|||
[ pathTests
|
||||
, identityTests
|
||||
, protocolTests
|
||||
, apiTests
|
||||
]
|
||||
|
||||
pathTests :: TestTree
|
||||
|
|
@ -76,6 +112,391 @@ protocolTests = testGroup "mutation protocol decisions"
|
|||
, testProperty "only stale active records are recovery eligible" propRecoveryTiming
|
||||
]
|
||||
|
||||
apiTests :: TestTree
|
||||
apiTests = 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 InvalidUsername
|
||||
deleteError = A.encode (DeleteMutationRejected "locked")
|
||||
prefixError = A.encode (DeletePrefixMutationRejected "partial")
|
||||
assertBool "login errors carry the login-specific code"
|
||||
("invalid_username" `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 login emits both cookies"
|
||||
testAuthenticationBoundary
|
||||
, testCase "retained browser forms are wired to the typed API bridge"
|
||||
testBrowserBridge
|
||||
, 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
|
||||
"/?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 "/?root=PERSONAL" [] ""
|
||||
simpleStatus invalidRoot @?= status400
|
||||
invalidPath <- apiRequest calls methodGet "/?prefix=docs%2F..%2Fprivate" [] ""
|
||||
simpleStatus invalidPath @?= status400
|
||||
readIORef calls >>= (@?= 0)
|
||||
|
||||
testMalformedUtf8 :: IO ()
|
||||
testMalformedUtf8 = do
|
||||
calls <- newIORef 0
|
||||
response <- apiRequest calls methodGet "/?q=%FF" [] ""
|
||||
simpleStatus response @?= status400
|
||||
readIORef calls >>= (@?= 0)
|
||||
|
||||
testUploadDecoding :: IO ()
|
||||
testUploadDecoding = do
|
||||
calls <- newIORef 0
|
||||
let csrf = BS.replicate 43 97
|
||||
let 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
|
||||
"/upload?root=personal&path=docs%2Ffile.txt&operation_id=bad%20id"
|
||||
headers
|
||||
"body"
|
||||
simpleStatus response @?= status400
|
||||
invalidSize <- apiRequest calls methodPost
|
||||
"/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 "/?continuation=" [] ""
|
||||
simpleStatus invalidPagination @?= status400
|
||||
readIORef calls >>= (@?= 0)
|
||||
|
||||
testStreamingEndpoints :: IO ()
|
||||
testStreamingEndpoints = do
|
||||
calls <- newIORef 0
|
||||
let csrf = BS.replicate 43 97
|
||||
let 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
|
||||
"/upload?root=personal&path=docs%2Ffile.txt&operation_id=upload-1"
|
||||
headers
|
||||
"body"
|
||||
simpleStatus upload @?= status200
|
||||
download <- apiRequest calls methodGet
|
||||
"/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 methodPost
|
||||
"/login"
|
||||
[ ("Content-Type", "application/json")
|
||||
, ("Accept", "application/json")
|
||||
]
|
||||
"{\"username\":\"alice\"}"
|
||||
simpleStatus login @?= status200
|
||||
assertBool "login response must carry a user identity"
|
||||
("user_id" `BS.isInfixOf` BL.toStrict (simpleBody login))
|
||||
formLogin <- apiRequest calls methodPost
|
||||
"/login"
|
||||
[("Content-Type", "application/x-www-form-urlencoded")]
|
||||
"username=bob"
|
||||
simpleStatus formLogin @?= status200
|
||||
assertBool "browser login response navigates into the UI"
|
||||
("continue" `BS.isInfixOf` BL.toStrict (simpleBody formLogin))
|
||||
invalidLogin <- apiRequest calls methodPost
|
||||
"/login"
|
||||
[("Content-Type", "application/json")]
|
||||
"{\"username\":\"two words\"}"
|
||||
simpleStatus invalidLogin @?= status400
|
||||
deletion <- apiRequest calls methodPost
|
||||
"/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))
|
||||
malformed <- apiRequest calls methodPost
|
||||
"/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 (HtmlPage "login")
|
||||
:<|> counted (BrowserScript "script")
|
||||
:<|> (\_ -> counted
|
||||
(addHeader "session=cookie"
|
||||
(addHeader "csrf=cookie"
|
||||
(addHeader (CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
|
||||
(LoginView
|
||||
(HtmlPage "continue")
|
||||
(LoginResponse (UserId "user")))))))
|
||||
:<|> (\_ _ -> counted
|
||||
(addHeader "session=expired"
|
||||
(addHeader "csrf=expired" NoContent)))
|
||||
:<|> (\_ _ _ _ _ -> counted
|
||||
(BrowseView
|
||||
(HtmlPage "browse")
|
||||
BrowseResponse
|
||||
{ browseEntries = []
|
||||
, browseContinuation = Nothing
|
||||
, browsePartial = False
|
||||
}))
|
||||
:<|> (\_ _ _ -> counted
|
||||
(addHeader "attachment; filename=\"file.txt\""
|
||||
(addHeader "nosniff" (source ["body"]))))
|
||||
:<|> (\_ _ _ operation _ _ _ _ -> counted UploadResponse
|
||||
{ uploadResponseOperationId = operation
|
||||
, uploadResponseResult = MutationSucceeded
|
||||
})
|
||||
:<|> (\_ request -> counted DeleteResponse
|
||||
{ deleteResponseOperationId = deleteOperationId request
|
||||
, deleteResponseResult = MutationSucceeded
|
||||
})
|
||||
:<|> (\_ _ -> counted (DeletePrefixResponse 1))
|
||||
where
|
||||
counted :: a -> Handler a
|
||||
counted value = liftIO (modifyIORef' calls (+ 1)) >> pure value
|
||||
|
||||
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 (UserId "user") token csrf)
|
||||
cookieHeaders =
|
||||
[ value
|
||||
| (name, value) <- responseHeaders
|
||||
, name == "Set-Cookie"
|
||||
]
|
||||
length cookieHeaders @?= 2
|
||||
assertBool "login sets the session cookie"
|
||||
(any ("nuthatch_session=" `BS.isPrefixOf`) cookieHeaders)
|
||||
assertBool "login sets the CSRF cookie"
|
||||
(any ("nuthatch_csrf=" `BS.isPrefixOf`) cookieHeaders)
|
||||
|
||||
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
|
||||
"/?root=personal"
|
||||
[("Cookie", cookie)]
|
||||
""
|
||||
simpleStatus authenticated @?= status200
|
||||
readIORef calls >>= (@?= 1)
|
||||
|
||||
writeIORef calls 0
|
||||
malformed <- apiRequestWith app methodGet
|
||||
"/?root=personal"
|
||||
[("Cookie", "nuthatch_session=" <> BS.singleton 255
|
||||
<> "; nuthatch_csrf=" <> TE.encodeUtf8 (unCsrfToken csrf))]
|
||||
""
|
||||
simpleStatus malformed @?= status400
|
||||
readIORef calls >>= (@?= 0)
|
||||
|
||||
missingCsrf <- apiRequestWith app methodGet
|
||||
"/?root=personal"
|
||||
[("Cookie", "nuthatch_session=" <> TE.encodeUtf8 (unSessionToken token))]
|
||||
""
|
||||
simpleStatus missingCsrf @?= status200
|
||||
readIORef calls >>= (@?= 1)
|
||||
|
||||
testBrowserBridge :: IO ()
|
||||
testBrowserBridge = do
|
||||
let csrf = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
||||
user = SessionUser
|
||||
{ suIssuer = "issuer"
|
||||
, suSubject = "subject"
|
||||
, suUserId = UserId "user"
|
||||
, suDisplay = Just "User"
|
||||
}
|
||||
entry = ListEntry
|
||||
{ leName = "folder"
|
||||
, leIsPrefix = True
|
||||
, leSize = Nothing
|
||||
, leRelativePath = "folder"
|
||||
}
|
||||
browse = browsePage
|
||||
user
|
||||
Personal
|
||||
""
|
||||
csrf
|
||||
"upload-1"
|
||||
["delete-1"]
|
||||
[entry]
|
||||
Nothing
|
||||
""
|
||||
assertBool "login page loads the external bridge"
|
||||
("/nuthatch.js" `T.isInfixOf` loginPage "")
|
||||
mapM_
|
||||
(\marker -> assertBool ("browse page includes " <> T.unpack marker)
|
||||
(marker `T.isInfixOf` browse))
|
||||
[ "data-nuthatch=\"upload\""
|
||||
, "data-nuthatch=\"delete\""
|
||||
, "data-nuthatch=\"logout\""
|
||||
]
|
||||
mapM_
|
||||
(\endpoint -> assertBool ("bridge calls " <> T.unpack endpoint)
|
||||
(endpoint `T.isInfixOf` browserScript))
|
||||
[ "/upload"
|
||||
, "/delete-prefix"
|
||||
, "/logout"
|
||||
]
|
||||
|
||||
productionAuthTestApplication :: Config -> IORef Int -> Application
|
||||
productionAuthTestApplication cfg calls =
|
||||
utf8Boundary $
|
||||
serveWithContext
|
||||
api
|
||||
(authenticationHandler cfg :. EmptyContext)
|
||||
(typedTestServer calls)
|
||||
|
||||
testConfig :: Config
|
||||
testConfig = Config
|
||||
{ cfgListenHost = "127.0.0.1"
|
||||
, cfgListenPort = 8080
|
||||
, cfgPublicBaseUrl = "https://nuthatch.example"
|
||||
, cfgJwtSecret = "unit-test-secret-material"
|
||||
, cfgSessionHours = 1
|
||||
, cfgCookieName = "nuthatch_session"
|
||||
, cfgCsrfCookieName = "nuthatch_csrf"
|
||||
, cfgPgConn = ""
|
||||
, cfgRedisHost = ""
|
||||
, cfgRedisPort = 6379
|
||||
, cfgRedisDb = 0
|
||||
, cfgS3Endpoint = "https://s3.example"
|
||||
, cfgS3Region = "test"
|
||||
, cfgS3Bucket = "test"
|
||||
, cfgS3AccessKey = "test"
|
||||
, cfgS3SecretKey = "test"
|
||||
, cfgS3PathStyle = True
|
||||
, cfgPersonalQuotaBytes = 1024
|
||||
, cfgSharedQuotaBytes = 1024
|
||||
, cfgMaxObjectBytes = 1024
|
||||
, cfgThrottleBytesPerSec = 1024
|
||||
, cfgThrottleBurstBytes = 1024
|
||||
, cfgListCacheTtlSec = 30
|
||||
, cfgSearchMaxKeys = 100
|
||||
, cfgRecoveryGraceSec = 30
|
||||
, cfgAuthMode = AuthDev
|
||||
}
|
||||
|
||||
newtype ValidPath = ValidPath { getValidPath :: Text }
|
||||
deriving stock (Show)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue