diff --git a/package.yaml b/package.yaml index 24c033f065c884f386af724cdc7e291f6e06f9ec..5de395d906fa9843d7d605eaa08e1c1a83a9606b 100644 --- a/package.yaml +++ b/package.yaml @@ -38,6 +38,7 @@ dependencies: - pipes-concurrency - pipes-network - pipes-parse +- pipes-safe - stm - text - time diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs index 83cff690a605493f10fa557c8d5bcb9f0bee4614..711ec049cd11cc92e4850598424139528d12d0c0 100644 --- a/src/QBar/Core.hs +++ b/src/QBar/Core.hs @@ -7,7 +7,7 @@ import QBar.BlockText import Control.Exception (catch, finally, IOException) import Control.Monad (forever) -import Control.Monad.Reader (ReaderT, runReaderT, ask, asks) +import Control.Monad.Reader (ReaderT, runReaderT, ask) import Control.Concurrent (threadDelay) import Control.Concurrent.Async import Control.Concurrent.Event as Event @@ -22,6 +22,7 @@ import qualified Data.Text.Lazy.Encoding as E import qualified Data.Text.Lazy.IO as TIO import Pipes import Pipes.Concurrent +import Pipes.Safe (SafeT, runSafeT) import qualified Pipes.Prelude as PP import System.Exit import System.IO @@ -71,7 +72,7 @@ instance IsBlockMode CachedMode where exitBlock = return CachedMode -type BarIO = ReaderT Bar IO +type BarIO = SafeT (ReaderT Bar IO) data Bar = Bar { requestBarUpdate :: IO (), @@ -89,7 +90,10 @@ type BarUpdateEvent = Event.Event runBarIO :: Bar -> BarIO r -> IO r -runBarIO bar action = runReaderT action bar +runBarIO bar action = runReaderT (runSafeT action) bar + +askBar :: BarIO Bar +askBar = lift ask createBlock :: BlockText -> BlockOutput createBlock text = BlockOutput @@ -153,7 +157,7 @@ sharedInterval seconds = do liftIO $ threadDelay $ seconds * 1000000 -- Updates all client blocks -- If send returns 'False' the clients mailbox has been closed, so it is removed - bar <- ask + bar <- askBar liftIO $ modifyMVar_ clientsMVar $ fmap catMaybes . mapConcurrently (\r -> runBarIO bar $ runAndFilterClient r) -- Then update the bar updateBar @@ -168,9 +172,9 @@ sharedInterval seconds = do return $ if result then Just client else Nothing runClient :: (MVar PullBlock, Output (Maybe BlockOutput)) -> BarIO Bool runClient (blockProducerMVar, output) = do - bar <- ask + bar <- askBar liftIO $ modifyMVar blockProducerMVar $ \blockProducer -> do - result <- runReaderT (next blockProducer) bar + result <- runReaderT (runSafeT $ next blockProducer) bar case result of Left _ -> return (exitBlock, False) Right (blockOutput, blockProducer') -> do @@ -237,9 +241,9 @@ startPersistentBlockScript :: FilePath -> CachedBlock -- This is only using 'CachedBlock' because the code was already written and tested -- This could probably be massively simplified by using the new 'pushBlock' startPersistentBlockScript path = do - bar <- lift ask + bar <- lift askBar do - (output, input, seal) <- liftIO $ spawn' $ latest $ Just emptyBlock + (output, input, seal) <- liftIO $ spawn' $ latest $ Nothing initialDataEvent <- liftIO Event.new task <- liftIO $ async $ do let processConfig = setStdin closed $ setStdout createPipe $ shell path @@ -275,19 +279,19 @@ startPersistentBlockScript path = do addBlock :: IsBlock a => a -> BarIO () addBlock block = do - newBlockChan' <- asks newBlockChan + newBlockChan' <- newBlockChan <$> askBar liftIO $ atomically $ writeTChan newBlockChan' $ toCachedBlock block updateBar :: BarIO () -updateBar = liftIO =<< asks requestBarUpdate +updateBar = liftIO =<< requestBarUpdate <$> askBar updateBar' :: Bar -> IO () -updateBar' = runReaderT updateBar +updateBar' bar = runBarIO bar updateBar barAsync :: BarIO a -> BarIO (Async a) barAsync action = do - bar <- ask - lift $ async $ runReaderT action bar + bar <- askBar + liftIO $ async $ runBarIO bar action cachePushBlock :: PushBlock -> CachedBlock cachePushBlock pushBlock = lift (next pushBlock) >>= either (const exitBlock) withInitialBlock diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs index 3e554ea421da926a6624b9dde0f4865ca0aa6cd7..452b45a1fd83f43b2714c025bb42c155bca8a978 100644 --- a/src/QBar/Server.hs +++ b/src/QBar/Server.hs @@ -9,7 +9,6 @@ import QBar.BlockText import QBar.Themes import Control.Monad (forever, when, unless) -import Control.Monad.Reader (ask) import Control.Monad.STM (atomically) import Control.Concurrent (threadDelay, forkFinally) import Control.Concurrent.Async @@ -138,7 +137,7 @@ createBarUpdateChannel = do handleStdin :: MainOptions -> IORef [(T.Text, Click -> BarIO ())] -> BarIO () handleStdin options actionListIORef = do - bar <- ask + bar <- askBar liftIO $ forever $ do line <- BSSC8.hGetLine stdin @@ -169,7 +168,7 @@ handleStdin options actionListIORef = do installSignalHandlers :: BarIO () installSignalHandlers = do - bar <- ask + bar <- askBar liftIO $ void $ installHandler sigCONT (Catch (sigContAction bar)) Nothing where sigContAction :: Bar -> IO ()