Merge pull request #344 from calebmer/feature/jwt-expire

Ensure JWT expires

src/PostgREST/Auth.hs

@@ -18,6 +18,7 @@ module PostgREST.Auth (
   , tokenJWT
   ) where
 
+import           Control.Monad           (join)
 import           Data.Aeson              (Value (..), Object)
 import           Data.Aeson.Types        (emptyObject, emptyArray)
 import           Data.Vector             as V (null, head)
@@ -25,6 +26,7 @@ import           Data.Map                as M (fromList, toList)
 import           Data.Monoid             ((<>))
 import           Data.String.Conversions (cs)
 import           Data.Text               (Text)
+import           Data.Time.Clock         (NominalDiffTime)
 import           PostgREST.PgQuery       (pgFmtLit, pgFmtIdent, unquoted)
 import qualified Web.JWT                 as JWT
 import qualified Data.HashMap.Lazy       as H
@@ -49,10 +51,19 @@ claimsToSQL = map setVar . toList
   returns a map of JWT claims
   In case there is any problem decoding the JWT it returns Nothing.
 -}
-jwtClaims :: Text -> Text -> Maybe JWT.ClaimsMap
-jwtClaims secret input = JWT.unregisteredClaims . JWT.claims <$> decoded
+jwtClaims :: Text -> Text -> NominalDiffTime -> Maybe JWT.ClaimsMap
+jwtClaims secret input time =
+  case join $ claim JWT.exp of
+    Just expires ->
+      if JWT.secondsSinceEpoch expires > time
+        then customClaims
+        else Nothing
+    _ -> customClaims
   where
     decoded = JWT.decodeAndVerifySignature (JWT.secret secret) input
+    claim :: (JWT.JWTClaimsSet -> a) -> Maybe a
+    claim prop = prop . JWT.claims <$> decoded
+    customClaims = claim JWT.unregisteredClaims
 
 -- | Receives the name of a role and returns a SET ROLE statement
 setRole :: Text -> Text

src/PostgREST/Main.hs

@@ -2,7 +2,6 @@ module Main where
 
 
 import           PostgREST.App
--- import PostgREST.QueryBuilder
 import           PostgREST.Config                     (AppConfig (..),
                                                        minimumPgVersion,
                                                        prettyVersion,
@@ -70,13 +69,6 @@ main = do
           <> show minimumPgVersion)
     ) supportedOrError
 
-  -- what was this code for?
-  -- roleOrError <- H.session pool $ do
-  --   Identity (role :: Text) <- H.tx Nothing $ H.singleEx
-  --     [H.stmt|SELECT SESSION_USER|]
-  --   return role
-  -- authenticator <- either hasqlError return roleOrError
-
   let txSettings = Just (H.ReadCommitted, Just True)
   metadata <- H.session pool $ H.tx txSettings $ do
     rels <- allRelations

src/PostgREST/Middleware.hs

@@ -6,6 +6,7 @@ module PostgREST.Middleware where
 import           Data.Maybe                    (fromMaybe, isNothing)
 import           Data.Text
 import           Data.String.Conversions       (cs)
+import           Data.Time.Clock.POSIX         (getPOSIXTime)
 import qualified Hasql                         as H
 import qualified Hasql.Postgres                as P
 
@@ -21,6 +22,8 @@ import           PostgREST.App                 (contentTypeForAccept)
 import           PostgREST.Auth                (setRole, jwtClaims, claimsToSQL)
 import           PostgREST.Config              (AppConfig (..), corsPolicy)
 
+import           System.IO.Unsafe              (unsafePerformIO)
+
 import           Prelude hiding(concat)
 
 import qualified Data.Vector             as V
@@ -31,23 +34,27 @@ runWithClaims :: forall s. AppConfig ->
                  (Request -> H.Tx P.Postgres s Response) ->
                  Request -> H.Tx P.Postgres s Response
 runWithClaims conf app req = do
-    mapM_ H.unitEx $ stmt <$> env
-    app req
- where
-   stmt = (flip $ flip B.Stmt V.empty) True
-   hdrs = requestHeaders req
-   jwtSecret = (cs $ configJwtSecret conf) :: Text
-   auth = fromMaybe "" $ lookup hAuthorization hdrs
-   anon = cs $ configAnonRole conf
-   claims =
-     fromMaybe (M.fromList []) $
-     case split (==' ') (cs auth) of
-       ("Bearer" : jwt : _) -> jwtClaims jwtSecret jwt
-       _ -> Nothing
-   env = if M.member "role" claims
-            then jwtEnv
-            else setRole anon : jwtEnv
-   jwtEnv = claimsToSQL claims
+    _ <- H.unitEx $ stmt setAnon
+    let time = unsafePerformIO getPOSIXTime
+    case split (== ' ') (cs auth) of
+      ("Bearer" : tokenStr : _) ->
+        case jwtClaims jwtSecret tokenStr time of
+          Just claims ->
+            if M.member "role" claims
+            then do
+              mapM_ H.unitEx $ stmt <$> claimsToSQL claims
+              app req
+            else invalidJWT
+          _ -> invalidJWT
+      _ -> app req
+  where
+    stmt c = B.Stmt c V.empty True
+    hdrs = requestHeaders req
+    jwtSecret = (cs $ configJwtSecret conf) :: Text
+    auth = fromMaybe "" $ lookup hAuthorization hdrs
+    anon = cs $ configAnonRole conf
+    setAnon = setRole anon
+    invalidJWT = return $ responseLBS status400 [("Content-Type","application/json")] "{\"message\":\"Invalid JWT\"}"
 
 unsupportedAccept :: Application -> Application
 unsupportedAccept app req respond = do