{-# LANGUAGE OverloadedStrings #-}-- | This widget listens on DBus for freedesktop notifications-- (http://developer.gnome.org/notification-spec/). Currently it is-- somewhat ugly, but the format is somewhat configurable. A visual-- overhaul of the widget is coming.---- The widget only displays one notification at a time and-- notifications are cancellable.moduleSystem.Taffybar.FreedesktopNotifications(-- * TypesNotification(..),NotificationConfig(..),-- * ConstructornotifyAreaNew,defaultNotificationConfig)whereimportControl.ConcurrentimportControl.Monad.Trans(liftIO)importData.Int(Int32)importData.IORefimportData.Map(Map)importData.Monoid(mconcat)importqualifiedData.SequenceasSimportData.Sequence(Seq,(|>),viewl,ViewL(..))importData.Text(Text)importqualifiedData.TextasTimportData.Word(Word32)importDBus.Client.SimpleimportGraphics.UI.Gtkhiding(Variant)importWeb.Encodings(decodeHtml,encodeHtml)-- | A simple structure representing a Freedesktop notificationdataNotification=Notification{noteAppName::Text,noteReplaceId::Word32,noteSummary::Text,noteBody::Text,noteExpireTimeout::Int32,noteId::Word32}deriving(Show,Eq)dataWorkType=CancelNote(MaybeWord32)|ReplaceNoteWord32Notification|NewNote|ExpireNoteWord32dataNotifyState=NotifyState{noteQueue::MVar(SeqNotification),noteIdSource::MVarWord32,noteWorkerChan::ChanWorkType,noteWidget::Label,noteContainer::Widget,noteTimerThread::MVar(MaybeThreadId),noteConfig::NotificationConfig}initialNoteState::Widget->Label->NotificationConfig->IONotifyStateinitialNoteStatewrapperlcfg=doc<-newChanm<-newMVar1q<-newMVarS.emptyt<-newMVarNothingreturnNotifyState{noteQueue=q,noteIdSource=m,noteWorkerChan=c,noteWidget=l,noteContainer=wrapper,noteTimerThread=t,noteConfig=cfg}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"]closeNotification::NotifyState->Word32->IO()closeNotificationistatenid=do-- FIXME: filter anything with this nid out of the queue before-- posting to the queue so that the worker doesn't need to scan the-- queuewriteChan(noteWorkerChanistate)(CancelNote(Justnid))-- | Apply the user's formatter and truncate the result with the-- specified maxlen.formatMessage::NotifyState->Notification->StringformatMessages=takemaxlen.fmtwheremaxlen=notificationMaxLength$noteConfigsfmt=notificationFormatter$noteConfigsnotify::MVarInt->NotifyState->Text-- ^ Application name->Word32-- ^ Replaces id->Text-- ^ App icon->Text-- ^ Summary->Text-- ^ Body->[Text]-- ^ Actions->MapTextVariant-- ^ Hints->Int32-- ^ Expires timeout (milliseconds)->IOWord32notifyidSrcistateappNamereplaceIdiconsummarybodyactionshintstimeout=doletmaxtout=fromIntegral$notificationMaxTimeout(noteConfigistate)tout=casetimeoutof0->maxtout(-1)->maxtout_->minmaxtouttimeoutcasereplaceIdof0->donid<-modifyMVaridSrc(\x->return(x+1,x))letn=Notification{noteAppName=appName,noteReplaceId=0,noteSummary=encodeHtml$decodeHtmlsummary,noteBody=encodeHtml$decodeHtmlbody,noteExpireTimeout=tout,noteId=fromIntegralnid}modifyMVar_(noteQueueistate)(\x->return(x|>n))writeChan(noteWorkerChanistate)NewNotereturn(fromIntegralnid)i->doletn=Notification{noteAppName=appName,noteReplaceId=i,noteSummary=summary,noteBody=body,noteExpireTimeout=tout,noteId=i}-- First, replace any notes in the note queue with this note, if-- applicable. Next, notify the worker and have it replace the-- current note if that note has this id.modifyMVar_(noteQueueistate)(\q->return$fmap(replaceNotein)q)writeChan(noteWorkerChanistate)(ReplaceNotein)returnireplaceNote::Word32->Notification->Notification->NotificationreplaceNotenidnewNotecurNote=casenoteIdcurNote==nidofFalse->curNoteTrue->newNotenotificationDaemononNoteonCloseNote=doclient<-connectSession_<-requestNameclient"org.freedesktop.Notifications"[AllowReplacement,ReplaceExisting]exportclient"/org/freedesktop/Notifications"[method"org.freedesktop.Notifications""GetServerInformation"getServerInformation,method"org.freedesktop.Notifications""GetCapabilities"getCapabilities,method"org.freedesktop.Notifications""CloseNotification"onCloseNote,method"org.freedesktop.Notifications""Notify"onNote]-- When a notification is received, add it to the queue. Post a token to the channel that the-- worker blocks on.-- The worker thread should sit idle waiting on a chan read. When it-- wakes up, check to see if the current notification needs to be-- expired (due to a cancellation) or just expired on its own. If it-- expired on its own, just empty it out and post the next item in the-- queue, if any. If posting, start a thread that just calls-- theadDelay for the lifetime of the notification.workerThread::NotifyState->IO()workerThreads=docurrentNote<-newIORefNothingworkerThread'currentNotewhereworkerThread'currentNote=dowork<-readChan(noteWorkerChans)caseworkofNewNote->onNewNotecurrentNoteReplaceNotenidn->onReplaceNotecurrentNotenidnCancelNoteNothing->userCancelNotecurrentNoteCancelNotenid->doworkerThread'currentNoteExpireNotenid->expireNotecurrentNotenid-- | The user closed the notification manuallyuserCancelNotecurrentNote=dowriteIORefcurrentNoteNothingpostGUIAsync$widgetHideAll(noteContainers)showNextNoteIfAnycurrentNoteonReplaceNotecurrentNotenidn=docnote<-readIORefcurrentNotecasecnoteofNothing->dowriteIORefcurrentNote(Justn)postGUIAsync$dolabelSetMarkup(noteWidgets)(formatMessagesn)widgetShowAll(noteContainers)timerThreadId<-forkIO$setExpireTimeout(noteWorkerChans)(noteIdn)(noteExpireTimeoutn)modifyMVar_(noteTimerThreads)$const(return(JusttimerThreadId))workerThread'currentNoteJustcnote'->casenoteIdcnote'==nidof-- The replaced note was not current and it either does not-- exist or it was already replaced in the note queueFalse->workerThread'currentNote-- Otherwise, swap out the current noteTrue->dowithMVar(noteTimerThreads)(maybe(return())killThread)writeIORefcurrentNote(Justn)postGUIAsync$labelSetMarkup(noteWidgets)(formatMessagesn)timerId<-forkIO$setExpireTimeout(noteWorkerChans)(noteIdn)(noteExpireTimeoutn)modifyMVar_(noteTimerThreads)$const$return(JusttimerId)workerThread'currentNote-- | If the current note has the ID being expired, clear the-- notification area and see if there is a pending note to post.expireNotecurrentNotenid=docnote<-readIORefcurrentNotecasecnoteofNothing->showNextNoteIfAnycurrentNoteJustcnote'->casenoteIdcnote'==nidofFalse->workerThread'currentNote-- Already expiredTrue->do-- Drop the reference and clear the notification area-- before trying to show a new notewriteIORefcurrentNoteNothingpostGUIAsync$widgetHideAll(noteContainers)showNextNoteIfAnycurrentNoteonNewNotecurrentNote=domaybeCurrent<-readIORefcurrentNotecasemaybeCurrentofNothing->showNextNoteIfAnycurrentNote-- Grab the next note, show it, and then start a timerJustnote->do-- Otherwise, the current note isn't expired yet and we need-- to wait for it.workerThread'currentNote-- For use when there is no current note, attempt to show the next-- node and then block to wait for the next event. This is-- guarded by a postGUIAsync.showNextNoteIfAnynoCurrentNote=donextNote<-modifyMVar(noteQueues)takeNotecasenextNoteofNothing->workerThread'noCurrentNoteJustnextNote'->dowriteIORefnoCurrentNotenextNotepostGUIAsync$dolabelSetMarkup(noteWidgets)(formatMessagesnextNote')widgetShowAll(noteContainers)timerThreadId<-forkIO$setExpireTimeout(noteWorkerChans)(noteIdnextNote')(noteExpireTimeoutnextNote')modifyMVar_(noteTimerThreads)$const(return(JusttimerThreadId))workerThread'noCurrentNotetakeNote::Monadm=>Seqa->m(Seqa,Maybea)takeNoteq=caseviewlqofEmptyL->return(q,Nothing)n:<rest->return(rest,Justn)setExpireTimeout::ChanWorkType->Word32->Int32->IO()setExpireTimeoutcnidseconds=dothreadDelay(fromIntegralseconds*1000000)writeChanc(ExpireNotenid)userCancels=doliftIO$writeChan(noteWorkerChans)(CancelNoteNothing)returnTruedataNotificationConfig=NotificationConfig{notificationMaxTimeout::Int-- ^ Maximum time that a notification will be displayed (in seconds). Default: 10,notificationMaxLength::Int-- ^ Maximum length displayed, in characters. Default: 50,notificationFormatter::Notification->String-- ^ Function used to format notifications}defaultFormatter::Notification->StringdefaultFormatternote=msgwheremsg=caseT.null(noteBodynote)ofTrue->T.unpack$noteSummarynoteFalse->T.unpack$mconcat["<span fgcolor='yellow'>Note:</span>",noteSummarynote,": ",noteBodynote]-- | The default formatter is one of---- * Summary : Body---- * Summary---- depending on the presence of a notification body.defaultNotificationConfig::NotificationConfigdefaultNotificationConfig=NotificationConfig{notificationMaxTimeout=10,notificationMaxLength=100,notificationFormatter=defaultFormatter}-- | Create a new notification area with the given configuration.notifyAreaNew::NotificationConfig->IOWidgetnotifyAreaNewcfg=doframe<-frameNewbox<-hBoxNewFalse3textArea<-labelNewNothingbutton<-eventBoxNewsep<-vSeparatorNewbuttonLabel<-labelNewNothingwidgetSetNamebuttonLabel"NotificationCloseButton"buttonStyle<-rcGetStylebuttonLabelbuttonTextColor<-styleGetTextbuttonStyleStateNormallabelSetMarkupbuttonLabel"×"labelSetMaxWidthCharstextArea(notificationMaxLengthcfg)labelSetEllipsizetextAreaEllipsizeEndcontainerAddbuttonbuttonLabelboxPackStartboxtextAreaPackGrow0boxPackStartboxsepPackNatural0boxPackStartboxbuttonPackNatural0containerAddframeboxwidgetHideAllframeistate<-initialNoteState(toWidgetframe)textAreacfg_<-onbuttonbuttonReleaseEvent(userCancelistate)_<-forkIO(workerThreadistate)-- This is only available to the notify handler, so it doesn't need-- to be protected from the worker thread. There might be multiple-- notifiation handler threads, though (not sure), so keep it safe-- and use an mvar.idSrc<-newMVar1realizableWrapper<-hBoxNewFalse0boxPackStartrealizableWrapperframePackNatural0widgetShowrealizableWrapper-- We can't start the dbus listener thread until we are in the GTK-- main loop, otherwise things are prone to lock up and block-- infinitely on an mvar. Bad stuff - only start the dbus thread-- after the fake invisible wrapper widget is realized.onrealizableWrapperrealize$notificationDaemon(notifyidSrcistate)(closeNotificationistate)-- Don't show ib by default - it will appear when neededreturn(toWidgetrealizableWrapper)