From 6dc577c821b20778a74ff9d8070c86c0e4c2332a Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 18:49:01 +0100 Subject: [PATCH 01/10] Add basic-auth data types to servant core --- servant/src/Servant/API.hs | 4 ++++ servant/src/Servant/API/BasicAuth.hs | 29 ++++++++++++++++++++++++++++ 2 files changed, 33 insertions(+) create mode 100644 servant/src/Servant/API/BasicAuth.hs diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index fcaf5e91..5dda312c 100644 --- a/servant/src/Servant/API.hs +++ b/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, diff --git a/servant/src/Servant/API/BasicAuth.hs b/servant/src/Servant/API/BasicAuth.hs new file mode 100644 index 00000000..0a78bded --- /dev/null +++ b/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 . +-- +-- *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) + deriving (Typeable) + +-- | A simple datatype to hold data required to decorate a request +data BasicAuthData = BasicAuthData { basicAuthUsername :: !ByteString + , basicAuthPassword :: !ByteString + } From 84172c613554af58db1f9736c3e148d4d90d6179 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 19:00:31 +0100 Subject: [PATCH 02/10] Augment Delayed to handle authentication. --- .../Server/Internal/RoutingApplication.hs | 92 +++++++++++++++---- 1 file changed, 72 insertions(+), 20 deletions(-) diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 3be47123..7e846504 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs @@ -52,6 +52,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 +120,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 - Delayed :: IO (RouteResult a) - -> IO (RouteResult ()) - -> IO (RouteResult b) - -> (a -> b -> RouteResult c) - -> Delayed c +data Delayed c where + Delayed :: { capturesD :: IO (RouteResult captures) + , methodD :: IO (RouteResult ()) + , authD :: IO (RouteResult auth) + , bodyD :: IO (RouteResult body) + , 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 = - 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, @@ -157,8 +193,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 @@ -190,13 +231,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. @@ -215,3 +260,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 , we cannot +do the more succint thing - just update the records we actually change. +-} From 9966e5b3044078f18aece298cb80cc93f4cde4c1 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 19:23:05 +0100 Subject: [PATCH 03/10] Add userdata to BasicAuth API type --- servant/src/Servant/API/BasicAuth.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/servant/src/Servant/API/BasicAuth.hs b/servant/src/Servant/API/BasicAuth.hs index 0a78bded..cc38ddb3 100644 --- a/servant/src/Servant/API/BasicAuth.hs +++ b/servant/src/Servant/API/BasicAuth.hs @@ -20,7 +20,7 @@ import GHC.TypeLits (Symbol) -- 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) +data BasicAuth (realm :: Symbol) (userData :: *) deriving (Typeable) -- | A simple datatype to hold data required to decorate a request From 104ac29bf8da2891cd4e4b875d279efeaa6807db Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 19:56:15 +0100 Subject: [PATCH 04/10] Add BasicAuth support to servant-server --- servant-server/servant-server.cabal | 3 + servant-server/src/Servant/Server.hs | 7 +- servant-server/src/Servant/Server/Internal.hs | 25 +++++- .../src/Servant/Server/Internal/BasicAuth.hs | 69 ++++++++++++++++ .../Server/Internal/RoutingApplication.hs | 1 + .../test/Servant/Server/ErrorSpec.hs | 78 +++++++++++++------ servant-server/test/Servant/ServerSpec.hs | 77 +++++++++++++----- servant/servant.cabal | 1 + 8 files changed, 214 insertions(+), 47 deletions(-) create mode 100644 servant-server/src/Servant/Server/Internal/BasicAuth.hs diff --git a/servant-server/servant-server.cabal b/servant-server/servant-server.cabal index 9a23a4d7..2aa25cee 100644 --- a/servant-server/servant-server.cabal +++ b/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 diff --git a/servant-server/src/Servant/Server.hs b/servant-server/src/Servant/Server.hs index 70fae733..6b37297e 100644 --- a/servant-server/src/Servant/Server.hs +++ b/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 ()) diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index 05450649..bdf7451f 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/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 config + , HasConfigEntry config (BasicAuthCheck usr) + ) + => HasServer (BasicAuth realm usr :> api) config where + + type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m + + route Proxy config subserver = WithRequest $ \ request -> + route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request) + where + realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) + basicAuthConfig = getConfigEntry config + authCheck req = runBasicAuth req realm basicAuthConfig + +-- * helpers + pathIsEmpty :: Request -> Bool pathIsEmpty = go . pathInfo where go [] = True diff --git a/servant-server/src/Servant/Server/Internal/BasicAuth.hs b/servant-server/src/Servant/Server/Internal/BasicAuth.hs new file mode 100644 index 00000000..f941f401 --- /dev/null +++ b/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] } diff --git a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs b/servant-server/src/Servant/Server/Internal/RoutingApplication.hs index 7e846504..cd1ac019 100644 --- a/servant-server/src/Servant/Server/Internal/RoutingApplication.hs +++ b/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 diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 3575e2ac..5ae22361 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/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" - $ with (return $ serve errorOrderApi errorOrderServer) $ do +errorOrderSpec = + describe "HTTP error order" $ + with (return $ serve errorOrderApi + (errorOrderAuthCheck :. EmptyConfig) + 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 - request goodMethod goodUrl [badContentType, badAccept] badBody + it "has 401 as its third highest priority error (auth)" $ do + 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 - request goodMethod goodUrl [goodContentType, badAccept] badBody + it "has 400 as its fifth highest priority error" $ do + request goodMethod goodUrl [goodAuth, goodContentType, badAccept] badBody `shouldRespondWith` 400 - it "has 406 as its fifth highest priority error" $ do - request goodMethod goodUrl [goodContentType, badAccept] goodBody + it "has 406 as its sixth highest priority error" $ do + 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 - :<|> ReqBody '[JSON] Int :> Get '[JSON] Int -- 6 - :<|> ReqBody '[JSON] Int :> Post '[JSON] Int -- 7 + :<|> "a" :> BasicAuth "bar-realm" () + :> ReqBody '[JSON] Int :> Get '[PlainText] Int -- 5 + :<|> "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" - $ with (return $ serve errorRetryApi errorRetryServer) $ do +errorRetrySpec = + describe "Handler search" $ + with (return $ serve errorRetryApi + (errorOrderAuthCheck :. EmptyConfig) + 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 {{{ diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 6bf9defc..71f1bd9f 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/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, - Get, Header (..), +import Servant.API ((:<|>) (..), (:>), BasicAuth, BasicAuthData(BasicAuthData), + Capture, Delete, Get, Header (..), Headers, HttpVersion, IsSecure (..), JSON, NoContent (..), Patch, PlainText, @@ -49,13 +49,16 @@ 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, - shouldRespondWith, with, (<:>)) + matchStatus, shouldRespondWith, + with, (<:>)) +import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck), + BasicAuthResult(Authorized,Unauthorized)) import Servant.Server.Internal.RoutingApplication (toApplication, RouteResult(..)) import Servant.Server.Internal.Router @@ -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 -- }}} @@ -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 {{{ diff --git a/servant/servant.cabal b/servant/servant.cabal index 1b5e3c27..56e4580e 100644 --- a/servant/servant.cabal +++ b/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 From d989d15e4c6daa8aeeb97158f7183ca53c8a9f82 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 20:12:47 +0100 Subject: [PATCH 05/10] Add basic-auth support to servant-client --- servant-client/servant-client.cabal | 2 + servant-client/src/Servant/Client.hs | 10 +++++ .../src/Servant/Common/BasicAuth.hs | 21 ++++++++++ servant-client/test/Servant/ClientSpec.hs | 40 +++++++++++++++++++ 4 files changed, 73 insertions(+) create mode 100644 servant-client/src/Servant/Common/BasicAuth.hs diff --git a/servant-client/servant-client.cabal b/servant-client/servant-client.cabal index 71cb2ee6..8e20f1a3 100644 --- a/servant-client/servant-client.cabal +++ b/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 diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index ed27b3c7..d3373708 100644 --- a/servant-client/src/Servant/Client.hs +++ b/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 diff --git a/servant-client/src/Servant/Common/BasicAuth.hs b/servant-client/src/Servant/Common/BasicAuth.hs new file mode 100644 index 00000000..e2802699 --- /dev/null +++ b/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 diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 2bca7c13..291b9786 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/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 + +serverConfig :: Config '[ BasicAuthCheck () ] +serverConfig = basicAuthHandler :. EmptyConfig + +basicAuthServer :: Application +basicAuthServer = serve basicAuthAPI serverConfig (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 From f13c61956ce67314298789779f4de023068a02c5 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 20:15:51 +0100 Subject: [PATCH 06/10] Add authentication support to servant-docs --- servant-docs/src/Servant/Docs/Internal.hs | 45 ++++++++++++++++++++--- 1 file changed, 40 insertions(+), 5 deletions(-) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 666cad4c..2d0cf673 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/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 (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp +Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ = + 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 From e13965ae34c09abeedf933df47ef0041f58765c9 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 20:23:32 +0100 Subject: [PATCH 07/10] Add a basic authentication example --- servant-examples/basic-auth/basic-auth.hs | 105 ++++++++++++++++++++++ servant-examples/servant-examples.cabal | 16 ++++ 2 files changed, 121 insertions(+) create mode 100644 servant-examples/basic-auth/basic-auth.hs diff --git a/servant-examples/basic-auth/basic-auth.hs b/servant-examples/basic-auth/basic-auth.hs new file mode 100644 index 00000000..1d538169 --- /dev/null +++ b/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 + ), + Config ((:.), EmptyConfig), Server, + serve) + +-- | 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 configuration. In this case, +-- Basic Authentication requires a Config Entry with the 'BasicAuthCheck' value +-- tagged with "foo-tag" This config is then supplied to 'server' and threaded +-- to the BasicAuth HasServer handlers. +serverConfig :: Config (BasicAuthCheck User ': '[]) +serverConfig = authCheck :. EmptyConfig + +-- | 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 (serve api serverConfig 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"} +-} diff --git a/servant-examples/servant-examples.cabal b/servant-examples/servant-examples.cabal index d62c01c7..a36a5eba 100644 --- a/servant-examples/servant-examples.cabal +++ b/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 From 60a536382fd286627229284c62528e0d0948f457 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Wed, 17 Feb 2016 20:25:34 +0100 Subject: [PATCH 08/10] Update CHANGELOG for basic authentication support --- servant-client/CHANGELOG.md | 1 + servant-docs/CHANGELOG.md | 1 + servant-server/CHANGELOG.md | 1 + servant/CHANGELOG.md | 1 + 4 files changed, 4 insertions(+) diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index d6ffc14b..055cfa17 100644 --- a/servant-client/CHANGELOG.md +++ b/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 ----- diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index a5be837a..7f6ed577 100644 --- a/servant-docs/CHANGELOG.md +++ b/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 --- diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index bfdbe421..c5916153 100644 --- a/servant-server/CHANGELOG.md +++ b/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 ----- diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index ef344650..cf447968 100644 --- a/servant/CHANGELOG.md +++ b/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 ----- From 1e703be15fad97b18ec387c32033a19723121d7f Mon Sep 17 00:00:00 2001 From: aaron levin Date: Sun, 6 Mar 2016 21:16:28 +0100 Subject: [PATCH 09/10] replace serve with serveWithConfig --- servant-client/test/Servant/ClientSpec.hs | 2 +- servant-examples/basic-auth/basic-auth.hs | 4 ++-- servant-server/test/Servant/Server/ErrorSpec.hs | 4 ++-- servant-server/test/Servant/ServerSpec.hs | 4 ++-- 4 files changed, 7 insertions(+), 7 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 291b9786..b6237b0e 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -170,7 +170,7 @@ serverConfig :: Config '[ BasicAuthCheck () ] serverConfig = basicAuthHandler :. EmptyConfig basicAuthServer :: Application -basicAuthServer = serve basicAuthAPI serverConfig (const (return alice)) +basicAuthServer = serveWithConfig basicAuthAPI serverConfig (const (return alice)) {-# NOINLINE manager #-} manager :: C.Manager diff --git a/servant-examples/basic-auth/basic-auth.hs b/servant-examples/basic-auth/basic-auth.hs index 1d538169..208edbb1 100644 --- a/servant-examples/basic-auth/basic-auth.hs +++ b/servant-examples/basic-auth/basic-auth.hs @@ -19,7 +19,7 @@ import Servant.Server (BasicAuthCheck (BasicAuthCheck), , Unauthorized ), Config ((:.), EmptyConfig), Server, - serve) + serveWithConfig) -- | let's define some types that our API returns. @@ -80,7 +80,7 @@ server = -- | hello, server! main :: IO () -main = run 8080 (serve api serverConfig server) +main = run 8080 (serveWithConfig api serverConfig server) {- Sample session diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 5ae22361..3dce641d 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -56,7 +56,7 @@ errorOrderServer = \_ _ _ -> throwE err402 errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" $ - with (return $ serve errorOrderApi + with (return $ serveWithConfig errorOrderApi (errorOrderAuthCheck :. EmptyConfig) errorOrderServer ) $ do @@ -183,7 +183,7 @@ errorRetryServer errorRetrySpec :: Spec errorRetrySpec = describe "Handler search" $ - with (return $ serve errorRetryApi + with (return $ serveWithConfig errorRetryApi (errorOrderAuthCheck :. EmptyConfig) errorRetryServer ) $ do diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 71f1bd9f..763a16e2 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -347,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 From 546adc391a2699063d76f2e5f5b18498f1415e85 Mon Sep 17 00:00:00 2001 From: aaron levin Date: Tue, 8 Mar 2016 23:28:27 +0100 Subject: [PATCH 10/10] basic-auth: config -> context --- servant-client/test/Servant/ClientSpec.hs | 6 +++--- servant-examples/basic-auth/basic-auth.hs | 16 ++++++++-------- servant-server/src/Servant/Server/Internal.hs | 14 +++++++------- servant-server/test/Servant/Server/ErrorSpec.hs | 8 ++++---- servant-server/test/Servant/ServerSpec.hs | 2 +- 5 files changed, 23 insertions(+), 23 deletions(-) diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index b6237b0e..4b6ccbb9 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -166,11 +166,11 @@ basicAuthHandler = else return Unauthorized in BasicAuthCheck check -serverConfig :: Config '[ BasicAuthCheck () ] -serverConfig = basicAuthHandler :. EmptyConfig +serverContext :: Context '[ BasicAuthCheck () ] +serverContext = basicAuthHandler :. EmptyContext basicAuthServer :: Application -basicAuthServer = serveWithConfig basicAuthAPI serverConfig (const (return alice)) +basicAuthServer = serveWithContext basicAuthAPI serverContext (const (return alice)) {-# NOINLINE manager #-} manager :: C.Manager diff --git a/servant-examples/basic-auth/basic-auth.hs b/servant-examples/basic-auth/basic-auth.hs index 208edbb1..cedd4694 100644 --- a/servant-examples/basic-auth/basic-auth.hs +++ b/servant-examples/basic-auth/basic-auth.hs @@ -18,8 +18,8 @@ import Servant.Server (BasicAuthCheck (BasicAuthCheck), BasicAuthResult( Authorized , Unauthorized ), - Config ((:.), EmptyConfig), Server, - serveWithConfig) + Context ((:.), EmptyContext), Server, + serveWithContext) -- | let's define some types that our API returns. @@ -62,12 +62,12 @@ authCheck = else return Unauthorized in BasicAuthCheck check --- | We need to supply our handlers with the right configuration. In this case, --- Basic Authentication requires a Config Entry with the 'BasicAuthCheck' value --- tagged with "foo-tag" This config is then supplied to 'server' and threaded +-- | 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. -serverConfig :: Config (BasicAuthCheck User ': '[]) -serverConfig = authCheck :. EmptyConfig +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 @@ -80,7 +80,7 @@ server = -- | hello, server! main :: IO () -main = run 8080 (serveWithConfig api serverConfig server) +main = run 8080 (serveWithContext api serverContext server) {- Sample session diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index bdf7451f..ea89b0a0 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -457,19 +457,19 @@ instance HasServer api context => HasServer (HttpVersion :> api) context where -- | Basic Authentication instance ( KnownSymbol realm - , HasServer api config - , HasConfigEntry config (BasicAuthCheck usr) + , HasServer api context + , HasContextEntry context (BasicAuthCheck usr) ) - => HasServer (BasicAuth realm usr :> api) config where + => HasServer (BasicAuth realm usr :> api) context where type ServerT (BasicAuth realm usr :> api) m = usr -> ServerT api m - route Proxy config subserver = WithRequest $ \ request -> - route (Proxy :: Proxy api) config (subserver `addAuthCheck` authCheck request) + route Proxy context subserver = WithRequest $ \ request -> + route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request) where realm = BC8.pack $ symbolVal (Proxy :: Proxy realm) - basicAuthConfig = getConfigEntry config - authCheck req = runBasicAuth req realm basicAuthConfig + basicAuthContext = getContextEntry context + authCheck req = runBasicAuth req realm basicAuthContext -- * helpers diff --git a/servant-server/test/Servant/Server/ErrorSpec.hs b/servant-server/test/Servant/Server/ErrorSpec.hs index 3dce641d..96d2df6f 100644 --- a/servant-server/test/Servant/Server/ErrorSpec.hs +++ b/servant-server/test/Servant/Server/ErrorSpec.hs @@ -56,8 +56,8 @@ errorOrderServer = \_ _ _ -> throwE err402 errorOrderSpec :: Spec errorOrderSpec = describe "HTTP error order" $ - with (return $ serveWithConfig errorOrderApi - (errorOrderAuthCheck :. EmptyConfig) + with (return $ serveWithContext errorOrderApi + (errorOrderAuthCheck :. EmptyContext) errorOrderServer ) $ do let badContentType = (hContentType, "text/plain") @@ -183,8 +183,8 @@ errorRetryServer errorRetrySpec :: Spec errorRetrySpec = describe "Handler search" $ - with (return $ serveWithConfig errorRetryApi - (errorOrderAuthCheck :. EmptyConfig) + with (return $ serveWithContext errorRetryApi + (errorOrderAuthCheck :. EmptyContext) errorRetryServer ) $ do diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 763a16e2..0524a11a 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -65,7 +65,7 @@ import Servant.Server.Internal.Router (tweakResponse, runRouter, Router, Router'(LeafRouter)) import Servant.Server.Internal.Context - (Context(..), NamedContext(..)) + (NamedContext(..)) -- * comprehensive api test