eeva/servant
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

Implement Basic Auth with Config Tooling

Browse source 
Extend the Config tooling to allow an implementation with Basic
Authentication.
This commit is contained in:
aaron levin 2016-01-07 22:51:16 +01:00
parent f8ea9ba8fe
commit f6bdfa3c05
8 changed files with 182 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
servant-server/servant-server.cabal
View file

@ -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
, deepseq == 1.4.*
@ -68,6 +70,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

2
servant-server/src/Servant/Server.hs
View file

@ -114,7 +114,7 @@ serve :: (HasCfg layout a, HasServer layout)
=> Proxy layout -> Config a -> Server layout -> Application
serve p cfg server = toApplication (runRouter (route p cfg d))
where
d = Delayed r r r (\ _ _ -> Route server)
d = Delayed r r r r (\ _ _ _ -> Route server)
r = return (Route ())

18
servant-server/src/Servant/Server/Internal.hs
View file

@ -24,6 +24,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)
@ -47,7 +48,7 @@ import Web.HttpApiData.Internal (parseHeaderMaybe,
parseQueryParamMaybe,
parseUrlPieceMaybe)
import Servant.API ((:<|>) (..), (:>), Capture,
import Servant.API ((:<|>) (..), (:>), Capture, BasicAuth,
Verb, ReflectMethod(reflectMethod),
IsSecure(..), Header,
QueryFlag, QueryParam, QueryParams,
@ -60,6 +61,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
@ -464,6 +466,20 @@ instance HasServer api => HasServer (HttpVersion :> api) where
route Proxy cfg subserver = WithRequest $ \req ->
route (Proxy :: Proxy api) cfg (passToServer subserver $ httpVersion req)
instance (KnownSymbol realm, HasServer api)
=> HasServer (BasicAuth tag realm usr :> api) where
type ServerT (BasicAuth tag realm usr :> api) m = usr -> ServerT api m
type HasCfg (BasicAuth tag realm usr :> api) c
= (HasConfigEntry c tag (BasicAuthCheck usr), HasCfg api c)
route Proxy cfg subserver = WithRequest $ \ request ->
route (Proxy :: Proxy api) cfg (subserver `addAuthCheck` authCheck request)
where
realm = BC8.pack $ symbolVal (Proxy :: Proxy realm)
baCfg = getConfigEntry (Proxy :: Proxy tag) cfg
authCheck req = runBasicAuth req realm baCfg
pathIsEmpty :: Request -> Bool
pathIsEmpty = go . pathInfo
where go [] = True

61
servant-server/src/Servant/Server/Internal/Auth.hs Normal file
View file

@ -0,0 +1,61 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
module Servant.Server.Internal.Auth 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.Server.Internal.RoutingApplication
import Servant.Server.Internal.ServantErr
-- * General Auth
-- | The result of authentication/authorization
data AuthResult 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 (AuthResult 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] }

95
servant-server/src/Servant/Server/Internal/RoutingApplication.hs
View file

@ -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
Delayed :: IO (RouteResult a)
-> IO (RouteResult ())
-> IO (RouteResult b)
-> (a -> b -> RouteResult c)
-> Delayed c
data Delayed c = forall captures auth body. Delayed
{ capturesD :: IO (RouteResult captures)
, methodD :: IO (RouteResult ())
, authD :: IO (RouteResult auth)
, bodyD :: IO (RouteResult body)
, 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 =
Delayed (combineRouteResults (,) captures new) method body (\ (x, v) y -> ($ v) <$> server x y)
addCapture Delayed{..} new
= 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 =
Delayed captures (combineRouteResults const method new) body server
addMethodCheck Delayed{..} new
= 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 =
Delayed captures method (combineRouteResults (,) body new) (\ x (y, v) -> ($ v) <$> server x y)
addBodyCheck Delayed{..} new
= 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 =
Delayed captures method (combineRouteResults const body new) server
addAcceptCheck Delayed{..} new
= 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) =
captures `bindRouteResults` \ c ->
method `bindRouteResults` \ _ ->
body `bindRouteResults` \ b ->
return (server c b)
runDelayed Delayed{..} =
capturesD `bindRouteResults` \ c ->
methodD `bindRouteResults` \ _ ->
authD `bindRouteResults` \ a ->
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.
-}

1
servant/servant.cabal
View file

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

4
servant/src/Servant/API.hs
View file

@ -35,6 +35,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
@ -49,6 +52,7 @@ module Servant.API (
) where
import Servant.API.Alternative ((:<|>) (..))
import Servant.API.Auth (BasicAuth)
import Servant.API.Capture (Capture)
import Servant.API.ContentTypes (Accept (..), FormUrlEncoded,
FromFormUrlEncoded (..), JSON,

20
servant/src/Servant/API/Auth.hs Normal file
View file

@ -0,0 +1,20 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE KindSignatures #-}
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 config (realm :: Symbol) usr
deriving (Typeable)