add desktop notifications
Motivation: Hook scripts for nautilus or other file managers need to provide the user with feedback that a file is being downloaded. This commit was sponsored by THM Schoemaker.
This commit is contained in:
parent
0439de4710
commit
e426fac273
21 changed files with 285 additions and 142 deletions
3
Annex.hs
3
Annex.hs
|
@ -60,6 +60,7 @@ import Types.FileMatcher
|
||||||
import Types.NumCopies
|
import Types.NumCopies
|
||||||
import Types.LockPool
|
import Types.LockPool
|
||||||
import Types.MetaData
|
import Types.MetaData
|
||||||
|
import Types.DesktopNotify
|
||||||
import Types.CleanupActions
|
import Types.CleanupActions
|
||||||
import qualified Utility.Matcher
|
import qualified Utility.Matcher
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
|
@ -122,6 +123,7 @@ data AnnexState = AnnexState
|
||||||
, unusedkeys :: Maybe (S.Set Key)
|
, unusedkeys :: Maybe (S.Set Key)
|
||||||
, quviversion :: Maybe QuviVersion
|
, quviversion :: Maybe QuviVersion
|
||||||
, existinghooks :: M.Map Git.Hook.Hook Bool
|
, existinghooks :: M.Map Git.Hook.Hook Bool
|
||||||
|
, desktopnotify :: DesktopNotify
|
||||||
}
|
}
|
||||||
|
|
||||||
newState :: GitConfig -> Git.Repo -> AnnexState
|
newState :: GitConfig -> Git.Repo -> AnnexState
|
||||||
|
@ -163,6 +165,7 @@ newState c r = AnnexState
|
||||||
, unusedkeys = Nothing
|
, unusedkeys = Nothing
|
||||||
, quviversion = Nothing
|
, quviversion = Nothing
|
||||||
, existinghooks = M.empty
|
, existinghooks = M.empty
|
||||||
|
, desktopnotify = mempty
|
||||||
}
|
}
|
||||||
|
|
||||||
{- Makes an Annex state object for the specified git repo.
|
{- Makes an Annex state object for the specified git repo.
|
||||||
|
|
178
Annex/Transfer.hs
Normal file
178
Annex/Transfer.hs
Normal file
|
@ -0,0 +1,178 @@
|
||||||
|
{- git-annex transfers
|
||||||
|
-
|
||||||
|
- Copyright 2012-2014 Joey Hess <joey@kitenet.net>
|
||||||
|
-
|
||||||
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
|
-}
|
||||||
|
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
|
||||||
|
module Annex.Transfer (
|
||||||
|
module X,
|
||||||
|
upload,
|
||||||
|
download,
|
||||||
|
runTransfer,
|
||||||
|
notifyTransfer,
|
||||||
|
NotifyWitness,
|
||||||
|
noRetry,
|
||||||
|
forwardRetry,
|
||||||
|
) where
|
||||||
|
|
||||||
|
import qualified Annex
|
||||||
|
import Logs.Transfer as X
|
||||||
|
import Annex.Perms
|
||||||
|
import Annex.Exception
|
||||||
|
import Utility.Metered
|
||||||
|
#ifdef WITH_DBUS_NOTIFICATIONS
|
||||||
|
import Common.Annex
|
||||||
|
import Types.DesktopNotify
|
||||||
|
import qualified DBus.Notify as Notify
|
||||||
|
import qualified DBus.Client
|
||||||
|
#endif
|
||||||
|
#ifdef mingw32_HOST_OS
|
||||||
|
import Utility.WinLock
|
||||||
|
#endif
|
||||||
|
|
||||||
|
import Control.Concurrent
|
||||||
|
|
||||||
|
upload :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> NotifyWitness -> Annex Bool
|
||||||
|
upload u key f d a _witness = runTransfer (Transfer Upload u key) f d a
|
||||||
|
|
||||||
|
download :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> NotifyWitness -> Annex Bool
|
||||||
|
download u key f d a _witness = runTransfer (Transfer Download u key) f d a
|
||||||
|
|
||||||
|
{- Runs a transfer action. Creates and locks the lock file while the
|
||||||
|
- action is running, and stores info in the transfer information
|
||||||
|
- file.
|
||||||
|
-
|
||||||
|
- If the transfer action returns False, the transfer info is
|
||||||
|
- left in the failedTransferDir.
|
||||||
|
-
|
||||||
|
- If the transfer is already in progress, returns False.
|
||||||
|
-
|
||||||
|
- An upload can be run from a read-only filesystem, and in this case
|
||||||
|
- no transfer information or lock file is used.
|
||||||
|
-}
|
||||||
|
runTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
|
||||||
|
runTransfer t file shouldretry a = do
|
||||||
|
info <- liftIO $ startTransferInfo file
|
||||||
|
(meter, tfile, metervar) <- mkProgressUpdater t info
|
||||||
|
mode <- annexFileMode
|
||||||
|
(fd, inprogress) <- liftIO $ prep tfile mode info
|
||||||
|
if inprogress
|
||||||
|
then do
|
||||||
|
showNote "transfer already in progress"
|
||||||
|
return False
|
||||||
|
else do
|
||||||
|
ok <- retry info metervar $
|
||||||
|
bracketIO (return fd) (cleanup tfile) (const $ a meter)
|
||||||
|
unless ok $ recordFailedTransfer t info
|
||||||
|
return ok
|
||||||
|
where
|
||||||
|
#ifndef mingw32_HOST_OS
|
||||||
|
prep tfile mode info = do
|
||||||
|
mfd <- catchMaybeIO $
|
||||||
|
openFd (transferLockFile tfile) ReadWrite (Just mode)
|
||||||
|
defaultFileFlags { trunc = True }
|
||||||
|
case mfd of
|
||||||
|
Nothing -> return (Nothing, False)
|
||||||
|
Just fd -> do
|
||||||
|
locked <- catchMaybeIO $
|
||||||
|
setLock fd (WriteLock, AbsoluteSeek, 0, 0)
|
||||||
|
if isNothing locked
|
||||||
|
then return (Nothing, True)
|
||||||
|
else do
|
||||||
|
void $ tryIO $ writeTransferInfoFile info tfile
|
||||||
|
return (mfd, False)
|
||||||
|
#else
|
||||||
|
prep tfile _mode info = do
|
||||||
|
v <- catchMaybeIO $ lockExclusive (transferLockFile tfile)
|
||||||
|
case v of
|
||||||
|
Nothing -> return (Nothing, False)
|
||||||
|
Just Nothing -> return (Nothing, True)
|
||||||
|
Just (Just lockhandle) -> do
|
||||||
|
void $ tryIO $ writeTransferInfoFile info tfile
|
||||||
|
return (Just lockhandle, False)
|
||||||
|
#endif
|
||||||
|
cleanup _ Nothing = noop
|
||||||
|
cleanup tfile (Just lockhandle) = do
|
||||||
|
void $ tryIO $ removeFile tfile
|
||||||
|
#ifndef mingw32_HOST_OS
|
||||||
|
void $ tryIO $ removeFile $ transferLockFile tfile
|
||||||
|
closeFd lockhandle
|
||||||
|
#else
|
||||||
|
{- Windows cannot delete the lockfile until the lock
|
||||||
|
- is closed. So it's possible to race with another
|
||||||
|
- process that takes the lock before it's removed,
|
||||||
|
- so ignore failure to remove.
|
||||||
|
-}
|
||||||
|
dropLock lockhandle
|
||||||
|
void $ tryIO $ removeFile $ transferLockFile tfile
|
||||||
|
#endif
|
||||||
|
retry oldinfo metervar run = do
|
||||||
|
v <- tryAnnex run
|
||||||
|
case v of
|
||||||
|
Right b -> return b
|
||||||
|
Left _ -> do
|
||||||
|
b <- getbytescomplete metervar
|
||||||
|
let newinfo = oldinfo { bytesComplete = Just b }
|
||||||
|
if shouldretry oldinfo newinfo
|
||||||
|
then retry newinfo metervar run
|
||||||
|
else return False
|
||||||
|
getbytescomplete metervar
|
||||||
|
| transferDirection t == Upload =
|
||||||
|
liftIO $ readMVar metervar
|
||||||
|
| otherwise = do
|
||||||
|
f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t)
|
||||||
|
liftIO $ catchDefaultIO 0 $
|
||||||
|
fromIntegral . fileSize <$> getFileStatus f
|
||||||
|
|
||||||
|
type RetryDecider = TransferInfo -> TransferInfo -> Bool
|
||||||
|
|
||||||
|
noRetry :: RetryDecider
|
||||||
|
noRetry _ _ = False
|
||||||
|
|
||||||
|
{- Retries a transfer when it fails, as long as the failed transfer managed
|
||||||
|
- to send some data. -}
|
||||||
|
forwardRetry :: RetryDecider
|
||||||
|
forwardRetry old new = bytesComplete old < bytesComplete new
|
||||||
|
|
||||||
|
-- Witness that notification has happened.
|
||||||
|
data NotifyWitness = NotifyWitness
|
||||||
|
|
||||||
|
{- Wrap around an action that performs a transfer, which may run multiple
|
||||||
|
- attempts, and displays notification when supported. -}
|
||||||
|
notifyTransfer :: Direction -> Maybe FilePath -> (NotifyWitness -> Annex Bool) -> Annex Bool
|
||||||
|
notifyTransfer _ Nothing a = a NotifyWitness
|
||||||
|
notifyTransfer direction (Just f) a = do
|
||||||
|
#ifdef WITH_DBUS_NOTIFICATIONS
|
||||||
|
wanted <- Annex.getState Annex.desktopnotify
|
||||||
|
let action = if direction == Upload then "uploading" else "downloading"
|
||||||
|
let basedesc = action ++ " " ++ f
|
||||||
|
let startdesc = "started " ++ basedesc
|
||||||
|
let enddesc = "finished " ++ basedesc
|
||||||
|
if (notifyStart wanted || notifyFinish wanted)
|
||||||
|
then do
|
||||||
|
client <- liftIO DBus.Client.connectSession
|
||||||
|
let mknote desc = Notify.blankNote
|
||||||
|
{ Notify.appName = "git-annex"
|
||||||
|
, Notify.body = Just $ Notify.Text desc
|
||||||
|
, Notify.hints =
|
||||||
|
[ Notify.Category Notify.Transfer
|
||||||
|
, Notify.Urgency Notify.Low
|
||||||
|
, Notify.SuppressSound True
|
||||||
|
]
|
||||||
|
}
|
||||||
|
startnotification <- liftIO $ if notifyStart wanted
|
||||||
|
then Just <$> Notify.notify client (mknote startdesc)
|
||||||
|
else pure Nothing
|
||||||
|
r <- a NotifyWitness
|
||||||
|
when (notifyFinish wanted) $ liftIO $ void $ maybe
|
||||||
|
(Notify.notify client $ mknote enddesc)
|
||||||
|
(\n -> Notify.replace client n $ mknote enddesc)
|
||||||
|
startnotification
|
||||||
|
return r
|
||||||
|
else a NotifyWitness
|
||||||
|
#else
|
||||||
|
a NotifyWitness
|
||||||
|
#endif
|
|
@ -14,7 +14,6 @@ import Utility.Tense
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import Data.Monoid
|
|
||||||
|
|
||||||
{- This is as many alerts as it makes sense to display at a time.
|
{- This is as many alerts as it makes sense to display at a time.
|
||||||
- A display might be smaller, or larger, the point is to not overwhelm the
|
- A display might be smaller, or larger, the point is to not overwhelm the
|
||||||
|
|
|
@ -57,6 +57,9 @@ buildFlags = filter (not . null)
|
||||||
#ifdef WITH_DBUS
|
#ifdef WITH_DBUS
|
||||||
, "DBus"
|
, "DBus"
|
||||||
#endif
|
#endif
|
||||||
|
#ifdef WITH_DESKTOP_NOTIFY
|
||||||
|
, "DesktopNotify"
|
||||||
|
#endif
|
||||||
#ifdef WITH_XMPP
|
#ifdef WITH_XMPP
|
||||||
, "XMPP"
|
, "XMPP"
|
||||||
#else
|
#else
|
||||||
|
|
|
@ -20,6 +20,7 @@ import System.Console.GetOpt
|
||||||
import Common.Annex
|
import Common.Annex
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import Types.Messages
|
import Types.Messages
|
||||||
|
import Types.DesktopNotify
|
||||||
import Limit
|
import Limit
|
||||||
import CmdLine.Usage
|
import CmdLine.Usage
|
||||||
|
|
||||||
|
@ -41,6 +42,10 @@ commonOptions =
|
||||||
"don't show debug messages"
|
"don't show debug messages"
|
||||||
, Option ['b'] ["backend"] (ReqArg setforcebackend paramName)
|
, Option ['b'] ["backend"] (ReqArg setforcebackend paramName)
|
||||||
"specify key-value backend to use"
|
"specify key-value backend to use"
|
||||||
|
, Option [] ["notify-finish"] (NoArg (setdesktopnotify mkNotifyFinish))
|
||||||
|
"show desktop notification after transfer finishes"
|
||||||
|
, Option [] ["notify-start"] (NoArg (setdesktopnotify mkNotifyStart))
|
||||||
|
"show desktop notification after transfer completes"
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
setforce v = Annex.changeState $ \s -> s { Annex.force = v }
|
setforce v = Annex.changeState $ \s -> s { Annex.force = v }
|
||||||
|
@ -49,6 +54,7 @@ commonOptions =
|
||||||
setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v }
|
setforcebackend v = Annex.changeState $ \s -> s { Annex.forcebackend = Just v }
|
||||||
setdebug = Annex.changeGitConfig $ \c -> c { annexDebug = True }
|
setdebug = Annex.changeGitConfig $ \c -> c { annexDebug = True }
|
||||||
unsetdebug = Annex.changeGitConfig $ \c -> c { annexDebug = False }
|
unsetdebug = Annex.changeGitConfig $ \c -> c { annexDebug = False }
|
||||||
|
setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v }
|
||||||
|
|
||||||
matcherOptions :: [Option]
|
matcherOptions :: [Option]
|
||||||
matcherOptions =
|
matcherOptions =
|
||||||
|
|
|
@ -26,7 +26,7 @@ import Types.KeySource
|
||||||
import Config
|
import Config
|
||||||
import Annex.Content.Direct
|
import Annex.Content.Direct
|
||||||
import Logs.Location
|
import Logs.Location
|
||||||
import qualified Logs.Transfer as Transfer
|
import qualified Annex.Transfer as Transfer
|
||||||
#ifdef WITH_QUVI
|
#ifdef WITH_QUVI
|
||||||
import Annex.Quvi
|
import Annex.Quvi
|
||||||
import qualified Utility.Quvi as Quvi
|
import qualified Utility.Quvi as Quvi
|
||||||
|
@ -116,7 +116,8 @@ addUrlFileQuvi relaxed quviurl videourl file = do
|
||||||
prepGetViaTmpChecked sizedkey $ do
|
prepGetViaTmpChecked sizedkey $ do
|
||||||
tmp <- fromRepo $ gitAnnexTmpObjectLocation key
|
tmp <- fromRepo $ gitAnnexTmpObjectLocation key
|
||||||
showOutput
|
showOutput
|
||||||
ok <- Transfer.download webUUID key (Just file) Transfer.forwardRetry $ const $ do
|
ok <- Transfer.notifyTransfer Transfer.Download (Just file) $
|
||||||
|
Transfer.download webUUID key (Just file) Transfer.forwardRetry $ const $ do
|
||||||
liftIO $ createDirectoryIfMissing True (parentDir tmp)
|
liftIO $ createDirectoryIfMissing True (parentDir tmp)
|
||||||
downloadUrl [videourl] tmp
|
downloadUrl [videourl] tmp
|
||||||
if ok
|
if ok
|
||||||
|
@ -179,7 +180,7 @@ download url file = do
|
||||||
, return False
|
, return False
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
runtransfer dummykey tmp =
|
runtransfer dummykey tmp = Transfer.notifyTransfer Transfer.Download (Just file) $
|
||||||
Transfer.download webUUID dummykey (Just file) Transfer.forwardRetry $ const $ do
|
Transfer.download webUUID dummykey (Just file) Transfer.forwardRetry $ const $ do
|
||||||
liftIO $ createDirectoryIfMissing True (parentDir tmp)
|
liftIO $ createDirectoryIfMissing True (parentDir tmp)
|
||||||
downloadUrl [url] tmp
|
downloadUrl [url] tmp
|
||||||
|
|
|
@ -11,7 +11,7 @@ import Common.Annex
|
||||||
import Command
|
import Command
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import Annex.Content
|
import Annex.Content
|
||||||
import Logs.Transfer
|
import Annex.Transfer
|
||||||
import Config.NumCopies
|
import Config.NumCopies
|
||||||
import Annex.Wanted
|
import Annex.Wanted
|
||||||
import qualified Command.Move
|
import qualified Command.Move
|
||||||
|
@ -69,15 +69,15 @@ getKeyFile' key afile dest = dispatch
|
||||||
showNote "not available"
|
showNote "not available"
|
||||||
showlocs
|
showlocs
|
||||||
return False
|
return False
|
||||||
dispatch remotes = trycopy remotes remotes
|
dispatch remotes = notifyTransfer Download afile $ trycopy remotes remotes
|
||||||
trycopy full [] = do
|
trycopy full [] _ = do
|
||||||
Remote.showTriedRemotes full
|
Remote.showTriedRemotes full
|
||||||
showlocs
|
showlocs
|
||||||
return False
|
return False
|
||||||
trycopy full (r:rs) =
|
trycopy full (r:rs) witness =
|
||||||
ifM (probablyPresent r)
|
ifM (probablyPresent r)
|
||||||
( docopy r (trycopy full rs)
|
( docopy r witness <||> trycopy full rs witness
|
||||||
, trycopy full rs
|
, trycopy full rs witness
|
||||||
)
|
)
|
||||||
showlocs = Remote.showLocations key []
|
showlocs = Remote.showLocations key []
|
||||||
"No other repository is known to contain the file."
|
"No other repository is known to contain the file."
|
||||||
|
@ -87,8 +87,6 @@ getKeyFile' key afile dest = dispatch
|
||||||
| Remote.hasKeyCheap r =
|
| Remote.hasKeyCheap r =
|
||||||
either (const False) id <$> Remote.hasKey r key
|
either (const False) id <$> Remote.hasKey r key
|
||||||
| otherwise = return True
|
| otherwise = return True
|
||||||
docopy r continue = do
|
docopy r = download (Remote.uuid r) key afile noRetry $ \p -> do
|
||||||
ok <- download (Remote.uuid r) key afile noRetry $ \p -> do
|
|
||||||
showAction $ "from " ++ Remote.name r
|
showAction $ "from " ++ Remote.name r
|
||||||
Remote.retrieveKeyFile r key afile dest p
|
Remote.retrieveKeyFile r key afile dest p
|
||||||
if ok then return ok else continue
|
|
||||||
|
|
|
@ -38,7 +38,7 @@ seek ps = do
|
||||||
|
|
||||||
getList :: Annex [(UUID, RemoteName, TrustLevel)]
|
getList :: Annex [(UUID, RemoteName, TrustLevel)]
|
||||||
getList = ifM (Annex.getFlag $ optionName allrepos)
|
getList = ifM (Annex.getFlag $ optionName allrepos)
|
||||||
( nubBy ((==) `on` fst3) <$> ((++) <$> getRemotes <*> getAll)
|
( nubBy ((==) `on` fst3) <$> ((++) <$> getRemotes <*> getAllUUIDs)
|
||||||
, getRemotes
|
, getRemotes
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
@ -48,7 +48,7 @@ getList = ifM (Annex.getFlag $ optionName allrepos)
|
||||||
hereu <- getUUID
|
hereu <- getUUID
|
||||||
heretrust <- lookupTrust hereu
|
heretrust <- lookupTrust hereu
|
||||||
return $ (hereu, "here", heretrust) : zip3 (map uuid rs) (map name rs) ts
|
return $ (hereu, "here", heretrust) : zip3 (map uuid rs) (map name rs) ts
|
||||||
getAll = do
|
getAllUUIDs = do
|
||||||
rs <- M.toList <$> uuidMap
|
rs <- M.toList <$> uuidMap
|
||||||
rs3 <- forM rs $ \(u, n) -> (,,)
|
rs3 <- forM rs $ \(u, n) -> (,,)
|
||||||
<$> pure u
|
<$> pure u
|
||||||
|
|
|
@ -14,8 +14,8 @@ import qualified Annex
|
||||||
import Annex.Content
|
import Annex.Content
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import Annex.UUID
|
import Annex.UUID
|
||||||
|
import Annex.Transfer
|
||||||
import Logs.Presence
|
import Logs.Presence
|
||||||
import Logs.Transfer
|
|
||||||
|
|
||||||
def :: [Command]
|
def :: [Command]
|
||||||
def = [withOptions moveOptions $ command "move" paramPaths seek
|
def = [withOptions moveOptions $ command "move" paramPaths seek
|
||||||
|
@ -98,7 +98,8 @@ toPerform dest move key afile fastcheck isthere = moveLock move key $
|
||||||
stop
|
stop
|
||||||
Right False -> do
|
Right False -> do
|
||||||
showAction $ "to " ++ Remote.name dest
|
showAction $ "to " ++ Remote.name dest
|
||||||
ok <- upload (Remote.uuid dest) key afile noRetry $
|
ok <- notifyTransfer Upload afile $
|
||||||
|
upload (Remote.uuid dest) key afile noRetry $
|
||||||
Remote.storeKey dest key afile
|
Remote.storeKey dest key afile
|
||||||
if ok
|
if ok
|
||||||
then do
|
then do
|
||||||
|
@ -155,7 +156,8 @@ fromPerform src move key afile = moveLock move key $
|
||||||
, handle move =<< go
|
, handle move =<< go
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
go = download (Remote.uuid src) key afile noRetry $ \p -> do
|
go = notifyTransfer Download afile $
|
||||||
|
download (Remote.uuid src) key afile noRetry $ \p -> do
|
||||||
showAction $ "from " ++ Remote.name src
|
showAction $ "from " ++ Remote.name src
|
||||||
getViaTmp key $ \t -> Remote.retrieveKeyFile src key afile t p
|
getViaTmp key $ \t -> Remote.retrieveKeyFile src key afile t p
|
||||||
handle _ False = stop -- failed
|
handle _ False = stop -- failed
|
||||||
|
|
|
@ -12,7 +12,7 @@ import Command
|
||||||
import Annex.Content
|
import Annex.Content
|
||||||
import Annex
|
import Annex
|
||||||
import Utility.Rsync
|
import Utility.Rsync
|
||||||
import Logs.Transfer
|
import Annex.Transfer
|
||||||
import qualified CmdLine.GitAnnexShell.Fields as Fields
|
import qualified CmdLine.GitAnnexShell.Fields as Fields
|
||||||
import Utility.Metered
|
import Utility.Metered
|
||||||
|
|
||||||
|
|
|
@ -11,7 +11,7 @@ import Common.Annex
|
||||||
import Command
|
import Command
|
||||||
import Annex.Content
|
import Annex.Content
|
||||||
import Logs.Location
|
import Logs.Location
|
||||||
import Logs.Transfer
|
import Annex.Transfer
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import Types.Remote
|
import Types.Remote
|
||||||
|
|
||||||
|
@ -41,7 +41,7 @@ start to from file key =
|
||||||
_ -> error "specify either --from or --to"
|
_ -> error "specify either --from or --to"
|
||||||
|
|
||||||
toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
|
toPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
|
||||||
toPerform remote key file = go $
|
toPerform remote key file = go Upload file $
|
||||||
upload (uuid remote) key file forwardRetry $ \p -> do
|
upload (uuid remote) key file forwardRetry $ \p -> do
|
||||||
ok <- Remote.storeKey remote key file p
|
ok <- Remote.storeKey remote key file p
|
||||||
when ok $
|
when ok $
|
||||||
|
@ -49,9 +49,9 @@ toPerform remote key file = go $
|
||||||
return ok
|
return ok
|
||||||
|
|
||||||
fromPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
|
fromPerform :: Remote -> Key -> AssociatedFile -> CommandPerform
|
||||||
fromPerform remote key file = go $
|
fromPerform remote key file = go Upload file $
|
||||||
download (uuid remote) key file forwardRetry $ \p ->
|
download (uuid remote) key file forwardRetry $ \p ->
|
||||||
getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
|
getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
|
||||||
|
|
||||||
go :: Annex Bool -> CommandPerform
|
go :: Direction -> AssociatedFile -> (NotifyWitness -> Annex Bool) -> CommandPerform
|
||||||
go a = a >>= liftIO . exitBool
|
go direction file a = notifyTransfer direction file a >>= liftIO . exitBool
|
||||||
|
|
|
@ -13,7 +13,7 @@ import Common.Annex
|
||||||
import Command
|
import Command
|
||||||
import Annex.Content
|
import Annex.Content
|
||||||
import Logs.Location
|
import Logs.Location
|
||||||
import Logs.Transfer
|
import Annex.Transfer
|
||||||
import qualified Remote
|
import qualified Remote
|
||||||
import Types.Key
|
import Types.Key
|
||||||
|
|
||||||
|
@ -34,13 +34,14 @@ start = withHandles $ \(readh, writeh) -> do
|
||||||
stop
|
stop
|
||||||
where
|
where
|
||||||
runner (TransferRequest direction remote key file)
|
runner (TransferRequest direction remote key file)
|
||||||
| direction == Upload =
|
| direction == Upload = notifyTransfer direction file $
|
||||||
upload (Remote.uuid remote) key file forwardRetry $ \p -> do
|
upload (Remote.uuid remote) key file forwardRetry $ \p -> do
|
||||||
ok <- Remote.storeKey remote key file p
|
ok <- Remote.storeKey remote key file p
|
||||||
when ok $
|
when ok $
|
||||||
Remote.logStatus remote key InfoPresent
|
Remote.logStatus remote key InfoPresent
|
||||||
return ok
|
return ok
|
||||||
| otherwise = download (Remote.uuid remote) key file forwardRetry $ \p ->
|
| otherwise = notifyTransfer direction file $
|
||||||
|
download (Remote.uuid remote) key file forwardRetry $ \p ->
|
||||||
getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
|
getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
|
||||||
|
|
||||||
{- stdin and stdout are connected with the caller, to be used for
|
{- stdin and stdout are connected with the caller, to be used for
|
||||||
|
|
|
@ -11,6 +11,7 @@ import Control.Exception.Extensible as X (IOException)
|
||||||
import Data.Maybe as X
|
import Data.Maybe as X
|
||||||
import Data.List as X hiding (head, tail, init, last)
|
import Data.List as X hiding (head, tail, init, last)
|
||||||
import Data.String.Utils as X hiding (join)
|
import Data.String.Utils as X hiding (join)
|
||||||
|
import Data.Monoid as X
|
||||||
|
|
||||||
import System.FilePath as X
|
import System.FilePath as X
|
||||||
import System.Directory as X
|
import System.Directory as X
|
||||||
|
|
102
Logs/Transfer.hs
102
Logs/Transfer.hs
|
@ -88,108 +88,6 @@ percentComplete :: Transfer -> TransferInfo -> Maybe Percentage
|
||||||
percentComplete (Transfer { transferKey = key }) info =
|
percentComplete (Transfer { transferKey = key }) info =
|
||||||
percentage <$> keySize key <*> Just (fromMaybe 0 $ bytesComplete info)
|
percentage <$> keySize key <*> Just (fromMaybe 0 $ bytesComplete info)
|
||||||
|
|
||||||
type RetryDecider = TransferInfo -> TransferInfo -> Bool
|
|
||||||
|
|
||||||
noRetry :: RetryDecider
|
|
||||||
noRetry _ _ = False
|
|
||||||
|
|
||||||
{- Retries a transfer when it fails, as long as the failed transfer managed
|
|
||||||
- to send some data. -}
|
|
||||||
forwardRetry :: RetryDecider
|
|
||||||
forwardRetry old new = bytesComplete old < bytesComplete new
|
|
||||||
|
|
||||||
upload :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
|
|
||||||
upload u key = runTransfer (Transfer Upload u key)
|
|
||||||
|
|
||||||
download :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
|
|
||||||
download u key = runTransfer (Transfer Download u key)
|
|
||||||
|
|
||||||
{- Runs a transfer action. Creates and locks the lock file while the
|
|
||||||
- action is running, and stores info in the transfer information
|
|
||||||
- file.
|
|
||||||
-
|
|
||||||
- If the transfer action returns False, the transfer info is
|
|
||||||
- left in the failedTransferDir.
|
|
||||||
-
|
|
||||||
- If the transfer is already in progress, returns False.
|
|
||||||
-
|
|
||||||
- An upload can be run from a read-only filesystem, and in this case
|
|
||||||
- no transfer information or lock file is used.
|
|
||||||
-}
|
|
||||||
runTransfer :: Transfer -> Maybe FilePath -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool
|
|
||||||
runTransfer t file shouldretry a = do
|
|
||||||
info <- liftIO $ startTransferInfo file
|
|
||||||
(meter, tfile, metervar) <- mkProgressUpdater t info
|
|
||||||
mode <- annexFileMode
|
|
||||||
(fd, inprogress) <- liftIO $ prep tfile mode info
|
|
||||||
if inprogress
|
|
||||||
then do
|
|
||||||
showNote "transfer already in progress"
|
|
||||||
return False
|
|
||||||
else do
|
|
||||||
ok <- retry info metervar $
|
|
||||||
bracketIO (return fd) (cleanup tfile) (const $ a meter)
|
|
||||||
unless ok $ recordFailedTransfer t info
|
|
||||||
return ok
|
|
||||||
where
|
|
||||||
#ifndef mingw32_HOST_OS
|
|
||||||
prep tfile mode info = do
|
|
||||||
mfd <- catchMaybeIO $
|
|
||||||
openFd (transferLockFile tfile) ReadWrite (Just mode)
|
|
||||||
defaultFileFlags { trunc = True }
|
|
||||||
case mfd of
|
|
||||||
Nothing -> return (Nothing, False)
|
|
||||||
Just fd -> do
|
|
||||||
locked <- catchMaybeIO $
|
|
||||||
setLock fd (WriteLock, AbsoluteSeek, 0, 0)
|
|
||||||
if isNothing locked
|
|
||||||
then return (Nothing, True)
|
|
||||||
else do
|
|
||||||
void $ tryIO $ writeTransferInfoFile info tfile
|
|
||||||
return (mfd, False)
|
|
||||||
#else
|
|
||||||
prep tfile _mode info = do
|
|
||||||
v <- catchMaybeIO $ lockExclusive (transferLockFile tfile)
|
|
||||||
case v of
|
|
||||||
Nothing -> return (Nothing, False)
|
|
||||||
Just Nothing -> return (Nothing, True)
|
|
||||||
Just (Just lockhandle) -> do
|
|
||||||
void $ tryIO $ writeTransferInfoFile info tfile
|
|
||||||
return (Just lockhandle, False)
|
|
||||||
#endif
|
|
||||||
cleanup _ Nothing = noop
|
|
||||||
cleanup tfile (Just lockhandle) = do
|
|
||||||
void $ tryIO $ removeFile tfile
|
|
||||||
#ifndef mingw32_HOST_OS
|
|
||||||
void $ tryIO $ removeFile $ transferLockFile tfile
|
|
||||||
closeFd lockhandle
|
|
||||||
#else
|
|
||||||
{- Windows cannot delete the lockfile until the lock
|
|
||||||
- is closed. So it's possible to race with another
|
|
||||||
- process that takes the lock before it's removed,
|
|
||||||
- so ignore failure to remove.
|
|
||||||
-}
|
|
||||||
dropLock lockhandle
|
|
||||||
void $ tryIO $ removeFile $ transferLockFile tfile
|
|
||||||
#endif
|
|
||||||
retry oldinfo metervar run = do
|
|
||||||
v <- tryAnnex run
|
|
||||||
case v of
|
|
||||||
Right b -> return b
|
|
||||||
Left _ -> do
|
|
||||||
b <- getbytescomplete metervar
|
|
||||||
let newinfo = oldinfo { bytesComplete = Just b }
|
|
||||||
if shouldretry oldinfo newinfo
|
|
||||||
then retry newinfo metervar run
|
|
||||||
else return False
|
|
||||||
getbytescomplete metervar
|
|
||||||
| transferDirection t == Upload =
|
|
||||||
liftIO $ readMVar metervar
|
|
||||||
| otherwise = do
|
|
||||||
f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t)
|
|
||||||
liftIO $ catchDefaultIO 0 $
|
|
||||||
fromIntegral . fileSize <$> getFileStatus f
|
|
||||||
|
|
||||||
{- Generates a callback that can be called as transfer progresses to update
|
{- Generates a callback that can be called as transfer progresses to update
|
||||||
- the transfer info file. Also returns the file it'll be updating, and a
|
- the transfer info file. Also returns the file it'll be updating, and a
|
||||||
- MVar that can be used to read the number of bytesComplete. -}
|
- MVar that can be used to read the number of bytesComplete. -}
|
||||||
|
|
|
@ -24,7 +24,7 @@ import qualified Git.Command
|
||||||
import qualified Git.GCrypt
|
import qualified Git.GCrypt
|
||||||
import qualified Annex
|
import qualified Annex
|
||||||
import Logs.Presence
|
import Logs.Presence
|
||||||
import Logs.Transfer
|
import Annex.Transfer
|
||||||
import Annex.UUID
|
import Annex.UUID
|
||||||
import Annex.Exception
|
import Annex.Exception
|
||||||
import qualified Annex.Content
|
import qualified Annex.Content
|
||||||
|
@ -321,7 +321,7 @@ copyFromRemote' r key file dest
|
||||||
case v of
|
case v of
|
||||||
Nothing -> return False
|
Nothing -> return False
|
||||||
Just (object, checksuccess) ->
|
Just (object, checksuccess) ->
|
||||||
upload u key file noRetry
|
runTransfer (Transfer Download u key) file noRetry
|
||||||
(rsyncOrCopyFile params object dest)
|
(rsyncOrCopyFile params object dest)
|
||||||
<&&> checksuccess
|
<&&> checksuccess
|
||||||
| Git.repoIsSsh (repo r) = feedprogressback $ \feeder -> do
|
| Git.repoIsSsh (repo r) = feedprogressback $ \feeder -> do
|
||||||
|
@ -418,7 +418,7 @@ copyToRemote r key file p
|
||||||
( return True
|
( return True
|
||||||
, do
|
, do
|
||||||
ensureInitialized
|
ensureInitialized
|
||||||
download u key file noRetry $ const $
|
runTransfer (Transfer Download u key) file noRetry $ const $
|
||||||
Annex.Content.saveState True `after`
|
Annex.Content.saveState True `after`
|
||||||
Annex.Content.getViaTmpChecked (liftIO checksuccessio) key
|
Annex.Content.getViaTmpChecked (liftIO checksuccessio) key
|
||||||
(\d -> rsyncOrCopyFile params object d p)
|
(\d -> rsyncOrCopyFile params object d p)
|
||||||
|
|
27
Types/DesktopNotify.hs
Normal file
27
Types/DesktopNotify.hs
Normal file
|
@ -0,0 +1,27 @@
|
||||||
|
{- git-annex DesktopNotify type
|
||||||
|
-
|
||||||
|
- Copyright 2014 Joey Hess <joey@kitenet.net>
|
||||||
|
-
|
||||||
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
|
-}
|
||||||
|
|
||||||
|
module Types.DesktopNotify where
|
||||||
|
|
||||||
|
import Data.Monoid
|
||||||
|
|
||||||
|
data DesktopNotify = DesktopNotify
|
||||||
|
{ notifyStart :: Bool
|
||||||
|
, notifyFinish :: Bool
|
||||||
|
}
|
||||||
|
deriving (Show)
|
||||||
|
|
||||||
|
instance Monoid DesktopNotify where
|
||||||
|
mempty = DesktopNotify False False
|
||||||
|
mappend (DesktopNotify s1 f1) (DesktopNotify s2 f2) =
|
||||||
|
DesktopNotify (s1 || s2) (f1 || f2)
|
||||||
|
|
||||||
|
mkNotifyStart :: DesktopNotify
|
||||||
|
mkNotifyStart = DesktopNotify True False
|
||||||
|
|
||||||
|
mkNotifyFinish :: DesktopNotify
|
||||||
|
mkNotifyFinish = DesktopNotify False True
|
|
@ -33,7 +33,6 @@ import qualified Data.Text as T
|
||||||
import qualified Data.Text.Encoding as TE
|
import qualified Data.Text.Encoding as TE
|
||||||
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
|
import Blaze.ByteString.Builder.Char.Utf8 (fromText)
|
||||||
import Blaze.ByteString.Builder (Builder)
|
import Blaze.ByteString.Builder (Builder)
|
||||||
import Data.Monoid
|
|
||||||
import Control.Arrow ((***))
|
import Control.Arrow ((***))
|
||||||
import Control.Concurrent
|
import Control.Concurrent
|
||||||
#ifdef WITH_WEBAPP_SECURE
|
#ifdef WITH_WEBAPP_SECURE
|
||||||
|
|
5
debian/changelog
vendored
5
debian/changelog
vendored
|
@ -2,6 +2,11 @@ git-annex (5.20140321) UNRELEASED; urgency=medium
|
||||||
|
|
||||||
* unannex, uninit: Avoid committing after every file is unannexed,
|
* unannex, uninit: Avoid committing after every file is unannexed,
|
||||||
for massive speedup.
|
for massive speedup.
|
||||||
|
* --notify-finish switch will cause desktop notifications after each
|
||||||
|
file upload/download compltes
|
||||||
|
(using the dbus Desktop Notifications Specification)
|
||||||
|
* --notify-start switch will show desktop notifications when each
|
||||||
|
file upload/download starts.
|
||||||
|
|
||||||
-- Joey Hess <joeyh@debian.org> Fri, 21 Mar 2014 14:08:41 -0400
|
-- Joey Hess <joeyh@debian.org> Fri, 21 Mar 2014 14:08:41 -0400
|
||||||
|
|
||||||
|
|
1
debian/control
vendored
1
debian/control
vendored
|
@ -30,6 +30,7 @@ Build-Depends:
|
||||||
libghc-hinotify-dev [linux-any],
|
libghc-hinotify-dev [linux-any],
|
||||||
libghc-stm-dev (>= 2.3),
|
libghc-stm-dev (>= 2.3),
|
||||||
libghc-dbus-dev (>= 0.10.3) [linux-any],
|
libghc-dbus-dev (>= 0.10.3) [linux-any],
|
||||||
|
libghc-fdo-notify-dev (>= 0.3) [linux-any],
|
||||||
libghc-yesod-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
|
libghc-yesod-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
|
||||||
libghc-yesod-static-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
|
libghc-yesod-static-dev [i386 amd64 kfreebsd-i386 kfreebsd-amd64 powerpc sparc],
|
||||||
libghc-yesod-default-dev [i386 amd64 kfreebsd-amd64 powerpc sparc],
|
libghc-yesod-default-dev [i386 amd64 kfreebsd-amd64 powerpc sparc],
|
||||||
|
|
|
@ -1053,6 +1053,19 @@ subdirectories).
|
||||||
|
|
||||||
Overrides the User-Agent to use when downloading files from the web.
|
Overrides the User-Agent to use when downloading files from the web.
|
||||||
|
|
||||||
|
* `--notify-finish`
|
||||||
|
|
||||||
|
Caused a desktop notification to be displayed after each successful
|
||||||
|
file download and upload.
|
||||||
|
|
||||||
|
(Only supported on some platforms, eg Linux with dbus. A no-op when
|
||||||
|
not supported.)
|
||||||
|
|
||||||
|
* `--notify-start`
|
||||||
|
|
||||||
|
Caused a desktop notification to be displayed when a file upload
|
||||||
|
or download has started.
|
||||||
|
|
||||||
* `-c name=value`
|
* `-c name=value`
|
||||||
|
|
||||||
Overrides git configuration settings. May be specified multiple times.
|
Overrides git configuration settings. May be specified multiple times.
|
||||||
|
|
|
@ -85,6 +85,9 @@ Flag Tahoe
|
||||||
Flag CryptoHash
|
Flag CryptoHash
|
||||||
Description: Enable use of cryptohash for checksumming
|
Description: Enable use of cryptohash for checksumming
|
||||||
|
|
||||||
|
Flag DesktopNotify
|
||||||
|
Description: Enable desktop environment notifications
|
||||||
|
|
||||||
Flag EKG
|
Flag EKG
|
||||||
Description: Enable use of EKG to monitor git-annex as it runs (at http://localhost:4242/)
|
Description: Enable use of EKG to monitor git-annex as it runs (at http://localhost:4242/)
|
||||||
Default: False
|
Default: False
|
||||||
|
@ -167,10 +170,15 @@ Executable git-annex
|
||||||
CPP-Options: -DWITH_KQUEUE
|
CPP-Options: -DWITH_KQUEUE
|
||||||
C-Sources: Utility/libkqueue.c
|
C-Sources: Utility/libkqueue.c
|
||||||
|
|
||||||
if os(linux) && flag(Dbus)
|
if flag(Dbus)
|
||||||
Build-Depends: dbus (>= 0.10.3)
|
Build-Depends: dbus (>= 0.10.3)
|
||||||
CPP-Options: -DWITH_DBUS
|
CPP-Options: -DWITH_DBUS
|
||||||
|
|
||||||
|
if flag(DesktopNotify)
|
||||||
|
if flag(Dbus)
|
||||||
|
Build-Depends: dbus (>= 0.10.3), fdo-notify (>= 0.3)
|
||||||
|
CPP-Options: -DWITH_DESKTOP_NOTIFY -DWITH_DBUS_NOTIFICATIONS
|
||||||
|
|
||||||
if flag(Android)
|
if flag(Android)
|
||||||
Build-Depends: data-endian
|
Build-Depends: data-endian
|
||||||
CPP-Options: -D__ANDROID__ -DANDROID_SPLICES -D__NO_TH__
|
CPP-Options: -D__ANDROID__ -DANDROID_SPLICES -D__NO_TH__
|
||||||
|
|
Loading…
Add table
Reference in a new issue