Implement Authentication with Config Tooling

servant-client/servant-client.cabal

@@ -27,6 +27,7 @@ source-repository head
 library
   exposed-modules:
     Servant.Client
+    Servant.Common.Auth
     Servant.Common.BaseUrl
     Servant.Common.Req
   build-depends:
@@ -34,6 +35,7 @@ library
     , aeson
     , attoparsec
     , bytestring
+    , base64-bytestring
     , exceptions
     , http-api-data >= 0.1  && < 0.3
     , http-client
@@ -68,6 +70,7 @@ test-suite spec
     , transformers-compat
     , aeson
     , bytestring
+    , base64-bytestring
     , deepseq
     , hspec == 2.*
     , http-client

servant-client/src/Servant/Client.hs

@@ -15,8 +15,12 @@
 -- querying functions for each endpoint just from the type representing your
 -- API.
 module Servant.Client
-  ( client
+  ( AuthClientData
+  , AuthenticateReq(..)
+  , BasicAuthData(..)
+  , client
   , HasClient(..)
+  , mkAuthenticateReq
   , ServantError(..)
   , module Servant.Common.BaseUrl
   ) where
@@ -36,6 +40,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.Common.Auth
 import           Servant.Common.BaseUrl
 import           Servant.Common.Req
 
@@ -423,6 +428,20 @@ instance HasClient subapi =>
   type Client (WithNamedConfig name config subapi) = Client subapi
   clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)
 
+instance HasClient api => HasClient (BasicAuth realm :> api) where
+  type Client (BasicAuth realm :> api) = BasicAuthData -> Client api
+
+  clientWithRoute Proxy req baseurl manager val =
+    clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager
+
+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
+
 
 {- Note [Non-Empty Content Types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

servant-client/src/Servant/Common/Auth.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeFamilies      #-}
+
+-- | Authentication for clients
+
+module Servant.Common.Auth (
+    AuthenticateReq(AuthenticateReq, unAuthReq)
+  , AuthClientData
+  , BasicAuthData (BasicAuthData, username, password)
+  , basicAuthReq
+  , mkAuthenticateReq
+  ) where
+
+import Data.ByteString (ByteString)
+import Data.ByteString.Base64  (encode)
+import Data.Monoid ((<>))
+import Data.Text.Encoding (decodeUtf8)
+import Servant.Common.Req (addHeader, Req)
+
+
+-- | A simple datatype to hold data required to decorate a request
+data BasicAuthData = BasicAuthData { username :: ByteString
+                                   , password :: ByteString
+                                   }
+
+-- | Authenticate a request using Basic Authentication
+basicAuthReq :: BasicAuthData -> Req -> Req
+basicAuthReq (BasicAuthData user pass) req =
+    let authText = decodeUtf8 ("Basic " <> encode (user <> ":" <> pass))
+    in addHeader "Authorization" authText 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
+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
+newtype AuthenticateReq a =
+  AuthenticateReq { unAuthReq :: (AuthClientData a, AuthClientData a -> Req -> Req) }
+
+-- | Handy helper to avoid wrapping datatypes in tuples everywhere.
+mkAuthenticateReq :: AuthClientData a
+                  -> (AuthClientData a -> Req -> Req)
+                  -> AuthenticateReq a
+mkAuthenticateReq val func = AuthenticateReq (val, func)
+

servant-client/test/Servant/ClientSpec.hs

@@ -13,6 +13,7 @@
 {-# LANGUAGE StandaloneDeriving     #-}
 {-# LANGUAGE ScopedTypeVariables    #-}
 {-# LANGUAGE TypeOperators          #-}
+{-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE UndecidableInstances   #-}
 {-# OPTIONS_GHC -fcontext-stack=100 #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
@@ -28,7 +29,7 @@ import           Control.Arrow              (left)
 import           Control.Concurrent         (forkIO, killThread, ThreadId)
 import           Control.Exception          (bracket)
 import           Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
-import           Data.Aeson
+import           Data.Aeson                 hiding ((.:))
 import           Data.Char                  (chr, isPrint)
 import           Data.Foldable              (forM_)
 import           Data.Monoid                hiding (getLast)
@@ -41,7 +42,7 @@ 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 +54,7 @@ import           Servant.API
 import           Servant.API.Internal.Test.ComprehensiveAPI
 import           Servant.Client
 import           Servant.Server
+import qualified Servant.Common.Req as SCR
 
 -- This declaration simply checks that all instances are in place.
 _ = client comprehensiveAPI
@@ -62,6 +64,7 @@ spec = describe "Servant.Client" $ do
     sucessSpec
     failSpec
     wrappedApiSpec
+    authSpec
 
 -- * test data types
 
@@ -111,9 +114,11 @@ type Api =
             Get '[JSON] (String, Maybe Int, Bool, [(String, [Rational])])
   :<|> "headers" :> Get '[JSON] (Headers TestHeaders Bool)
   :<|> "deleteContentType" :> DeleteNoContent '[JSON] NoContent
+
 api :: Proxy Api
 api = Proxy
 
+
 server :: Application
 server = serve api EmptyConfig (
        return alice
@@ -148,6 +153,46 @@ failServer = serve failApi EmptyConfig (
   :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
  )
 
+--  auth stuff
+type AuthAPI =
+       BasicAuth "foo-realm" :> "private" :> "basic" :> Get '[JSON] Person
+  :<|> AuthProtect "auth-tag" :> "private" :> "auth" :> Get '[JSON] Person
+
+authAPI :: Proxy AuthAPI
+authAPI = Proxy
+
+type instance AuthReturnType (BasicAuth "foo-realm")  = ()
+type instance AuthReturnType (AuthProtect "auth-tag") = ()
+type instance AuthClientData (AuthProtect "auth-tag") = ()
+
+basicAuthHandler :: BasicAuthCheck ()
+basicAuthHandler =
+  let check username password =
+        if username == "servant" && password == "server"
+        then return (Authorized ())
+        else return Unauthorized
+  in BasicAuthCheck check
+
+authHandler :: AuthHandler Request ()
+authHandler =
+  let handler req = case lookup "AuthHeader" (requestHeaders req) of
+        Nothing -> throwE (err401 { errBody = "Missing auth header"
+                                  , errReasonPhrase = "denied!"
+                                  })
+        Just _ -> return ()
+  in mkAuthHandler handler
+
+serverConfig :: Config '[ BasicAuthCheck ()
+                        , AuthHandler Request ()
+                        ]
+serverConfig = basicAuthHandler :. authHandler :. EmptyConfig
+
+authServer :: Application
+authServer = serve authAPI serverConfig (const (return alice) :<|> const (return alice))
+
+{-
+     -}
+
 {-# NOINLINE manager #-}
 manager :: C.Manager
 manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
@@ -287,14 +332,41 @@ failSpec = beforeAll (startWaiApp failServer) $ afterAll endWaiApp $ do
           InvalidContentTypeHeader "fooooo" _ -> return ()
           _ -> fail $ "expected InvalidContentTypeHeader, but got " <> show res
 
+authSpec :: Spec
+authSpec = beforeAll (startWaiApp authServer) $ afterAll endWaiApp $ do
+  context "Authentication works when requests are properly authenticated" $ do
+
+    it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
+      let (getBasic :<|> _) = client authAPI baseUrl manager
+      let authData = BasicAuthData "servant" "server"
+      (left show <$> runExceptT (getBasic authData)) `shouldReturn` Right alice
+
+    it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
+      let (_ :<|> getProtected) = client authAPI 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 BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
+      let (getBasic :<|> _) = client authAPI baseUrl manager
+      let authData = BasicAuthData "not" "password"
+      Left FailureResponse{..} <- runExceptT (getBasic authData)
+      responseStatus `shouldBe` Status 403 "Forbidden"
+
+    it "Authenticates a AuthProtect protected server appropriately" $ \(_, baseUrl) -> do
+      let (_ :<|> getProtected) = client authAPI baseUrl manager
+      let authRequest = mkAuthenticateReq () (\_ req ->  SCR.addHeader "Wrong" ("header" :: String) req)
+      Left FailureResponse{..} <- runExceptT (getProtected authRequest)
+      responseStatus `shouldBe` (Status 401 "denied")
+
+-- * utils
+
 data WrappedApi where
   WrappedApi :: (HasServer (api :: *) '[], Server api ~ ExceptT ServantErr IO a,
                  HasClient api, Client api ~ ExceptT ServantError IO ()) =>
     Proxy api -> WrappedApi
 
-
--- * utils
-
 startWaiApp :: Application -> IO (ThreadId, BaseUrl)
 startWaiApp app = do
     (port, socket) <- openTestSocket

servant-docs/src/Servant/Docs/Internal.hs

@@ -22,7 +22,7 @@ module Servant.Docs.Internal where
 
 import           Control.Applicative
 import           Control.Arrow              (second)
-import           Control.Lens               (makeLenses, over, traversed, (%~),
+import           Control.Lens               (makeLenses, mapped, over, traversed, view, (%~),
                                              (&), (.~), (<>~), (^.), (|>))
 import qualified Control.Monad.Omega        as Omega
 import           Data.ByteString.Conversion (ToByteString, toByteString)
@@ -140,6 +140,12 @@ data DocIntro = DocIntro
   , _introBody  :: [String] -- ^ Each String is a paragraph.
   } deriving (Eq, Show)
 
+-- | A type to represent Authentication information about an endpoint.
+data DocAuthentication = DocAuthentication
+  { _authIntro        :: String
+  , _authDataRequired :: String
+  } deriving (Eq, Ord, Show)
+
 instance Ord DocIntro where
     compare = comparing _introTitle
 
@@ -230,7 +236,8 @@ defResponse = Response
 -- You can tweak an 'Action' (like the default 'defAction') with these lenses
 -- to transform an action and add some information to it.
 data Action = Action
-  { _captures :: [DocCapture]                -- type collected + user supplied info
+  { _authInfo :: [DocAuthentication]         -- user supplied info
+  , _captures :: [DocCapture]                -- type collected + user supplied info
   , _headers  :: [Text]                      -- type collected
   , _params   :: [DocQueryParam]             -- type collected + user supplied info
   , _notes    :: [DocNote]                   -- user supplied
@@ -247,8 +254,8 @@ data Action = Action
 -- 'combineAction' to mush two together taking the response, body and content
 -- types from the very left.
 combineAction :: Action -> Action -> Action
-Action c h p n m ts body resp `combineAction` Action c' h' p' n' m' _ _ _ =
+Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
-        Action (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
+        Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
 
 -- Default 'Action'. Has no 'captures', no GET 'params', expects
 -- no request body ('rqbody') and the typical response is 'defResponse'.
@@ -268,6 +275,7 @@ defAction =
          []
          []
          []
+         []
          defResponse
 
 -- | Create an API that's comprised of a single endpoint.
@@ -277,6 +285,7 @@ single :: Endpoint -> Action -> API
 single e a = API mempty (HM.singleton e a)
 
 -- gimme some lenses
+makeLenses ''DocAuthentication
 makeLenses ''DocOptions
 makeLenses ''API
 makeLenses ''Endpoint
@@ -454,7 +463,7 @@ instance AllHeaderSamples '[] where
 
 instance (ToByteString l, AllHeaderSamples ls, ToSample l, KnownSymbol h)
     => AllHeaderSamples (Header h l ': ls) where
-    allHeaderToSample _ = (mkHeader (toSample (Proxy :: Proxy l))) :
+    allHeaderToSample _ = mkHeader (toSample (Proxy :: Proxy l)) :
                           allHeaderToSample (Proxy :: Proxy ls)
       where headerName = CI.mk . cs $ symbolVal (Proxy :: Proxy h)
             mkHeader (Just x) = (headerName, cs $ toByteString x)
@@ -504,6 +513,10 @@ class ToParam t where
 class ToCapture c where
   toCapture :: Proxy c -> DocCapture
 
+-- | The class that helps us get documentation for authenticated endpoints
+class ToAuthInfo a where
+      toAuthInfo :: Proxy a -> DocAuthentication
+
 -- | Generate documentation in Markdown format for
 --   the given 'API'.
 markdown :: API -> String
@@ -516,6 +529,7 @@ markdown api = unlines $
           str :
           "" :
           notesStr (action ^. notes) ++
+          authStr (action ^. authInfo) ++
           capturesStr (action ^. captures) ++
           headersStr (action ^. headers) ++
           paramsStr (action ^. params) ++
@@ -548,6 +562,20 @@ markdown api = unlines $
             "" :
             []
 
+
+        authStr :: [DocAuthentication] -> [String]
+        authStr auths =
+          let authIntros = mapped %~ view authIntro $ auths
+              clientInfos = mapped %~ view authDataRequired $ auths
+          in "#### Authentication":
+              "":
+              unlines authIntros :
+              "":
+              "Clients must supply the following data" :
+              unlines clientInfos :
+              "" :
+              []
+
         capturesStr :: [DocCapture] -> [String]
         capturesStr [] = []
         capturesStr l =
@@ -797,6 +825,20 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where
 instance HasDocs sublayout => HasDocs (WithNamedConfig name config sublayout) where
   docsFor Proxy = docsFor (Proxy :: Proxy sublayout)
 
+instance (ToAuthInfo (BasicAuth realm), HasDocs sublayout) => HasDocs (BasicAuth realm :> sublayout) where
+  docsFor Proxy (endpoint, action) =
+    docsFor (Proxy :: Proxy sublayout) (endpoint, action')
+      where
+        authProxy = Proxy :: Proxy (BasicAuth realm)
+        action' = over authInfo (|> toAuthInfo authProxy) action
+
+instance (ToAuthInfo (AuthProtect tag), HasDocs sublayout) => HasDocs (AuthProtect tag :> sublayout) where
+  docsFor Proxy (endpoint, action) =
+    docsFor (Proxy :: Proxy sublayout) (endpoint, action')
+      where
+        authProxy = Proxy :: Proxy (AuthProtect tag)
+        action' = over authInfo (|> toAuthInfo authProxy) action
+
 -- ToSample instances for simple types
 instance ToSample ()
 instance ToSample Bool

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

@@ -9,56 +9,39 @@
 {-# 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.Text                  (Text)
 import           GHC.Generics
 import           Network.Wai
 import           Network.Wai.Handler.Warp
 import           Servant
-import           Servant.Server.Internal
 
--- Pretty much stolen/adapted from
+-- | A user type that we "fetch from the database" after
--- https://github.com/haskell-servant/HaskellSGMeetup2015/blob/master/examples/authentication-combinator/AuthenticationCombinator.hs
+-- performing authentication
+newtype User = User { unUser :: Text }
 
-type DBConnection = IORef [ByteString]
-type DBLookup = DBConnection -> ByteString -> IO Bool
 
-initDB :: IO DBConnection
+-- | A method that, when given a password, will return a User.
-initDB = newIORef ["good password"]
+-- This is our bespoke (and bad) authentication logic.
+lookupUser :: ByteString -> ExceptT ServantErr IO User
+lookupUser cookie =
+  if cookie == "good password"
+  then return (User "user")
+  else throwE (err403 { errBody = "Invalid Cookie" })
 
-isGoodCookie :: DBLookup
+-- | The auth handler wraps a function from Request -> ExceptT ServantErr IO User
-isGoodCookie ref password = do
+-- we look for a Cookie and pass the value of the cookie to `lookupUser`.
-  allowed <- readIORef ref
+authHandler :: AuthHandler Request User
-  return (password `elem` allowed)
+authHandler =
-
+  let handler req = case lookup "Cookie" (requestHeaders req) of
-data AuthProtected
+        Nothing -> throwE (err401 { errBody = "Missing auth header" })
-
+        Just cookie -> lookupUser cookie
-instance (HasConfigEntry config DBConnection, HasServer rest config)
+  in mkAuthHandler handler
-  => HasServer (AuthProtected :> rest) config where
-
-  type ServerT (AuthProtected :> rest) m = ServerT rest m
-
-  route Proxy config subserver = WithRequest $ \ request ->
-    route (Proxy :: Proxy rest) config $ 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 = getConfigEntry config
-              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 +52,54 @@ 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
 
-server :: Server API
+-- | We need to specify the data returned after authentication
-server = return prvdata :<|> return pubdata
+type instance AuthReturnType (AuthProtect "cookie-auth") = User
 
-  where prvdata = [PrivateData "this is a secret"]
+-- | The configuration 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.
+serverConfig :: Config (AuthHandler Request User ': '[])
+serverConfig = authHandler :. EmptyConfig
+
+-- | Our API, where we provide all the author-supplied handlers for each end point.
+-- note that 'prvdata' is a function that takes 'User' as an argument. We dont' worry
+-- about the authentication instrumentation here, that is taken care of by supplying
+-- configuration
+server :: Server API
+server = prvdata :<|> return pubdata
+
+  where prvdata (User name) = return [PrivateData ("this is a secret: " <> name)]
         pubdata = [PublicData "this is a public piece of data"]
 
+-- | run our server
 main :: IO ()
-main = do
+main = run 8080 (serve api serverConfig server)
-  dbConnection <- initDB
-  let config = dbConnection :. EmptyConfig
-  run 8080 (serve api config server)
 
-{- Sample session:
+{- Sample Session:
-$ curl http://localhost:8080/
+
+$ curl -XGET localhost:8080/private
+Missing auth header
+
+$ curl -XGET localhost:8080/private -H "Cookie: good password"
+[{"ssshhh":"this is a secret: user"}]
+
+$ curl -XGET localhost:8080/private -H "Cookie: bad password"
+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/basic-auth/basic-auth.hs

@@ -0,0 +1,108 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Main where
+
+import           Data.Aeson                   (ToJSON)
+import           Data.Proxy                   (Proxy (Proxy))
+import           Data.Text                    (Text)
+import           GHC.Generics                 (Generic)
+import           Network.Wai.Handler.Warp     (run)
+import           Servant.API                  ((:<|>) ((:<|>)), (:>), BasicAuth,
+                                               Get, JSON)
+import           Servant.Server               (AuthReturnType, BasicAuthResult (Authorized, Unauthorized), Config ((:.), EmptyConfig),
+                                               Server, serve, BasicAuthCheck(BasicAuthCheck))
+
+-- | let's define some types that our API returns.
+
+-- | private data that needs protection
+newtype PrivateData = PrivateData { ssshhh :: Text }
+  deriving (Eq, Show, Generic)
+
+instance ToJSON PrivateData
+
+-- | public data that anyone can use.
+newtype PublicData = PublicData { somedata :: Text }
+  deriving (Eq, Show, Generic)
+
+instance ToJSON PublicData
+
+-- | A user we'll grab from the database when we authenticate someone
+newtype User = User { userName :: Text }
+  deriving (Eq, Show)
+
+-- | a type to wrap our public api
+type PublicAPI = Get '[JSON] [PublicData]
+
+-- | a type to wrap our private api
+type PrivateAPI = Get '[JSON] PrivateData
+
+-- | our API
+type API = "public"  :> PublicAPI
+      :<|> "private" :> BasicAuth "foo-realm" :> PrivateAPI
+
+-- | a value holding a proxy of our API type
+api :: Proxy API
+api = Proxy
+
+-- | a value holding a proxy of our basic auth realm.
+authRealm :: Proxy "foo-realm"
+authRealm = Proxy
+
+-- | Specify the data type returned after performing basic authentication
+type instance AuthReturnType (BasicAuth "foo-realm") = User
+
+-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
+authCheck :: BasicAuthCheck User
+authCheck =
+  let check username password =
+        if username == "servant" && password == "server"
+        then return (Authorized (User "servant"))
+        else return Unauthorized
+  in BasicAuthCheck check
+
+-- | We need to supply our handlers with the right configuration. In this case,
+-- Basic Authentication requires a Config Entry with the 'BasicAuthCheck' value
+-- tagged with "foo-tag" This config is then supplied to 'server' and threaded 
+-- to the BasicAuth HasServer handlers.
+serverConfig :: Config (BasicAuthCheck User ': '[])
+serverConfig = authCheck :. EmptyConfig
+
+-- | an implementation of our server. Here is where we pass all the handlers to our endpoints.
+-- In particular, for the BasicAuth protected handler, we need to supply a function
+-- that takes 'User' as an argument.
+server :: Server API
+server =
+  let publicAPIHandler = return [PublicData "foo", PublicData "bar"]
+      privateAPIHandler (user :: User) = return (PrivateData (userName user))
+  in publicAPIHandler :<|> privateAPIHandler
+
+-- | hello, server!
+main :: IO ()
+main = run 8080 (serve api serverConfig server)
+
+{- Sample session
+
+$ curl -XGET localhost:8080/public
+[{"somedata":"foo"},{"somedata":"bar"}
+
+$ curl -iXGET localhost:8080/private
+HTTP/1.1 401 Unauthorized
+transfer-encoding: chunked
+Date: Thu, 07 Jan 2016 22:36:38 GMT
+Server: Warp/3.1.8
+WWW-Authenticate: Basic realm="foo-realm"
+
+$ curl -iXGET localhost:8080/private -H "Authorization: Basic c2VydmFudDpzZXJ2ZXI="
+HTTP/1.1 200 OK
+transfer-encoding: chunked
+Date: Thu, 07 Jan 2016 22:37:58 GMT
+Server: Warp/3.1.8
+Content-Type: application/json
+
+{"ssshhh":"servant"}
+-}

servant-examples/servant-examples.cabal

@@ -100,11 +100,28 @@ executable auth-combinator
     , servant == 0.5.*
     , servant-server == 0.5.*
     , text
+    , transformers
     , wai
     , warp
   hs-source-dirs: auth-combinator
   default-language: Haskell2010
 
+executable basic-auth
+  main-is: basic-auth.hs
+  ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing
+  build-depends:
+      aeson >= 0.8
+    , base >= 4.7 && < 5
+    , bytestring
+    , http-types
+    , servant == 0.5.*
+    , servant-server == 0.5.*
+    , text
+    , wai
+    , warp
+  hs-source-dirs: basic-auth
+  default-language: Haskell2010
+
 executable socket-io-chat
   main-is: socket-io-chat.hs
   ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing

servant-server/servant-server.cabal

@@ -37,6 +37,7 @@ library
     Servant
     Servant.Server
     Servant.Server.Internal
+    Servant.Server.Internal.Auth
     Servant.Server.Internal.Config
     Servant.Server.Internal.Enter
     Servant.Server.Internal.Router
@@ -47,6 +48,7 @@ library
         base               >= 4.7  && < 5
       , aeson              >= 0.7  && < 0.11
       , attoparsec         >= 0.12 && < 0.14
+      , base64-bytestring  == 1.0.*
       , bytestring         >= 0.10 && < 0.11
       , containers         >= 0.5  && < 0.6
       , http-api-data      >= 0.1  && < 0.3
@@ -67,6 +69,7 @@ library
       , wai                >= 3.0  && < 3.3
       , wai-app-static     >= 3.0  && < 3.2
       , warp               >= 3.0  && < 3.3
+      , word8              == 0.1.*
 
   hs-source-dirs: src
   default-language: Haskell2010

servant-server/src/Servant/Server.hs

@@ -43,6 +43,15 @@ module Servant.Server
   , NamedConfig(..)
   , descendIntoNamedConfig
 
+  -- * General Authentication
+  , AuthHandler(unAuthHandler)
+  , AuthReturnType
+  , mkAuthHandler
+
+  -- * Basic Authentication
+  , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)
+  , BasicAuthResult(..)
+
     -- * Default error type
   , ServantErr(..)
     -- ** 3XX
@@ -117,7 +126,7 @@ serve :: (HasServer layout config)
     => Proxy layout -> Config config -> Server layout -> Application
 serve p config server = toApplication (runRouter (route p config d))
   where
-    d = Delayed r r r (\ _ _ -> Route server)
+    d = Delayed r r r r (\ _ _ _ -> Route server)
     r = return (Route ())
 
 

servant-server/src/Servant/Server/Internal.hs

@@ -10,11 +10,13 @@
 {-# LANGUAGE ScopedTypeVariables        #-}
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE UndecidableInstances       #-}
 
 #include "overlapping-compat.h"
 
 module Servant.Server.Internal
   ( module Servant.Server.Internal
+  , module Servant.Server.Internal.Auth
   , module Servant.Server.Internal.Config
   , module Servant.Server.Internal.Router
   , module Servant.Server.Internal.RoutingApplication
@@ -24,11 +26,13 @@ module Servant.Server.Internal
 #if !MIN_VERSION_base(4,8,0)
 import           Control.Applicative         ((<$>))
 #endif
-import           Control.Monad.Trans.Except (ExceptT)
+import           Control.Monad.Trans.Except                 (ExceptT, runExceptT)
 import qualified Data.ByteString                            as B
+import qualified Data.ByteString.Char8                      as BC8
 import qualified Data.ByteString.Lazy                       as BL
 import qualified Data.Map                                   as M
-import           Data.Maybe                 (fromMaybe, mapMaybe)
+import           Data.Maybe                                 (fromMaybe,
+                                                             mapMaybe)
 import           Data.String                                (fromString)
 import           Data.String.Conversions                    (cs, (<>))
 import           Data.Text                                  (Text)
@@ -48,7 +52,7 @@ import           Web.HttpApiData.Internal   (parseHeaderMaybe,
                                              parseQueryParamMaybe,
                                              parseUrlPieceMaybe)
 
-import           Servant.API                 ((:<|>) (..), (:>), Capture,
+import           Servant.API                 ((:<|>) (..), (:>), AuthProtect, BasicAuth, Capture,
                                               Verb, ReflectMethod(reflectMethod),
                                               IsSecure(..), Header,
                                               QueryFlag, QueryParam, QueryParams,
@@ -62,6 +66,7 @@ import           Servant.API.ContentTypes    (AcceptHeader (..),
 import           Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
                                               getResponse)
 
+import           Servant.Server.Internal.Auth
 import           Servant.Server.Internal.Config
 import           Servant.Server.Internal.Router
 import           Servant.Server.Internal.RoutingApplication
@@ -450,6 +455,28 @@ instance HasServer api config => HasServer (HttpVersion :> api) config where
   route Proxy config subserver = WithRequest $ \req ->
     route (Proxy :: Proxy api) config (passToServer subserver $ httpVersion req)
 
+-- | Basic Authentication
+instance (KnownSymbol realm, HasServer api config, HasConfigEntry config (BasicAuthCheck (AuthReturnType (BasicAuth realm))))
+    => HasServer (BasicAuth realm :> api) config where
+  type ServerT (BasicAuth realm :> api) m = AuthReturnType (BasicAuth realm) -> ServerT api m
+
+  route Proxy config subserver = WithRequest $ \ request ->
+    route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request)
+    where
+       realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
+       basicAuthConfig = getConfigEntry config
+       authCheck req = runBasicAuth req realm basicAuthConfig
+
+-- | General Authentication
+instance (HasServer api config, HasConfigEntry config (AuthHandler Request (AuthReturnType (AuthProtect tag)))) => HasServer (AuthProtect tag :> api) config where
+  type ServerT (AuthProtect tag :> api) m = AuthReturnType (AuthProtect tag) -> ServerT api m
+
+  route Proxy config subserver = WithRequest $ \ request ->
+    route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request)
+      where
+        authHandler = unAuthHandler (getConfigEntry config)
+        authCheck = fmap (either FailFatal Route) . runExceptT . authHandler
+
 pathIsEmpty :: Request -> Bool
 pathIsEmpty = go . pathInfo
   where go []   = True

servant-server/src/Servant/Server/Internal/Auth.hs

@@ -0,0 +1,77 @@
+{-# LANGUAGE DeriveFunctor      #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE TypeFamilies       #-}
+
+module Servant.Server.Internal.Auth where
+
+import           Control.Monad          (guard)
+import           Control.Monad.Trans.Except (ExceptT)
+import qualified Data.ByteString        as BS
+import           Data.ByteString.Base64 (decodeLenient)
+import           Data.Monoid            ((<>))
+import           Data.Typeable          (Typeable)
+import           Data.Word8             (isSpace, toLower, _colon)
+import           GHC.Generics
+import           Network.HTTP.Types     (Header)
+import           Network.Wai            (Request, requestHeaders)
+
+import Servant.Server.Internal.RoutingApplication
+import Servant.Server.Internal.ServantErr
+
+-- * General Auth
+
+-- | Specify the type of data returned after we've authenticated a request.
+-- quite often this is some `User` datatype.
+type family AuthReturnType a :: *
+
+-- | Handlers for AuthProtected resources
+newtype AuthHandler r usr = AuthHandler
+  { unAuthHandler :: r -> ExceptT ServantErr IO usr }
+  deriving (Generic, Typeable)
+
+mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr
+mkAuthHandler = AuthHandler
+
+-- | The result of authentication/authorization
+data BasicAuthResult usr
+  = Unauthorized
+  | BadPassword
+  | NoSuchUser
+  | Authorized usr
+  deriving (Eq, Show, Read, Generic, Typeable, Functor)
+
+-- * Basic Auth
+
+newtype BasicAuthCheck usr = BasicAuthCheck
+  { unBasicAuthCheck :: BS.ByteString  -- Username
+                     -> BS.ByteString  -- Password
+                     -> IO (BasicAuthResult usr)
+  }
+  deriving (Generic, Typeable, Functor)
+
+mkBAChallengerHdr :: BS.ByteString -> Header
+mkBAChallengerHdr realm = ("WWW-Authenticate", "Basic realm=\"" <> realm <> "\"")
+
+-- | Find and decode an 'Authorization' header from the request as Basic Auth
+decodeBAHdr :: Request -> Maybe (BS.ByteString, BS.ByteString)
+decodeBAHdr req = do
+    ah <- lookup "Authorization" $ requestHeaders req
+    let (b, rest) = BS.break isSpace ah
+    guard (BS.map toLower b == "basic")
+    let decoded = decodeLenient (BS.dropWhile isSpace rest)
+    let (username, passWithColonAtHead) = BS.break (== _colon) decoded
+    (_, password) <- BS.uncons passWithColonAtHead
+    return (username, password)
+
+runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr)
+runBasicAuth req realm (BasicAuthCheck ba) =
+  case decodeBAHdr req of
+     Nothing -> plzAuthenticate
+     Just e  -> uncurry ba e >>= \res -> case res of
+       BadPassword    -> plzAuthenticate
+       NoSuchUser     -> plzAuthenticate
+       Unauthorized   -> return $ Fail err403
+       Authorized usr -> return $ Route usr
+  where plzAuthenticate = return $ Fail err401 { errHeaders = [mkBAChallengerHdr realm] }

servant-server/src/Servant/Server/Internal/RoutingApplication.hs

@@ -1,9 +1,11 @@
 {-# LANGUAGE CPP                        #-}
 {-# LANGUAGE DeriveFunctor              #-}
+{-# LANGUAGE ExistentialQuantification  #-}
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 module Servant.Server.Internal.RoutingApplication where
 
@@ -84,6 +86,7 @@ toApplication ra request respond = do
 -- static routes (can cause 404)
 -- delayed captures (can cause 404)
 -- methods (can cause 405)
+-- authentication and authorization (can cause 401, 403)
 -- delayed body (can cause 415, 400)
 -- accept header (can cause 406)
 --
@@ -151,36 +154,71 @@ toApplication ra request respond = do
 -- The accept header check can be performed as the final
 -- computation in this block. It can cause a 406.
 --
-data Delayed :: * -> * where
+data Delayed c = forall captures auth body. Delayed
-  Delayed :: IO (RouteResult a)
+  { capturesD :: IO (RouteResult captures)
-          -> IO (RouteResult ())
+  , methodD   :: IO (RouteResult ())
-          -> IO (RouteResult b)
+  , authD     :: IO (RouteResult auth)
-          -> (a -> b -> RouteResult c)
+  , bodyD     :: IO (RouteResult body)
-          -> Delayed c
+  , serverD   :: (captures -> auth -> body -> RouteResult c)
+  }
 
 instance Functor Delayed where
-   fmap f (Delayed a b c g) = Delayed a b c ((fmap . fmap . fmap) f g)
+   fmap f Delayed{..}
+    = Delayed { capturesD = capturesD
+              , methodD   = methodD
+              , authD     = authD
+              , bodyD     = bodyD
+              , serverD   = (fmap.fmap.fmap.fmap) f serverD
+              } -- Note [Existential Record Update]
 
 -- | Add a capture to the end of the capture block.
 addCapture :: Delayed (a -> b)
            -> IO (RouteResult a)
            -> Delayed b
-addCapture (Delayed captures method body server) new =
+addCapture Delayed{..} new
-  Delayed (combineRouteResults (,) captures new) method body (\ (x, v) y -> ($ v) <$> server x y)
+    = Delayed { capturesD = combineRouteResults (,) capturesD new
+              , methodD   = methodD
+              , authD     = authD
+              , bodyD     = bodyD
+              , serverD   = \ (x, v) y z -> ($ v) <$> serverD x y z
+              } -- Note [Existential Record Update]
 
 -- | Add a method check to the end of the method block.
 addMethodCheck :: Delayed a
                -> IO (RouteResult ())
                -> Delayed a
-addMethodCheck (Delayed captures method body server) new =
+addMethodCheck Delayed{..} new
-  Delayed captures (combineRouteResults const method new) body server
+    = Delayed { capturesD = capturesD
+              , methodD   = combineRouteResults const methodD new
+              , authD     = authD
+              , bodyD     = bodyD
+              , serverD   = serverD
+              } -- Note [Existential Record Update]
+
+-- | Add an auth check to the end of the auth block.
+addAuthCheck :: Delayed (a -> b)
+             -> IO (RouteResult a)
+             -> Delayed b
+addAuthCheck Delayed{..} new
+    = Delayed { capturesD = capturesD
+              , methodD   = methodD
+              , authD     = combineRouteResults (,) authD new
+              , bodyD     = bodyD
+              , serverD   = \ x (y, v) z -> ($ v) <$> serverD x y z
+              } -- Note [Existential Record Update]
 
 -- | Add a body check to the end of the body block.
 addBodyCheck :: Delayed (a -> b)
              -> IO (RouteResult a)
              -> Delayed b
-addBodyCheck (Delayed captures method body server) new =
+addBodyCheck Delayed{..} new
-  Delayed captures method (combineRouteResults (,) body new) (\ x (y, v) -> ($ v) <$> server x y)
+    = Delayed { capturesD = capturesD
+              , methodD   = methodD
+              , authD     = authD
+              , bodyD     = combineRouteResults (,) bodyD new
+              , serverD   = \ x y (z, v) -> ($ v) <$> serverD x y z
+              } -- Note [Existential Record Update]
+
 
 -- | Add an accept header check to the end of the body block.
 -- The accept header check should occur after the body check,
@@ -189,8 +227,13 @@ addBodyCheck (Delayed captures method body server) new =
 addAcceptCheck :: Delayed a
                 -> IO (RouteResult ())
                 -> Delayed a
-addAcceptCheck (Delayed captures method body server) new =
+addAcceptCheck Delayed{..} new
-  Delayed captures method (combineRouteResults const body new) server
+    = Delayed { capturesD = capturesD
+              , methodD   = methodD
+              , authD     = authD
+              , bodyD     = combineRouteResults const bodyD new
+              , serverD   = serverD
+              } -- Note [Existential Record Update]
 
 -- | Many combinators extract information that is passed to
 -- the handler without the possibility of failure. In such a
@@ -222,13 +265,17 @@ combineRouteResults f m1 m2 =
 -- | Run a delayed server. Performs all scheduled operations
 -- in order, and passes the results from the capture and body
 -- blocks on to the actual handler.
+--
+-- This should only be called once per request; otherwise the guarantees about
+-- effect and HTTP error ordering break down.
 runDelayed :: Delayed a
            -> IO (RouteResult a)
-runDelayed (Delayed captures method body server) =
+runDelayed Delayed{..} =
-  captures `bindRouteResults` \ c ->
+  capturesD `bindRouteResults` \ c ->
-  method   `bindRouteResults` \ _ ->
+  methodD   `bindRouteResults` \ _ ->
-  body     `bindRouteResults` \ b ->
+  authD     `bindRouteResults` \ a ->
-  return (server c b)
+  bodyD     `bindRouteResults` \ b ->
+  return (serverD c a b)
 
 -- | Runs a delayed server and the resulting action.
 -- Takes a continuation that lets us send a response.
@@ -247,3 +294,11 @@ runAction action respond k = runDelayed action >>= go >>= respond
       case e of
         Left err -> return . Route $ responseServantErr err
         Right x  -> return $! k x
+
+
+{- Note [Existential Record Update]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Due to GHC issue <https://ghc.haskell.org/trac/ghc/ticket/2595 2595>, we cannot
+do the more succint thing - just update the records we actually change.
+-}

servant-server/test/Servant/ServerSpec.hs

@@ -3,7 +3,6 @@
 {-# LANGUAGE DeriveGeneric        #-}
 {-# LANGUAGE FlexibleContexts     #-}
 {-# LANGUAGE FlexibleInstances    #-}
-{-# LANGUAGE FlexibleInstances    #-}
 {-# LANGUAGE OverloadedStrings    #-}
 {-# LANGUAGE PolyKinds            #-}
 {-# LANGUAGE ScopedTypeVariables  #-}
@@ -31,14 +30,14 @@ 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.Internal       (Response (ResponseBuilder), requestHeaders)
 import           Network.Wai.Test           (defaultRequest, request,
                                              runSession, simpleBody,
                                              simpleHeaders, simpleStatus)
-import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
+import           Servant.API                ((:<|>) (..), (:>), AuthProtect, BasicAuth, Capture, Delete,
                                              Get, Header (..),
                                              Headers, HttpVersion,
                                              IsSecure (..), JSON,
@@ -48,14 +47,21 @@ import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
                                              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, Config(EmptyConfig))
+                                             serve, Config((:.), EmptyConfig))
 import           Test.Hspec                 (Spec, context, describe, it,
                                              shouldBe, shouldContain)
+import qualified Test.Hspec.Wai as THW
 import           Test.Hspec.Wai             (get, liftIO, matchHeaders,
                                              matchStatus, request,
                                              shouldRespondWith, with, (<:>))
+import qualified Test.Hspec.Wai as THW
 
+import           Servant.Server.Internal.Auth
+                                            (AuthHandler, AuthReturnType, BasicAuthCheck (BasicAuthCheck),
+                                               BasicAuthResult (Authorized, Unauthorized), mkAuthHandler)
+
+import           Servant.Server.Internal.Auth
 import           Servant.Server.Internal.RoutingApplication
                                             (toApplication, RouteResult(..))
 import           Servant.Server.Internal.Router
@@ -86,6 +92,7 @@ spec = do
   responseHeadersSpec
   routerSpec
   miscCombinatorSpec
+  authSpec
 
 ------------------------------------------------------------------------------
 -- * verbSpec {{{
@@ -528,6 +535,53 @@ miscCombinatorSpec = with (return $ serve miscApi EmptyConfig miscServ) $
       go "/host" "\"0.0.0.0:0\""
 
   where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res
+
+-- }}}
+------------------------------------------------------------------------------
+-- * Authentication {{{
+------------------------------------------------------------------------------
+type AuthAPI = BasicAuth "foo" :> "basic" :> Get '[JSON] Animal
+          :<|> AuthProtect "auth" :> "auth" :> Get '[JSON] Animal
+authApi :: Proxy AuthAPI
+authApi = Proxy
+authServer :: Server AuthAPI
+authServer = const (return jerry) :<|> const (return tweety)
+
+type instance AuthReturnType (BasicAuth "foo") = ()
+type instance AuthReturnType (AuthProtect "auth") = ()
+
+authConfig :: Config '[ BasicAuthCheck ()
+                      , AuthHandler Request ()
+                      ]
+authConfig =
+  let basicHandler = BasicAuthCheck $ (\usr pass ->
+        if usr == "servant" && pass == "server"
+        then return (Authorized ())
+        else return Unauthorized
+        )
+      authHandler = (\req ->
+        if elem ("Auth", "secret") (requestHeaders req)
+        then return ()
+        else throwE err401
+        )
+  in basicHandler :. mkAuthHandler authHandler :. EmptyConfig
+
+authSpec :: Spec
+authSpec = do
+  describe "Servant.API.Auth" $ do
+    with (return (serve authApi authConfig authServer)) $ do
+
+      context "Basic Authentication" $ do
+        it "returns with 401 with bad password" $ do
+          get "/basic" `shouldRespondWith` 401
+        it "returns 200 with the right password" $ do
+          THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200
+
+      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/servant.cabal

@@ -27,6 +27,7 @@ library
   exposed-modules:
     Servant.API
     Servant.API.Alternative
+    Servant.API.Auth
     Servant.API.Capture
     Servant.API.ContentTypes
     Servant.API.Header

servant/src/Servant/API.hs

@@ -37,6 +37,9 @@ module Servant.API (
   -- * Response Headers
   module Servant.API.ResponseHeaders,
 
+  -- * Authentication
+  module Servant.API.Auth,
+
   -- * Untyped endpoints
   module Servant.API.Raw,
   -- | Plugging in a wai 'Network.Wai.Application', serving directories
@@ -51,6 +54,7 @@ module Servant.API (
   ) where
 
 import           Servant.API.Alternative     ((:<|>) (..))
+import           Servant.API.Auth            (BasicAuth, AuthProtect)
 import           Servant.API.Capture         (Capture)
 import           Servant.API.ContentTypes    (Accept (..), FormUrlEncoded,
                                               FromFormUrlEncoded (..), JSON,

servant/src/Servant/API/Auth.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE KindSignatures     #-}
+{-# LANGUAGE PolyKinds          #-}
+module Servant.API.Auth where
+
+import           Data.Typeable (Typeable)
+import           GHC.TypeLits  (Symbol)
+
+
+-- | Combinator for <https://tools.ietf.org/html/rfc2617#section-2 Basic Access Authentication>.
+--
+-- *IMPORTANT*: Only use Basic Auth over HTTPS! Credentials are not hashed or
+-- encrypted. Note also that because the same credentials are sent on every
+-- request, Basic Auth is not as secure as some alternatives.
+--
+-- In Basic Auth, username and password are base64-encoded and transmitted via
+-- the @Authorization@ header. Handshakes are not required, making it
+-- relatively efficient.
+data BasicAuth (realm :: Symbol)
+  deriving (Typeable)
+
+-- | A generalized Authentication combinator.
+data AuthProtect (tag :: k)
+  deriving (Typeable)