Source

fdo-notify / DBus / Notify.hs

{-# LANGUAGE OverloadedStrings #-}
-- |A library for issuing notifications using FreeDesktop.org Desktop
-- Notifications protocol. This protocol is used to communicate with services
-- such as Ubuntu's NotifyOSD.
--
-- This library does not yet support receiving events relating to notifications,
-- or images in notifications: if you need that functionality please contact the maintainer.
module DBus.Notify 
    (
    -- * Usage
    -- $usage

    -- * Displaying notifications
      notify
    , replace
    , mkSessionClient
    , Client
    -- * Constructing notifications
    , blankNote
    , Note (..)
    , Body (..)
    , URL
    , Timeout (..)
    , Action (..)
    , Image
    , Category (..)
    , UrgencyLevel (..)
    , Hint (..)
    -- * Handles to displayed notifications
    , Notification
    ) where

import DBus.Message
import DBus.Client
import DBus.Bus
import DBus.Types
import Control.Applicative
import Data.Maybe (fromMaybe, fromJust)
import Data.Int
import Data.Word
import Data.Char (isLower, toLower)
import Control.Arrow (first, second, (***))

-- $usage
-- A DBUS 'Client' is needed to display notifications, so the first step is to
-- create one. The notification service will usually run on the session bus (the DBUS
-- instance responsible for messages within a desktop session) so you can use
-- 'mkSessionClient' to create the client.
--
-- To display a notification, first construct a 'Note'. This can be done in pure
-- code. Notifications can have actions, categories, etc. associated to them but
-- we will just show a simple example (these features are not supported by all
-- notification services anyway).
--
-- Use the function 'notify' to display a 'Note'. This returns a handle which
-- can be passed to 'replace' to replace a notification.
--
-- @
--import DBus.Notify
--
--main = do
--         client <- mkSessionClient
--         let startNote = appNote { summary=\"Starting\"
--                                 , body=(Just $ Text \"Calculating fib(33).\") }
--         notification <- notify client startNote
--         let endNote = appNote { summary=\"Finished\"
--                               , body=(Just . Text . show $ fib33) }
--         fib33 \`seq\` replace client notification endNote
--     where
--         appNote = blankNote { appName=\"Fibonacci Demonstration\" }
--         fib 0 = 0
--         fib 1 = 1
--         fib n = fib (n-1) + fib (n-2)
--         fib33 = fib 33
-- @

-- |Create a 'Client' connected to the session bus.
-- Note that this opens a socket and spawns a thread,
-- so it's best to reuse a single client.
mkSessionClient :: IO Client
mkSessionClient = mkClient getSessionBus

-- |A 'Note' with default values.
-- All fields are blank except for 'expiry', which is 'Dependent'.
blankNote :: Note
blankNote = Note { appName=""
                   , appImage=Nothing
                   , summary=""
                   , body=Nothing
                   , actions=[]
                   , hints=[]
                   , expiry=Dependent
                   }

proxy = Proxy (RemoteObject busname path) iface
    where
        busname = mkBusName' "org.freedesktop.Notifications"
        path = mkObjectPath' "/org/freedesktop/Notifications"
        iface = mkInterfaceName' "org.freedesktop.Notifications"

-- |Contents of a notification
data Note = Note { appName :: String
                 , appImage :: Maybe Image
                 , summary :: String
                 , body :: Maybe Body
                 , actions :: [(Action, String)]
                 , hints :: [Hint]
                 , expiry :: Timeout
                 }
    deriving (Eq, Show)

-- |Message bodies may contain simple markup.
-- NotifyOSD doesn't support any markup.
data Body =   Text String
            | Bold Body
            | Italic Body
            | Underline Body
            | Hyperlink URL Body
            | Img URL String
            | Concat Body Body
    deriving (Eq, Show)

type URL = String

-- |Length of time to display notifications. NotifyOSD seems to ignore these.
data Timeout =   Never              -- ^Wait to be dismissed by user
               | Dependent          -- ^Let the notification service decide
               | Milliseconds Int32 -- ^Show notification for a fixed duration
                                    -- (must be positive)
    deriving (Eq, Show)

newtype Action = Action { actionName :: String }
    deriving (Eq, Show)

-- |Images are not yet supported
newtype Image = Image { bitmap :: String }
    deriving (Eq, Show)

-- |Urgency of the notification. Notifications may be prioritised by urgency.
data UrgencyLevel =   Low
                    | Normal
                    | Critical -- ^Critical notifications require user attention
    deriving (Eq, Ord, Enum, Show)

-- |Various hints about how the notification should be displayed
data Hint =   Urgency UrgencyLevel
            | Category Category
            -- DesktopEntry ApplicationDesktopID
            | ImageData Image
            | SoundFile FilePath
            | SuppressSound Bool
            | X Int32
            | Y Int32
    deriving (Eq, Show)

-- |Categorisation of (some) notifications
data Category =   Device | DeviceAdded | DeviceError | DeviceRemoved
                | Email | EmailArrived | EmailBounced
                | Im | ImError | ImReceived
                | Network | NetworkConnected | NetworkDisconnected | NetworkError 
                | Presence | PresenceOffline | PresenceOnline
                | Transfer | TransferComplete | TransferError
    deriving (Eq, Show)

notifyArgs :: Note -> Word32 -> [Variant]
notifyArgs note replaceId = map ($ note) args
    where
        args = [ toVariant . appName
               , const $ toVariant (replaceId::Word32)
               , toVariant . fromMaybe "" .fmap bitmap . appImage
               , toVariant . summary
               , toVariant . fromMaybe "" . fmap flattenBody . body
               , toVariant . actionsArray . actions
               , toVariant . hintsDict . hints
               , toVariant . timeoutInt . expiry
               ]

data ClosedReason = Expired | Dismissed | CloseNotificationCalled
data NotificationEvent = ActionInvoked Action | Closed ClosedReason

-- |A handle on a displayed notification
-- The notification may not have reached the screen yet, and may already have
-- been closed.
data Notification = Notification { notificationId :: Word32 }

-- |Display a notification.
-- Return a handle which can be used to replace the notification.
notify :: Client -> Note -> IO Notification
notify cl = replace cl (Notification { notificationId=0 })

-- |Replace an existing notification.
-- If the notification has already been closed, a new one will be created.
replace :: Client -> Notification -> Note -> IO Notification
replace cl (Notification { notificationId=replaceId }) note =
    Notification . fromJust . fromVariant . head . methodReturnBody <$>
        callBlocking cl proxy (mkMemberName' "Notify") [] (notifyArgs note replaceId)

timeoutInt :: Timeout -> Int32
timeoutInt Never = 0
timeoutInt Dependent = -1
timeoutInt (Milliseconds n) 
    | n > 0     = n
    | otherwise = error "notification timeout not positive"

flattenBody :: Body -> String
flattenBody (Text s) = concatMap escape s
    where
        escape '>' = "&gt;"
        escape '<' = "&lt;"
        escape '&' = "&amp;"
        escape x = [x]

flattenBody (Bold b) = "<b>" ++ flattenBody b ++ "</b>"
flattenBody (Italic b) = "<i>" ++ flattenBody b ++ "</i>"
flattenBody (Underline b) = "<u>" ++ flattenBody b ++ "</u>"
flattenBody (Hyperlink h b) = "<a href=\"" ++ h ++ "\">" ++ flattenBody b ++ "</a>"
flattenBody (Img h alt) = "<img src=\"" ++ h ++ "\" alt=\"" ++ alt ++ "\"/>"
flattenBody (Concat b1 b2) = flattenBody b1 ++ flattenBody b2

actionsArray :: [(Action, String)] -> Array
actionsArray = fromJust . arrayFromItems DBusString . concatMap pairList
    where
        pairList (a, b) = [toVariant $ actionName a, toVariant $ b]

hintsDict :: [Hint] -> Dictionary
hintsDict = fromJust . dictionaryFromItems DBusString DBusVariant
            . map ((toVariant *** toVariant) . hint)
    where
        hint :: Hint -> (String, Variant)
        hint (Urgency u) = ("urgency", toVariant (fromIntegral $ fromEnum u :: Word8))
        hint (Category c) = ("category", toVariant $ catName c)
        hint (ImageData i) = ("image_data", toVariant $ bitmap i)
        hint (SoundFile s) = ("sound-file", toVariant s)
        hint (SuppressSound b) = ("suppress-sound", toVariant b)
        hint (X x) = ("x", toVariant x)
        hint (Y y) = ("x", toVariant y)

-- HACK: Assumes the constructor for category foo.bar.baz is FooBarBaz and
-- categories have no capital letters
catName :: Category -> String
catName c = catName' (show c)
    where
        catName' (c:cs) = map toLower $ c: (uncurry (++) . second ('.':) . span isLower $ cs)