Merge pull request #376 from haskell-servant/auth-gen
Generalized Auth Support
This commit is contained in:
commit
16e7234ab1
17 changed files with 328 additions and 70 deletions
|
@ -9,6 +9,8 @@ HEAD
|
|||
* Client functions now consider any 2xx successful.
|
||||
* Remove matrix params.
|
||||
* Added support for Basic authentication
|
||||
* Add generalized authentication support via the `AuthClientData` type family and
|
||||
`AuthenticateReq` data type
|
||||
|
||||
0.4.1
|
||||
-----
|
||||
|
|
|
@ -27,6 +27,7 @@ source-repository head
|
|||
library
|
||||
exposed-modules:
|
||||
Servant.Client
|
||||
Servant.Client.Experimental.Auth
|
||||
Servant.Common.BaseUrl
|
||||
Servant.Common.BasicAuth
|
||||
Servant.Common.Req
|
||||
|
|
|
@ -15,8 +15,11 @@
|
|||
-- querying functions for each endpoint just from the type representing your
|
||||
-- API.
|
||||
module Servant.Client
|
||||
( client
|
||||
( AuthClientData
|
||||
, AuthenticateReq(..)
|
||||
, client
|
||||
, HasClient(..)
|
||||
, mkAuthenticateReq
|
||||
, ServantError(..)
|
||||
, module Servant.Common.BaseUrl
|
||||
) where
|
||||
|
@ -36,6 +39,7 @@ import Network.HTTP.Media
|
|||
import qualified Network.HTTP.Types as H
|
||||
import qualified Network.HTTP.Types.Header as HTTP
|
||||
import Servant.API
|
||||
import Servant.Client.Experimental.Auth
|
||||
import Servant.Common.BaseUrl
|
||||
import Servant.Common.BasicAuth
|
||||
import Servant.Common.Req
|
||||
|
@ -424,6 +428,13 @@ instance HasClient subapi =>
|
|||
type Client (WithNamedContext name context subapi) = Client subapi
|
||||
clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)
|
||||
|
||||
instance ( HasClient api
|
||||
) => HasClient (AuthProtect tag :> api) where
|
||||
type Client (AuthProtect tag :> api)
|
||||
= AuthenticateReq (AuthProtect tag) -> Client api
|
||||
|
||||
clientWithRoute Proxy req baseurl manager (AuthenticateReq (val,func)) =
|
||||
clientWithRoute (Proxy :: Proxy api) (func val req) baseurl manager
|
||||
|
||||
-- * Basic Authentication
|
||||
|
||||
|
|
36
servant-client/src/Servant/Client/Experimental/Auth.hs
Normal file
36
servant-client/src/Servant/Client/Experimental/Auth.hs
Normal file
|
@ -0,0 +1,36 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
-- | Authentication for clients
|
||||
|
||||
module Servant.Client.Experimental.Auth (
|
||||
AuthenticateReq(AuthenticateReq, unAuthReq)
|
||||
, AuthClientData
|
||||
, mkAuthenticateReq
|
||||
) where
|
||||
|
||||
import Servant.Common.Req (Req)
|
||||
|
||||
-- | For a resource protected by authentication (e.g. AuthProtect), we need
|
||||
-- to provide the client with some data used to add authentication data
|
||||
-- to a request
|
||||
--
|
||||
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||
type family AuthClientData a :: *
|
||||
|
||||
-- | For better type inference and to avoid usage of a data family, we newtype
|
||||
-- wrap the combination of some 'AuthClientData' and a function to add authentication
|
||||
-- data to a request
|
||||
--
|
||||
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||
newtype AuthenticateReq a =
|
||||
AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) }
|
||||
|
||||
-- | Handy helper to avoid wrapping datatypes in tuples everywhere.
|
||||
--
|
||||
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||
mkAuthenticateReq :: AuthClientData a
|
||||
-> (AuthClientData a -> Req -> Req)
|
||||
-> AuthenticateReq a
|
||||
mkAuthenticateReq val func = AuthenticateReq (val, func)
|
|
@ -12,6 +12,7 @@
|
|||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fcontext-stack=100 #-}
|
||||
|
@ -41,7 +42,8 @@ import Network.HTTP.Media
|
|||
import Network.HTTP.Types (Status (..), badRequest400,
|
||||
methodGet, ok200, status400)
|
||||
import Network.Socket
|
||||
import Network.Wai (Application, responseLBS)
|
||||
import Network.Wai (Application, Request,
|
||||
requestHeaders, responseLBS)
|
||||
import Network.Wai.Handler.Warp
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import Test.Hspec
|
||||
|
@ -53,6 +55,8 @@ import Servant.API
|
|||
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||
import Servant.Client
|
||||
import Servant.Server
|
||||
import Servant.Server.Experimental.Auth
|
||||
import qualified Servant.Common.Req as SCR
|
||||
|
||||
-- This declaration simply checks that all instances are in place.
|
||||
_ = client comprehensiveAPI
|
||||
|
@ -63,6 +67,7 @@ spec = describe "Servant.Client" $ do
|
|||
failSpec
|
||||
wrappedApiSpec
|
||||
basicAuthSpec
|
||||
genAuthSpec
|
||||
|
||||
-- * test data types
|
||||
|
||||
|
@ -149,8 +154,7 @@ failServer = serve failApi (
|
|||
:<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
|
||||
)
|
||||
|
||||
|
||||
-- * auth stuff
|
||||
-- * basic auth stuff
|
||||
|
||||
type BasicAuthAPI =
|
||||
BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
|
||||
|
@ -166,11 +170,35 @@ basicAuthHandler =
|
|||
else return Unauthorized
|
||||
in BasicAuthCheck check
|
||||
|
||||
serverContext :: Context '[ BasicAuthCheck () ]
|
||||
serverContext = basicAuthHandler :. EmptyContext
|
||||
basicServerContext :: Context '[ BasicAuthCheck () ]
|
||||
basicServerContext = basicAuthHandler :. EmptyContext
|
||||
|
||||
basicAuthServer :: Application
|
||||
basicAuthServer = serveWithContext basicAuthAPI serverContext (const (return alice))
|
||||
basicAuthServer = serveWithContext basicAuthAPI basicServerContext (const (return alice))
|
||||
|
||||
-- * general auth stuff
|
||||
|
||||
type GenAuthAPI =
|
||||
AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person
|
||||
|
||||
genAuthAPI :: Proxy GenAuthAPI
|
||||
genAuthAPI = Proxy
|
||||
|
||||
type instance AuthServerData (AuthProtect "auth-tag") = ()
|
||||
type instance AuthClientData (AuthProtect "auth-tag") = ()
|
||||
|
||||
genAuthHandler :: AuthHandler Request ()
|
||||
genAuthHandler =
|
||||
let handler req = case lookup "AuthHeader" (requestHeaders req) of
|
||||
Nothing -> throwE (err401 { errBody = "Missing auth header" })
|
||||
Just _ -> return ()
|
||||
in mkAuthHandler handler
|
||||
|
||||
genAuthServerContext :: Context '[ AuthHandler Request () ]
|
||||
genAuthServerContext = genAuthHandler :. EmptyContext
|
||||
|
||||
genAuthServer :: Application
|
||||
genAuthServer = serveWithContext genAuthAPI genAuthServerContext (const (return alice))
|
||||
|
||||
{-# NOINLINE manager #-}
|
||||
manager :: C.Manager
|
||||
|
@ -333,6 +361,23 @@ basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ d
|
|||
Left FailureResponse{..} <- runExceptT (getBasic basicAuthData)
|
||||
responseStatus `shouldBe` Status 403 "Forbidden"
|
||||
|
||||
genAuthSpec :: Spec
|
||||
genAuthSpec = beforeAll (startWaiApp genAuthServer) $ afterAll endWaiApp $ do
|
||||
context "Authentication works when requests are properly authenticated" $ do
|
||||
|
||||
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
|
||||
let getProtected = client genAuthAPI baseUrl manager
|
||||
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "AuthHeader" ("cool" :: String) req)
|
||||
(left show <$> runExceptT (getProtected authRequest)) `shouldReturn` Right alice
|
||||
|
||||
context "Authentication is rejected when requests are not authenticated properly" $ do
|
||||
|
||||
it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
|
||||
let getProtected = client genAuthAPI baseUrl manager
|
||||
let authRequest = mkAuthenticateReq () (\_ req -> SCR.addHeader "Wrong" ("header" :: String) req)
|
||||
Left FailureResponse{..} <- runExceptT (getProtected authRequest)
|
||||
responseStatus `shouldBe` (Status 401 "Unauthorized")
|
||||
|
||||
-- * utils
|
||||
|
||||
startWaiApp :: Application -> IO (ThreadId, BaseUrl)
|
||||
|
|
|
@ -9,56 +9,54 @@
|
|||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
import Data.Aeson
|
||||
import Control.Monad.Trans.Except (ExceptT, throwE)
|
||||
import Data.Aeson hiding ((.:))
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.IORef
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Map (Map, fromList)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Text (Text)
|
||||
import GHC.Generics
|
||||
import Network.Wai
|
||||
import Network.Wai.Handler.Warp
|
||||
import Servant
|
||||
import Servant.Server.Internal
|
||||
import Servant.Server.Experimental.Auth
|
||||
|
||||
-- Pretty much stolen/adapted from
|
||||
-- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs
|
||||
-- | This file contains an authenticated server using servant's generalized
|
||||
-- authentication support. Our basic authentication scheme is trivial: we
|
||||
-- look for a cookie named "servant-auth-cookie" and its value will contain
|
||||
-- a key, which we use to lookup a User. Obviously this is an absurd example,
|
||||
-- but we pick something simple and non-standard to show you how to extend
|
||||
-- servant's support for authentication.
|
||||
|
||||
type DBConnection = IORef [ByteString]
|
||||
type DBLookup = DBConnection -> ByteString -> IO Bool
|
||||
-- | A user type that we "fetch from the database" after
|
||||
-- performing authentication
|
||||
newtype User = User { unUser :: Text }
|
||||
|
||||
initDB :: IO DBConnection
|
||||
initDB = newIORef ["good password"]
|
||||
-- | A (pure) database mapping keys to users.
|
||||
database :: Map ByteString User
|
||||
database = fromList [ ("key1", User "Anne Briggs")
|
||||
, ("key2", User "Bruce Cockburn")
|
||||
, ("key3", User "Ghédalia Tazartès")
|
||||
]
|
||||
|
||||
isGoodCookie :: DBLookup
|
||||
isGoodCookie ref password = do
|
||||
allowed <- readIORef ref
|
||||
return (password `elem` allowed)
|
||||
-- | A method that, when given a password, will return a User.
|
||||
-- This is our bespoke (and bad) authentication logic.
|
||||
lookupUser :: ByteString -> ExceptT ServantErr IO User
|
||||
lookupUser key = case Map.lookup key database of
|
||||
Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
|
||||
Just usr -> return usr
|
||||
|
||||
data AuthProtected
|
||||
|
||||
instance (HasContextEntry context DBConnection, HasServer rest context)
|
||||
=> HasServer (AuthProtected :> rest) context where
|
||||
|
||||
type ServerT (AuthProtected :> rest) m = ServerT rest m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \ request ->
|
||||
route (Proxy :: Proxy rest) context $ addAcceptCheck subserver $ cookieCheck request
|
||||
where
|
||||
cookieCheck req = case lookup "Cookie" (requestHeaders req) of
|
||||
Nothing -> return $ FailFatal err401 { errBody = "Missing auth header" }
|
||||
Just v -> do
|
||||
let dbConnection = getContextEntry context
|
||||
authGranted <- isGoodCookie dbConnection v
|
||||
if authGranted
|
||||
then return $ Route ()
|
||||
else return $ FailFatal err403 { errBody = "Invalid cookie" }
|
||||
|
||||
type PrivateAPI = Get '[JSON] [PrivateData]
|
||||
|
||||
type PublicAPI = Get '[JSON] [PublicData]
|
||||
|
||||
type API = "private" :> AuthProtected :> PrivateAPI
|
||||
:<|> PublicAPI
|
||||
-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User
|
||||
-- we look for a Cookie and pass the value of the cookie to `lookupUser`.
|
||||
authHandler :: AuthHandler Request User
|
||||
authHandler =
|
||||
let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
|
||||
Nothing -> throwE (err401 { errBody = "Missing auth header" })
|
||||
Just authCookieKey -> lookupUser authCookieKey
|
||||
in mkAuthHandler handler
|
||||
|
||||
-- | Data types that will be returned from various api endpoints
|
||||
newtype PrivateData = PrivateData { ssshhh :: Text }
|
||||
deriving (Eq, Show, Generic)
|
||||
|
||||
|
@ -69,28 +67,58 @@ newtype PublicData = PublicData { somedata :: Text }
|
|||
|
||||
instance ToJSON PublicData
|
||||
|
||||
-- | Our private API that we want to be auth-protected.
|
||||
type PrivateAPI = Get '[JSON] [PrivateData]
|
||||
|
||||
-- | Our public API that doesn't have any protection
|
||||
type PublicAPI = Get '[JSON] [PublicData]
|
||||
|
||||
-- | Our API, with auth-protection
|
||||
type API = "private" :> AuthProtect "cookie-auth" :> PrivateAPI
|
||||
:<|> "public" :> PublicAPI
|
||||
|
||||
-- | A value holding our type-level API
|
||||
api :: Proxy API
|
||||
api = Proxy
|
||||
|
||||
-- | We need to specify the data returned after authentication
|
||||
type instance AuthServerData (AuthProtect "cookie-auth") = User
|
||||
|
||||
-- | The context that will be made available to request handlers. We supply the
|
||||
-- "cookie-auth"-tagged request handler defined above, so that the 'HasServer' instance
|
||||
-- of 'AuthProtect' can extract the handler and run it on the request.
|
||||
serverContext :: Context (AuthHandler Request User ': '[])
|
||||
serverContext = authHandler :. EmptyContext
|
||||
|
||||
-- | Our API, where we provide all the author-supplied handlers for each end
|
||||
-- point. Note that 'privateDataFunc' is a function that takes 'User' as an
|
||||
-- argument. We dont' worry about the authentication instrumentation here,
|
||||
-- that is taken care of by supplying context
|
||||
server :: Server API
|
||||
server = return prvdata :<|> return pubdata
|
||||
server = privateDataFunc :<|> return publicData
|
||||
|
||||
where prvdata = [PrivateData "this is a secret"]
|
||||
pubdata = [PublicData "this is a public piece of data"]
|
||||
where privateDataFunc (User name) =
|
||||
return [PrivateData ("this is a secret: " <> name)]
|
||||
publicData = [PublicData "this is a public piece of data"]
|
||||
|
||||
-- | run our server
|
||||
main :: IO ()
|
||||
main = do
|
||||
dbConnection <- initDB
|
||||
let context = dbConnection :. EmptyContext
|
||||
run 8080 (serveWithContext api context server)
|
||||
main = run 8080 (serveWithContext api serverContext server)
|
||||
|
||||
{- Sample session:
|
||||
$ curl http://localhost:8080/
|
||||
{- Sample Session:
|
||||
|
||||
$ curl -XGET localhost:8080/private
|
||||
Missing auth header
|
||||
>>>>>>> modify auth-combinator example for gen auth
|
||||
>>>>>>> 8246c1f... modify auth-combinator example for gen auth
|
||||
|
||||
$ curl -XGET localhost:8080/private -H "servant-auth-cookie: key3"
|
||||
[{"ssshhh":"this is a secret: Ghédalia Tazartès"}]
|
||||
|
||||
$ curl -XGET localhost:8080/private -H "servant-auth-cookie: bad-key"
|
||||
Invalid Cookie
|
||||
|
||||
$ curl -XGET localhost:8080/public
|
||||
[{"somedata":"this is a public piece of data"}]
|
||||
$ curl http://localhost:8080/private
|
||||
Missing auth header.
|
||||
$ curl -H "Cookie: good password" http://localhost:8080/private
|
||||
[{"ssshhh":"this is a secret"}]
|
||||
$ curl -H "Cookie: bad password" http://localhost:8080/private
|
||||
Invalid cookie.
|
||||
-}
|
||||
|
||||
|
|
|
@ -112,10 +112,12 @@ executable auth-combinator
|
|||
aeson >= 0.8
|
||||
, base >= 4.7 && < 5
|
||||
, bytestring
|
||||
, containers
|
||||
, http-types
|
||||
, servant == 0.5.*
|
||||
, servant-server == 0.5.*
|
||||
, text
|
||||
, transformers
|
||||
, wai
|
||||
, warp
|
||||
hs-source-dirs: auth-combinator
|
||||
|
|
|
@ -12,6 +12,7 @@ HEAD
|
|||
* Redefined constructors of `RouteResult`.
|
||||
* Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`)
|
||||
* Added support for Basic Authentication
|
||||
* Add generalized authentication support via the `AuthServerData` type family and `AuthHandler` handler
|
||||
|
||||
0.4.1
|
||||
-----
|
||||
|
|
|
@ -36,9 +36,10 @@ library
|
|||
exposed-modules:
|
||||
Servant
|
||||
Servant.Server
|
||||
Servant.Server.Experimental.Auth
|
||||
Servant.Server.Internal
|
||||
Servant.Server.Internal.Context
|
||||
Servant.Server.Internal.BasicAuth
|
||||
Servant.Server.Internal.Context
|
||||
Servant.Server.Internal.Enter
|
||||
Servant.Server.Internal.Router
|
||||
Servant.Server.Internal.RoutingApplication
|
||||
|
|
|
@ -45,11 +45,15 @@ module Servant.Server
|
|||
, NamedContext(..)
|
||||
, descendIntoNamedContext
|
||||
|
||||
|
||||
-- * Basic Authentication
|
||||
, BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)
|
||||
, BasicAuthResult(..)
|
||||
|
||||
-- * General Authentication
|
||||
-- , AuthHandler(unAuthHandler)
|
||||
-- , AuthServerData
|
||||
-- , mkAuthHandler
|
||||
|
||||
-- * Default error type
|
||||
, ServantErr(..)
|
||||
-- ** 3XX
|
||||
|
|
66
servant-server/src/Servant/Server/Experimental/Auth.hs
Normal file
66
servant-server/src/Servant/Server/Experimental/Auth.hs
Normal file
|
@ -0,0 +1,66 @@
|
|||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Servant.Server.Experimental.Auth where
|
||||
|
||||
import Control.Monad.Trans.Except (ExceptT,
|
||||
runExceptT)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import Data.Typeable (Typeable)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.Wai (Request)
|
||||
|
||||
import Servant ((:>))
|
||||
import Servant.API.Experimental.Auth
|
||||
import Servant.Server.Internal (HasContextEntry,
|
||||
HasServer, ServerT,
|
||||
getContextEntry,
|
||||
route)
|
||||
import Servant.Server.Internal.Router (Router' (WithRequest))
|
||||
import Servant.Server.Internal.RoutingApplication (RouteResult (FailFatal, Route),
|
||||
addAuthCheck)
|
||||
import Servant.Server.Internal.ServantErr (ServantErr)
|
||||
|
||||
-- * General Auth
|
||||
|
||||
-- | Specify the type of data returned after we've authenticated a request.
|
||||
-- quite often this is some `User` datatype.
|
||||
--
|
||||
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||
type family AuthServerData a :: *
|
||||
|
||||
-- | Handlers for AuthProtected resources
|
||||
--
|
||||
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||
newtype AuthHandler r usr = AuthHandler
|
||||
{ unAuthHandler :: r -> ExceptT ServantErr IO usr }
|
||||
deriving (Generic, Typeable)
|
||||
|
||||
-- | NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE
|
||||
mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr
|
||||
mkAuthHandler = AuthHandler
|
||||
|
||||
-- | Known orphan instance.
|
||||
instance ( HasServer api context
|
||||
, HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag)))
|
||||
)
|
||||
=> HasServer (AuthProtect tag :> api) context where
|
||||
|
||||
type ServerT (AuthProtect tag :> api) m =
|
||||
AuthServerData (AuthProtect tag) -> ServerT api m
|
||||
|
||||
route Proxy context subserver = WithRequest $ \ request ->
|
||||
route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
|
||||
where
|
||||
authHandler = unAuthHandler (getContextEntry context)
|
||||
authCheck = fmap (either FailFatal Route) . runExceptT . authHandler
|
||||
|
|
@ -453,8 +453,6 @@ instance HasServer api context => HasServer (HttpVersion :> api) context where
|
|||
route Proxy context subserver = WithRequest $ \req ->
|
||||
route (Proxy :: Proxy api) context (passToServer subserver $ httpVersion req)
|
||||
|
||||
-- * Basic Authentication
|
||||
|
||||
-- | Basic Authentication
|
||||
instance ( KnownSymbol realm
|
||||
, HasServer api context
|
||||
|
@ -482,6 +480,9 @@ pathIsEmpty = go . pathInfo
|
|||
ct_wildcard :: B.ByteString
|
||||
ct_wildcard = "*" <> "/" <> "*" -- Because CPP
|
||||
|
||||
-- * General Authentication
|
||||
|
||||
|
||||
-- * contexts
|
||||
|
||||
instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)
|
||||
|
|
|
@ -31,14 +31,15 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType,
|
|||
methodHead, methodPatch,
|
||||
methodPost, methodPut, ok200,
|
||||
parseQuery)
|
||||
import Network.Wai (Application, Request, pathInfo,
|
||||
import Network.Wai (Application, Request, requestHeaders, pathInfo,
|
||||
queryString, rawQueryString,
|
||||
responseBuilder, responseLBS)
|
||||
import Network.Wai.Internal (Response (ResponseBuilder))
|
||||
import Network.Wai.Test (defaultRequest, request,
|
||||
runSession, simpleBody,
|
||||
simpleHeaders, simpleStatus)
|
||||
import Servant.API ((:<|>) (..), (:>), BasicAuth, BasicAuthData(BasicAuthData),
|
||||
import Servant.API ((:<|>) (..), (:>), AuthProtect,
|
||||
BasicAuth, BasicAuthData(BasicAuthData),
|
||||
Capture, Delete, Get, Header (..),
|
||||
Headers, HttpVersion,
|
||||
IsSecure (..), JSON,
|
||||
|
@ -48,7 +49,7 @@ import Servant.API ((:<|>) (..), (:>), BasicAuth, Basic
|
|||
Raw, RemoteHost, ReqBody,
|
||||
StdMethod (..), Verb, addHeader)
|
||||
import Servant.API.Internal.Test.ComprehensiveAPI
|
||||
import Servant.Server (ServantErr (..), Server, err404,
|
||||
import Servant.Server (ServantErr (..), Server, err401, err404,
|
||||
serve, serveWithContext, Context((:.), EmptyContext))
|
||||
import Test.Hspec (Spec, context, describe, it,
|
||||
shouldBe, shouldContain)
|
||||
|
@ -59,6 +60,9 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders,
|
|||
|
||||
import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),
|
||||
BasicAuthResult(Authorized,Unauthorized))
|
||||
import Servant.Server.Experimental.Auth
|
||||
(AuthHandler, AuthServerData,
|
||||
mkAuthHandler)
|
||||
import Servant.Server.Internal.RoutingApplication
|
||||
(toApplication, RouteResult(..))
|
||||
import Servant.Server.Internal.Router
|
||||
|
@ -90,6 +94,7 @@ spec = do
|
|||
routerSpec
|
||||
miscCombinatorSpec
|
||||
basicAuthSpec
|
||||
genAuthSpec
|
||||
|
||||
------------------------------------------------------------------------------
|
||||
-- * verbSpec {{{
|
||||
|
@ -534,7 +539,7 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $
|
|||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Authentication {{{
|
||||
-- * Basic Authentication {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal
|
||||
|
@ -564,6 +569,39 @@ basicAuthSpec = do
|
|||
it "returns 200 with the right password" $ do
|
||||
THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * General Authentication {{{
|
||||
------------------------------------------------------------------------------
|
||||
|
||||
type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal
|
||||
authApi :: Proxy GenAuthAPI
|
||||
authApi = Proxy
|
||||
authServer :: Server GenAuthAPI
|
||||
authServer = const (return tweety)
|
||||
|
||||
type instance AuthServerData (AuthProtect "auth") = ()
|
||||
|
||||
genAuthContext :: Context '[ AuthHandler Request () ]
|
||||
genAuthContext =
|
||||
let authHandler = (\req ->
|
||||
if elem ("Auth", "secret") (requestHeaders req)
|
||||
then return ()
|
||||
else throwE err401
|
||||
)
|
||||
in mkAuthHandler authHandler :. EmptyContext
|
||||
|
||||
genAuthSpec :: Spec
|
||||
genAuthSpec = do
|
||||
describe "Servant.API.Auth" $ do
|
||||
with (return (serveWithContext authApi genAuthContext authServer)) $ do
|
||||
|
||||
context "Custom Auth Protection" $ do
|
||||
it "returns 401 when missing headers" $ do
|
||||
get "/auth" `shouldRespondWith` 401
|
||||
it "returns 200 with the right header" $ do
|
||||
THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200
|
||||
|
||||
-- }}}
|
||||
------------------------------------------------------------------------------
|
||||
-- * Test data types {{{
|
||||
|
|
|
@ -11,6 +11,7 @@ HEAD
|
|||
* Add new `Verbs` combinator, and make all existing and new verb combinators
|
||||
type synonyms of it.
|
||||
* Add `BasicAuth` combinator to support Basic authentication
|
||||
* Add generalized authentication support
|
||||
|
||||
0.4.2
|
||||
-----
|
||||
|
|
|
@ -30,6 +30,7 @@ library
|
|||
Servant.API.BasicAuth
|
||||
Servant.API.Capture
|
||||
Servant.API.ContentTypes
|
||||
Servant.API.Experimental.Auth
|
||||
Servant.API.Header
|
||||
Servant.API.HttpVersion
|
||||
Servant.API.Internal.Test.ComprehensiveAPI
|
||||
|
|
|
@ -48,6 +48,11 @@ module Servant.API (
|
|||
module Web.HttpApiData,
|
||||
-- | Classes and instances for types that can be converted to and from HTTP API data.
|
||||
|
||||
|
||||
-- * Experimental modules
|
||||
module Servant.API.Experimental.Auth,
|
||||
-- | General Authentication
|
||||
|
||||
-- * Utilities
|
||||
module Servant.Utils.Links,
|
||||
-- | Type-safe internal URIs
|
||||
|
@ -61,6 +66,7 @@ import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
|
|||
MimeRender (..), NoContent (NoContent),
|
||||
MimeUnrender (..), OctetStream,
|
||||
PlainText, ToFormUrlEncoded (..))
|
||||
import Servant.API.Experimental.Auth (AuthProtect)
|
||||
import Servant.API.Header (Header (..))
|
||||
import Servant.API.HttpVersion (HttpVersion (..))
|
||||
import Servant.API.IsSecure (IsSecure (..))
|
||||
|
|
14
servant/src/Servant/API/Experimental/Auth.hs
Normal file
14
servant/src/Servant/API/Experimental/Auth.hs
Normal file
|
@ -0,0 +1,14 @@
|
|||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveDataTypeable #-}
|
||||
{-# LANGUAGE KindSignatures #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
module Servant.API.Experimental.Auth where
|
||||
|
||||
import Data.Typeable (Typeable)
|
||||
|
||||
-- | A generalized Authentication combinator. Use this if you have a
|
||||
-- non-standard authentication technique.
|
||||
--
|
||||
-- NOTE: THIS API IS EXPERIMENTAL AND SUBJECT TO CHANGE.
|
||||
data AuthProtect (tag :: k) deriving (Typeable)
|
||||
|
Loading…
Reference in a new issue