1{- git-annex desktop notifications
2 -
3 - Copyright 2014 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
9{-# LANGUAGE CPP #-}
10
11module Annex.Notification (NotifyWitness, noNotification, notifyTransfer, notifyDrop) where
12
13import Annex.Common
14import Types.Transfer
15#ifdef WITH_DBUS_NOTIFICATIONS
16import qualified Annex
17import Types.DesktopNotify
18import qualified DBus.Notify as Notify
19import qualified DBus.Client
20#endif
21
22-- Witness that notification has happened.
23data NotifyWitness = NotifyWitness
24
25-- Only use when no notification should be done.
26noNotification :: NotifyWitness
27noNotification = NotifyWitness
28
29{- Wrap around an action that performs a transfer, which may run multiple
30 - attempts. Displays notification when supported and when the user asked
31 - for it. -}
32notifyTransfer :: Transferrable t => Observable v => Direction -> t -> (NotifyWitness -> Annex v) -> Annex v
33#ifdef WITH_DBUS_NOTIFICATIONS
34notifyTransfer direction t a = case descTransfrerrable t of
35	Nothing -> a NotifyWitness
36	Just desc -> do
37		wanted <- Annex.getState Annex.desktopnotify
38		if (notifyStart wanted || notifyFinish wanted)
39			then do
40				client <- liftIO DBus.Client.connectSession
41				startnotification <- liftIO $ if notifyStart wanted
42					then Just <$> Notify.notify client (startedTransferNote direction desc)
43					else pure Nothing
44				res <- a NotifyWitness
45				let ok = observeBool res
46				when (notifyFinish wanted) $ liftIO $ void $ maybe
47					(Notify.notify client $ finishedTransferNote ok direction desc)
48					(\n -> Notify.replace client n $ finishedTransferNote ok direction desc)
49					startnotification
50				return res
51			else a NotifyWitness
52#else
53notifyTransfer _ _ a = a NotifyWitness
54#endif
55
56notifyDrop :: AssociatedFile -> Bool -> Annex ()
57notifyDrop (AssociatedFile Nothing) _ = noop
58#ifdef WITH_DBUS_NOTIFICATIONS
59notifyDrop (AssociatedFile (Just f)) ok = do
60	wanted <- Annex.getState Annex.desktopnotify
61	when (notifyFinish wanted) $ liftIO $ do
62		client <- DBus.Client.connectSession
63		void $ Notify.notify client (droppedNote ok (fromRawFilePath f))
64#else
65notifyDrop (AssociatedFile (Just _)) _ = noop
66#endif
67
68#ifdef WITH_DBUS_NOTIFICATIONS
69startedTransferNote :: Direction -> String -> Notify.Note
70startedTransferNote Upload   = mkNote Notify.Transfer Notify.Low iconUpload
71	"Uploading"
72startedTransferNote Download = mkNote Notify.Transfer Notify.Low iconDownload
73	"Downloading"
74
75finishedTransferNote :: Bool -> Direction -> String -> Notify.Note
76finishedTransferNote False Upload   = mkNote Notify.TransferError Notify.Normal iconFailure
77	"Failed to upload"
78finishedTransferNote False Download = mkNote Notify.TransferError Notify.Normal iconFailure
79	"Failed to download"
80finishedTransferNote True  Upload   = mkNote Notify.TransferComplete Notify.Low iconSuccess
81	"Finished uploading"
82finishedTransferNote True  Download = mkNote Notify.TransferComplete Notify.Low iconSuccess
83	"Finished downloading"
84
85droppedNote :: Bool -> String -> Notify.Note
86droppedNote False = mkNote Notify.TransferError Notify.Normal iconFailure
87	"Failed to drop"
88droppedNote True  = mkNote Notify.TransferComplete Notify.Low iconSuccess
89	"Dropped"
90
91iconUpload, iconDownload, iconFailure, iconSuccess :: String
92iconUpload   = "network-transmit"
93iconDownload = "network-receive"
94iconFailure  = "dialog-error"
95iconSuccess  = "git-annex"  -- Is there a standard icon for success/completion?
96
97mkNote :: Notify.Category -> Notify.UrgencyLevel -> String -> String -> FilePath -> Notify.Note
98mkNote category urgency icon desc path = Notify.blankNote
99	{ Notify.appName = "git-annex"
100	, Notify.appImage = Just (Notify.Icon icon)
101	, Notify.summary = desc ++ " " ++ path
102	, Notify.hints =
103		[ Notify.Category category
104		, Notify.Urgency urgency
105		, Notify.SuppressSound True
106		]
107	}
108#endif
109