diff --git a/postgres-websockets.cabal b/postgres-websockets.cabal --- a/postgres-websockets.cabal +++ b/postgres-websockets.cabal @@ -1,5 +1,5 @@ name: postgres-websockets -version: 0.11.1.0 +version: 0.11.2.1 synopsis: Middleware to map LISTEN/NOTIFY messages to Websockets description: WAI middleware that adds websockets capabilites on top of PostgreSQL's asynchronous notifications using LISTEN and NOTIFY commands. Fully functioning server included. homepage: https://github.com/diogob/postgres-websockets#readme @@ -27,8 +27,8 @@ , PostgresWebsockets.Middleware , PostgresWebsockets.Context build-depends: base >= 4.7 && < 5 - , hasql-pool >= 0.5 && < 0.6 - , text >= 1.2 && < 1.3 + , hasql-pool >= 0.8 && < 0.10 + , text >= 1.2 && < 2.1 , wai >= 3.2 && < 4 , websockets >= 0.9 && < 0.13 , wai-websockets >= 3.0 && < 4 @@ -38,18 +38,18 @@ , lens >= 4.17.1 , jose >= 0.6 , unordered-containers >= 0.2 - , aeson >= 1.4.6.0 && < 1.6 + , aeson >= 2.0 && < 2.2 , protolude >= 0.2.3 && < 0.4 , hasql >= 1.4.1 , hasql-notifications >= 0.1.0.0 && < 0.3 , either >= 5.0.1.1 && < 5.1 - , stm-containers >= 1.1.0.2 && < 1.2 + , stm-containers >= 1.1.0.2 && < 1.3 , stm >= 2.5.0.0 && < 2.6 - , retry >= 0.8.1.0 && < 0.9 - , time >= 1.8.0.2 && < 1.10 + , retry >= 0.8.1.0 && < 0.10 + , time >= 1.8.0.2 && < 1.13 , alarmclock >= 0.7.0.2 && < 0.8 , envparse >= 0.4.1 - , base64-bytestring >= 1.0.0.3 && < 1.2 + , base64-bytestring >= 1.0.0.3 && < 1.3 , bytestring >= 0.10 , warp >= 3.2 && < 4 , warp-tls >= 3.2 && < 4 @@ -82,19 +82,19 @@ build-depends: base , protolude >= 0.2.3 && < 0.4 , postgres-websockets - , hspec >= 2.7.1 && < 2.8 - , aeson >= 1.4.6.0 && < 1.6 + , hspec >= 2.7.1 && < 2.11 + , aeson >= 2.0 && < 2.2 , hasql >= 0.19 - , hasql-pool >= 0.4 + , hasql-pool >= 0.8 && < 0.10 , hasql-notifications >= 0.1.0.0 && < 0.3 , http-types >= 0.9 - , time >= 1.8.0.2 && < 1.10 + , time >= 1.8.0.2 && < 1.13 , unordered-containers >= 0.2 , wai-extra >= 3.0.29 && < 3.2 , stm >= 2.5.0.0 && < 2.6 , websockets >= 0.12.7.0 && < 0.13 , network >= 2.8.0.1 && < 3.2 - , lens >= 4.17.1 && < 4.20 + , lens >= 4.17.1 && < 5.3 , lens-aeson ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/PostgresWebsockets/Claims.hs b/src/PostgresWebsockets/Claims.hs --- a/src/PostgresWebsockets/Claims.hs +++ b/src/PostgresWebsockets/Claims.hs @@ -18,15 +18,15 @@ import Data.List import Data.Time.Clock (UTCTime) import qualified Crypto.JOSE.Types as JOSE.Types -import qualified Data.HashMap.Strict as M import qualified Data.Aeson as JSON - +import qualified Data.Aeson.KeyMap as JSON +import qualified Data.Aeson.Key as Key -type Claims = M.HashMap Text JSON.Value +type Claims = JSON.KeyMap JSON.Value type ConnectionInfo = ([Text], Text, Claims) {-| Given a secret, a token and a timestamp it validates the claims and returns - either an error message or a triple containing channel, mode and claims hashmap. + either an error message or a triple containing channel, mode and claims KeyMap. -} validateClaims :: Maybe Text @@ -59,12 +59,12 @@ where claimAsJSON :: Text -> Claims -> Maybe Text - claimAsJSON name cl = case M.lookup name cl of + claimAsJSON name cl = case JSON.lookup (Key.fromText name) cl of Just (JSON.String s) -> Just s _ -> Nothing claimAsJSONList :: Text -> Claims -> Maybe [Text] - claimAsJSONList name cl = case M.lookup name cl of + claimAsJSONList name cl = case JSON.lookup (Key.fromText name) cl of Just channelsJson -> case JSON.fromJSON channelsJson :: JSON.Result [Text] of JSON.Success channelsList -> Just channelsList @@ -75,7 +75,7 @@ Possible situations encountered with client JWTs -} data JWTAttempt = JWTInvalid JWTError - | JWTClaims (M.HashMap Text JSON.Value) + | JWTClaims (JSON.KeyMap JSON.Value) deriving Eq {-| @@ -83,7 +83,7 @@ of JWT claims. -} jwtClaims :: UTCTime -> JWK -> LByteString -> IO JWTAttempt -jwtClaims _ _ "" = return $ JWTClaims M.empty +jwtClaims _ _ "" = return $ JWTClaims JSON.empty jwtClaims time jwk' payload = do let config = defaultJWTValidationSettings (const True) eJwt <- runExceptT $ do @@ -97,11 +97,11 @@ Internal helper used to turn JWT ClaimSet into something easier to work with -} -claims2map :: ClaimsSet -> M.HashMap Text JSON.Value +claims2map :: ClaimsSet -> JSON.KeyMap JSON.Value claims2map = val2map . JSON.toJSON where val2map (JSON.Object o) = o - val2map _ = M.empty + val2map _ = JSON.empty {-| Internal helper to generate HMAC-SHA256. When the jwt key in the diff --git a/src/PostgresWebsockets/Context.hs b/src/PostgresWebsockets/Context.hs --- a/src/PostgresWebsockets/Context.hs +++ b/src/PostgresWebsockets/Context.hs @@ -31,7 +31,7 @@ mkContext :: AppConfig -> IO () -> IO Context mkContext conf@AppConfig {..} shutdownServer = do Context conf - <$> P.acquire (configPool, 10, pgSettings) + <$> P.acquire configPool 10000 10000 pgSettings <*> newHasqlBroadcaster shutdown (toS configListenChannel) configRetries configReconnectInterval pgSettings <*> mkGetTime where diff --git a/src/PostgresWebsockets/HasqlBroadcast.hs b/src/PostgresWebsockets/HasqlBroadcast.hs --- a/src/PostgresWebsockets/HasqlBroadcast.hs +++ b/src/PostgresWebsockets/HasqlBroadcast.hs @@ -17,9 +17,11 @@ import Control.Retry (RetryStatus (..), capDelay, exponentialBackoff, retrying) import Data.Aeson (Value (..), decode) +import qualified Data.Aeson.KeyMap as JSON +import qualified Data.Aeson.Key as Key + import Data.Either.Combinators (mapBoth) import Data.Function (id) -import Data.HashMap.Lazy (lookupDefault) import GHC.Show import Hasql.Connection import qualified Hasql.Decoders as HD @@ -102,6 +104,9 @@ String s -> toS s _ -> toS d lookupStringDef _ d _ = toS d + + lookupDefault d key obj = fromMaybe d $ JSON.lookup (Key.fromText key) obj + channelDef = lookupStringDef "channel" shouldRestart = do con <- getCon diff --git a/src/PostgresWebsockets/Middleware.hs b/src/PostgresWebsockets/Middleware.hs --- a/src/PostgresWebsockets/Middleware.hs +++ b/src/PostgresWebsockets/Middleware.hs @@ -22,9 +22,11 @@ import qualified Network.WebSockets as WS import qualified Data.Aeson as A +import qualified Data.Aeson.KeyMap as A +import qualified Data.Aeson.Key as Key + import qualified Data.Text as T import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as M import PostgresWebsockets.Broadcast (onMessage) import PostgresWebsockets.Claims ( ConnectionInfo, validateClaims ) @@ -87,7 +89,7 @@ conn <- WS.acceptRequest pendingConn -- Fork a pinging thread to ensure browser connections stay alive WS.withPingThread conn 30 (pure ()) $ do - case M.lookup "exp" validClaims of + case A.lookup "exp" validClaims of Just (A.Number expClaim) -> do connectionExpirer <- newAlarmClock $ const (WS.sendCloseCode conn jwtExpirationStatusCode ("JWT expired" :: ByteString)) setAlarm connectionExpirer (posixSecondsToUTCTime $ realToFrac expClaim) @@ -134,4 +136,4 @@ timestampMessage :: IO UTCTime -> Message -> IO Message timestampMessage getTime msg@Message{..} = do time <- utcTimeToPOSIXSeconds <$> getTime - return $ msg{ claims = M.insert "message_delivered_at" (A.Number $ realToFrac time) claims} + return $ msg{ claims = A.insert (Key.fromText "message_delivered_at") (A.Number $ realToFrac time) claims} diff --git a/test/ClaimsSpec.hs b/test/ClaimsSpec.hs --- a/test/ClaimsSpec.hs +++ b/test/ClaimsSpec.hs @@ -2,9 +2,9 @@ import Protolude -import qualified Data.HashMap.Strict as M import Test.Hspec import Data.Aeson (Value (..), toJSON) +import qualified Data.Aeson.KeyMap as JSON import Data.Time.Clock import PostgresWebsockets.Claims @@ -23,23 +23,23 @@ time <- getCurrentTime validateClaims (Just "test") secret "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJtb2RlIjoiciJ9.jL5SsRFegNUlbBm8_okhHSujqLcKKZdDglfdqNl1_rY" time - `shouldReturn` Right (["test"], "r", M.fromList[("mode",String "r")]) + `shouldReturn` Right (["test"], "r", JSON.fromList[("mode",String "r")]) it "requesting a channel that is set by and old style channel claim should work" $ do time <- getCurrentTime validateClaims (Just "test") secret "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJtb2RlIjoiciIsImNoYW5uZWwiOiJ0ZXN0In0.1d4s-at2kWj8OSabHZHTbNh1dENF7NWy_r0ED3Rwf58" time - `shouldReturn` Right (["test"], "r", M.fromList[("mode",String "r"),("channel",String "test")]) + `shouldReturn` Right (["test"], "r", JSON.fromList[("mode",String "r"),("channel",String "test")]) it "no requesting channel should return all channels in the token" $ do time <- getCurrentTime validateClaims Nothing secret "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJtb2RlIjoiciIsImNoYW5uZWxzIjpbInRlc3QiLCJhbm90aGVyIHRlc3QiXX0.b9N8J8tPOPIxxFj5WJ7sWrmcL8ib63i8eirsRZTM9N0" time - `shouldReturn` Right (["test", "another test"], "r", M.fromList[("mode",String "r"),("channels", toJSON["test"::Text, "another test"::Text] ) ]) + `shouldReturn` Right (["test", "another test"], "r", JSON.fromList[("mode",String "r"),("channels", toJSON["test"::Text, "another test"::Text] ) ]) it "requesting a channel from the channels claim shoud return only the requested channel" $ do time <- getCurrentTime validateClaims (Just "test") secret "eyJhbGciOiJIUzI1NiIsInR5cCI6IkpXVCJ9.eyJtb2RlIjoiciIsImNoYW5uZWxzIjpbInRlc3QiLCJ0ZXN0MiJdfQ.MumdJ5FpFX4Z6SJD3qsygVF0r9vqxfqhj5J30O32N0k" time - `shouldReturn` Right (["test"], "r", M.fromList[("mode",String "r"),("channels", toJSON ["test"::Text, "test2"] )]) + `shouldReturn` Right (["test"], "r", JSON.fromList[("mode",String "r"),("channels", toJSON ["test"::Text, "test2"] )]) it "requesting a channel not from the channels claim shoud error" $ do time <- getCurrentTime