postgrest-ws 0.2.0.0 → 0.3.0.0

raw patch · 6 files changed

+47/−39 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• app/Config.hs +3/−3
• app/Main.hs +7/−12
• postgrest-ws.cabal +1/−1
• src/PostgRESTWS.hs +5/−5
• src/PostgRESTWS/Claims.hs +14/−17
• src/PostgRESTWS/HasqlBroadcast.hs +17/−1

@@ -44,7 +44,7 @@   , configHost              :: Text   , configPort              :: Int -  , configJwtSecret         :: Maybe B.ByteString+  , configJwtSecret         :: B.ByteString   , configJwtSecretIsBase64 :: Bool    , configPool              :: Int@@ -73,10 +73,10 @@     cHost     <- C.lookupDefault "*4" conf "server-host"     cPort     <- C.lookupDefault 3000 conf "server-port"     -- jwt ----------------    cJwtSec   <- C.lookup conf "jwt-secret"+    cJwtSec   <- C.require conf "jwt-secret"     cJwtB64   <- C.lookupDefault False conf "secret-is-base64" -    return $ AppConfig cDbUri cPath cHost cPort (encodeUtf8 <$> cJwtSec) cJwtB64 cPool+    return $ AppConfig cDbUri cPath cHost cPort (encodeUtf8 cJwtSec) cJwtB64 cPool   where   opts = info (helper <*> pathParser) $

@@ -2,7 +2,6 @@  import           Protolude import           PostgRESTWS-import           PostgRESTWS.Broadcast import           PostgRESTWS.HasqlBroadcast import           Config                               (AppConfig (..),                                                        PgVersion (..),@@ -17,7 +16,6 @@ import           Data.Text.Encoding                   (encodeUtf8, decodeUtf8) import           Data.Text.IO                         (readFile) import           Data.Time.Clock.POSIX                (getPOSIXTime)-import qualified Hasql.Connection                     as H import qualified Hasql.Query                          as H import qualified Hasql.Session                        as H import qualified Hasql.Decoders                       as HD@@ -59,29 +57,26 @@   putStrLn $ ("Listening on port " :: Text) <> show (configPort conf)    pool <- P.acquire (configPool conf, 10, pgSettings)-  conOrError <- H.acquire pgSettings-  let con = either (panic . show) id conOrError :: H.Connection    -- ask for the OS time at most once per second   getTime <- mkAutoUpdate     defaultUpdateSettings { updateAction = getPOSIXTime } -  multi <- newHasqlBroadcaster con-  void $ relayMessagesForever multi+  multiOrError <- newHasqlBroadcasterOrError pgSettings+  let multi = either (panic . show) id multiOrError    runSettings appSettings $     postgrestWsMiddleware (configJwtSecret conf) getTime pool multi $     logStdout $ staticApp $ defaultFileServerSettings $ toS $ configPath conf  loadSecretFile :: AppConfig -> IO AppConfig-loadSecretFile conf = extractAndTransform mSecret+loadSecretFile conf = extractAndTransform secret   where-    mSecret   = decodeUtf8 <$> configJwtSecret conf+    secret   = decodeUtf8 $ configJwtSecret conf     isB64     = configJwtSecretIsBase64 conf -    extractAndTransform :: Maybe Text -> IO AppConfig-    extractAndTransform Nothing  = return conf-    extractAndTransform (Just s) =+    extractAndTransform :: Text -> IO AppConfig+    extractAndTransform s =       fmap setSecret $ transformString isB64 =<<         case stripPrefix "@" s of             Nothing       -> return s@@ -94,6 +89,6 @@         Left errMsg -> panic $ pack errMsg         Right bs    -> return bs -    setSecret bs = conf { configJwtSecret = Just bs }+    setSecret bs = conf { configJwtSecret = bs }      replaceUrlChars = replace "_" "/" . replace "-" "+" . replace "." "="

@@ -1,5 +1,5 @@ name:                postgrest-ws-version:             0.2.0.0+version:             0.3.0.0 synopsis:            PostgREST extension to map LISTEN/NOTIFY messages to Websockets description:         Please see README.md homepage:            https://github.com/diogob/postgrest-ws#readme

@@ -36,7 +36,7 @@ instance A.ToJSON Message  -- | Given a Maybe Secret, a function to fetch the system time, a Hasql Pool and a Multiplexer this will give you a WAI middleware.-postgrestWsMiddleware :: Maybe ByteString -> IO POSIXTime -> H.Pool -> Multiplexer -> Wai.Application -> Wai.Application+postgrestWsMiddleware :: ByteString -> IO POSIXTime -> H.Pool -> Multiplexer -> Wai.Application -> Wai.Application postgrestWsMiddleware =   WS.websocketsOr WS.defaultConnectionOptions `compose` wsApp   where@@ -44,9 +44,9 @@  -- when the websocket is closed a ConnectionClosed Exception is triggered -- this kills all children and frees resources for us-wsApp :: Maybe ByteString -> IO POSIXTime -> H.Pool -> Multiplexer -> WS.ServerApp-wsApp mSecret getTime pqCon multi pendingConn =-  getTime >>= forkSessionsWhenTokenIsValid . validateClaims mSecret jwtToken+wsApp :: ByteString -> IO POSIXTime -> H.Pool -> Multiplexer -> WS.ServerApp+wsApp secret getTime pqCon multi pendingConn =+  getTime >>= forkSessionsWhenTokenIsValid . validateClaims secret jwtToken   where     forkSessionsWhenTokenIsValid = either rejectRequest forkSessions     hasRead m = m == ("r" :: ByteString) || m == ("rw" :: ByteString)@@ -64,7 +64,7 @@           when (hasRead mode) $             onMessage multi channel (\ch ->               forever $ atomically (readTChan ch) >>= WS.sendTextData conn . B.payload)-              +           notifySessionFinished <- if hasWrite mode             then forkAndWait $ forever $ notifySession channel validClaims pqCon conn             else newMVar ()

@@ -17,7 +17,7 @@ type Claims = M.HashMap Text Value type ConnectionInfo = (ByteString, ByteString, Claims) -validateClaims :: Maybe ByteString -> Text -> POSIXTime -> Either Text ConnectionInfo+validateClaims :: ByteString -> Text -> POSIXTime -> Either Text ConnectionInfo validateClaims secret jwtToken time = do   cl <- case jwtClaims jwtSecret jwtToken time of     JWTClaims c -> Right c@@ -28,7 +28,7 @@   mode <- value2BS jMode   Right (channel, mode, cl)   where-    jwtSecret = binarySecret <$> secret+    jwtSecret = binarySecret secret     value2BS val = case val of       String s -> Right $ encodeUtf8 s       _ -> Left "claim is not string value"@@ -56,20 +56,17 @@   Receives the JWT secret (from config) and a JWT and returns a map   of JWT claims. -}-jwtClaims :: Maybe JWT.Secret -> Text -> NominalDiffTime -> JWTAttempt+jwtClaims :: JWT.Secret -> Text -> NominalDiffTime -> JWTAttempt jwtClaims _ "" _ = JWTClaims M.empty jwtClaims secret jwt time =-  case secret of-    Nothing -> JWTMissingSecret-    Just s ->-      let mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature s jwt in-      case isExpired <$> mClaims of-        Just True -> JWTExpired-        Nothing -> JWTInvalid-        Just False -> JWTClaims $ value2map $ fromJust mClaims- where-  isExpired claims =-    let mExp = claims ^? key "exp" . _Integer-    in fromMaybe False $ (<= time) . fromInteger <$> mExp-  value2map (Object o) = o-  value2map _          = M.empty+  case isExpired <$> mClaims of+    Just True -> JWTExpired+    Nothing -> JWTInvalid+    Just False -> JWTClaims $ value2map $ fromJust mClaims+  where+    mClaims = toJSON . JWT.claims <$> JWT.decodeAndVerifySignature secret jwt+    isExpired claims =+      let mExp = claims ^? key "exp" . _Integer+      in fromMaybe False $ (<= time) . fromInteger <$> mExp+    value2map (Object o) = o+    value2map _          = M.empty

@@ -8,6 +8,7 @@ -} module PostgRESTWS.HasqlBroadcast   ( newHasqlBroadcaster+  , newHasqlBroadcasterOrError   -- re-export   , acquire   , relayMessages@@ -17,12 +18,23 @@ import Protolude  import Hasql.Connection+import Data.Either.Combinators (mapBoth)  import PostgRESTWS.Database import PostgRESTWS.Broadcast +{- | Returns a multiplexer from a connection URI or an error message on the left case+   This function also spawns a thread that keeps relaying the messages from the database to the multiplexer's listeners+-}+   +newHasqlBroadcasterOrError :: ByteString -> IO (Either ByteString Multiplexer)+newHasqlBroadcasterOrError =+  acquire >=> (sequence . mapBoth show newHasqlBroadcaster)+ {- | Returns a multiplexer from a connection, listen for different database notification channels using that connection. +   This function also spawns a thread that keeps relaying the messages from the database to the multiplexer's listeners+    To listen on channels *chat*     @@@ -42,7 +54,9 @@  -} newHasqlBroadcaster :: Connection -> IO Multiplexer-newHasqlBroadcaster con = newMultiplexer (\cmds msgs-> do+newHasqlBroadcaster con = do+  multi <-+    newMultiplexer (\cmds msgs-> do     waitForNotifications       (\c m-> atomically $ writeTQueue msgs $ Message c m)       con@@ -52,3 +66,5 @@         Open ch -> listen con ch         Close ch -> unlisten con ch     ) (\_ -> return ())+  void $ relayMessagesForever multi+  return multi