Commits

Max Rabkin  committed 0b9d317

version 0.1

  • Participants

Comments (0)

Files changed (4)

File 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)
+Copyright (c) 2009, Max Rabkin
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of his contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.

File examples/fib.hs

+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

File fdo-notify.cabal

+name:               fdo-notify
+version:            0.1
+synopsis:           Desktop Notifications client
+description:
+    A library for issuing notifications using FreeDesktop.org's Desktop
+    Notifications protcol. This protocol is supported by services such
+    as Ubuntu's NotifyOSD.
+category:           Desktop
+license:            BSD3
+license-file:       LICENSE
+author:             Max Rabkin
+maintainer:         max.rabkin@gmail.com
+cabal-version:      >= 1.2.1
+build-type:         Simple
+
+extra-source-files:
+    examples/fib.hs
+
+library
+    build-depends: base >= 3 && < 5, dbus-core >= 0.5 && < 0.6, dbus-client >= 0.1 && < 0.2
+
+    exposed-modules: DBus.Notify