From 5c87fe2704a87937cbe1b75f81a15941138a11c3 Mon Sep 17 00:00:00 2001 From: steve-chavez Date: Tue, 27 Feb 2018 12:27:52 -0500 Subject: [PATCH] Add getCurrentTime cache for jwt validation --- main/Main.hs | 10 +++++++++- postgrest.cabal | 9 +++++++-- src/PostgREST/App.hs | 8 +++++--- src/PostgREST/Auth.hs | 9 +++++---- stack.yaml | 1 + test/Main.hs | 22 +++++++++++++--------- 6 files changed, 40 insertions(+), 19 deletions(-) diff --git a/main/Main.hs b/main/Main.hs index 1aa40b251..06ccb3a5d 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -14,6 +14,9 @@ import PostgREST.OpenAPI (isMalformedProxyUri) import PostgREST.Types (DbStructure, Schema, PgVersion(..)) import Protolude hiding (hPutStrLn, replace) + +import Control.AutoUpdate (defaultUpdateSettings, + mkAutoUpdate, updateAction) import Control.Retry (RetryStatus, capDelay, exponentialBackoff, retrying, rsPreviousDelay) @@ -25,6 +28,7 @@ import Data.String (IsString (..)) import Data.Text (pack, replace, stripPrefix, strip) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Text.IO (hPutStrLn) +import Data.Time.Clock (getCurrentTime) import qualified Hasql.Pool as P import qualified Hasql.Session as H import Network.Wai.Handler.Warp (defaultSettings, @@ -206,13 +210,17 @@ main = do ) Nothing #endif - -- + + -- ask for the OS time at most once per second + getTime <- mkAutoUpdate defaultUpdateSettings {updateAction = getCurrentTime} + -- run the postgrest application runSettings appSettings $ postgrest conf refDbStructure pool + getTime (connectionWorker mainTid pool diff --git a/postgrest.cabal b/postgrest.cabal index 6de5113c3..ee9caee6f 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -29,12 +29,14 @@ executable postgrest -rtsopts "-with-rtsopts=-N -I2" default-language: Haskell2010 - build-depends: base + build-depends: auto-update + , base , hasql , hasql-pool , postgrest , protolude , text + , time , warp , bytestring , base64-bytestring @@ -68,7 +70,7 @@ library , http-types , insert-ordered-containers , interpolatedstring-perl6 - , jose >= 0.6 + , jose , lens , lens-aeson , network-uri @@ -81,6 +83,7 @@ library , scientific , swagger2 , text + , time , unordered-containers , vector , wai @@ -138,6 +141,7 @@ Test-Suite spec Build-Depends: aeson , aeson-qq , async + , auto-update , base , bytestring , base64-bytestring @@ -160,6 +164,7 @@ Test-Suite spec , process , protolude , regex-tdfa + , time , transformers-base , wai , wai-extra diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index ffe163d02..354528e0d 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -12,6 +12,7 @@ import qualified Data.ByteString.Char8 as BS import Data.Maybe import Data.IORef (IORef, readIORef) import Data.Text (intercalate) +import Data.Time.Clock (UTCTime) import qualified Data.Set as S import qualified Hasql.Pool as P @@ -62,12 +63,13 @@ import Data.Function (id) import Protolude hiding (intercalate, Proxy) import Safe (headMay) -postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO () -> Application -postgrest conf refDbStructure pool worker = +postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO UTCTime -> IO () -> Application +postgrest conf refDbStructure pool getTime worker = let middle = (if configQuiet conf then id else logStdout) . defaultMiddle jwtSecret = parseJWK <$> configJwtSecret conf in middle $ \ req respond -> do + time <- getTime body <- strictRequestBody req maybeDbStructure <- readIORef refDbStructure case maybeDbStructure of @@ -76,7 +78,7 @@ postgrest conf refDbStructure pool worker = response <- case userApiRequest (configSchema conf) req body of Left err -> return $ apiRequestError err Right apiRequest -> do - eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) + eClaims <- jwtClaims jwtSecret (configJwtAudience conf) (toS $ iJWT apiRequest) time let authed = containsRole eClaims proc = case (iTarget apiRequest, iPayload apiRequest, iPreferSingleObjectParameter apiRequest) of diff --git a/src/PostgREST/Auth.hs b/src/PostgREST/Auth.hs index 3f29fa4b0..a91913561 100644 --- a/src/PostgREST/Auth.hs +++ b/src/PostgREST/Auth.hs @@ -21,6 +21,7 @@ module PostgREST.Auth ( import Control.Lens.Operators import Data.Aeson (Value (..), decode, toJSON) import qualified Data.HashMap.Strict as M +import Data.Time.Clock (UTCTime) import Protolude import qualified Crypto.JOSE.Types as JOSE.Types @@ -38,16 +39,16 @@ data JWTAttempt = JWTInvalid JWTError Receives the JWT secret and audience (from config) and a JWT and returns a map of JWT claims. -} -jwtClaims :: Maybe JWK -> Maybe StringOrURI -> LByteString -> IO JWTAttempt -jwtClaims _ _ "" = return $ JWTClaims M.empty -jwtClaims secret audience payload = +jwtClaims :: Maybe JWK -> Maybe StringOrURI -> LByteString -> UTCTime -> IO JWTAttempt +jwtClaims _ _ "" _ = return $ JWTClaims M.empty +jwtClaims secret audience payload time = case secret of Nothing -> return JWTMissingSecret Just s -> do let validation = defaultJWTValidationSettings (maybe (const True) (==) audience) eJwt <- runExceptT $ do jwt <- decodeCompact payload - verifyClaims validation s jwt + verifyClaimsAt validation s time jwt return $ case eJwt of Left e -> JWTInvalid e Right jwt -> JWTClaims . claims2map $ jwt diff --git a/stack.yaml b/stack.yaml index b17f9e807..9703e1211 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,6 +9,7 @@ extra-deps: - hasql-1.1 - hasql-pool-0.4.3 - hasql-transaction-0.5.2 + - jose-0.7.0.0 ghc-options: postgrest: -O2 -Werror -Wall -fwarn-identities -fno-warn-redundant-constraints nix: diff --git a/test/Main.hs b/test/Main.hs index bf5abc418..7f188cc03 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -9,8 +9,10 @@ import PostgREST.App (postgrest) import PostgREST.Config (pgVersion95, pgVersion96, configSettings) import PostgREST.DbStructure (getDbStructure, getPgVersion, fillSessionWithSettings) import PostgREST.Types (DbStructure(..)) +import Control.AutoUpdate (defaultUpdateSettings, mkAutoUpdate, updateAction) import Data.Function (id) import Data.IORef +import Data.Time.Clock (getCurrentTime) import qualified Feature.AuthSpec import qualified Feature.AsymmetricJwtSpec @@ -47,17 +49,19 @@ main = do dbStructure <- pure $ either (panic.show) id result + getTime <- mkAutoUpdate defaultUpdateSettings { updateAction = getCurrentTime } + refDbStructure <- newIORef $ Just dbStructure - let withApp = return $ postgrest (testCfg testDbConn) refDbStructure pool $ pure () - ltdApp = return $ postgrest (testLtdRowsCfg testDbConn) refDbStructure pool $ pure () - unicodeApp = return $ postgrest (testUnicodeCfg testDbConn) refDbStructure pool $ pure () - proxyApp = return $ postgrest (testProxyCfg testDbConn) refDbStructure pool $ pure () - noJwtApp = return $ postgrest (testCfgNoJWT testDbConn) refDbStructure pool $ pure () - binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool $ pure () - audJwtApp = return $ postgrest (testCfgAudienceJWT testDbConn) refDbStructure pool $ pure () - asymJwkApp = return $ postgrest (testCfgAsymJWK testDbConn) refDbStructure pool $ pure () - nonexistentSchemaApp = return $ postgrest (testNonexistentSchemaCfg testDbConn) refDbStructure pool $ pure () + let withApp = return $ postgrest (testCfg testDbConn) refDbStructure pool getTime $ pure () + ltdApp = return $ postgrest (testLtdRowsCfg testDbConn) refDbStructure pool getTime $ pure () + unicodeApp = return $ postgrest (testUnicodeCfg testDbConn) refDbStructure pool getTime $ pure () + proxyApp = return $ postgrest (testProxyCfg testDbConn) refDbStructure pool getTime $ pure () + noJwtApp = return $ postgrest (testCfgNoJWT testDbConn) refDbStructure pool getTime $ pure () + binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool getTime $ pure () + audJwtApp = return $ postgrest (testCfgAudienceJWT testDbConn) refDbStructure pool getTime $ pure () + asymJwkApp = return $ postgrest (testCfgAsymJWK testDbConn) refDbStructure pool getTime $ pure () + nonexistentSchemaApp = return $ postgrest (testNonexistentSchemaCfg testDbConn) refDbStructure pool getTime $ pure () let reset :: IO () reset = P.use pool (fillSessionWithSettings (configSettings $ testCfg testDbConn)) >> resetDb testDbConn