postgres-websockets 0.11.1.0 → 0.11.2.1
raw patch · 6 files changed
+40/−33 lines, 6 filesdep ~aesondep ~base64-bytestringdep ~hasql-pool
Dependency ranges changed: aeson, base64-bytestring, hasql-pool, hspec, lens, retry, stm-containers, text, time
Files
- postgres-websockets.cabal +13/−13
- src/PostgresWebsockets/Claims.hs +10/−10
- src/PostgresWebsockets/Context.hs +1/−1
- src/PostgresWebsockets/HasqlBroadcast.hs +6/−1
- src/PostgresWebsockets/Middleware.hs +5/−3
- test/ClaimsSpec.hs +5/−5
postgres-websockets.cabal view
@@ -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
src/PostgresWebsockets/Claims.hs view
@@ -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
src/PostgresWebsockets/Context.hs view
@@ -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
src/PostgresWebsockets/HasqlBroadcast.hs view
@@ -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
src/PostgresWebsockets/Middleware.hs view
@@ -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}
test/ClaimsSpec.hs view
@@ -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