git.iko.soy/servant
on c8dbcea help sign in
servant/servant-server/src/Servant/Server/Internal/BasicAuth.hs
70 lines 2.8 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE OverloadedStrings #-}
6module Servant.Server.Internal.BasicAuth where
8import Control.Monad (guard)
9import Control.Monad.Trans (liftIO)
10import qualified Data.ByteString as BS
11import Data.ByteString.Base64 (decodeLenient)
12import Data.Monoid ((<>))
13import Data.Typeable (Typeable)
14import Data.Word8 (isSpace, toLower, _colon)
15import GHC.Generics
16import Network.HTTP.Types (Header)
17import Network.Wai (Request, requestHeaders)
19import Servant.API.BasicAuth (BasicAuthData(BasicAuthData))
20import Servant.Server.Internal.RoutingApplication
21import Servant.Server.Internal.ServantErr
23-- * Basic Auth
25-- | servant-server's current implementation of basic authentication is not
26-- immune to certian kinds of timing attacks. Decoding payloads does not take
27-- a fixed amount of time.
29-- | The result of authentication/authorization
30data BasicAuthResult usr
31 = Unauthorized
32 | BadPassword
33 | NoSuchUser
34 | Authorized usr
35 deriving (Eq, Show, Read, Generic, Typeable, Functor)
37-- | Datatype wrapping a function used to check authentication.
38newtype BasicAuthCheck usr = BasicAuthCheck
39 { unBasicAuthCheck :: BasicAuthData
40 -> IO (BasicAuthResult usr)
41 }
42 deriving (Generic, Typeable, Functor)
44-- | Internal method to make a basic-auth challenge
45mkBAChallengerHdr :: BS.ByteString -> Header
46mkBAChallengerHdr realm = ("WWW-Authenticate", "Basic realm=\"" <> realm <> "\"")
48-- | Find and decode an 'Authorization' header from the request as Basic Auth
49decodeBAHdr :: Request -> Maybe BasicAuthData
50decodeBAHdr req = do
51 ah <- lookup "Authorization" $ requestHeaders req
52 let (b, rest) = BS.break isSpace ah
53 guard (BS.map toLower b == "basic")
54 let decoded = decodeLenient (BS.dropWhile isSpace rest)
55 let (username, passWithColonAtHead) = BS.break (== _colon) decoded
56 (_, password) <- BS.uncons passWithColonAtHead
57 return (BasicAuthData username password)
59-- | Run and check basic authentication, returning the appropriate http error per
60-- the spec.
61runBasicAuth :: Request -> BS.ByteString -> BasicAuthCheck usr -> DelayedIO usr
62runBasicAuth req realm (BasicAuthCheck ba) =
63 case decodeBAHdr req of
64 Nothing -> plzAuthenticate
65 Just e -> liftIO (ba e) >>= \res -> case res of
66 BadPassword -> plzAuthenticate
67 NoSuchUser -> plzAuthenticate
68 Unauthorized -> delayedFailFatal err403
69 Authorized usr -> return usr
70 where plzAuthenticate = delayedFailFatal err401 { errHeaders = [mkBAChallengerHdr realm] }