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

Generalized Auth Support

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

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

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
 

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)

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")] "")
  )
 
-
+-- * basic auth stuff
--- * 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 () ]
+basicServerContext :: Context '[ BasicAuthCheck () ]
-serverContext = basicAuthHandler :. EmptyContext
+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)

servant-examples/auth-combinator/auth-combinator.hs

@@ -9,56 +9,54 @@
 {-# LANGUAGE TypeOperators       #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-import           Data.Aeson
+import           Control.Monad.Trans.Except (ExceptT, throwE)
-import           Data.ByteString          (ByteString)
+import           Data.Aeson                 hiding ((.:))
-import           Data.IORef
+import           Data.ByteString            (ByteString)
-import           Data.Text                (Text)
+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
+-- | This file contains an authenticated server using servant's generalized
--- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs
+-- 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]
+-- | A user type that we "fetch from the database" after
-type DBLookup = DBConnection -> ByteString -> IO Bool
+-- performing authentication
+newtype User = User { unUser :: Text }
 
-initDB :: IO DBConnection
+-- | A (pure) database mapping keys to users.
-initDB = newIORef ["good password"]
+database :: Map ByteString User
+database = fromList [ ("key1", User "Anne Briggs")
+                    , ("key2", User "Bruce Cockburn")
+                    , ("key3", User "Ghédalia Tazartès")
+                    ]
 
-isGoodCookie :: DBLookup
+-- | A method that, when given a password, will return a User.
-isGoodCookie ref password = do
+-- This is our bespoke (and bad) authentication logic.
-  allowed <- readIORef ref
+lookupUser :: ByteString -> ExceptT ServantErr IO User
-  return (password `elem` allowed)
+lookupUser key = case Map.lookup key database of
+  Nothing -> throwE (err403 { errBody = "Invalid Cookie" })
+  Just usr -> return usr
 
-data AuthProtected
+-- | 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`.
-instance (HasContextEntry context DBConnection, HasServer rest context)
+authHandler :: AuthHandler Request User
-  => HasServer (AuthProtected :> rest) context where
+authHandler =
-
+  let handler req = case lookup "servant-auth-cookie" (requestHeaders req) of
-  type ServerT (AuthProtected :> rest) m = ServerT rest m
+        Nothing -> throwE (err401 { errBody = "Missing auth header" })
-
+        Just authCookieKey -> lookupUser authCookieKey
-  route Proxy context subserver = WithRequest $ \ request ->
+  in mkAuthHandler handler
-    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
 
+-- | 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"]
+  where privateDataFunc (User name) =
-        pubdata = [PublicData "this is a public piece of data"]
+          return [PrivateData ("this is a secret: " <> name)]
+        publicData = [PublicData "this is a public piece of data"]
 
+-- | run our server
 main :: IO ()
-main = do
+main = run 8080 (serveWithContext api serverContext server)
-  dbConnection <- initDB
-  let context = dbConnection :. EmptyContext
-  run 8080 (serveWithContext api context server)
 
-{- Sample session:
+{- Sample Session:
-$ curl http://localhost:8080/
+
+$ 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.
 -}
+

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

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

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

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

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
+

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)

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

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

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

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

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