servant-auth-server 0.2.6.1 → 0.2.7.0
raw patch · 7 files changed
+95/−50 lines, 7 files
Files
- executables/README.lhs +13/−7
- package.yaml +1/−1
- servant-auth-server.cabal +1/−1
- src/Servant/Auth/Server.hs +4/−0
- src/Servant/Auth/Server/Internal.hs +16/−22
- src/Servant/Auth/Server/Internal/AddSetCookie.hs +2/−7
- src/Servant/Auth/Server/Internal/Cookie.hs +58/−12
executables/README.lhs view
@@ -74,7 +74,9 @@ type Unprotected = "login" :> ReqBody '[JSON] Login- :> PostNoContent '[JSON] (Headers '[Header "Set-Cookie" SetCookie] NoContent)+ :> PostNoContent '[JSON] (Headers '[ Header "Set-Cookie" SetCookie+ , Header "Set-Cookie" SetCookie]+ NoContent) :<|> Raw unprotected :: CookieSettings -> JWTSettings -> Server Unprotected@@ -203,17 +205,21 @@ -- Here is the login handler-checkCreds :: CookieSettings -> JWTSettings -> Login- -> Handler (Headers '[Header "Set-Cookie" SetCookie] NoContent)+checkCreds :: CookieSettings+ -> JWTSettings+ -> Login+ -> Handler (Headers '[ Header "Set-Cookie" SetCookie+ , Header "Set-Cookie" SetCookie]+ NoContent) checkCreds cookieSettings jwtSettings (Login "Ali Baba" "Open Sesame") = do -- Usually you would ask a database for the user info. This is just a -- regular servant handler, so you can follow your normal database access -- patterns (including using 'enter'). let usr = User "Ali Baba" "ali@email.com"- mcookie <- liftIO $ makeCookie cookieSettings jwtSettings usr- case mcookie of- Nothing -> throwError err401- Just cookie -> return $ addHeader cookie NoContent+ mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings usr+ case mApplyCookies of+ Nothing -> throwError err401+ Just applyCookies -> return $ applyCookies NoContent checkCreds _ _ _ = throwError err401 ~~~
package.yaml view
@@ -1,5 +1,5 @@ name: servant-auth-server-version: 0.2.6.1+version: 0.2.7.0 synopsis: servant-server/servant-auth compatibility description: | This package provides the required instances for using the @Auth@ combinator
servant-auth-server.cabal view
@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: servant-auth-server-version: 0.2.6.1+version: 0.2.7.0 synopsis: servant-server/servant-auth compatibility description: This package provides the required instances for using the @Auth@ combinator in your 'servant' server.
src/Servant/Auth/Server.hs view
@@ -68,8 +68,12 @@ -- ** Settings , CookieSettings(..) , defaultCookieSettings+ , makeSessionCookie+ , makeSessionCookieBS+ , makeCsrfCookie , makeCookie , makeCookieBS+ , acceptLogin -- ** Related types
src/Servant/Auth/Server/Internal.hs view
@@ -3,11 +3,11 @@ module Servant.Auth.Server.Internal where -import Control.Monad.Trans (liftIO)-import Servant ((:>), Handler, HasServer (..),- Proxy (..), HasContextEntry(getContextEntry))+import Control.Monad.Trans (liftIO)+import Servant ((:>), Handler, HasServer (..),+ Proxy (..),+ HasContextEntry(getContextEntry)) import Servant.Auth-import qualified Web.Cookie as Cookie import Servant.Auth.Server.Internal.AddSetCookie import Servant.Auth.Server.Internal.Class@@ -36,18 +36,8 @@ authCheck :: DelayedIO (AuthResult v, SetCookieList ('S ('S 'Z))) authCheck = withRequest $ \req -> liftIO $ do authResult <- runAuthCheck (runAuths (Proxy :: Proxy auths) context) req- csrf' <- csrfCookie- let csrf = Cookie.def- { Cookie.setCookieName = xsrfCookieName cookieSettings- , Cookie.setCookieValue = csrf'- , Cookie.setCookieMaxAge = cookieMaxAge cookieSettings- , Cookie.setCookieExpires = cookieExpires cookieSettings- , Cookie.setCookieSecure = case cookieIsSecure cookieSettings of- Secure -> True- NotSecure -> False- } cookies <- makeCookies authResult- return (authResult, Just csrf `SetCookieCons` cookies)+ return (authResult, cookies) jwtSettings :: JWTSettings jwtSettings = getContextEntry context@@ -55,13 +45,17 @@ cookieSettings :: CookieSettings cookieSettings = getContextEntry context - makeCookies :: AuthResult v -> IO (SetCookieList ('S 'Z))- makeCookies (Authenticated v) = do- ejwt <- makeCookie cookieSettings jwtSettings v- case ejwt of- Nothing -> return $ Nothing `SetCookieCons` SetCookieNil- Just jwt -> return $ Just jwt `SetCookieCons` SetCookieNil- makeCookies _ = return $ Nothing `SetCookieCons` SetCookieNil+ makeCookies :: AuthResult v -> IO (SetCookieList ('S ('S 'Z)))+ makeCookies authResult = do+ csrf <- makeCsrfCookie cookieSettings+ fmap (Just csrf `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 go :: ( old ~ ServerT api Handler , new ~ ServerT (AddSetCookiesApi n api) Handler
src/Servant/Auth/Server/Internal/AddSetCookie.hs view
@@ -2,17 +2,15 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-}+ module Servant.Auth.Server.Internal.AddSetCookie where import Blaze.ByteString.Builder (toByteString) import qualified Data.ByteString as BS-import qualified Data.ByteString.Base64 as BS64 import qualified Network.HTTP.Types as HTTP import Network.Wai (mapResponseHeaders) import Servant--import System.Entropy (getEntropy)-import Web.Cookie+import Web.Cookie -- What are we doing here? Well, the idea is to add headers to the response, -- but the headers come from the authentication check. In order to do that, we@@ -80,6 +78,3 @@ mkCookies (SetCookieCons Nothing rest) = mkCookies rest mkCookies (SetCookieCons (Just y) rest) = toByteString (renderSetCookie y) : mkCookies rest--csrfCookie :: IO BS.ByteString-csrfCookie = BS64.encode <$> getEntropy 32
src/Servant/Auth/Server/Internal/Cookie.hs view
@@ -7,9 +7,12 @@ import qualified Crypto.JWT as Jose import Crypto.Util (constTimeEq) import qualified Data.ByteString as BS+import qualified Data.ByteString.Base64 as BS64 import qualified Data.ByteString.Lazy as BSL import Data.CaseInsensitive (mk) import Network.Wai (requestHeaders)+import Servant (AddHeader, addHeader)+import System.Entropy (getEntropy) import Web.Cookie import Servant.Auth.Server.Internal.ConfigTypes@@ -41,21 +44,64 @@ Left _ -> mzero Right v' -> return v' -makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)-makeCookie cookieSettings jwtSettings v = do+-- | Makes a cookie to be used for CSRF.+makeCsrfCookie :: CookieSettings -> IO SetCookie+makeCsrfCookie cookieSettings = do+ csrfValue <- BS64.encode <$> getEntropy 32+ return $ def+ { setCookieName = xsrfCookieName cookieSettings+ , setCookieValue = csrfValue+ , setCookieMaxAge = cookieMaxAge cookieSettings+ , setCookieExpires = cookieExpires cookieSettings+ , setCookieSecure = case cookieIsSecure cookieSettings of+ Secure -> True+ NotSecure -> False+ }++-- | Makes a cookie with session information.+makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)+makeSessionCookie cookieSettings jwtSettings v = do ejwt <- makeJWT v jwtSettings Nothing case ejwt of Left _ -> return Nothing Right jwt -> return $ Just $ def- { setCookieName = sessionCookieName cookieSettings- , setCookieValue = BSL.toStrict jwt- , setCookieHttpOnly = True- , setCookieMaxAge = cookieMaxAge cookieSettings- , setCookieExpires = cookieExpires cookieSettings- , setCookieSecure = case cookieIsSecure cookieSettings of- Secure -> True- NotSecure -> False- }+ { setCookieName = sessionCookieName cookieSettings+ , setCookieValue = BSL.toStrict jwt+ , setCookieHttpOnly = True+ , setCookieMaxAge = cookieMaxAge cookieSettings+ , setCookieExpires = cookieExpires cookieSettings+ , setCookieSecure = case cookieIsSecure cookieSettings of+ Secure -> True+ NotSecure -> False+ } +-- | For a JWT-serializable session, returns a function that decorates a+-- provided response object with CSRF and session cookies. This should be used+-- when a user successfully authenticates with credentials.+acceptLogin :: ( ToJWT session+ , AddHeader "Set-Cookie" SetCookie response withOneCookie+ , AddHeader "Set-Cookie" SetCookie withOneCookie withTwoCookies )+ => CookieSettings+ -> JWTSettings+ -> session+ -> IO (Maybe (response -> withTwoCookies))+acceptLogin cookieSettings jwtSettings session = do+ mSessionCookie <- makeSessionCookie cookieSettings jwtSettings session+ case mSessionCookie of+ Nothing -> pure Nothing+ Just sessionCookie -> do+ csrfCookie <- makeCsrfCookie cookieSettings+ return $ Just $ addHeader sessionCookie . addHeader csrfCookie++makeSessionCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)+makeSessionCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeSessionCookie a b c++-- | Alias for 'makeSessionCookie'.+makeCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)+makeCookie = makeSessionCookie+{-# DEPRECATED makeCookie "Use makeSessionCookie instead" #-}++-- | Alias for 'makeSessionCookieBS'. makeCookieBS :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe BS.ByteString)-makeCookieBS a b c = fmap (toByteString . renderSetCookie) <$> makeCookie a b c+makeCookieBS = makeSessionCookieBS+{-# DEPRECATED makeCookieBS "Use makeSessionCookieBS instead" #-}