0461c46 · servant · git.iko.soy

git.iko.soy/servant

on master help sign in

Add gen. authentication support to servant-server

0461c46aaron levin11 years ago

servant-server/servant-server.cabal+1

compare with master

unifiedsplit

@@ -38,6 +38,7 @@ library

38 Servant.Server

39 Servant.Server.Internal

40 Servant.Server.Internal.Context

41+ Servant.Server.Internal.Auth

41 Servant.Server.Internal.BasicAuth

42 Servant.Server.Internal.BasicAuth

42 Servant.Server.Internal.Enter

43 Servant.Server.Internal.Enter

43 Servant.Server.Internal.Router

44 Servant.Server.Internal.Router

servant-server/src/Servant/Server.hs+5−1

@@ -45,11 +45,15 @@ module Servant.Server

45 , NamedContext(..)

46 , descendIntoNamedContext

48−

49 -- * Basic Authentication

48 -- * Basic Authentication

50 , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)

49 , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)

51 , BasicAuthResult(..)

50 , BasicAuthResult(..)

52+ -- * General Authentication

53+ , AuthHandler(unAuthHandler)

54+ , AuthServerData

55+ , mkAuthHandler

56+

53 -- * Default error type

57 -- * Default error type

54 , ServantErr(..)

58 , ServantErr(..)

55 -- ** 3XX

59 -- ** 3XX

servant-server/src/Servant/Server/Internal.hs+21−2

@@ -10,11 +10,13 @@

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE TypeFamilies #-}

12{-# LANGUAGE TypeOperators #-}

13+{-# LANGUAGE UndecidableInstances #-}

14#include "overlapping-compat.h"

15#include "overlapping-compat.h"

16module Servant.Server.Internal

17module Servant.Server.Internal

17 ( module Servant.Server.Internal

18 ( module Servant.Server.Internal

19+ , module Servant.Server.Internal.Auth

18 , module Servant.Server.Internal.Context

20 , module Servant.Server.Internal.Context

19 , module Servant.Server.Internal.BasicAuth

21 , module Servant.Server.Internal.BasicAuth

20 , module Servant.Server.Internal.Router

22 , module Servant.Server.Internal.Router

@@ -25,7 +27,7 @@ module Servant.Server.Internal

25#if !MIN_VERSION_base(4,8,0)

27#if !MIN_VERSION_base(4,8,0)

26import Control.Applicative ((<$>))

28import Control.Applicative ((<$>))

27#endif

29#endif

28−import Control.Monad.Trans.Except (ExceptT)

30+import Control.Monad.Trans.Except (ExceptT, runExceptT)

29import qualified Data.ByteString as B

31import qualified Data.ByteString as B

30import qualified Data.ByteString.Char8 as BC8

32import qualified Data.ByteString.Char8 as BC8

31import qualified Data.ByteString.Lazy as BL

33import qualified Data.ByteString.Lazy as BL

@@ -50,7 +52,7 @@ import Web.HttpApiData.Internal (parseHeaderMaybe,

50 parseQueryParamMaybe,

52 parseQueryParamMaybe,

51 parseUrlPieceMaybe)

53 parseUrlPieceMaybe)

53−import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,

55+import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, Capture,

54 Verb, ReflectMethod(reflectMethod),

56 Verb, ReflectMethod(reflectMethod),

55 IsSecure(..), Header,

57 IsSecure(..), Header,

56 QueryFlag, QueryParam, QueryParams,

58 QueryFlag, QueryParam, QueryParams,

@@ -64,6 +66,7 @@ import Servant.API.ContentTypes (AcceptHeader (..),

64import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,

66import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,

65 getResponse)

67 getResponse)

69+import Servant.Server.Internal.Auth

67import Servant.Server.Internal.Context

70import Servant.Server.Internal.Context

68import Servant.Server.Internal.BasicAuth

71import Servant.Server.Internal.BasicAuth

69import Servant.Server.Internal.Router

72import Servant.Server.Internal.Router

@@ -482,6 +485,22 @@ pathIsEmpty = go . pathInfo

482ct_wildcard :: B.ByteString

485ct_wildcard :: B.ByteString

483ct_wildcard = "*" <> "/" <> "*" -- Because CPP

486ct_wildcard = "*" <> "/" <> "*" -- Because CPP

484

487

488+-- * General Authentication

489+

490+instance ( HasServer api context

491+ , HasContextEntry context (AuthHandler Request (AuthServerData (AuthProtect tag)))

492+ )

493+ => HasServer (AuthProtect tag :> api) context where

494+

495+ type ServerT (AuthProtect tag :> api) m =

496+ AuthServerData (AuthProtect tag) -> ServerT api m

497+

498+ route Proxy context subserver = WithRequest $ \ request ->

499+ route (Proxy :: Proxy api) context (subserver `addAuthCheck` authCheck request)

500+ where

501+ authHandler = unAuthHandler (getContextEntry context)

502+ authCheck = fmap (either FailFatal Route) . runExceptT . authHandler

503+

485-- * contexts

504-- * contexts

486

505

487instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)

506instance (HasContextEntry context (NamedContext name subContext), HasServer subApi subContext)

servant-server/src/Servant/Server/Internal/Auth.hsnew file+27

@@ -0,0 +1,27 @@

1+{-# LANGUAGE DeriveDataTypeable #-}

2+{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE DeriveGeneric #-}

4+{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE TypeFamilies #-}

7+module Servant.Server.Internal.Auth where

9+import Control.Monad.Trans.Except (ExceptT)

10+import Data.Typeable (Typeable)

11+import GHC.Generics (Generic)

12+

13+import Servant.Server.Internal.ServantErr (ServantErr)

14+

15+-- * General Auth

16+

17+-- | Specify the type of data returned after we've authenticated a request.

18+-- quite often this is some `User` datatype.

19+type family AuthServerData a :: *

20+

21+-- | Handlers for AuthProtected resources

22+newtype AuthHandler r usr = AuthHandler

23+ { unAuthHandler :: r -> ExceptT ServantErr IO usr }

24+ deriving (Generic, Typeable)

25+

26+mkAuthHandler :: (r -> ExceptT ServantErr IO usr) -> AuthHandler r usr

27+mkAuthHandler = AuthHandler

servant-server/test/Servant/ServerSpec.hs+41−3

@@ -31,14 +31,15 @@ import Network.HTTP.Types (Status (..), hAccept, hContentType,

31 methodHead, methodPatch,

32 methodPost, methodPut, ok200,

33 parseQuery)

34−import Network.Wai (Application, Request, pathInfo,

34+import Network.Wai (Application, Request, requestHeaders, pathInfo,

35 queryString, rawQueryString,

36 responseBuilder, responseLBS)

37import Network.Wai.Internal (Response (ResponseBuilder))

38import Network.Wai.Test (defaultRequest, request,

39 runSession, simpleBody,

40 simpleHeaders, simpleStatus)

41+import Servant.API ((:<|>) (..), (:>), AuthProtect,

41−import Servant.API ((:<|>) (..), (:>), BasicAuth, BasicAuthData(BasicAuthData),

42+ BasicAuth, BasicAuthData(BasicAuthData),

42 Capture, Delete, Get, Header (..),

43 Capture, Delete, Get, Header (..),

43 Headers, HttpVersion,

44 Headers, HttpVersion,

44 IsSecure (..), JSON,

45 IsSecure (..), JSON,

@@ -59,6 +60,9 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders,

60import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),

61import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),

61 BasicAuthResult(Authorized,Unauthorized))

62 BasicAuthResult(Authorized,Unauthorized))

63+import Servant.Server.Internal.Auth

64+ (AuthHandler, AuthServerData,

65+ mkAuthHandler)

62import Servant.Server.Internal.RoutingApplication

66import Servant.Server.Internal.RoutingApplication

63 (toApplication, RouteResult(..))

67 (toApplication, RouteResult(..))

64import Servant.Server.Internal.Router

68import Servant.Server.Internal.Router

@@ -90,6 +94,7 @@ spec = do

90 routerSpec

94 routerSpec

91 miscCombinatorSpec

95 miscCombinatorSpec

92 basicAuthSpec

96 basicAuthSpec

97+ genAuthSpec

94------------------------------------------------------------------------------

99------------------------------------------------------------------------------

95-- * verbSpec {{{

100-- * verbSpec {{{

@@ -534,7 +539,7 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $

534

539

535-- }}}

540-- }}}

536------------------------------------------------------------------------------

541------------------------------------------------------------------------------

537−-- * Authentication {{{

542+-- * Basic Authentication {{{

538------------------------------------------------------------------------------

543------------------------------------------------------------------------------

539

544

540type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal

545type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal

@@ -564,6 +569,39 @@ basicAuthSpec = do

564 it "returns 200 with the right password" $ do

569 it "returns 200 with the right password" $ do

565 THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200

570 THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200

566

571

572+-- }}}

573+------------------------------------------------------------------------------

574+-- * General Authentication {{{

575+------------------------------------------------------------------------------

576+

577+type GenAuthAPI = AuthProtect "auth" :> "auth" :> Get '[JSON] Animal

578+authApi :: Proxy GenAuthAPI

579+authApi = Proxy

580+authServer :: Server GenAuthAPI

581+authServer = const (return tweety)

582+

583+type instance AuthServerData (AuthProtect "auth") = ()

584+

585+genAuthContext :: Context '[ AuthHandler Request () ]

586+genAuthContext =

587+ let authHandler = (\req ->

588+ if elem ("Auth", "secret") (requestHeaders req)

589+ then return ()

590+ else throwE err401

591+ )

592+ in mkAuthHandler authHandler :. EmptyContext

593+

594+genAuthSpec :: Spec

595+genAuthSpec = do

596+ describe "Servant.API.Auth" $ do

597+ with (return (serveWithContext authApi genAuthContext authServer)) $ do

598+

599+ context "Custom Auth Protection" $ do

600+ it "returns 401 when missing headers" $ do

601+ get "/auth" `shouldRespondWith` 401

602+ it "returns 200 with the right header" $ do

603+ THW.request methodGet "/auth" [("Auth","secret")] "" `shouldRespondWith` 200

604+

567-- }}}

605-- }}}

568------------------------------------------------------------------------------

606------------------------------------------------------------------------------

569-- * Test data types {{{

607-- * Test data types {{{