module System.Taffybar.FreedesktopNotifications (
Notification(..),
NotificationConfig(..),
notifyAreaNew,
defaultNotificationConfig
) where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad ( forever )
import Control.Monad.Trans ( liftIO )
import Data.Int ( Int32 )
import Data.Map ( Map )
import Data.Monoid ( mconcat )
import qualified Data.Sequence as S
import Data.Sequence ( Seq, (|>), viewl, ViewL(..) )
import Data.Text ( Text )
import qualified Data.Text as T
import Data.Word ( Word32 )
import DBus
import DBus.Client
import Graphics.UI.Gtk hiding ( Variant )
data Notification = Notification { noteAppName :: Text
, noteReplaceId :: Word32
, noteSummary :: Text
, noteBody :: Text
, noteExpireTimeout :: Int32
, noteId :: Word32
}
deriving (Show, Eq)
data NotifyState = NotifyState { noteWidget :: Label
, noteContainer :: Widget
, noteConfig :: NotificationConfig
, noteQueue :: TVar (Seq Notification)
, noteIdSource :: TVar Word32
, noteCurrent :: TVar (Maybe Notification)
, noteChan :: Chan ()
}
initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState
initialNoteState wrapper l cfg = do
m <- newTVarIO 1
q <- newTVarIO S.empty
c <- newTVarIO Nothing
ch <- newChan
return NotifyState { noteQueue = q
, noteIdSource = m
, noteWidget = l
, noteContainer = wrapper
, noteCurrent = c
, noteConfig = cfg
, noteChan = ch
}
getServerInformation :: IO (Text, Text, Text, Text)
getServerInformation =
return ("haskell-notification-daemon",
"nochair.net",
"0.0.1",
"1.1")
getCapabilities :: IO [Text]
getCapabilities = return ["body", "body-markup"]
nextNotification :: NotifyState -> STM ()
nextNotification s = do
q <- readTVar (noteQueue s)
case viewl q of
EmptyL -> do
writeTVar (noteCurrent s) Nothing
next :< rest -> do
writeTVar (noteQueue s) rest
writeTVar (noteCurrent s) (Just next)
closeNotification :: NotifyState -> Word32 -> IO ()
closeNotification istate nid = do
atomically $ do
modifyTVar' (noteQueue istate) removeNote
curNote <- readTVar (noteCurrent istate)
case curNote of
Nothing -> return ()
Just cnote
| noteId cnote /= nid -> return ()
| otherwise ->
nextNotification istate
wakeupDisplayThread istate
where
removeNote = S.filter (\n -> noteId n /= nid)
formatMessage :: NotifyState -> Notification -> String
formatMessage s = take maxlen . fmt
where
maxlen = notificationMaxLength $ noteConfig s
fmt = notificationFormatter $ noteConfig s
notify :: NotifyState
-> Text
-> Word32
-> Text
-> Text
-> Text
-> [Text]
-> Map Text Variant
-> Int32
-> IO Word32
notify istate appName replaceId _ summary body _ _ timeout = do
nid <- atomically $ do
tid <- readTVar idsrc
modifyTVar' idsrc (+1)
return tid
let realId = if replaceId == 0 then fromIntegral nid else replaceId
n = Notification { noteAppName = appName
, noteReplaceId = replaceId
, noteSummary = escapeText summary
, noteBody = escapeText body
, noteExpireTimeout = tout
, noteId = realId
}
dn <- atomically $ do
modifyTVar' (noteQueue istate) (replaceNote n)
cnote <- readTVar (noteCurrent istate)
case cnote of
Nothing -> do
writeTVar (noteCurrent istate) (Just n)
return (Just n)
Just curNote
| noteId curNote == realId -> do
writeTVar (noteCurrent istate) (Just n)
return (Just n)
| otherwise -> do
modifyTVar' (noteQueue istate) (|>n)
return Nothing
case dn of
Nothing -> return ()
Just _ -> wakeupDisplayThread istate
return realId
where
replaceNote newNote = fmap (\n -> if noteId n == noteReplaceId newNote then newNote else n)
idsrc = noteIdSource istate
escapeText = T.pack . escapeMarkup . T.unpack
maxtout = fromIntegral $ notificationMaxTimeout (noteConfig istate)
tout = case timeout of
0 -> maxtout
(1) -> maxtout
_ -> min maxtout timeout
notificationDaemon :: (AutoMethod f1, AutoMethod f2)
=> f1 -> f2 -> IO ()
notificationDaemon onNote onCloseNote = do
client <- connectSession
_ <- requestName client "org.freedesktop.Notifications" [nameAllowReplacement, nameReplaceExisting]
export client "/org/freedesktop/Notifications"
[ autoMethod "org.freedesktop.Notifications" "GetServerInformation" getServerInformation
, autoMethod "org.freedesktop.Notifications" "GetCapabilities" getCapabilities
, autoMethod "org.freedesktop.Notifications" "CloseNotification" onCloseNote
, autoMethod "org.freedesktop.Notifications" "Notify" onNote
]
wakeupDisplayThread :: NotifyState -> IO ()
wakeupDisplayThread s = writeChan (noteChan s) ()
displayThread :: NotifyState -> IO ()
displayThread s = forever $ do
_ <- readChan (noteChan s)
cur <- atomically $ readTVar (noteCurrent s)
case cur of
Nothing -> postGUIAsync (widgetHideAll (noteContainer s))
Just n -> postGUIAsync $ do
labelSetMarkup (noteWidget s) (formatMessage s n)
widgetShowAll (noteContainer s)
startTimeoutThread s n
startTimeoutThread :: NotifyState -> Notification -> IO ()
startTimeoutThread s n = do
_ <- forkIO $ do
let seconds = noteExpireTimeout n
threadDelay (fromIntegral seconds * 1000000)
atomically $ do
curNote <- readTVar (noteCurrent s)
case curNote of
Nothing -> return ()
Just cnote
| cnote /= n -> return ()
| otherwise ->
nextNotification s
wakeupDisplayThread s
return ()
data NotificationConfig =
NotificationConfig { notificationMaxTimeout :: Int
, notificationMaxLength :: Int
, notificationFormatter :: Notification -> String
}
defaultFormatter :: Notification -> String
defaultFormatter note = msg
where
msg = case T.null (noteBody note) of
True -> T.unpack $ noteSummary note
False -> T.unpack $ mconcat [ "<span fgcolor='yellow'>Note:</span>"
, noteSummary note, ": ", noteBody note ]
defaultNotificationConfig :: NotificationConfig
defaultNotificationConfig =
NotificationConfig { notificationMaxTimeout = 10
, notificationMaxLength = 100
, notificationFormatter = defaultFormatter
}
notifyAreaNew :: NotificationConfig -> IO Widget
notifyAreaNew cfg = do
frame <- frameNew
box <- hBoxNew False 3
textArea <- labelNew (Nothing :: Maybe String)
button <- eventBoxNew
sep <- vSeparatorNew
bLabel <- labelNew (Nothing :: Maybe String)
widgetSetName bLabel ("NotificationCloseButton" :: String)
labelSetMarkup bLabel ("×" :: String)
labelSetMaxWidthChars textArea (notificationMaxLength cfg)
labelSetEllipsize textArea EllipsizeEnd
containerAdd button bLabel
boxPackStart box textArea PackGrow 0
boxPackStart box sep PackNatural 0
boxPackStart box button PackNatural 0
containerAdd frame box
widgetHideAll frame
istate <- initialNoteState (toWidget frame) textArea cfg
_ <- on button buttonReleaseEvent (userCancel istate)
realizableWrapper <- hBoxNew False 0
boxPackStart realizableWrapper frame PackNatural 0
widgetShow realizableWrapper
_ <- on realizableWrapper realize $ do
_ <- forkIO (displayThread istate)
notificationDaemon (notify istate) (closeNotification istate)
return (toWidget realizableWrapper)
where
userCancel s = do
liftIO $ do
atomically $ nextNotification s
wakeupDisplayThread s
return True