40ecf58d4b
This does not change the overall license of the git-annex program, which was already AGPL due to a number of sources files being AGPL already. Legally speaking, I'm adding a new license under which these files are now available; I already released their current contents under the GPL license. Now they're dual licensed GPL and AGPL. However, I intend for all my future changes to these files to only be released under the AGPL license, and I won't be tracking the dual licensing status, so I'm simply changing the license statement to say it's AGPL. (In some cases, others wrote parts of the code of a file and released it under the GPL; but in all cases I have contributed a significant portion of the code in each file and it's that code that is getting the AGPL license; the GPL license of other contributors allows combining with AGPL code.)
108 lines
3.8 KiB
Haskell
108 lines
3.8 KiB
Haskell
{- git-annex desktop notifications
|
|
-
|
|
- Copyright 2014 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Annex.Notification (NotifyWitness, noNotification, notifyTransfer, notifyDrop) where
|
|
|
|
import Annex.Common
|
|
import Types.Transfer
|
|
#ifdef WITH_DBUS_NOTIFICATIONS
|
|
import qualified Annex
|
|
import Types.DesktopNotify
|
|
import qualified DBus.Notify as Notify
|
|
import qualified DBus.Client
|
|
#endif
|
|
|
|
-- Witness that notification has happened.
|
|
data NotifyWitness = NotifyWitness
|
|
|
|
-- Only use when no notification should be done.
|
|
noNotification :: NotifyWitness
|
|
noNotification = NotifyWitness
|
|
|
|
{- Wrap around an action that performs a transfer, which may run multiple
|
|
- attempts. Displays notification when supported and when the user asked
|
|
- for it. -}
|
|
notifyTransfer :: Transferrable t => Observable v => Direction -> t -> (NotifyWitness -> Annex v) -> Annex v
|
|
#ifdef WITH_DBUS_NOTIFICATIONS
|
|
notifyTransfer direction t a = case descTransfrerrable t of
|
|
Nothing -> a NotifyWitness
|
|
Just desc -> do
|
|
wanted <- Annex.getState Annex.desktopnotify
|
|
if (notifyStart wanted || notifyFinish wanted)
|
|
then do
|
|
client <- liftIO DBus.Client.connectSession
|
|
startnotification <- liftIO $ if notifyStart wanted
|
|
then Just <$> Notify.notify client (startedTransferNote direction desc)
|
|
else pure Nothing
|
|
res <- a NotifyWitness
|
|
let ok = observeBool res
|
|
when (notifyFinish wanted) $ liftIO $ void $ maybe
|
|
(Notify.notify client $ finishedTransferNote ok direction desc)
|
|
(\n -> Notify.replace client n $ finishedTransferNote ok direction desc)
|
|
startnotification
|
|
return res
|
|
else a NotifyWitness
|
|
#else
|
|
notifyTransfer _ _ a = a NotifyWitness
|
|
#endif
|
|
|
|
notifyDrop :: AssociatedFile -> Bool -> Annex ()
|
|
notifyDrop (AssociatedFile Nothing) _ = noop
|
|
#ifdef WITH_DBUS_NOTIFICATIONS
|
|
notifyDrop (AssociatedFile (Just f)) ok = do
|
|
wanted <- Annex.getState Annex.desktopnotify
|
|
when (notifyFinish wanted) $ liftIO $ do
|
|
client <- DBus.Client.connectSession
|
|
void $ Notify.notify client (droppedNote ok f)
|
|
#else
|
|
notifyDrop (AssociatedFile (Just _)) _ = noop
|
|
#endif
|
|
|
|
#ifdef WITH_DBUS_NOTIFICATIONS
|
|
startedTransferNote :: Direction -> String -> Notify.Note
|
|
startedTransferNote Upload = mkNote Notify.Transfer Notify.Low iconUpload
|
|
"Uploading"
|
|
startedTransferNote Download = mkNote Notify.Transfer Notify.Low iconDownload
|
|
"Downloading"
|
|
|
|
finishedTransferNote :: Bool -> Direction -> String -> Notify.Note
|
|
finishedTransferNote False Upload = mkNote Notify.TransferError Notify.Normal iconFailure
|
|
"Failed to upload"
|
|
finishedTransferNote False Download = mkNote Notify.TransferError Notify.Normal iconFailure
|
|
"Failed to download"
|
|
finishedTransferNote True Upload = mkNote Notify.TransferComplete Notify.Low iconSuccess
|
|
"Finished uploading"
|
|
finishedTransferNote True Download = mkNote Notify.TransferComplete Notify.Low iconSuccess
|
|
"Finished downloading"
|
|
|
|
droppedNote :: Bool -> String -> Notify.Note
|
|
droppedNote False = mkNote Notify.TransferError Notify.Normal iconFailure
|
|
"Failed to drop"
|
|
droppedNote True = mkNote Notify.TransferComplete Notify.Low iconSuccess
|
|
"Dropped"
|
|
|
|
iconUpload, iconDownload, iconFailure, iconSuccess :: String
|
|
iconUpload = "network-transmit"
|
|
iconDownload = "network-receive"
|
|
iconFailure = "dialog-error"
|
|
iconSuccess = "git-annex" -- Is there a standard icon for success/completion?
|
|
|
|
mkNote :: Notify.Category -> Notify.UrgencyLevel -> String -> String -> FilePath -> Notify.Note
|
|
mkNote category urgency icon desc path = Notify.blankNote
|
|
{ Notify.appName = "git-annex"
|
|
, Notify.appImage = Just (Notify.Icon icon)
|
|
, Notify.summary = desc ++ " " ++ path
|
|
, Notify.hints =
|
|
[ Notify.Category category
|
|
, Notify.Urgency urgency
|
|
, Notify.SuppressSound True
|
|
]
|
|
}
|
|
#endif
|