xnobar 0.0.0.2 → 1.0.0.0
raw patch · 6 files changed
+43/−72 lines, 6 files
Files
- exe/Echo.hs +8/−11
- lib/Scroller/XNobar/Internal/Scroller.hs +1/−1
- lib/Scroller/XNobar/Scroller.hs +16/−33
- lib/Server/XNobar/Server.hs +7/−14
- lib/XNobar/XNobar.hs +3/−5
- xnobar.cabal +8/−8
exe/Echo.hs view
@@ -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
lib/Scroller/XNobar/Internal/Scroller.hs view
@@ -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
lib/Scroller/XNobar/Scroller.hs view
@@ -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*)
lib/Server/XNobar/Server.hs view
@@ -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
lib/XNobar/XNobar.hs view
@@ -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 ["<action=`xdg-open ", docUrl, "`>",+ = startServer >>= \case Right notifs -> do scroller config cb notifs+ Left reply -> cb $ unwords ["<action=`xdg-open ", docUrl, "`>", "<fc=#FF0000>", "<box type=Bottom width=3 color=red>",- "Server could not start: ", show err, "",+ "Server could not start: ", show reply, "", "</box>", "</fc>", "</action>"
xnobar.cabal view
@@ -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