module System.Taffybar.FreedesktopNotifications (
Notification(..),
NotificationConfig(..),
notifyAreaNew,
defaultNotificationConfig
) where
import Control.Concurrent
import Control.Monad.Trans ( liftIO )
import Data.Int ( Int32 )
import Data.IORef
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.Client.Simple
import Graphics.UI.Gtk hiding ( Variant )
import Web.Encodings ( decodeHtml, encodeHtml )
data Notification = Notification { noteAppName :: Text
, noteReplaceId :: Word32
, noteSummary :: Text
, noteBody :: Text
, noteExpireTimeout :: Int32
, noteId :: Word32
}
deriving (Show, Eq)
data WorkType = CancelNote (Maybe Word32)
| ReplaceNote Word32 Notification
| NewNote
| ExpireNote Word32
data NotifyState = NotifyState { noteQueue :: MVar (Seq Notification)
, noteIdSource :: MVar Word32
, noteWorkerChan :: Chan WorkType
, noteWidget :: Label
, noteContainer :: Widget
, noteTimerThread :: MVar (Maybe ThreadId)
, noteConfig :: NotificationConfig
}
initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState
initialNoteState wrapper l cfg = do
c <- newChan
m <- newMVar 1
q <- newMVar S.empty
t <- newMVar Nothing
return NotifyState { 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 ()
closeNotification istate nid = do
writeChan (noteWorkerChan istate) (CancelNote (Just nid))
formatMessage :: NotifyState -> Notification -> String
formatMessage s = take maxlen . fmt
where
maxlen = notificationMaxLength $ noteConfig s
fmt = notificationFormatter $ noteConfig s
notify :: MVar Int
-> NotifyState
-> Text
-> Word32
-> Text
-> Text
-> Text
-> [Text]
-> Map Text Variant
-> Int32
-> IO Word32
notify idSrc istate appName replaceId icon summary body actions hints timeout = do
let maxtout = fromIntegral $ notificationMaxTimeout (noteConfig istate)
tout = case timeout of
0 -> maxtout
(1) -> maxtout
_ -> min maxtout timeout
case replaceId of
0 -> do
nid <- modifyMVar idSrc (\x -> return (x+1, x))
let n = Notification { noteAppName = appName
, noteReplaceId = 0
, noteSummary = encodeHtml $ decodeHtml summary
, noteBody = encodeHtml $ decodeHtml body
, noteExpireTimeout = tout
, noteId = fromIntegral nid
}
modifyMVar_ (noteQueue istate) (\x -> return (x |> n))
writeChan (noteWorkerChan istate) NewNote
return (fromIntegral nid)
i -> do
let n = Notification { noteAppName = appName
, noteReplaceId = i
, noteSummary = summary
, noteBody = body
, noteExpireTimeout = tout
, noteId = i
}
modifyMVar_ (noteQueue istate) (\q -> return $ fmap (replaceNote i n) q)
writeChan (noteWorkerChan istate) (ReplaceNote i n)
return i
replaceNote :: Word32 -> Notification -> Notification -> Notification
replaceNote nid newNote curNote =
case noteId curNote == nid of
False -> curNote
True -> newNote
notificationDaemon onNote onCloseNote = do
client <- connectSession
_ <- requestName client "org.freedesktop.Notifications" [AllowReplacement, ReplaceExisting]
export client "/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
]
workerThread :: NotifyState -> IO ()
workerThread s = do
currentNote <- newIORef Nothing
workerThread' currentNote
where
workerThread' currentNote = do
work <- readChan (noteWorkerChan s)
case work of
NewNote -> onNewNote currentNote
ReplaceNote nid n -> onReplaceNote currentNote nid n
CancelNote Nothing -> userCancelNote currentNote
CancelNote nid -> do
workerThread' currentNote
ExpireNote nid -> expireNote currentNote nid
userCancelNote currentNote = do
writeIORef currentNote Nothing
postGUIAsync $ widgetHideAll (noteContainer s)
showNextNoteIfAny currentNote
onReplaceNote currentNote nid n = do
cnote <- readIORef currentNote
case cnote of
Nothing -> do
writeIORef currentNote (Just n)
postGUIAsync $ do
labelSetMarkup (noteWidget s) (formatMessage s n)
widgetShowAll (noteContainer s)
timerThreadId <- forkIO $ setExpireTimeout (noteWorkerChan s) (noteId n) (noteExpireTimeout n)
modifyMVar_ (noteTimerThread s) $ const (return (Just timerThreadId))
workerThread' currentNote
Just cnote' -> case noteId cnote' == nid of
False -> workerThread' currentNote
True -> do
withMVar (noteTimerThread s) (maybe (return ()) killThread)
writeIORef currentNote (Just n)
postGUIAsync $ labelSetMarkup (noteWidget s) (formatMessage s n)
timerId <- forkIO $ setExpireTimeout (noteWorkerChan s) (noteId n) (noteExpireTimeout n)
modifyMVar_ (noteTimerThread s) $ const $ return (Just timerId)
workerThread' currentNote
expireNote currentNote nid = do
cnote <- readIORef currentNote
case cnote of
Nothing -> showNextNoteIfAny currentNote
Just cnote' ->
case noteId cnote' == nid of
False -> workerThread' currentNote
True -> do
writeIORef currentNote Nothing
postGUIAsync $ widgetHideAll (noteContainer s)
showNextNoteIfAny currentNote
onNewNote currentNote = do
maybeCurrent <- readIORef currentNote
case maybeCurrent of
Nothing -> showNextNoteIfAny currentNote
Just note -> do
workerThread' currentNote
showNextNoteIfAny noCurrentNote = do
nextNote <- modifyMVar (noteQueue s) takeNote
case nextNote of
Nothing -> workerThread' noCurrentNote
Just nextNote' -> do
writeIORef noCurrentNote nextNote
postGUIAsync $ do
labelSetMarkup (noteWidget s) (formatMessage s nextNote')
widgetShowAll (noteContainer s)
timerThreadId <- forkIO $ setExpireTimeout (noteWorkerChan s) (noteId nextNote') (noteExpireTimeout nextNote')
modifyMVar_ (noteTimerThread s) $ const (return (Just timerThreadId))
workerThread' noCurrentNote
takeNote :: Monad m => Seq a -> m (Seq a, Maybe a)
takeNote q =
case viewl q of
EmptyL -> return (q, Nothing)
n :< rest -> return (rest, Just n)
setExpireTimeout :: Chan WorkType -> Word32 -> Int32 -> IO ()
setExpireTimeout c nid seconds = do
threadDelay (fromIntegral seconds * 1000000)
writeChan c (ExpireNote nid)
userCancel s = do
liftIO $ writeChan (noteWorkerChan s) (CancelNote Nothing)
return True
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
button <- eventBoxNew
sep <- vSeparatorNew
buttonLabel <- labelNew Nothing
widgetSetName buttonLabel "NotificationCloseButton"
buttonStyle <- rcGetStyle buttonLabel
buttonTextColor <- styleGetText buttonStyle StateNormal
labelSetMarkup buttonLabel "×"
labelSetMaxWidthChars textArea (notificationMaxLength cfg)
labelSetEllipsize textArea EllipsizeEnd
containerAdd button buttonLabel
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)
_ <- forkIO (workerThread istate)
idSrc <- newMVar 1
realizableWrapper <- hBoxNew False 0
boxPackStart realizableWrapper frame PackNatural 0
widgetShow realizableWrapper
on realizableWrapper realize $ notificationDaemon (notify idSrc istate) (closeNotification istate)
return (toWidget realizableWrapper)