diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 055cfa17..be3453cc 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -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 ----- diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 8e20f1a3..6fbb6642 100644 --- a/servant-client/servant-client.cabal +++ b/servant-client/servant-client.cabal @@ -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 diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index d3373708..e73c05a4 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -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 diff --git a/servant-client/src/Servant/Client/Experimental/Auth.hs b/servant-client/src/Servant/Client/Experimental/Auth.hs new file mode 100644 index 00000000..a98d0b41 --- /dev/null +++ b/servant-client/src/Servant/Client/Experimental/Auth.hs @@ -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) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 4b6ccbb9..0ad3b70e 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -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) diff --git a/servant-examples/auth-combinator/auth-combinator.hs b/servant-examples/auth-combinator/auth-combinator.hs index 94bb8931..709efa0c 100644 --- a/servant-examples/auth-combinator/auth-combinator.hs +++ b/servant-examples/auth-combinator/auth-combinator.hs @@ -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. -} + diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal index a36a5eba..1f00349e 100644 --- a/servant-examples/servant-examples.cabal +++ b/servant-examples/servant-examples.cabal @@ -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 diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index c5916153..3c121ddd 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -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 ----- diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 2aa25cee..6167a2b4 100644 --- a/servant-server/servant-server.cabal +++ b/servant-server/servant-server.cabal @@ -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 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 6b37297e..8eff9c66 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -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 diff --git a/servant-server/src/Servant/Server/Experimental/Auth.hs b/servant-server/src/Servant/Server/Experimental/Auth.hs new file mode 100644 index 00000000..1cc698fc --- /dev/null +++ b/servant-server/src/Servant/Server/Experimental/Auth.hs @@ -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 + diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index ea89b0a0..c170de9b 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -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) diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 0524a11a..0e17c022 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -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 {{{ diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index cf447968..3707dda4 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -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 ----- diff --git a/servant/servant.cabal b/servant/servant.cabal index 56e4580e..a66efbce 100644 --- a/servant/servant.cabal +++ b/servant/servant.cabal @@ -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 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 5dda312c..5ea7b480 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -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 (..)) diff --git a/servant/src/Servant/API/Experimental/Auth.hs b/servant/src/Servant/API/Experimental/Auth.hs new file mode 100644 index 00000000..ce330287 --- /dev/null +++ b/servant/src/Servant/API/Experimental/Auth.hs @@ -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) +