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