From f6bdfa3c058264435b69c3691efa34b6e7ef2a19 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Thu, 7 Jan 2016 22:51:16 +0100 Subject: [PATCH] Implement Basic Auth with Config Tooling Extend the Config tooling to allow an implementation with Basic Authentication. --- servant-server/servant-server.cabal | 3 + servant-server/src/Servant/Server.hs | 2 +- servant-server/src/Servant/Server/Internal.hs | 18 +++- .../src/Servant/Server/Internal/Auth.hs | 61 ++++++++++++ .../Server/Internal/RoutingApplication.hs | 95 +++++++++++++++---- servant/servant.cabal | 1 + servant/src/Servant/API.hs | 4 + servant/src/Servant/API/Auth.hs | 20 ++++ 8 files changed, 182 insertions(+), 22 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/Auth.hs create mode 100644 servant/src/Servant/API/Auth.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index d0d0e2a3..ad7c6bde 100644 --- a/servant-server/servant-server.cabal +++ b/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 , 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 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index b5ba471a..6788da4a 100644 --- a/servant-server/src/Servant/Server.hs +++ b/servant-server/src/Servant/Server.hs @@ -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 ()) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 86c56b32..9dacd693 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -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 diff --git a/servant-server/src/Servant/Server/Internal/Auth.hs b/servant-server/src/Servant/Server/Internal/Auth.hs new file mode 100644 index 00000000..cc8e379f --- /dev/null +++ b/servant-server/src/Servant/Server/Internal/Auth.hs @@ -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] } diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 4b27c688..3a433c22 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/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 - 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 , we cannot +do the more succint thing - just update the records we actually change. +-} diff --git a/servant/servant.cabal b/servant/servant.cabal index 451eb166..c71dc913 100644 --- a/servant/servant.cabal +++ b/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 diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 2565149f..4f8d6bce 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -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, diff --git a/servant/src/Servant/API/Auth.hs b/servant/src/Servant/API/Auth.hs new file mode 100644 index 00000000..61d52b05 --- /dev/null +++ b/servant/src/Servant/API/Auth.hs @@ -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 . +-- +-- *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)