Merge pull request #375 from haskell-servant/auth-basic

Basic Authentication Support

servant-client/CHANGELOG.md

@@ -8,6 +8,7 @@ HEAD
 * Use `http-api-data` instead of `Servant.Common.Text`
 * Client functions now consider any 2xx successful.
 * Remove matrix params.
+* Added support for Basic authentication
 
 0.4.1
 -----

servant-client/servant-client.cabal

@@ -28,11 +28,13 @@ library
   exposed-modules:
     Servant.Client
     Servant.Common.BaseUrl
+    Servant.Common.BasicAuth
     Servant.Common.Req
   build-depends:
       base >=4.7 && <5
     , aeson
     , attoparsec
+    , base64-bytestring
     , bytestring
     , exceptions
     , http-api-data >= 0.1  && < 0.3

servant-client/src/Servant/Client.hs

@@ -37,6 +37,7 @@ import qualified Network.HTTP.Types         as H
 import qualified Network.HTTP.Types.Header  as HTTP
 import           Servant.API
 import           Servant.Common.BaseUrl
+import           Servant.Common.BasicAuth
 import           Servant.Common.Req
 
 -- * Accessing APIs as a Client
@@ -424,6 +425,15 @@ instance HasClient subapi =>
   clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy subapi)
 
 
+-- * Basic Authentication
+
+instance HasClient api => HasClient (BasicAuth realm usr :> api) where
+  type Client (BasicAuth realm usr :> api) = BasicAuthData -> Client api
+
+  clientWithRoute Proxy req baseurl manager val =
+    clientWithRoute (Proxy :: Proxy api) (basicAuthReq val req) baseurl manager
+
+
 {- Note [Non-Empty Content Types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Rather than have

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

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+{-# LANGUAGE TypeFamilies      #-}
+
+-- | Basic Authentication for clients
+
+module Servant.Common.BasicAuth (
+    basicAuthReq
+  ) where
+
+import Data.ByteString.Base64 (encode)
+import Data.Monoid ((<>))
+import Data.Text.Encoding (decodeUtf8)
+import Servant.Common.Req (addHeader, Req)
+import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
+
+-- | 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

servant-client/test/Servant/ClientSpec.hs

@@ -62,6 +62,7 @@ spec = describe "Servant.Client" $ do
     sucessSpec
     failSpec
     wrappedApiSpec
+    basicAuthSpec
 
 -- * test data types
 
@@ -148,6 +149,29 @@ failServer = serve failApi (
   :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "")
  )
 
+
+-- * auth stuff
+
+type BasicAuthAPI =
+       BasicAuth "foo-realm" () :> "private" :> "basic" :> Get '[JSON] Person
+
+basicAuthAPI :: Proxy BasicAuthAPI
+basicAuthAPI = Proxy
+
+basicAuthHandler :: BasicAuthCheck ()
+basicAuthHandler =
+  let check (BasicAuthData username password) =
+        if username == "servant" && password == "server"
+        then return (Authorized ())
+        else return Unauthorized
+  in BasicAuthCheck check
+
+serverContext :: Context '[ BasicAuthCheck () ]
+serverContext = basicAuthHandler :. EmptyContext
+
+basicAuthServer :: Application
+basicAuthServer = serveWithContext basicAuthAPI serverContext (const (return alice))
+
 {-# NOINLINE manager #-}
 manager :: C.Manager
 manager = unsafePerformIO $ C.newManager C.defaultManagerSettings
@@ -292,6 +316,22 @@ data WrappedApi where
                  HasClient api, Client api ~ ExceptT ServantError IO ()) =>
     Proxy api -> WrappedApi
 
+basicAuthSpec :: Spec
+basicAuthSpec = beforeAll (startWaiApp basicAuthServer) $ afterAll endWaiApp $ do
+  context "Authentication works when requests are properly authenticated" $ do
+
+    it "Authenticates a BasicAuth protected server appropriately" $ \(_,baseUrl) -> do
+      let getBasic = client basicAuthAPI baseUrl manager
+      let basicAuthData = BasicAuthData "servant" "server"
+      (left show <$> runExceptT (getBasic basicAuthData)) `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 basicAuthAPI baseUrl manager
+      let basicAuthData = BasicAuthData "not" "password"
+      Left FailureResponse{..} <- runExceptT (getBasic basicAuthData)
+      responseStatus `shouldBe` Status 403 "Forbidden"
 
 -- * utils
 

servant-docs/CHANGELOG.md

@@ -9,6 +9,7 @@ HEAD
 * Move `toSample` out of `ToSample` class
 * Add a few helper functions to define `toSamples`
 * Remove matrix params.
+* Added support for Basic authentication
 
 0.4
 ---

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,13 @@ instance HasDocs sublayout => HasDocs (Vault :> sublayout) where
 instance HasDocs sublayout => HasDocs (WithNamedContext name context sublayout) where
   docsFor Proxy = docsFor (Proxy :: Proxy sublayout)
 
+instance (ToAuthInfo (BasicAuth realm usr), HasDocs sublayout) => HasDocs (BasicAuth realm usr :> sublayout) where
+  docsFor Proxy (endpoint, action) =
+    docsFor (Proxy :: Proxy sublayout) (endpoint, action')
+      where
+        authProxy = Proxy :: Proxy (BasicAuth realm usr)
+        action' = over authInfo (|> toAuthInfo authProxy) action
+
 -- ToSample instances for simple types
 instance ToSample ()
 instance ToSample Bool

servant-examples/basic-auth/basic-auth.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# 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.API.BasicAuth    (BasicAuthData (BasicAuthData))
+import           Servant.Server           (BasicAuthCheck (BasicAuthCheck),
+                                           BasicAuthResult( Authorized
+                                                          , Unauthorized
+                                                          ),
+                                           Context ((:.), EmptyContext), Server,
+                                           serveWithContext)
+
+-- | 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" User :> PrivateAPI
+
+-- | a value holding a proxy of our API type
+api :: Proxy API
+api = Proxy
+
+-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
+authCheck :: BasicAuthCheck User
+authCheck =
+  let check (BasicAuthData 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 Context. In this case,
+-- Basic Authentication requires a Context Entry with the 'BasicAuthCheck' value
+-- tagged with "foo-tag" This context is then supplied to 'server' and threaded 
+-- to the BasicAuth HasServer handlers.
+serverContext :: Context (BasicAuthCheck User ': '[])
+serverContext = authCheck :. EmptyContext
+
+-- | 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 (serveWithContext api serverContext 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

@@ -89,6 +89,22 @@ executable wai-middleware
   hs-source-dirs: wai-middleware
   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 auth-combinator
   main-is: auth-combinator.hs
   ghc-options: -Wall -fno-warn-unused-binds -fno-warn-name-shadowing

servant-server/CHANGELOG.md

@@ -11,6 +11,7 @@ HEAD
 * Remove `RouteMismatch`.
 * Redefined constructors of `RouteResult`.
 * Added `Delayed` and related functions (`addMethodCheck`, `addAcceptCheck`, `addBodyCheck`, `runDelayed`)
+* Added support for Basic Authentication
 
 0.4.1
 -----

servant-server/servant-server.cabal

@@ -38,6 +38,7 @@ library
     Servant.Server
     Servant.Server.Internal
     Servant.Server.Internal.Context
+    Servant.Server.Internal.BasicAuth
     Servant.Server.Internal.Enter
     Servant.Server.Internal.Router
     Servant.Server.Internal.RoutingApplication
@@ -47,6 +48,7 @@ library
         base               >= 4.7  && < 5
       , aeson              >= 0.7  && < 0.12
       , 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

@@ -45,6 +45,11 @@ module Servant.Server
   , NamedContext(..)
   , descendIntoNamedContext
 
+
+  -- * Basic Authentication
+  , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)
+  , BasicAuthResult(..)
+
     -- * Default error type
   , ServantErr(..)
     -- ** 3XX
@@ -119,7 +124,7 @@ serveWithContext :: (HasServer layout context)
     => Proxy layout -> Context context -> Server layout -> Application
 serveWithContext p context server = toApplication (runRouter (route p context 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

@@ -16,6 +16,7 @@
 module Servant.Server.Internal
   ( module Servant.Server.Internal
   , module Servant.Server.Internal.Context
+  , module Servant.Server.Internal.BasicAuth
   , module Servant.Server.Internal.Router
   , module Servant.Server.Internal.RoutingApplication
   , module Servant.Server.Internal.ServantErr
@@ -26,6 +27,7 @@ import           Control.Applicative         ((<$>))
 #endif
 import           Control.Monad.Trans.Except (ExceptT)
 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)
@@ -48,7 +50,7 @@ import           Web.HttpApiData.Internal   (parseHeaderMaybe,
                                              parseQueryParamMaybe,
                                              parseUrlPieceMaybe)
 
-import           Servant.API                 ((:<|>) (..), (:>), Capture,
+import           Servant.API                 ((:<|>) (..), (:>), BasicAuth, Capture,
                                               Verb, ReflectMethod(reflectMethod),
                                               IsSecure(..), Header,
                                               QueryFlag, QueryParam, QueryParams,
@@ -63,6 +65,7 @@ import           Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
                                               getResponse)
 
 import           Servant.Server.Internal.Context
+import           Servant.Server.Internal.BasicAuth
 import           Servant.Server.Internal.Router
 import           Servant.Server.Internal.RoutingApplication
 import           Servant.Server.Internal.ServantErr
@@ -450,6 +453,26 @@ 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
+         , HasContextEntry context (BasicAuthCheck usr)
+         )
+    => HasServer (BasicAuth realm usr :> api) context where
+
+  type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m
+
+  route Proxy context subserver = WithRequest $ \ request ->
+    route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)
+    where
+       realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
+       basicAuthContext = getContextEntry context
+       authCheck req = runBasicAuth req realm basicAuthContext
+
+-- * helpers
+
 pathIsEmpty :: Request -> Bool
 pathIsEmpty = go . pathInfo
   where go []   = True

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

@@ -0,0 +1,69 @@
+{-# LANGUAGE DeriveFunctor      #-}
+{-# LANGUAGE DeriveGeneric      #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings  #-}
+
+module Servant.Server.Internal.BasicAuth where
+
+import           Control.Monad          (guard)
+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.API.BasicAuth (BasicAuthData(BasicAuthData))
+import Servant.Server.Internal.RoutingApplication
+import Servant.Server.Internal.ServantErr
+
+-- * Basic Auth
+
+-- | servant-server's current implementation of basic authentication is not
+-- immune to certian kinds of timing attacks. Decoding payloads does not take
+-- a fixed amount of time.
+
+-- | The result of authentication/authorization
+data BasicAuthResult usr
+  = Unauthorized
+  | BadPassword
+  | NoSuchUser
+  | Authorized usr
+  deriving (Eq, Show, Read, Generic, Typeable, Functor)
+
+-- | Datatype wrapping a function used to check authentication.
+newtype BasicAuthCheck usr = BasicAuthCheck
+  { unBasicAuthCheck :: BasicAuthData
+                     -> IO (BasicAuthResult usr)
+  }
+  deriving (Generic, Typeable, Functor)
+
+-- | Internal method to make a basic-auth challenge
+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 BasicAuthData
+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 (BasicAuthData username password)
+
+-- | Run and check basic authentication, returning the appropriate http error per
+-- the spec.
+runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> IO (RouteResult usr)
+runBasicAuth req realm (BasicAuthCheck ba) =
+  case decodeBAHdr req of
+     Nothing -> plzAuthenticate
+     Just e  -> 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

@@ -4,6 +4,7 @@
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 module Servant.Server.Internal.RoutingApplication where
 
@@ -52,6 +53,7 @@ toApplication ra request respond = ra request routingRespond
 -- 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)
 --
@@ -119,36 +121,71 @@ toApplication ra request respond = ra request routingRespond
 -- 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 where
-  Delayed :: IO (RouteResult a)
+  Delayed :: { 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)
+             } -> Delayed 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,
@@ -157,8 +194,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
@@ -190,13 +232,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.
@@ -215,3 +261,10 @@ 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/Server/ErrorSpec.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE TypeFamilies          #-}
 {-# LANGUAGE TypeOperators         #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Servant.Server.ErrorSpec (spec) where
@@ -10,7 +11,8 @@ import           Data.Aeson                 (encode)
 import qualified Data.ByteString.Char8      as BC
 import qualified Data.ByteString.Lazy.Char8 as BCL
 import           Data.Proxy
-import           Network.HTTP.Types         (hAccept, hContentType, methodGet,
+import           Network.HTTP.Types         (hAccept, hAuthorization,
+                                             hContentType, methodGet,
                                              methodPost, methodPut)
 import           Safe                       (readMay)
 import           Test.Hspec
@@ -25,57 +27,79 @@ spec = describe "HTTP Errors" $ do
     errorRetrySpec
     errorChoiceSpec
 
+-- * Auth machinery (reused throughout)
+
+-- | 'BasicAuthCheck' holds the handler we'll use to verify a username and password.
+errorOrderAuthCheck :: BasicAuthCheck ()
+errorOrderAuthCheck =
+  let check (BasicAuthData username password) =
+        if username == "servant" && password == "server"
+        then return (Authorized ())
+        else return Unauthorized
+  in BasicAuthCheck check
+
 ------------------------------------------------------------------------------
 -- * Error Order {{{
 
 type ErrorOrderApi = "home"
+                  :> BasicAuth "error-realm" ()
                   :> ReqBody '[JSON] Int
                   :> Capture "t" Int
                   :> Post '[JSON] Int
 
-
 errorOrderApi :: Proxy ErrorOrderApi
 errorOrderApi = Proxy
 
 errorOrderServer :: Server ErrorOrderApi
-errorOrderServer = \_ _ -> throwE err402
+errorOrderServer = \_ _ _ -> throwE err402
 
 errorOrderSpec :: Spec
-errorOrderSpec = describe "HTTP error order"
+errorOrderSpec =
-           $ with (return $ serve errorOrderApi errorOrderServer) $ do
+  describe "HTTP error order" $
+    with (return $ serveWithContext errorOrderApi
+                   (errorOrderAuthCheck :. EmptyContext)
+                   errorOrderServer
+         ) $ do
   let badContentType  = (hContentType, "text/plain")
       badAccept       = (hAccept, "text/plain")
       badMethod       = methodGet
       badUrl          = "home/nonexistent"
       badBody         = "nonsense"
+      badAuth         = (hAuthorization, "Basic foofoofoo")
       goodContentType = (hContentType, "application/json")
       goodAccept      = (hAccept, "application/json")
       goodMethod      = methodPost
       goodUrl         = "home/2"
       goodBody        = encode (5 :: Int)
+      -- username:password = servant:server
+      goodAuth        = (hAuthorization, "Basic c2VydmFudDpzZXJ2ZXI=")
 
   it "has 404 as its highest priority error" $ do
-    request badMethod badUrl [badContentType, badAccept] badBody
+    request badMethod badUrl [badAuth, badContentType, badAccept] badBody
       `shouldRespondWith` 404
 
   it "has 405 as its second highest priority error" $ do
-    request badMethod goodUrl [badContentType, badAccept] badBody
+    request badMethod goodUrl [badAuth, badContentType, badAccept] badBody
       `shouldRespondWith` 405
 
-  it "has 415 as its third highest priority error" $ do
+  it "has 401 as its third highest priority error (auth)" $ do
-    request goodMethod goodUrl [badContentType, badAccept] badBody
+    request goodMethod goodUrl [badAuth, badContentType, badAccept] badBody
+      `shouldRespondWith` 401
+
+  it "has 415 as its fourth highest priority error" $ do
+    request goodMethod goodUrl [goodAuth, badContentType, badAccept] badBody
       `shouldRespondWith` 415
 
-  it "has 400 as its fourth highest priority error" $ do
+  it "has 400 as its fifth highest priority error" $ do
-    request goodMethod goodUrl [goodContentType, badAccept] badBody
+    request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody
       `shouldRespondWith` 400
 
-  it "has 406 as its fifth highest priority error" $ do
+  it "has 406 as its sixth highest priority error" $ do
-    request goodMethod goodUrl [goodContentType, badAccept] goodBody
+    request goodMethod goodUrl [goodAuth, goodContentType, badAccept] goodBody
       `shouldRespondWith` 406
 
   it "has handler-level errors as last priority" $ do
-    request goodMethod goodUrl [goodContentType, goodAccept] goodBody
+    request goodMethod goodUrl [goodAuth, goodContentType, goodAccept] goodBody
       `shouldRespondWith` 402
 
 type PrioErrorsApi = ReqBody '[JSON] Integer :> "foo" :> Get '[JSON] Integer
@@ -134,9 +158,12 @@ type ErrorRetryApi
   :<|> "a" :> ReqBody '[JSON] Int      :> Post '[PlainText] Int           -- 2
   :<|> "a" :> ReqBody '[JSON] String   :> Post '[JSON] Int                -- 3
   :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 4
-  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 5
+  :<|> "a" :> BasicAuth "bar-realm" ()
-  :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 6
+           :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 5
-  :<|>        ReqBody '[JSON] Int      :> Post '[JSON] Int                -- 7
+  :<|> "a" :> ReqBody '[JSON] Int      :> Get  '[PlainText] Int           -- 6
+
+  :<|>        ReqBody '[JSON] Int      :> Get  '[JSON] Int                -- 7
+  :<|>        ReqBody '[JSON] Int      :> Post '[JSON] Int                -- 8
 
 errorRetryApi :: Proxy ErrorRetryApi
 errorRetryApi = Proxy
@@ -148,13 +175,18 @@ errorRetryServer
   :<|> (\_ -> return 2)
   :<|> (\_ -> return 3)
   :<|> (\_ -> return 4)
-  :<|> (\_ -> return 5)
+  :<|> (\_ _ -> return 5)
   :<|> (\_ -> return 6)
   :<|> (\_ -> return 7)
+  :<|> (\_ -> return 8)
 
 errorRetrySpec :: Spec
-errorRetrySpec = describe "Handler search"
+errorRetrySpec =
-           $ with (return $ serve errorRetryApi errorRetryServer) $ do
+  describe "Handler search" $
+    with (return $ serveWithContext errorRetryApi
+                         (errorOrderAuthCheck :. EmptyContext)
+                         errorRetryServer
+         ) $ do
 
   let jsonCT      = (hContentType, "application/json")
       jsonAccept  = (hAccept, "application/json")
@@ -162,16 +194,12 @@ errorRetrySpec = describe "Handler search"
 
   it "should continue when URLs don't match" $ do
     request methodPost "" [jsonCT, jsonAccept] jsonBody
-     `shouldRespondWith` 200 { matchBody = Just $ encode (7 :: Int) }
+     `shouldRespondWith` 200 { matchBody = Just $ encode (8 :: Int) }
 
   it "should continue when methods don't match" $ do
     request methodGet "a" [jsonCT, jsonAccept] jsonBody
      `shouldRespondWith` 200 { matchBody = Just $ encode (4 :: Int) }
 
-  it "should not continue when body cannot be decoded" $ do
-    request methodPost "a" [jsonCT, jsonAccept] "a string"
-     `shouldRespondWith` 400
-
 -- }}}
 ------------------------------------------------------------------------------
 -- * Error Choice {{{

servant-server/test/Servant/ServerSpec.hs

@@ -38,8 +38,8 @@ import           Network.Wai.Internal       (Response (ResponseBuilder))
 import           Network.Wai.Test           (defaultRequest, request,
                                              runSession, simpleBody,
                                              simpleHeaders, simpleStatus)
-import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
+import           Servant.API                ((:<|>) (..), (:>), BasicAuth, BasicAuthData(BasicAuthData),
-                                             Get, Header (..),
+                                             Capture, Delete, Get, Header (..),
                                              Headers, HttpVersion,
                                              IsSecure (..), JSON,
                                              NoContent (..), Patch, PlainText,
@@ -49,20 +49,23 @@ import           Servant.API                ((:<|>) (..), (:>), Capture, Delete,
                                              StdMethod (..), Verb, addHeader)
 import           Servant.API.Internal.Test.ComprehensiveAPI
 import           Servant.Server             (ServantErr (..), Server, err404,
-                                             serve, serveWithContext, Context(EmptyContext))
+                                             serve, serveWithContext, Context((:.), EmptyContext))
 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,
+                                             matchStatus, shouldRespondWith,
-                                             shouldRespondWith, with, (<:>))
+                                             with, (<:>))
 
+import           Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),
+                                                    BasicAuthResult(Authorized,Unauthorized))
 import           Servant.Server.Internal.RoutingApplication
                                             (toApplication, RouteResult(..))
 import           Servant.Server.Internal.Router
                                             (tweakResponse, runRouter,
                                              Router, Router'(LeafRouter))
 import           Servant.Server.Internal.Context
-                                            (Context(..), NamedContext(..))
+                                            (NamedContext(..))
 
 -- * comprehensive api test
 
@@ -86,6 +89,7 @@ spec = do
   responseHeadersSpec
   routerSpec
   miscCombinatorSpec
+  basicAuthSpec
 
 ------------------------------------------------------------------------------
 -- * verbSpec {{{
@@ -117,49 +121,49 @@ verbSpec = describe "Servant.API.Verb" $ do
           -- HEAD and 214/215 need not return bodies
           unless (status `elem` [214, 215] || method == methodHead) $
             it "returns the person" $ do
-              response <- Test.Hspec.Wai.request method "/" [] ""
+              response <- THW.request method "/" [] ""
               liftIO $ statusCode (simpleStatus response) `shouldBe` status
               liftIO $ decode' (simpleBody response) `shouldBe` Just alice
 
           it "returns no content on NoContent" $ do
-              response <- Test.Hspec.Wai.request method "/noContent" [] ""
+              response <- THW.request method "/noContent" [] ""
               liftIO $ statusCode (simpleStatus response) `shouldBe` status
               liftIO $ simpleBody response `shouldBe` ""
 
           -- HEAD should not return body
           when (method == methodHead) $
             it "HEAD returns no content body" $ do
-              response <- Test.Hspec.Wai.request method "/" [] ""
+              response <- THW.request method "/" [] ""
               liftIO $ simpleBody response `shouldBe` ""
 
           it "throws 405 on wrong method " $ do
-            Test.Hspec.Wai.request (wrongMethod method) "/" [] ""
+            THW.request (wrongMethod method) "/" [] ""
               `shouldRespondWith` 405
 
           it "returns headers" $ do
-            response1 <- Test.Hspec.Wai.request method "/header" [] ""
+            response1 <- THW.request method "/header" [] ""
             liftIO $ statusCode (simpleStatus response1) `shouldBe` status
             liftIO $ simpleHeaders response1 `shouldContain` [("H", "5")]
 
-            response2 <- Test.Hspec.Wai.request method "/header" [] ""
+            response2 <- THW.request method "/header" [] ""
             liftIO $ statusCode (simpleStatus response2) `shouldBe` status
             liftIO $ simpleHeaders response2 `shouldContain` [("H", "5")]
 
           it "handles trailing '/' gracefully" $ do
-            response <- Test.Hspec.Wai.request method "/headerNC/" [] ""
+            response <- THW.request method "/headerNC/" [] ""
             liftIO $ statusCode (simpleStatus response) `shouldBe` status
 
           it "returns 406 if the Accept header is not supported" $ do
-            Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
+            THW.request method "" [(hAccept, "crazy/mime")] ""
               `shouldRespondWith` 406
 
           it "responds if the Accept header is supported" $ do
-            response <- Test.Hspec.Wai.request method ""
+            response <- THW.request method ""
                [(hAccept, "application/json")] ""
             liftIO $ statusCode (simpleStatus response) `shouldBe` status
 
           it "sets the Content-Type header" $ do
-            response <- Test.Hspec.Wai.request method "" [] ""
+            response <- THW.request method "" [] ""
             liftIO $ simpleHeaders response `shouldContain`
               [("Content-Type", "application/json")]
 
@@ -306,7 +310,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do
 
   let server :: Server ReqBodyApi
       server = return :<|> return . age
-      mkReq method x = Test.Hspec.Wai.request method x
+      mkReq method x = THW.request method x
          [(hContentType, "application/json;charset=utf-8")]
 
   with (return $ serve reqBodyApi server) $ do
@@ -319,7 +323,7 @@ reqBodySpec = describe "Servant.API.ReqBody" $ do
       mkReq methodPut "/blah" "some invalid body" `shouldRespondWith` 400
 
     it "responds with 415 if the request body media type is unsupported" $ do
-      Test.Hspec.Wai.request methodPost "/"
+      THW.request methodPost "/"
         [(hContentType, "application/nonsense")] "" `shouldRespondWith` 415
 
 -- }}}
@@ -343,13 +347,13 @@ headerSpec = describe "Servant.API.Header" $ do
         expectsString Nothing  = error "Expected a string"
 
     with (return (serve headerApi expectsInt)) $ do
-        let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "5")]
+        let delete' x = THW.request methodDelete x [("MyHeader", "5")]
 
         it "passes the header to the handler (Int)" $
             delete' "/" "" `shouldRespondWith` 200
 
     with (return (serve headerApi expectsString)) $ do
-        let delete' x = Test.Hspec.Wai.request methodDelete x [("MyHeader", "more from you")]
+        let delete' x = THW.request methodDelete x [("MyHeader", "more from you")]
 
         it "passes the header to the handler (String)" $
             delete' "/" "" `shouldRespondWith` 200
@@ -455,19 +459,19 @@ responseHeadersSpec = describe "ResponseHeaders" $ do
 
     it "includes the headers in the response" $
       forM_ methods $ \method ->
-        Test.Hspec.Wai.request method "/" [] ""
+        THW.request method "/" [] ""
           `shouldRespondWith` "\"hi\""{ matchHeaders = ["H1" <:> "5", "H2" <:> "kilroy"]
                                       , matchStatus  = 200
                                       }
 
     it "responds with not found for non-existent endpoints" $
       forM_ methods $ \method ->
-        Test.Hspec.Wai.request method "blahblah" [] ""
+        THW.request method "blahblah" [] ""
           `shouldRespondWith` 404
 
     it "returns 406 if the Accept header is not supported" $
       forM_ methods $ \method ->
-        Test.Hspec.Wai.request method "" [(hAccept, "crazy/mime")] ""
+        THW.request method "" [(hAccept, "crazy/mime")] ""
           `shouldRespondWith` 406
 
 -- }}}
@@ -527,6 +531,39 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $
       go "/host" "\"0.0.0.0:0\""
 
   where go path res = Test.Hspec.Wai.get path `shouldRespondWith` res
+
+-- }}}
+------------------------------------------------------------------------------
+-- * Authentication {{{
+------------------------------------------------------------------------------
+
+type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal
+
+basicAuthApi :: Proxy BasicAuthAPI
+basicAuthApi = Proxy
+basicAuthServer :: Server BasicAuthAPI
+basicAuthServer = const (return jerry)
+
+basicAuthContext :: Context '[ BasicAuthCheck () ]
+basicAuthContext =
+  let basicHandler = BasicAuthCheck $ (\(BasicAuthData usr pass) ->
+        if usr == "servant" && pass == "server"
+        then return (Authorized ())
+        else return Unauthorized
+        )
+  in basicHandler :. EmptyContext
+
+basicAuthSpec :: Spec
+basicAuthSpec = do
+  describe "Servant.API.BasicAuth" $ do
+    with (return (serveWithContext basicAuthApi basicAuthContext basicAuthServer)) $ 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
+
 -- }}}
 ------------------------------------------------------------------------------
 -- * Test data types {{{

servant/CHANGELOG.md

@@ -10,6 +10,7 @@ HEAD
 * Add PlainText String MimeRender and MimeUnrender instances.
 * Add new `Verbs` combinator, and make all existing and new verb combinators
 type synonyms of it.
+* Add `BasicAuth` combinator to support Basic authentication
 
 0.4.2
 -----

servant/servant.cabal

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

servant/src/Servant/API.hs

@@ -29,6 +29,9 @@ module Servant.API (
   -- * Actual endpoints, distinguished by HTTP method
   module Servant.API.Verbs,
 
+  -- * Authentication
+  module Servant.API.BasicAuth,
+
   -- * Content Types
   module Servant.API.ContentTypes,
   -- | Serializing and deserializing types based on @Accept@ and
@@ -51,6 +54,7 @@ module Servant.API (
   ) where
 
 import           Servant.API.Alternative     ((:<|>) (..))
+import           Servant.API.BasicAuth       (BasicAuth,BasicAuthData(..))
 import           Servant.API.Capture         (Capture)
 import           Servant.API.ContentTypes    (Accept (..), FormUrlEncoded,
                                               FromFormUrlEncoded (..), JSON,

servant/src/Servant/API/BasicAuth.hs

@@ -0,0 +1,29 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE KindSignatures     #-}
+{-# LANGUAGE PolyKinds          #-}
+module Servant.API.BasicAuth where
+
+import           Data.ByteString (ByteString)
+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. Further, the
+-- implementation in servant-server does not protect against some types of
+-- timing attacks.
+--
+-- 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) (userData :: *)
+  deriving (Typeable)
+
+-- | A simple datatype to hold data required to decorate a request
+data BasicAuthData = BasicAuthData { basicAuthUsername :: !ByteString
+                                   , basicAuthPassword :: !ByteString
+                                   }