Merge pull request #376 from haskell-servant/auth-gen

Generalized Auth Support
This commit is contained in:
Aaron Levin 2016-03-09 23:27:13 +01:00
commit 16e7234ab1
17 changed files with 328 additions and 70 deletions

View file

@ -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
-----

View file

@ -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

View file

@ -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

View 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)

View file

@ -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)

View file

@ -9,56 +9,54 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
import Data.Aeson
import Data.ByteString (ByteString)
import Data.IORef
import Data.Text (Text)
import Control.Monad.Trans.Except (ExceptT, throwE)
import Data.Aeson hiding ((.:))
import Data.ByteString (ByteString)
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.
-}

View file

@ -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

View file

@ -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
-----

View file

@ -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

View file

@ -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

View 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

View file

@ -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)

View file

@ -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 {{{

View file

@ -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
-----

View file

@ -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

View file

@ -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 (..))

View 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)