diff --git a/exe/Echo.hs b/exe/Echo.hs --- a/exe/Echo.hs +++ b/exe/Echo.hs @@ -1,19 +1,16 @@ import Control.Exception (finally) import Control.Monad (forever) -import XNobar.Internal.Scroller -import XNobar.Server -import Xmobar (tenthSeconds) +import XNobar.Internal.Scroller () -- import Show instance for XNobar.Internal.Notification.Notification +import XNobar.Server (fetch, startServer) +import Control.Concurrent (threadDelay) main :: IO () main = do putStrLn "Starting the server" - startServer >>= \case Left err -> print err - Right (notifs, stopServer) -> do + startServer >>= \case Left reply -> print reply + Right notifs -> do putStrLn "Fetching notifications" - (forever $ do + forever $ do ns <- fetch notifs - tenthSeconds 1 - print $ (show . snd) <$> ns) - -- TODO: even without this, I observe the exact same behavior - -- `finally` do putStrLn "Stopping the server" - -- stopServer + threadDelay 100000 + print $ show . snd <$> ns diff --git a/lib/Scroller/XNobar/Internal/Scroller.hs b/lib/Scroller/XNobar/Internal/Scroller.hs --- a/lib/Scroller/XNobar/Internal/Scroller.hs +++ b/lib/Scroller/XNobar/Internal/Scroller.hs @@ -40,7 +40,7 @@ then (i', o + 1, notifs) else (i'', 0, notifs)) -enableClick p ((Max i, u), s) = attachAction ("echo " ++ show i ++ " > " ++ p) +enableClick p ((Max i, u), s) = attachAction ("echo -n " ++ show i ++ " > " ++ p) 1 ((if u == 2 then red else id) s) where diff --git a/lib/Scroller/XNobar/Scroller.hs b/lib/Scroller/XNobar/Scroller.hs --- a/lib/Scroller/XNobar/Scroller.hs +++ b/lib/Scroller/XNobar/Scroller.hs @@ -5,31 +5,37 @@ import Control.Exception (finally) import Control.Monad (forever, when) import Control.Monad.State.Strict (evalStateT, get, liftIO, modify') -import Data.IORef (atomicModifyIORef', newIORef, readIORef, IORef) +import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.Maybe (fromJust, isJust, maybe) import Flow ((.>)) +import GHC.IO.Handle.FD (withFileBlocking) import System.Directory (removeFile) -import System.Exit (ExitCode(..)) +import System.IO (IOMode(ReadMode), hGetContents') import System.Process (readProcessWithExitCode) -import Xmobar (tenthSeconds) import XNobar.Internal.Notification (makeId) import XNobar.Internal.Scroller (onlyIf, remove, merge, scroll, showNotifs, Config(..)) import XNobar.Server (NotificationsRef, fetch) -import Control.Monad.IO.Class (MonadIO) +import Control.Concurrent (threadDelay) scroller :: Config -> (String -> IO ()) -> NotificationsRef -> IO () -scroller config@(Config{..}) callback notifs - = withIOState (\clicked pipe -> const $ evalStateT (forever (update clicked pipe)) Nothing) +scroller config@(Config{..}) callback notifs = do + clicked <- newIORef Nothing + (_, n, _) <- readProcessWithExitCode "uuidgen" [] "" + let pipe = "/tmp/xnobar-" ++ removeLinebreak n where removeLinebreak = init + (_, _, _) <- readProcessWithExitCode "mkfifo" [pipe] "" + withAsync (forever $ do out <- withFileBlocking pipe ReadMode hGetContents' + atomicModifyIORef' clicked (const (Just out, ()))) + (const $ evalStateT (forever (update clicked pipe)) Nothing) + `finally` removeFile pipe where - removeLinebreak = init update clicked pipe = do newNotifs <- liftIO $ fetch notifs - clicked' <- readIOState clicked + clicked' <- liftIO $ readIORef clicked - when (isJust clicked') $ clearIOState clicked + when (isJust clicked') $ liftIO $ clear clicked modify' $ onlyIf (isJust clicked') (remove (getId $ fromJust clicked')) @@ -44,27 +50,4 @@ where clear = (`atomicModifyIORef'` const (Nothing, ())) getId = makeId . read - -newtype IOState a = IOState (IORef a) - -readIOState :: MonadIO m => IOState a -> m a -readIOState (IOState ref) = liftIO $ readIORef ref - -clearIOState :: (MonadIO m, Monoid a) => IOState a -> m () -clearIOState (IOState ref) = liftIO $ clear ref - where - clear = (`atomicModifyIORef'` const (mempty, ())) - -withIOState f = do - clicked <- newIORef Nothing - (_, n, _) <- readProcessWithExitCode "uuidgen" [] "" - let pipe = "/tmp/xnobar-" ++ removeLinebreak n - (_, _, _) <- readProcessWithExitCode "mkfifo" [pipe] "" - withAsync (forever $ do (ret, out, _) <- readProcessWithExitCode "cat" [pipe] "" - case ret of - ExitSuccess -> atomicModifyIORef' clicked (const (Just (removeLinebreak out), ())) - ExitFailure _ -> error "how is this possible?") - (f (IOState clicked) pipe) - `finally` removeFile pipe - where - removeLinebreak = init + tenthSeconds = threadDelay . (100000*) diff --git a/lib/Server/XNobar/Server.hs b/lib/Server/XNobar/Server.hs --- a/lib/Server/XNobar/Server.hs +++ b/lib/Server/XNobar/Server.hs @@ -63,19 +63,19 @@ -- via 'fetch', atomically emptying the reference at the same time. newtype NotificationsRef = NotificationsRef { notifs :: IORef NotificationsById } --- |Action that starts a notification server and returns maybe a mutable --- reference to the notifications (or nothing if the server could not start for --- any reason). +-- |Action that starts a notification server and returns either a mutable +-- reference to the notifications, or the reply to the request of the name if +-- the server could not start for any reason. -- -- @ -- maybeNotifs <- startServer -- case of maybeNotifs --- Just notifs -> -- server has started and notitifcations will be pushed on notifs as they come --- Nothing -> -- some error occurred and the server could not start +-- Right notifs -> -- server has started and notitifcations will be pushed on notifs as they come +-- Left reply -> -- some error occurred and the server could not start -- @ -- -- The caller can interact with the notitications only via 'fetch'. -startServer :: IO (Either RequestNameReply (NotificationsRef, IO ())) +startServer :: IO (Either RequestNameReply NotificationsRef) startServer = do client <- connectSession let busName = "org.freedesktop.Notifications" @@ -91,11 +91,8 @@ makeMethod "Notify" (signature_ notifyInSig) (signature_ notifyOutSig) (notify notifications) ] } - let revoke = do unexport client objPath - releaseName client busName - disconnect client return $ if reply == NamePrimaryOwner - then Right (notifications, revoke) + then Right notifications else Left reply where initNotifs :: IO NotificationsRef @@ -118,10 +115,6 @@ then get else return (makeId reqId, error "This should not be used") when (reqId == 0) $ modify' (bimap succ succ) - -- This function is run everytime by a different Haskell thread, whereas `scroller` runs - -- always on the same thread (because it's never ending, essentially). Anyway, they are - -- different threads. I wonder if a better approach than appending to an immutable list, - -- thus having to create a new one everytime, would be to use a channel liftIO $ append ns (assignedId, notif) return $ ReplyReturn [toVariant $ getMax $ toWord32 assignedId] where diff --git a/lib/XNobar/XNobar.hs b/lib/XNobar/XNobar.hs --- a/lib/XNobar/XNobar.hs +++ b/lib/XNobar/XNobar.hs @@ -57,13 +57,11 @@ instance Exec Config where alias _ = "XNobar" start config cb - = startServer >>= \case Right (notifs, stopServer) -> do scroller config cb notifs - `finally` - stopServer - Left err -> cb $ unwords ["", + = startServer >>= \case Right notifs -> do scroller config cb notifs + Left reply -> cb $ unwords ["", "", "", - "Server could not start: ", show err, "", + "Server could not start: ", show reply, "", "", "", "" diff --git a/xnobar.cabal b/xnobar.cabal --- a/xnobar.cabal +++ b/xnobar.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: xnobar -version: 0.0.0.2 +version: 1.0.0.0 maintainer: Enrico Maria De Angelis homepage: https://codeberg.org/Aster89/xnobar synopsis: Text-based notification server for XMobar @@ -29,7 +29,7 @@ import: common build-depends: xnobar:Server , xnobar:Scroller - , xmobar + , xmobar >= 0.48.1 && <= 0.51 hs-source-dirs: exe main-is: Echo.hs @@ -49,8 +49,8 @@ import: common exposed-modules: XNobar.Internal.Notification build-depends: containers >= 0.6.8 && < 0.9 - , dbus - , flow + , dbus >= 1.3.6 && < 1.5 + , flow >= 2.0.0 && < 2.1 , xnobar:Positive32 hs-source-dirs: lib/Notification @@ -59,11 +59,11 @@ exposed-modules: XNobar.Scroller, XNobar.Internal.Scroller build-depends: async >= 2.2.5 && < 2.3 , directory >= 1.3.8 && < 1.4 - , extra - , flow + , extra >= 1.7.16 && <= 1.8 + , flow >= 2.0.0 && < 2.1 , mtl >= 2.3.1 && < 2.4 , process >= 1.6.18 && < 1.7 - , xmobar + , xmobar >= 0.48.1 && <= 0.51 , xnobar:Notification , xnobar:Positive32 , xnobar:Server @@ -79,7 +79,7 @@ type: exitcode-stdio-1.0 main-is: Main.hs build-depends: QuickCheck - , extra + , extra >= 1.7.16 && <= 1.8 , xnobar:Notification , xnobar:Positive32 , xnobar:Scroller