Auth + JWT Tests compile without errors
This commit is contained in:
aaron levin
parent
88974106b1
commit
710479e109
1 changed files with 19 additions and 89 deletions
|
|
@ -32,13 +32,13 @@ import GHC.Generics (Generic)
|
||||||
import Network.HTTP.Types (hAccept, hContentType,
|
import Network.HTTP.Types (hAccept, hContentType,
|
||||||
methodDelete, methodGet, methodHead,
|
methodDelete, methodGet, methodHead,
|
||||||
methodPatch, methodPost, methodPut,
|
methodPatch, methodPost, methodPut,
|
||||||
ok200, parseQuery, Status(..))
|
ok200, parseQuery, ResponseHeaders, Status(..))
|
||||||
import Network.Wai (Application, Request, pathInfo,
|
import Network.Wai (Application, Request, pathInfo,
|
||||||
queryString, rawQueryString,
|
queryString, rawQueryString,
|
||||||
responseLBS, responseBuilder)
|
responseLBS, responseBuilder)
|
||||||
import Network.Wai.Internal (Response(ResponseBuilder))
|
import Network.Wai.Internal (Response(ResponseBuilder))
|
||||||
import Network.Wai.Test (asertHeader, defaultRequest, request,
|
import Network.Wai.Test (defaultRequest, request,
|
||||||
runSession, simpleBody, SResponse)
|
runSession, simpleBody, simpleHeaders, SResponse)
|
||||||
import Servant.API ((:<|>) (..), (:>), Capture, Delete,
|
import Servant.API ((:<|>) (..), (:>), Capture, Delete,
|
||||||
Get, Header (..), Headers,
|
Get, Header (..), Headers,
|
||||||
HttpVersion, IsSecure (..), JSON,
|
HttpVersion, IsSecure (..), JSON,
|
||||||
|
|
@ -47,26 +47,18 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete,
|
||||||
Raw, RemoteHost, ReqBody,
|
Raw, RemoteHost, ReqBody,
|
||||||
addHeader)
|
addHeader)
|
||||||
import Servant.Server (Server, serve, ServantErr(..), err404)
|
import Servant.Server (Server, serve, ServantErr(..), err404)
|
||||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)
|
||||||
import Test.Hspec.Wai (get, liftIO, matchHeaders,
|
import Test.Hspec.Wai (get, liftIO, matchHeaders,
|
||||||
matchStatus, post, request,
|
matchStatus, post, request,
|
||||||
shouldRespondWith, with, (<:>))
|
shouldRespondWith, with, (<:>))
|
||||||
import Test.Hspec.Wai.Internal (WaiSession(WaiSession))
|
import Test.Hspec.Wai.Internal (WaiSession)
|
||||||
import Servant.Server.Internal.RoutingApplication (toApplication)
|
import Servant.Server.Internal.RoutingApplication (toApplication)
|
||||||
import Servant.Server.Internal.Router
|
import Servant.Server.Internal.Router
|
||||||
(tweakResponse, runRouter,
|
(tweakResponse, runRouter,
|
||||||
Router, Router'(LeafRouter))
|
Router, Router'(LeafRouter))
|
||||||
import Servant.API ((:<|>) (..), (:>),
|
|
||||||
addHeader, Capture,
|
|
||||||
Delete, Get, Header (..), Headers,
|
|
||||||
HttpVersion, IsSecure(..), JSON, MatrixFlag,
|
|
||||||
MatrixParam, MatrixParams, Patch, PlainText,
|
|
||||||
Post, Put, RemoteHost, QueryFlag, QueryParam,
|
|
||||||
QueryParams, Raw, ReqBody)
|
|
||||||
import Servant.API.Authentication
|
import Servant.API.Authentication
|
||||||
import Servant.Server.Internal.Authentication
|
import Servant.Server.Internal.Authentication
|
||||||
import Servant.Server (Server, serve, ServantErr(..), err404)
|
import Servant.Server.Internal.RoutingApplication (RouteResult(Route))
|
||||||
import Servant.Server.Internal (RouteMismatch (..))
|
|
||||||
import Web.JWT hiding (JSON)
|
import Web.JWT hiding (JSON)
|
||||||
|
|
||||||
|
|
||||||
|
|
@ -613,71 +605,6 @@ prioErrorsSpec = describe "PrioErrors" $ do
|
||||||
check put' "/bar" vjson 404
|
check put' "/bar" vjson 404
|
||||||
check put' "/foo" vjson 405
|
check put' "/foo" vjson 405
|
||||||
|
|
||||||
|
|
||||||
-- | fake equality to use for testing the RouteMismatch spec (errorSpec).
|
|
||||||
-- this is a hack around RouteMismatch not having an `Eq` instance.
|
|
||||||
(=:=) :: RouteMismatch -> RouteMismatch -> Bool
|
|
||||||
NotFound =:= NotFound = True
|
|
||||||
WrongMethod =:= WrongMethod = True
|
|
||||||
(InvalidBody ib1) =:= (InvalidBody ib2) = ib1 == ib2
|
|
||||||
(HttpError s1 hs1 mb1) =:= (HttpError s2 hs2 mb2) = s1 == s2 && hs1 == hs2 && mb1 == mb2
|
|
||||||
(RouteMismatch _) =:= (RouteMismatch _) = True
|
|
||||||
_ =:= _ = False
|
|
||||||
|
|
||||||
-- | Test server error functionality.
|
|
||||||
errorsSpec :: Spec
|
|
||||||
errorsSpec = do
|
|
||||||
let he = HttpError status409 [] (Just "A custom error")
|
|
||||||
let ib = InvalidBody "The body is invalid"
|
|
||||||
let wm = WrongMethod
|
|
||||||
let nf = NotFound
|
|
||||||
let rm = RouteMismatch (responseBuilder status409 [] mempty)
|
|
||||||
|
|
||||||
describe "Servant.Server.Internal.RouteMismatch" $ do
|
|
||||||
it "RouteMismatch > *" $ do
|
|
||||||
(ib <> rm) =:= rm `shouldBe` True
|
|
||||||
(wm <> rm) =:= rm `shouldBe` True
|
|
||||||
(nf <> rm) =:= rm `shouldBe` True
|
|
||||||
(he <> rm) =:= rm `shouldBe` True
|
|
||||||
|
|
||||||
(rm <> ib) =:= rm `shouldBe` True
|
|
||||||
(rm <> wm) =:= rm `shouldBe` True
|
|
||||||
(rm <> nf) =:= rm `shouldBe` True
|
|
||||||
(rm <> he) =:= rm `shouldBe` True
|
|
||||||
|
|
||||||
it "RouteMismatch > HttpError > *" $ do
|
|
||||||
(ib <> he) =:= he `shouldBe` True
|
|
||||||
(wm <> he) =:= he `shouldBe` True
|
|
||||||
(nf <> he) =:= he `shouldBe` True
|
|
||||||
|
|
||||||
(he <> ib) =:= he `shouldBe` True
|
|
||||||
(he <> wm) =:= he `shouldBe` True
|
|
||||||
(he <> nf) =:= he `shouldBe` True
|
|
||||||
|
|
||||||
it "HE > InvalidBody > (WM,NF)" $ do
|
|
||||||
(wm <> ib) =:= ib `shouldBe` True
|
|
||||||
(nf <> ib) =:= ib `shouldBe` True
|
|
||||||
|
|
||||||
(ib <> wm) =:= ib `shouldBe` True
|
|
||||||
(ib <> nf) =:= ib `shouldBe` True
|
|
||||||
|
|
||||||
it "HE > IB > WrongMethod > NF" $ do
|
|
||||||
(nf <> wm) =:= wm `shouldBe` True
|
|
||||||
|
|
||||||
(wm <> nf) =:= wm `shouldBe` True
|
|
||||||
|
|
||||||
-- TODO: this is redundant, but maybe helpful for clarity.
|
|
||||||
it "* > NotFound" $ do
|
|
||||||
(he <> nf) =:= he `shouldBe` True
|
|
||||||
(ib <> nf) =:= ib `shouldBe` True
|
|
||||||
(wm <> nf) =:= wm `shouldBe` True
|
|
||||||
(rm <> nf) =:= rm `shouldBe` True
|
|
||||||
|
|
||||||
(nf <> he) =:= he `shouldBe` True
|
|
||||||
(nf <> ib) =:= ib `shouldBe` True
|
|
||||||
(nf <> wm) =:= wm `shouldBe` True
|
|
||||||
(nf <> rm) =:= rm `shouldBe` True
|
|
||||||
|
|
||||||
type MiscCombinatorsAPI
|
type MiscCombinatorsAPI
|
||||||
= "version" :> HttpVersion :> Get '[JSON] String
|
= "version" :> HttpVersion :> Get '[JSON] String
|
||||||
:<|> "secure" :> IsSecure :> Get '[JSON] String
|
:<|> "secure" :> IsSecure :> Get '[JSON] String
|
||||||
|
|
@ -755,13 +682,13 @@ basicAuthRequiredSpec = do
|
||||||
describe "Servant.API.Authentication" $ do
|
describe "Servant.API.Authentication" $ do
|
||||||
with (return $ serve basicBasicAuthRequiredApi basicAuthRequiredServer) $ do
|
with (return $ serve basicBasicAuthRequiredApi basicAuthRequiredServer) $ do
|
||||||
it "allows access with the correct username and password" $ do
|
it "allows access with the correct username and password" $ do
|
||||||
response <- basicAuthGet "/foo" base64ServantColonServer
|
response1 <- basicAuthGet "/foo" base64ServantColonServer
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
decode' (simpleBody response) `shouldBe` Just alice
|
decode' (simpleBody response1) `shouldBe` Just alice
|
||||||
|
|
||||||
response <- basicAuthGet "/bar" base64BarColonPassword
|
response2 <- basicAuthGet "/bar" base64BarColonPassword
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
decode' (simpleBody response) `shouldBe` Just jerry
|
decode' (simpleBody response2) `shouldBe` Just jerry
|
||||||
|
|
||||||
it "rejects requests with the incorrect username and password" $ do
|
it "rejects requests with the incorrect username and password" $ do
|
||||||
basicAuthGet "/foo" base64UserColonPassword `shouldRespondWith` 401
|
basicAuthGet "/foo" base64UserColonPassword `shouldRespondWith` 401
|
||||||
|
|
@ -774,9 +701,11 @@ basicAuthRequiredSpec = do
|
||||||
it "adds the appropriate header to rejected 401 requests" $ do
|
it "adds the appropriate header to rejected 401 requests" $ do
|
||||||
foo401 <- get "/foo"
|
foo401 <- get "/foo"
|
||||||
bar401 <- get "/bar"
|
bar401 <- get "/bar"
|
||||||
WaiSession (assertHeader "WWW-Authenticate" "Basic realm=\"foo-realm\"" foo401)
|
liftIO $ do
|
||||||
WaiSession (assertHeader "WWW-Authenticate" "Basic realm=\"bar-realm\"" bar401)
|
let fooHeader = [("WWW-Authenticate", "Basic realm=\"foo-realm\"")] :: ResponseHeaders
|
||||||
|
let barHeader = [("WWW-Authenticate", "Basic realm=\"bar-realm\"")] :: ResponseHeaders
|
||||||
|
(simpleHeaders foo401) `shouldContain` fooHeader
|
||||||
|
(simpleHeaders bar401) `shouldContain` barHeader
|
||||||
|
|
||||||
|
|
||||||
type JWTAuthProtect = AuthProtect JWTAuth (JWT VerifiedJWT) 'Strict
|
type JWTAuthProtect = AuthProtect JWTAuth (JWT VerifiedJWT) 'Strict
|
||||||
|
|
@ -810,8 +739,9 @@ jwtAuthRequiredSpec = do
|
||||||
get "/foo" `shouldRespondWith` 401
|
get "/foo" `shouldRespondWith` 401
|
||||||
it "responds correctly to requests without auth data" $ do
|
it "responds correctly to requests without auth data" $ do
|
||||||
a <- jwtAuthGet "/foo" incorrectToken
|
a <- jwtAuthGet "/foo" incorrectToken
|
||||||
WaiSession (assertHeader "WWW-Authenticate" "Bearer error=\"invalid_token\"" a)
|
let aHeader = [("WWW-Authenticate", "Bearer error=\"invalid_token\"")] :: ResponseHeaders
|
||||||
|
liftIO (simpleHeaders a `shouldContain` aHeader)
|
||||||
it "respond correctly to requests with incorrect auth data" $ do
|
it "respond correctly to requests with incorrect auth data" $ do
|
||||||
a <- get "/foo"
|
a <- get "/foo"
|
||||||
WaiSession (assertHeader "WWW-Authenticate" "Bearer error=\"invalid_request\"" a)
|
let aHeader = [("WWW-Authenticate", "Bearer error=\"invalid_token\"")] :: ResponseHeaders
|
||||||
|
liftIO (simpleHeaders a `shouldContain` aHeader)
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue