module DBus.Notify
(
notify
, replace
, Notification
, mkSessionClient
, connectSession
, Client
, blankNote
, Note (..)
, Body (..)
, URL
, Timeout (..)
, Action (..)
, Image
, Icon (..)
, Category (..)
, UrgencyLevel (..)
, Hint (..)
, getCapabilities
, Capability (..)
) where
import DBus
import DBus.Client
import Control.Applicative
import Data.Maybe (fromMaybe, fromJust)
import Data.Int
import Data.Word
import Data.Char (isLower, toLower)
import Control.Arrow (first, second, (***))
import qualified Data.Map as M
mkSessionClient :: IO Client
mkSessionClient = connectSession
blankNote :: Note
blankNote = Note { appName=""
, appImage=Nothing
, summary=""
, body=Nothing
, actions=[]
, hints=[]
, expiry=Dependent
}
data Note = Note { appName :: String
, appImage :: Maybe Icon
, summary :: String
, body :: Maybe Body
, actions :: [(Action, String)]
, hints :: [Hint]
, expiry :: Timeout
}
deriving (Eq, Show)
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
data Timeout = Never
| Dependent
| Milliseconds Int32
deriving (Eq, Show)
newtype Action = Action { actionName :: String }
deriving (Eq, Show)
newtype Image = Image { bitmap :: String }
deriving (Eq, Show)
data Icon = File FilePath | Icon String
deriving (Eq, Show)
iconString (File fp) = "file://" ++ fp
iconString (Icon name) = name
data UrgencyLevel = Low
| Normal
| Critical
deriving (Eq, Ord, Enum, Show)
data Hint = Urgency UrgencyLevel
| Category Category
| ImageData Image
| ImagePath Icon
| SoundFile FilePath
| SuppressSound Bool
| X Int32
| Y Int32
deriving (Eq, Show)
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)
data ClosedReason = Expired | Dismissed | CloseNotificationCalled
data NotificationEvent = ActionInvoked Action | Closed ClosedReason
data Notification = Notification { notificationId :: Word32 }
notify :: Client -> Note -> IO Notification
notify cl = replace cl (Notification { notificationId=0 })
callNotificationMethod client methodName args =
call_ client $ (methodCall path iface methodName)
{ methodCallDestination=Just busname
, methodCallBody=args
}
where
busname = "org.freedesktop.Notifications"
path = "/org/freedesktop/Notifications"
iface = "org.freedesktop.Notifications"
replace :: Client -> Notification -> Note -> IO Notification
replace cl (Notification { notificationId=replaceId }) note =
Notification . fromJust . fromVariant . head . methodReturnBody <$>
callNotificationMethod cl "Notify" args
where
args = map ($ note)
[ toVariant . appName
, const $ toVariant (replaceId::Word32)
, toVariant . fromMaybe "" . fmap iconString . appImage
, toVariant . summary
, toVariant . fromMaybe "" . fmap flattenBody . body
, toVariant . actionsArray . actions
, toVariant . hintsDict . hints
, toVariant . timeoutInt . expiry
]
data Capability = ActionsCap | BodyCap | BodyHyperlinksCap | BodyImagesCap
| BodyMarkupCap | IconMultiCap | IconStaticCap | SoundCap
| UnknownCap String
deriving (Eq, Read, Show)
getCapabilities :: Client -> IO [Capability]
getCapabilities cl = map readCapability . fromJust
. fromVariant . head . methodReturnBody
<$> callNotificationMethod cl "GetCapabilities" []
readCapability :: String -> Capability
readCapability s = case s of
"actions" -> ActionsCap
"body" -> BodyCap
"body-hyperlinks" -> BodyHyperlinksCap
"body-images" -> BodyImagesCap
"body-markup" -> BodyMarkupCap
"icon-multi" -> IconMultiCap
"icon-static" -> IconStaticCap
"sound" -> SoundCap
s -> UnknownCap s
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 '>' = ">"
escape '<' = "<"
escape '&' = "&"
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 = concatMap pairList
where
pairList (a, b) = [actionName a, b]
hintsDict :: [Hint] -> M.Map String Variant
hintsDict = M.fromList . map hint
where
hint :: Hint -> (String, Variant)
hint (Urgency u) = ("urgency", toVariant (fromIntegral $ fromEnum u :: Word8))
hint (Category c) = ("category", toVariant $ catName c)
hint (ImagePath p) = ("image-path", toVariant $ iconString p)
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)
catName :: Category -> String
catName c = catName' (show c)
where
catName' (c:cs) = map toLower $ c: (uncurry (++) . second ('.':) . span isLower $ cs)