Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
A freedesktop notification plugin for xmobar
{-# LANGUAGE OverloadedStrings, RankNTypes, KindSignatures, FlexibleContexts #-}
module Plugins.NotificationDaemon where
-- xmobar plugin API
import Plugins
import DBus.Bus
import DBus.Client
import DBus.Constants
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.MVar
import Control.Monad (unless, forever)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans (liftIO)
import Data.Int (Int32)
import Data.Maybe (fromMaybe)
import Data.String (IsString)
import Data.Word (Word32)
-- Tweakable stuff. The formatting color could be extracted out into
-- a configuration option
buildMessage :: Notification -> [Char]
buildMessage itm = noteSummary itm ++ body
where body = case noteBody itm of
"" -> ""
body' -> " / " ++ body'
formatMessage :: forall a. (IsString [a]) => [a] -> [a]
formatMessage itm = "<fc=#FFFF00>" ++ itm ++ "</fc>"
type NotificationState = MVar EventState
data Notification = Notification { noteAppName :: String
, noteReplaceId :: Word32
, noteSummary :: String
, noteBody :: String
, noteExpireTimeout :: Int32
}
deriving (Show, Eq)
data EventToken = EventToken deriving (Show)
data EventState = EventState { notifyQueue :: Queue Notification
, notifyIdSource :: Word32
}
deriving (Show)
-- Arguments are: Max Message Len (chars), Animation Timestep (ms),
-- Max note timeout (ms), Def note timeout (ms)
data NotificationDaemon = NotificationDaemon Int32 Int32 Int32 Int32
deriving (Show, Read)
instance Exec NotificationDaemon where
alias _ = "NotificationDaemon"
start conf cb = daemonMain conf cb
-- This implementation of the Freedesktop Notification Spec
-- (apparently not a formal one) complies to version 1.1 of the spec:
-- http://people.canonical.com/~agateau/notifications-1.1/spec/index.html
daemonInterface:: NotificationState -> MVar Bool -> Int32 -> Int32 -> Object
daemonInterface state box maxTimeout defTimeout =
object [ ("org.freedesktop.Notifications",
interface [ ("GetServerInformation", getServerInformation)
, ("GetCapabilities", getCapabilities)
, ("CloseNotification", closeNotification state)
, ("Notify", notify state box maxTimeout defTimeout)
])
]
getServerInformation :: Member
getServerInformation = method "" "ssss" $ \ctx -> replyReturn ctx retVal
where appName = "notibar" :: String
vendorName = "nochair.net" :: String
versionNumber = "0.0.1" :: String
specNumber = "1.1" :: String
retVal = [ toVariant appName
, toVariant vendorName
, toVariant versionNumber
, toVariant specNumber
]
getCapabilities :: Member
getCapabilities = method "" "as" $ \ctx -> case arr of
Just a -> replyReturn ctx [ toVariant a ]
Nothing -> replyError ctx errorFailed [toVariant errMsg]
where bodyCap = "body" :: String
markupCap = "body-markup" :: String
arr = arrayFromItems DBusString [ toVariant bodyCap, toVariant markupCap ]
errMsg :: String
errMsg = "Could not construct return array"
-- This implementation of CloseNotification is not quite correct. It
-- will not close an active notification, just remove pending ones
-- from the queue. This is not a big deal since this implementation
-- does not support notifications with unlimited lifetimes.
closeNotification :: NotificationState -> Member
closeNotification state = method "u" "" $ \ctx -> do
let [ arg ] = methodCtxBody ctx
msgId :: Word32
msgId = fromMaybe 0 $ fromVariant arg
if msgId > 0
then tryRemoveNote ctx msgId
else replyError ctx errorFailed []
where tryRemoveNote ctx msgId = do
removedNote <- removeNoteById state msgId
unless removedNote (replyError ctx errorFailed [])
notify :: NotificationState -> MVar Bool -> Int32 -> Int32 -> Member
notify state box maxTimeout defTimeout = method "susssasa{sv}i" "u" $ \ctx -> do
-- Ignore icon, actions, and hints
let [ appName_, replaceId_, _, summary_, body_, _, _, expireTimeout_ ] = methodCtxBody ctx
appName :: String
appName = fromMaybe "" $ fromVariant appName_
replaceId :: Word32
replaceId = fromMaybe 0 $ fromVariant replaceId_
summary :: String
summary = fromMaybe "" $ fromVariant summary_
body :: String
body = fromMaybe "" $ fromVariant body_
expireTimeout :: Int32
expireTimeout = boundTimeout $ fromMaybe (-1) $ fromVariant expireTimeout_
-- If the replace_id was zero in the message, we have to generate
-- one to send back.
replaceId' <- case replaceId of
0 -> liftIO $ getNextReplaceId state
other -> return other
let note = Notification { noteAppName = appName
, noteReplaceId = replaceId'
, noteSummary = summary
, noteBody = body
, noteExpireTimeout = expireTimeout
}
-- Atomically enqueue a new notification
addNote state note
-- Wake the other thread up to make it start processing
-- notifications. If there is already a token in the box, the other
-- thread will wake up eventually. We don't need to put more since
-- state is actually tracked in the queue
liftIO $ tryPutMVar box True
-- Give the sender the ID we assigned to this notification
replyReturn ctx [ toVariant replaceId' ]
where boundTimeout :: Int32 -> Int32
boundTimeout t =
if t <= 0 || t > maxTimeout
then defTimeout
else t
-- Stub to initialize the notification service. Claim the appropriate
-- names on the session bus and export the notification objects.
notificationDaemon :: NotificationState -> MVar Bool -> Int32 -> Int32 -> DBus ()
notificationDaemon state box maxTimeout defTimeout = do
_ <- requestName "org.freedesktop.Notifications" []
(\_ -> liftIO $ putStrLn "There is a Notification daemon already running")
(\_ -> return ())
export "/org/freedesktop/Notifications" iface
-- Just wait forever, processing events
mainLoop
where iface = daemonInterface state box maxTimeout defTimeout
-- Helper to get the next notification identifier atomically from the
-- MVar
getNextReplaceId :: NotificationState -> IO Word32
getNextReplaceId state = modifyMVar state $ \val -> do
let thisId = notifyIdSource val
return (val { notifyIdSource = thisId + 1 }, thisId)
-- Helper to atomically add a notification to the MVar
addNote :: forall (m :: * -> *). (MonadIO m) => NotificationState -> Notification -> m ()
addNote state note = liftIO $ modifyMVar_ state $ \val -> do
let currentNotes = notifyQueue val
return val { notifyQueue = enqueue note currentNotes }
-- Helper to remove the notification with the given ID from the queue.
-- Note: This is not an entirely compliant implementation because it
-- will only remove enqueued notifications - not active ones. In
-- principle this is possible but not really worth the effort
-- (especially since this implementation does not allow notifications
-- to have unbounded lifetimes). Returns True if the notification was
-- still active.
removeNoteById :: forall (m :: * -> *). (MonadIO m) => NotificationState -> Word32 -> m Bool
removeNoteById state ident = liftIO $ modifyMVar state $ \val -> do
let currentNotes = notifyQueue val
remainingNotes = filterQueue ((==ident) . noteReplaceId) currentNotes
return (val { notifyQueue = remainingNotes }, currentNotes == remainingNotes)
waitForNotifications :: forall a a1. ([Char] -> IO a) -> NotificationState -> MVar a1 -> Int -> Int -> IO ()
waitForNotifications callback state mbox maxMsgLen aniTimeStep = do
-- This will block until this thread has something to do (the DBus
-- daemon thread enqueued a notification)
_ <- takeMVar mbox
-- For each item in the queue:
-- 1) Dequeue it
-- 2) Use the callback function to display it
-- 3) Wait for the prescribed timeout
-- 4) Goto 1 unless the queue is empty
showNotifications
where showNotifications = do
-- Atomically take an item off of the queue. The dbus
-- thread can't modify it from under us because it also uses
-- modify (instead of put)
itm <- modifyMVar state mdequeue
case itm of
-- Break the recursion and go back to waiting on the mailbox
Nothing -> return ()
-- Update the message and sleep for the required time,
-- then recursively call this method to get the next note
Just itm' -> postAndWait itm' >> showNotifications
-- Helper to dequeue through the MVar
mdequeue state' = do
let q = notifyQueue state'
case dequeue q of
Nothing -> return (state', Nothing)
Just (itm, q') -> return (state' { notifyQueue = q' }, Just itm)
postAndWait itm = do
if length msg < maxMsgLen
then displayMessage msg timeout
else animateMessage msgWindow timeout
-- Clear the message after a delay
callback ""
where msg = buildMessage itm
timeout = fromIntegral $ noteExpireTimeout itm
msgWindow = makeMessageWindow msg maxMsgLen
-- Display a message until the timeout
displayMessage msg timeout = do
callback $ formatMessage msg
threadDelay $ 1000 * timeout
-- Display the message scrolling back and forth if it is long.
-- This uses the message window code.
animateMessage msgWindow timeout
| timeout <= 0 = return ()
| otherwise = do
callback $ formatMessage $ show msgWindow
threadDelay $ 1000 * aniTimeStep
animateMessage (advanceMessageWindow msgWindow) (timeout - aniTimeStep)
-- Idea: The DBus thread is the producer. It will enqueue events as
-- they are received. It only needs to signal an event if the queue
-- was empty when it added the event.
-- When woken up, the Update thread (the consumer) sets a new message.
-- If the message is expire, dequeue and clear the message. If there
-- is another message still on the queue, use it to set the message
-- (but leave it there).
daemonMain :: forall a b. NotificationDaemon -> ([Char] -> IO a) -> IO b
daemonMain (NotificationDaemon msgLen timestep maxTimeout defTimeout) cb = do
-- Initially, there is no message (clear it manually so that xmobar
-- doesn't display "waiting...")
cb ""
-- Connect to the session bus
client <- newClient =<< getSessionBus
-- This MVar is used by the DBus thread to signal the display thread
-- to wake up.
mbox <- newEmptyMVar
-- Shared state between both threads, stored in an MVar
let defaultNotificationState = EventState {
notifyQueue = emptyQueue
, notifyIdSource = 1
}
state <- newMVar defaultNotificationState
-- Spawn off a thread to handle DBus notifications
forkIO $ runDBus client $ notificationDaemon state mbox maxTimeout defTimeout
-- Have this thread just wait until the DBus thread wakes it up to
-- do some display work
forever $ waitForNotifications cb state mbox (fromIntegral msgLen) (fromIntegral timestep)
-- This is a small helper "library" to manage a fixed-length window
-- into a string. Both the string and the window size are specified
-- at creation time. There is one operation: advanceWindow. This
-- function takes the window and moves it one character in the current
-- traversal direction. It manages switching the traversal direction
-- transparently when it reaches either extent of the string. Strings
-- smaller than the window size are always just returned.
data MessageScrollDirection = ScrollForward
| ScrollBackward
deriving (Show)
data MessageWindow = WindowedMessage { windowCurMsg :: String
, windowPastMsgs :: [String]
, windowSize :: Int
, windowDirection :: MessageScrollDirection
}
| TrivialMessage String
-- The show instance is trivial for strings smaller than the window
-- size. For larger strings, show just the number of characters that
-- can fit in the window.
instance Show MessageWindow where
show (TrivialMessage m) = m
show (WindowedMessage { windowCurMsg = msg, windowSize = sz }) = take sz msg
makeMessageWindow :: String -> Int -> MessageWindow
makeMessageWindow str sz = if length str > sz then wm else tm
where wm = WindowedMessage { windowCurMsg = str
, windowPastMsgs = []
, windowSize = sz
, windowDirection = ScrollForward }
tm = TrivialMessage str
-- Advance the window along the string in the current traversal
-- direction. Switch directions if the traversal reaches the "end" in
-- either direction.
advanceMessageWindow :: MessageWindow -> MessageWindow
advanceMessageWindow m@(TrivialMessage _) = m
-- Switch directions if we are going backwards and ran out of past messages.
advanceMessageWindow m@(WindowedMessage { windowCurMsg = curMsg
, windowPastMsgs = []
, windowSize = _
, windowDirection = ScrollBackward }) =
m { windowCurMsg = tail curMsg
, windowPastMsgs = [ curMsg ]
, windowDirection = ScrollForward }
-- Switch directions if we are going forwards and the current message
-- length is the window size (meaning we don't need to scroll anymore).
-- Otherwise, just keep going in the same direction
advanceMessageWindow m@(WindowedMessage { windowCurMsg = curMsg
, windowPastMsgs = pastMsgs
, windowSize = sz
, windowDirection = dir }) =
case dir of
ScrollForward -> if curLen <= sz then switchWindow else forwardWindow
ScrollBackward -> backwardWindow
where curLen = length curMsg
forwardWindow = m { windowCurMsg = tail curMsg
, windowPastMsgs = curMsg : pastMsgs
}
backwardWindow = m { windowCurMsg = head pastMsgs
, windowPastMsgs = tail pastMsgs
}
switchWindow = m { windowCurMsg = head pastMsgs
, windowPastMsgs = tail pastMsgs
, windowDirection = ScrollBackward
}
-- The trivial functional queue made up of two lists
data Queue a = Queue [a] [a]
deriving (Show, Eq)
emptyQueue :: forall a. Queue a
emptyQueue = Queue [] []
enqueue :: forall a. a -> Queue a -> Queue a
enqueue itm (Queue enq deq) = Queue (itm : enq) deq
dequeue :: forall a. Queue a -> Maybe (a, Queue a)
dequeue (Queue enq deq) =
case (enq, deq) of
([], []) -> Nothing
(_, []) -> let (itm : enq') = reverse enq in Just (itm, Queue [] enq')
(_, itm : []) -> Just (itm, Queue [] (reverse enq))
(_, itm : deq') -> Just (itm, Queue enq deq')
filterQueue :: forall a. (a -> Bool) -> Queue a -> Queue a
filterQueue p (Queue enq deq) = Queue (filter p enq) (filter p deq)
isQueueEmpty :: forall t. Queue t -> Bool
isQueueEmpty (Queue [] []) = True
isQueueEmpty _ = False

aniketd commented Jan 10, 2017

First, thanks for putting this together! New to Haskell and Xmonad. Would you have time to help me use it? https://github.com/aniketd/xmonad-config
Was wondering if you had plans to write more on how to use this, or even publish the plugin officially... Like just adding it to xmonad by default?

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment