sparrow 0.0.1.5 → 0.0.1.6
raw patch · 3 files changed
+19/−17 lines, 3 files
Files
- sparrow.cabal +2/−2
- src/Web/Dependencies/Sparrow/Server.hs +6/−6
- src/Web/Dependencies/Sparrow/Server/Types.hs +11/−9
sparrow.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 3f9c3813672238ca87ee5934111feb5998231571a89777abeb7b399b653dce3c+-- hash: 0ebfaafba5a716832f29a853a6fe6660eafd4c006e46eb404dcef9e832f7bf62 name: sparrow-version: 0.0.1.5+version: 0.0.1.6 synopsis: Unified streaming dependency management for web apps description: Please see the README on Github at <https://git.localcooking.com/tooling/sparrow#readme> category: Web
src/Web/Dependencies/Sparrow/Server.hs view
@@ -34,12 +34,12 @@ , sendTo , unsafeRegisterReceive , registerOnUnsubscribe- , registerOnOpenThread+ , registerOnOpenThreads , registerInvalidator , broadcaster , getCurrentRegisteredTopics , getCallReceive- , killOnOpenThread+ , killOnOpenThreads , killAllOnOpenThreads , callOnUnsubscribe , callAllOnUnsubscribe@@ -135,7 +135,7 @@ delSubscriber env topic withSessionIDSessionID sendTo env withSessionIDSessionID (WSTopicRejected topic)- killOnOpenThread env withSessionIDSessionID topic+ killOnOpenThreads env withSessionIDSessionID topic , serverSendCurrent = liftIO . atomically . sendTo env withSessionIDSessionID . WSOutgoing . WithTopic topic . toJSON }@@ -161,9 +161,9 @@ threads <- serverOnOpen serverArgs - forM_ threads $ \thread -> liftIO $ atomically $+ liftIO $ atomically $ -- register onOpen thread- registerOnOpenThread env withSessionIDSessionID topic thread+ registerOnOpenThreads env withSessionIDSessionID topic threads (NR.action $ NR.post $ \_ -> NR.json serverInitOut) app req resp @@ -250,7 +250,7 @@ -- update client of removed subscription send (WSTopicRemoved topic) - liftIO $ killOnOpenThread env sessionID topic+ liftIO $ killOnOpenThreads env sessionID topic WSIncoming (WithTopic topic x) -> do mEff <- liftIO $ atomically $ getCallReceive env sessionID topic x
src/Web/Dependencies/Sparrow/Server/Types.hs view
@@ -34,8 +34,8 @@ , callOnUnsubscribe , callAllOnUnsubscribe , -- ** Thread Management- registerOnOpenThread- , killOnOpenThread+ registerOnOpenThreads+ , killOnOpenThreads , killAllOnOpenThreads , -- ** Bookkeeping unregisterReceive@@ -203,18 +203,20 @@ pure effs sequenceA_ effs + type RegisteredOnOpenThreads =- TVar (HashMap SessionID (HashMap Topic (Async ())))+ TVar (HashMap SessionID (HashMap Topic [Async ()])) -registerOnOpenThread :: Env m -> SessionID -> Topic -> Async () -> STM ()-registerOnOpenThread Env{envRegisteredOnOpenThreads} sID topic thread = do++registerOnOpenThreads :: Env m -> SessionID -> Topic -> [Async ()] -> STM ()+registerOnOpenThreads Env{envRegisteredOnOpenThreads} sID topic thread = do xs <- readTVar envRegisteredOnOpenThreads let topics = fromMaybe HM.empty (HM.lookup sID xs) modifyTVar' envRegisteredOnOpenThreads (HM.insert sID (HM.insert topic thread topics)) -killOnOpenThread :: MonadIO m => Env m -> SessionID -> Topic -> IO ()-killOnOpenThread Env{envRegisteredOnOpenThreads} sID topic = do+killOnOpenThreads :: MonadIO m => Env m -> SessionID -> Topic -> IO ()+killOnOpenThreads Env{envRegisteredOnOpenThreads} sID topic = do mThread <- atomically $ do xs <- readTVar envRegisteredOnOpenThreads case HM.lookup sID xs of@@ -225,7 +227,7 @@ pure x case mThread of Nothing -> pure ()- Just thread -> cancel thread+ Just threads -> mapM_ cancel threads killAllOnOpenThreads :: MonadIO m => Env m -> SessionID -> IO ()@@ -238,7 +240,7 @@ let x = HM.elems topics modifyTVar' envRegisteredOnOpenThreads (HM.delete sID) pure x- forM_ threads cancel+ forM_ (concat threads) cancel data Env m = Env