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