Add JWT token expiration at JWTSettings level with calculated Expiration in NominalDiffTime

servant-auth/servant-auth-server/README.lhs

@@ -134,7 +134,7 @@ mainWithJWT = do
      xs <- words <$> getLine
      case xs of
        [name', email'] -> do
-         etoken <- makeJWT (User name' email') jwtCfg Nothing
+         etoken <- makeJWT (User name' email') jwtCfg
          case etoken of
            Left e -> putStrLn $ "Error generating token:t" ++ show e
            Right v -> putStrLn $ "New token:\t" ++ show v

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/ConfigTypes.hs

@@ -37,6 +37,10 @@ data JWTSettings = JWTSettings
   -- | An @aud@ predicate. The @aud@ is a string or URI that identifies the
   -- intended recipient of the JWT.
   , audienceMatches :: Jose.StringOrURI -> IsMatch
+
+  -- | How long from now until the jwt expires. Default: @Nothing@.
+  , expiresIn      :: Maybe NominalDiffTime
+
   } deriving (Generic)
 
 -- | A @JWTSettings@ where the audience always matches.
@@ -45,7 +49,9 @@ defaultJWTSettings k = JWTSettings
    { signingKey = k
    , jwtAlg = Nothing
    , validationKeys = pure $ Jose.JWKSet [k]
-   , audienceMatches = const Matches }
+   , audienceMatches = const Matches
+   , expiresIn = Nothing
+   }
 
 -- | The policies to use when generating cookies.
 --

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/Cookie.hs

@@ -4,8 +4,6 @@ module Servant.Auth.Server.Internal.Cookie where
 import           Blaze.ByteString.Builder (toByteString)
 import           Control.Monad.Except
 import           Control.Monad.Reader
-import qualified Crypto.JOSE              as Jose
-import qualified Crypto.JWT               as Jose
 import           Data.ByteArray           (constEq)
 import qualified Data.ByteString          as BS
 import qualified Data.ByteString.Base64   as BS64
@@ -21,7 +19,7 @@ import           Servant                  (AddHeader, addHeader)
 import           System.Entropy           (getEntropy)
 import           Web.Cookie
 
-import Servant.Auth.JWT                          (FromJWT (decodeJWT), ToJWT)
+import Servant.Auth.JWT                          (FromJWT, ToJWT)
 import Servant.Auth.Server.Internal.ConfigTypes
 import Servant.Auth.Server.Internal.JWT          (makeJWT, verifyJWT)
 import Servant.Auth.Server.Internal.Types
@@ -80,7 +78,7 @@ makeCsrfCookie = makeXsrfCookie
 -- | Makes a cookie with session information.
 makeSessionCookie :: ToJWT v => CookieSettings -> JWTSettings -> v -> IO (Maybe SetCookie)
 makeSessionCookie cookieSettings jwtSettings v = do
-  ejwt <- makeJWT v jwtSettings (cookieExpires cookieSettings)
+  ejwt <- makeJWT v jwtSettings
   case ejwt of
     Left _ -> return Nothing
     Right jwt -> return

servant-auth/servant-auth-server/src/Servant/Auth/Server/Internal/JWT.hs

@@ -13,7 +13,7 @@ import qualified Data.ByteString.Lazy as BSL
 import qualified Data.HashMap.Strict  as HM
 import           Data.Maybe           (fromMaybe)
 import qualified Data.Text            as T
-import           Data.Time            (UTCTime)
+import           Data.Time            (UTCTime, getCurrentTime, addUTCTime)
 import           Network.Wai          (requestHeaders)
 
 import Servant.Auth.JWT               (FromJWT(..), ToJWT(..))
@@ -38,22 +38,23 @@ jwtAuthCheck jwtSettings = do
     Just v -> return v
 
 -- | Creates a JWT containing the specified data. The data is stored in the
--- @dat@ claim. The 'Maybe UTCTime' argument indicates the time at which the
+-- @dat@ claim. The expiration time 'Maybe NominalDiffTime' is taken from 'JWTSettings'
--- token expires.
+-- and indicates the time at which the token expires.
 makeJWT :: ToJWT a
-  => a -> JWTSettings -> Maybe UTCTime -> IO (Either Jose.Error BSL.ByteString)
+  => a -> JWTSettings -> IO (Either Jose.Error BSL.ByteString)
-makeJWT v cfg expiry = runExceptT $ do
+makeJWT v cfg = runExceptT $ do
+  currentTime <- ExceptT $ pure <$> getCurrentTime
   bestAlg <- Jose.bestJWSAlg $ signingKey cfg
   let alg = fromMaybe bestAlg $ jwtAlg cfg
   ejwt <- Jose.signClaims (signingKey cfg)
                           (Jose.newJWSHeader ((), alg))
-                          (addExp $ encodeJWT v)
+                          (addExp currentTime $ encodeJWT v)
 
   return $ Jose.encodeCompact ejwt
   where
-   addExp claims = case expiry of
+   addExp currTime claims = case expiresIn cfg of
      Nothing -> claims
-     Just e  -> claims & Jose.claimExp ?~ Jose.NumericDate e
+     Just e  -> claims & Jose.claimExp ?~ Jose.NumericDate (addUTCTime e currTime)
 
 
 verifyJWT :: FromJWT a => JWTSettings -> BS.ByteString -> IO (Maybe a)

servant-auth/servant-auth-server/test/Servant/Auth/ServerSpec.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE NumericUnderscores #-}
 {-# LANGUAGE CPP #-}
 module Servant.Auth.ServerSpec (spec) where
 
@@ -85,7 +86,7 @@ authSpec
 
   it "succeeds if one authentication suceeds" $ \port -> property $
                                                 \(user :: User) -> do
-    jwt <- makeJWT user jwtCfg Nothing
+    jwt <- makeJWT user jwtCfg
     opts <- addJwtToHeader jwt
     resp <- getWith opts (url port)
     resp ^? responseBody . _JSON `shouldBe` Just (length $ name user)
@@ -95,7 +96,7 @@ authSpec
 
   it "doesn't clobber pre-existing response headers" $ \port -> property $
                                                 \(user :: User) -> do
-    jwt <- makeJWT user jwtCfg Nothing
+    jwt <- makeJWT user jwtCfg
     opts <- addJwtToHeader jwt
     resp <- getWith opts (url port ++ "/header")
     resp ^. responseHeader "Blah" `shouldBe` "1797"
@@ -104,14 +105,14 @@ authSpec
   context "Raw" $ do
 
     it "gets the response body" $ \port -> property $ \(user :: User) -> do
-      jwt <- makeJWT user jwtCfg Nothing
+      jwt <- makeJWT user jwtCfg
       opts <- addJwtToHeader jwt
       resp <- getWith opts (url port ++ "/raw")
       resp ^. responseBody `shouldBe` "how are you?"
 
     it "doesn't clobber pre-existing reponse headers" $ \port -> property $
                                                 \(user :: User) -> do
-      jwt <- makeJWT user jwtCfg Nothing
+      jwt <- makeJWT user jwtCfg
       opts <- addJwtToHeader jwt
       resp <- getWith opts (url port ++ "/raw")
       resp ^. responseHeader "hi" `shouldBe` "there"
@@ -146,7 +147,7 @@ authSpec
       let (cookieJar:_) = resp ^.. responseCookieJar
           Just xxsrf = find (\x -> cookie_name x == xsrfField xsrfCookieName cookieCfg)
                      $ destroyCookieJar cookieJar
-      xxsrf ^. cookieExpiryTime `shouldBe` future
+      xxsrf ^. cookieExpiryTime `shouldBe` futureUTC
 
     it "sets the token cookie as HttpOnly" $ \port -> property $ \(user :: User) -> do
       jwt <- createJWT theKey (newJWSHeader ((), HS256))
@@ -318,19 +319,19 @@ jwtAuthSpec
   it "fails if 'nbf' is set to a future date" $ \port -> property $
                                                 \(user :: User) -> do
     jwt <- createJWT theKey (newJWSHeader ((), HS256))
-      (claims (toJSON user) & claimNbf .~ Just (NumericDate future))
+      (claims (toJSON user) & claimNbf .~ Just (NumericDate futureUTC))
     opts <- addJwtToHeader (jwt >>= (return . encodeCompact))
     getWith opts (url port) `shouldHTTPErrorWith` status401
 
   it "fails if 'exp' is set to a past date" $ \port -> property $
                                               \(user :: User) -> do
-    jwt <- makeJWT user jwtCfg (Just past)
+    jwt <- makeJWT user $ jwtCfg {expiresIn = Just past}
     opts <- addJwtToHeader jwt
     getWith opts (url port) `shouldHTTPErrorWith` status401
 
   it "succeeds if 'exp' is set to a future date" $ \port -> property $
                                                    \(user :: User) -> do
-    jwt <- makeJWT user jwtCfg (Just future)
+    jwt <- makeJWT user $ jwtCfg {expiresIn = Just future}
     opts <- addJwtToHeader jwt
     resp <- getWith opts (url port)
     resp ^. responseStatus `shouldBe` status200
@@ -441,7 +442,7 @@ theKey = unsafePerformIO . genJWK $ OctGenParam 256
 
 cookieCfg :: CookieSettings
 cookieCfg = def
-  { cookieExpires = Just future
+  { cookieExpires = Just futureUTC
   , cookieIsSecure = NotSecure
   , sessionCookieName = "RuncibleSpoon"
   , cookieXsrfSetting = pure $ def
@@ -527,11 +528,14 @@ server ccfg =
 ------------------------------------------------------------------------------
 -- * Utils {{{
 
-past :: UTCTime
+past :: NominalDiffTime
-past = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "1970-01-01"
+past = (-1) * future
 
-future :: UTCTime
+future :: NominalDiffTime
-future = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"
+future = 1_000_000
+
+futureUTC :: UTCTime
+futureUTC = parseTimeOrError True defaultTimeLocale "%Y-%m-%d" "2070-01-01"
 
 addJwtToHeader :: Either Error BSL.ByteString -> IO Options
 addJwtToHeader jwt = case jwt of