git.iko.soy/typeable/servant
on master help sign in
Add gen. authentication support to servant-server
commit0461c4642d669b6f0478767cfd9512cdde21e710 authoraaron levin <aaron.levin@soundcloud.com> dateWed 17 Feb 2016, 21:21 (11 years ago) parent038abb4
5 files changed+95−6
compare with master
unifiedsplit
servant-server/servant-server.cabal+1 servant-server/src/Servant/Server.hs+5−1 servant-server/src/Servant/Server/Internal.hs+21−2 servant-server/src/Servant/Server/Internal/Auth.hs+27 servant-server/test/Servant/ServerSpec.hs+41−3
servant-server/servant-server.cabal+1
@@ -38,6 +38,7 @@ library
3838 Servant.Server
3939 Servant.Server.Internal
4040 Servant.Server.Internal.Context
41+ Servant.Server.Internal.Auth
4142 Servant.Server.Internal.BasicAuth
4243 Servant.Server.Internal.Enter
4344 Servant.Server.Internal.Router
servant-server/src/Servant/Server.hs+5−1
@@ -45,11 +45,15 @@ module Servant.Server
4545 , NamedContext(..)
4646 , descendIntoNamedContext
4747
48−
4948 -- * Basic Authentication
5049 , BasicAuthCheck(BasicAuthCheck, unBasicAuthCheck)
5150 , BasicAuthResult(..)
5251
52+ -- * General Authentication
53+ , AuthHandler(unAuthHandler)
54+ , AuthServerData
55+ , mkAuthHandler
56+
5357 -- * Default error type
5458 , ServantErr(..)
5559 -- ** 3XX
servant-server/src/Servant/Server/Internal.hs+21−2
@@ -10,11 +10,13 @@
1010{-# LANGUAGE ScopedTypeVariables #-}
1111{-# LANGUAGE TypeFamilies #-}
1212{-# LANGUAGE TypeOperators #-}
13+{-# LANGUAGE UndecidableInstances #-}
1314
1415#include "overlapping-compat.h"
1516
1617module Servant.Server.Internal
1718 ( module Servant.Server.Internal
19+ , module Servant.Server.Internal.Auth
1820 , module Servant.Server.Internal.Context
1921 , module Servant.Server.Internal.BasicAuth
2022 , module Servant.Server.Internal.Router
@@ -25,7 +27,7 @@ module Servant.Server.Internal
2527#if !MIN_VERSION_base(4,8,0)
2628import Control.Applicative ((<$>))
2729#endif
28−import Control.Monad.Trans.Except (ExceptT)
30+import Control.Monad.Trans.Except (ExceptT, runExceptT)
2931import qualified Data.ByteString as B
3032import qualified Data.ByteString.Char8 as BC8
3133import qualified Data.ByteString.Lazy as BL
@@ -50,7 +52,7 @@ import Web.HttpApiData.Internal (parseHeaderMaybe,
5052 parseQueryParamMaybe,
5153 parseUrlPieceMaybe)
5254
53−import Servant.API ((:<|>) (..), (:>), BasicAuth, Capture,
55+import Servant.API ((:<|>) (..), (:>), AuthProtect, BasicAuth, Capture,
5456 Verb, ReflectMethod(reflectMethod),
5557 IsSecure(..), Header,
5658 QueryFlag, QueryParam, QueryParams,
@@ -64,6 +66,7 @@ import Servant.API.ContentTypes (AcceptHeader (..),
6466import Servant.API.ResponseHeaders (GetHeaders, Headers, getHeaders,
6567 getResponse)
6668
69+import Servant.Server.Internal.Auth
6770import Servant.Server.Internal.Context
6871import Servant.Server.Internal.BasicAuth
6972import Servant.Server.Internal.Router
@@ -482,6 +485,22 @@ pathIsEmpty = go . pathInfo
482485ct_wildcard :: B.ByteString
483486ct_wildcard = "*" <> "/" <> "*" -- Because CPP
484487
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+
485504-- * contexts
486505
487506instance (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 #-}
6+
7+module Servant.Server.Internal.Auth where
8+
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,
3131 methodHead, methodPatch,
3232 methodPost, methodPut, ok200,
3333 parseQuery)
34−import Network.Wai (Application, Request, pathInfo,
34+import Network.Wai (Application, Request, requestHeaders, pathInfo,
3535 queryString, rawQueryString,
3636 responseBuilder, responseLBS)
3737import Network.Wai.Internal (Response (ResponseBuilder))
3838import Network.Wai.Test (defaultRequest, request,
3939 runSession, simpleBody,
4040 simpleHeaders, simpleStatus)
41−import Servant.API ((:<|>) (..), (:>), BasicAuth, BasicAuthData(BasicAuthData),
41+import Servant.API ((:<|>) (..), (:>), AuthProtect,
42+ BasicAuth, BasicAuthData(BasicAuthData),
4243 Capture, Delete, Get, Header (..),
4344 Headers, HttpVersion,
4445 IsSecure (..), JSON,
@@ -59,6 +60,9 @@ import Test.Hspec.Wai (get, liftIO, matchHeaders,
5960
6061import Servant.Server.Internal.BasicAuth (BasicAuthCheck(BasicAuthCheck),
6162 BasicAuthResult(Authorized,Unauthorized))
63+import Servant.Server.Internal.Auth
64+ (AuthHandler, AuthServerData,
65+ mkAuthHandler)
6266import Servant.Server.Internal.RoutingApplication
6367 (toApplication, RouteResult(..))
6468import Servant.Server.Internal.Router
@@ -90,6 +94,7 @@ spec = do
9094 routerSpec
9195 miscCombinatorSpec
9296 basicAuthSpec
97+ genAuthSpec
9398
9499------------------------------------------------------------------------------
95100-- * verbSpec {{{
@@ -534,7 +539,7 @@ miscCombinatorSpec = with (return $ serve miscApi miscServ) $
534539
535540-- }}}
536541------------------------------------------------------------------------------
537−-- * Authentication {{{
542+-- * Basic Authentication {{{
538543------------------------------------------------------------------------------
539544
540545type BasicAuthAPI = BasicAuth "foo" () :> "basic" :> Get '[JSON] Animal
@@ -564,6 +569,39 @@ basicAuthSpec = do
564569 it "returns 200 with the right password" $ do
565570 THW.request methodGet "/basic" [("Authorization","Basic c2VydmFudDpzZXJ2ZXI=")] "" `shouldRespondWith` 200
566571
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+
567605-- }}}
568606------------------------------------------------------------------------------
569607-- * Test data types {{{