Skip to content
This repository was archived by the owner on Oct 29, 2021. It is now read-only.

First stab at removing Cookie and JWT constraints from HasServer (Auth ...) #120

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion servant-auth-server/servant-auth-server.cabal
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
name: servant-auth-server
version: 0.4.0.0
version: 0.4.0.1
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Could you please leave this change out? we're now trying to be consistent over all the servant packages about not updating versions or changelogs in PRs, this is all taken care of at release time.

synopsis: servant-server/servant-auth compatibility
description: This package provides the required instances for using the @Auth@ combinator
in your 'servant' server.
Expand Down
1 change: 1 addition & 0 deletions servant-auth-server/src/Servant/Auth/Server.hs
Original file line number Diff line number Diff line change
Expand Up @@ -40,6 +40,7 @@ module Servant.Auth.Server
Auth
, AuthResult(..)
, AuthCheck(..)
, IsAuth

----------------------------------------------------------------------------
-- * JWT
Expand Down
46 changes: 9 additions & 37 deletions servant-auth-server/src/Servant/Auth/Server/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -6,26 +6,17 @@ module Servant.Auth.Server.Internal where

import Control.Monad.Trans (liftIO)
import Servant ((:>), Handler, HasServer (..),
Proxy (..),
HasContextEntry(getContextEntry))
Proxy (..))
import Servant.Auth

import Servant.Auth.Server.Internal.AddSetCookie
import Servant.Auth.Server.Internal.Class
import Servant.Auth.Server.Internal.Cookie
import Servant.Auth.Server.Internal.ConfigTypes
import Servant.Auth.Server.Internal.JWT
import Servant.Auth.Server.Internal.Types

import Servant.Server.Internal.RoutingApplication

instance ( n ~ 'S ('S 'Z)
, HasServer (AddSetCookiesApi n api) ctxs, AreAuths auths ctxs v

instance ( AreAuths auths ctxs v
, HasServer api ctxs -- this constraint is needed to implement hoistServer
, AddSetCookies n (ServerT api Handler) (ServerT (AddSetCookiesApi n api) Handler)
, ToJWT v
, HasContextEntry ctxs CookieSettings
, HasContextEntry ctxs JWTSettings
) => HasServer (Auth auths v :> api) ctxs where
type ServerT (Auth auths v :> api) m = AuthResult v -> ServerT api m

Expand All @@ -34,38 +25,19 @@ instance ( n ~ 'S ('S 'Z)
#endif

route _ context subserver =
route (Proxy :: Proxy (AddSetCookiesApi n api))
route (Proxy :: Proxy api)
context
(fmap go subserver `addAuthCheck` authCheck)

where
authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z)))
authCheck :: DelayedIO (AuthResult v)
authCheck = withRequest $ \req -> liftIO $ do
authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req
cookies <- makeCookies authResult
return (authResult, cookies)

jwtSettings :: JWTSettings
jwtSettings = getContextEntry context

cookieSettings :: CookieSettings
cookieSettings = getContextEntry context

makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))
makeCookies authResult = do
xsrf <- makeXsrfCookie cookieSettings
fmap (Just xsrf `SetCookieCons`) $
case authResult of
(Authenticated v) -> do
ejwt <- makeSessionCookie cookieSettings jwtSettings v
case ejwt of
Nothing -> return $ Nothing `SetCookieCons` SetCookieNil
Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil
_ -> return $ Nothing `SetCookieCons` SetCookieNil
return (authResult)

go :: ( old ~ ServerT api Handler
, new ~ ServerT (AddSetCookiesApi n api) Handler
, new ~ ServerT api Handler
)
=> (AuthResult v -> ServerT api Handler)
-> (AuthResult v, SetCookieList n) -> new
go fn (authResult, cookies) = addSetCookies cookies $ fn authResult
-> (AuthResult v) -> new
go fn (authResult) = fn authResult
2 changes: 1 addition & 1 deletion servant-auth/servant-auth.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -34,7 +34,7 @@ library
ghc-options: -Wall
build-depends:
base >= 4.8 && < 4.12
, servant >= 0.9.1 && < 0.15
, servant >= 0.14.1 && < 0.15
exposed-modules:
Servant.Auth
default-language: Haskell2010
2 changes: 1 addition & 1 deletion stack.yaml
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
resolver: lts-11.14
resolver: lts-12.9
apply-ghc-options: targets
packages:
- servant-auth
Expand Down