summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Command/Fsck.hs2
-rw-r--r--Command/Get.hs4
-rw-r--r--Command/Move.hs8
-rw-r--r--Command/Status.hs20
-rw-r--r--Logs/Transfer.hs33
-rw-r--r--Remote/Bup.hs10
-rw-r--r--Remote/Directory.hs8
-rw-r--r--Remote/Git.hs32
-rw-r--r--Remote/Helper/Encryptable.hs14
-rw-r--r--Remote/Helper/Hooks.hs4
-rw-r--r--Remote/Hook.hs8
-rw-r--r--Remote/Rsync.hs12
-rw-r--r--Remote/S3.hs10
-rw-r--r--Remote/Web.hs10
-rw-r--r--Types/Remote.hs7
-rw-r--r--debian/changelog1
16 files changed, 107 insertions, 76 deletions
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
index 7bfc46f4a..10cca489b 100644
--- a/Command/Fsck.hs
+++ b/Command/Fsck.hs
@@ -94,7 +94,7 @@ performRemote key file backend numcopies remote =
( return True
, ifM (Annex.getState Annex.fast)
( return False
- , Remote.retrieveKeyFile remote key tmp
+ , Remote.retrieveKeyFile remote key Nothing tmp
)
)
diff --git a/Command/Get.hs b/Command/Get.hs
index 35e25d975..a5901ba66 100644
--- a/Command/Get.hs
+++ b/Command/Get.hs
@@ -65,7 +65,7 @@ getKeyFile key file dest = dispatch =<< Remote.keyPossibilities key
| Remote.hasKeyCheap r =
either (const False) id <$> Remote.hasKey r key
| otherwise = return True
- docopy r continue = download r key file $ do
+ docopy r continue = download (Remote.uuid r) key (Just file) $ do
showAction $ "from " ++ Remote.name r
- ifM (Remote.retrieveKeyFile r key dest)
+ ifM (Remote.retrieveKeyFile r key (Just file) dest)
( return True , continue)
diff --git a/Command/Move.hs b/Command/Move.hs
index 8bba46878..e7c11e80d 100644
--- a/Command/Move.hs
+++ b/Command/Move.hs
@@ -89,7 +89,8 @@ toPerform dest move key file = moveLock move key $ do
stop
Right False -> do
showAction $ "to " ++ Remote.name dest
- ok <- upload dest key file $ Remote.storeKey dest key
+ ok <- upload (Remote.uuid dest) key (Just file) $
+ Remote.storeKey dest key (Just file)
if ok
then finish
else do
@@ -134,9 +135,10 @@ fromPerform :: Remote -> Bool -> Key -> FilePath -> CommandPerform
fromPerform src move key file = moveLock move key $
ifM (inAnnex key)
( handle move True
- , download src key file $ do
+ , download (Remote.uuid src) key (Just file) $ do
showAction $ "from " ++ Remote.name src
- ok <- getViaTmp key $ Remote.retrieveKeyFile src key
+ ok <- getViaTmp key $
+ Remote.retrieveKeyFile src key (Just file)
handle move ok
)
where
diff --git a/Command/Status.hs b/Command/Status.hs
index 2540a92da..eff21bb50 100644
--- a/Command/Status.hs
+++ b/Command/Status.hs
@@ -31,6 +31,7 @@ import Logs.Trust
import Remote
import Config
import Utility.Percentage
+import Logs.Transfer
-- a named computation that produces a statistic
type Stat = StatState (Maybe (String, StatState String))
@@ -70,6 +71,7 @@ fast_stats =
, remote_list SemiTrusted "semitrusted"
, remote_list UnTrusted "untrusted"
, remote_list DeadTrusted "dead"
+ , transfer_list
, disk_size
]
slow_stats :: [Stat]
@@ -170,6 +172,24 @@ bloom_info = stat "bloom filter size" $ json id $ do
return $ size ++ note
+transfer_list :: Stat
+transfer_list = stat "transfers in progress" $ nojson $ lift $ do
+ uuidmap <- Remote.remoteMap id
+ ts <- getTransfers
+ if null ts
+ then return "none"
+ else return $ pp uuidmap "" $ sort ts
+ where
+ pp _ c [] = c
+ pp uuidmap c ((t, i):xs) = "\n\t" ++ line uuidmap t i ++ pp uuidmap c xs
+ line uuidmap t i = unwords
+ [ show (transferDirection t) ++ "ing"
+ , fromMaybe (show $ transferKey t) (associatedFile i)
+ , if transferDirection t == Upload then "to" else "from"
+ , maybe (fromUUID $ transferRemote t) Remote.name $
+ M.lookup (transferRemote t) uuidmap
+ ]
+
disk_size :: Stat
disk_size = stat "available local disk space" $ json id $ lift $
calcfree
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index fe93b90b4..526241f93 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -8,13 +8,11 @@
module Logs.Transfer where
import Common.Annex
-import Types.Remote
-import Remote
import Annex.Perms
import Annex.Exception
import qualified Git
+import Types.Remote
-import qualified Data.Map as M
import Control.Concurrent
import System.Posix.Types
import Data.Time.Clock
@@ -23,7 +21,7 @@ import Data.Time.Clock
- of the transfer information file. -}
data Transfer = Transfer
{ transferDirection :: Direction
- , transferRemote :: Remote
+ , transferRemote :: UUID
, transferKey :: Key
}
deriving (Show, Eq, Ord)
@@ -50,11 +48,11 @@ readDirection "upload" = Just Upload
readDirection "download" = Just Download
readDirection _ = Nothing
-upload :: Remote -> Key -> FilePath -> Annex a -> Annex a
-upload remote key file a = transfer (Transfer Upload remote key) (Just file) a
+upload :: UUID -> Key -> AssociatedFile -> Annex a -> Annex a
+upload u key file a = transfer (Transfer Upload u key) file a
-download :: Remote -> Key -> FilePath -> Annex a -> Annex a
-download remote key file a = transfer (Transfer Download remote key) (Just file) a
+download :: UUID -> Key -> AssociatedFile -> Annex a -> Annex a
+download u key file a = transfer (Transfer Download u key) file a
{- Runs a transfer action. Creates and locks the transfer information file
- while the action is running. Will throw an error if the transfer is
@@ -83,10 +81,10 @@ transfer t file a = do
h <- fdToHandle fd
hPutStr h $ writeTransferInfo info
hFlush h
- return fd
- cleanup tfile fd = do
+ return h
+ cleanup tfile h = do
removeFile tfile
- closeFd fd
+ hClose h
{- If a transfer is still running, returns its TransferInfo. -}
checkTransfer :: Transfer -> Annex (Maybe TransferInfo)
@@ -114,8 +112,7 @@ checkTransfer t = do
{- Gets all currently running transfers. -}
getTransfers :: Annex [(Transfer, TransferInfo)]
getTransfers = do
- uuidmap <- remoteMap id
- transfers <- catMaybes . map (parseTransferFile uuidmap) <$> findfiles
+ transfers <- catMaybes . map parseTransferFile <$> findfiles
infos <- mapM checkTransfer transfers
return $ map (\(t, Just i) -> (t, i)) $
filter running $ zip transfers infos
@@ -126,18 +123,18 @@ getTransfers = do
{- The transfer information file to use for a given Transfer. -}
transferFile :: Transfer -> Git.Repo -> FilePath
-transferFile (Transfer direction remote key) r = gitAnnexTransferDir r
+transferFile (Transfer direction u key) r = gitAnnexTransferDir r
</> show direction
- </> fromUUID (uuid remote)
+ </> fromUUID u
</> keyFile key
{- Parses a transfer information filename to a Transfer. -}
-parseTransferFile :: M.Map UUID Remote -> FilePath -> Maybe Transfer
-parseTransferFile uuidmap file =
+parseTransferFile :: FilePath -> Maybe Transfer
+parseTransferFile file =
case drop (length bits - 3) bits of
[direction, u, key] -> Transfer
<$> readDirection direction
- <*> M.lookup (toUUID u) uuidmap
+ <*> pure (toUUID u)
<*> fileKey key
_ -> Nothing
where
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index f1a36e468..0d1b606d3 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -108,8 +108,8 @@ bupSplitParams r buprepo k src = do
return $ bupParams "split" buprepo
(os ++ [Param "-n", Param (bupRef k), src])
-store :: Git.Repo -> BupRepo -> Key -> Annex Bool
-store r buprepo k = do
+store :: Git.Repo -> BupRepo -> Key -> AssociatedFile -> Annex Bool
+store r buprepo k _f = do
src <- inRepo $ gitAnnexLocation k
params <- bupSplitParams r buprepo k (File src)
liftIO $ boolSystem "bup" params
@@ -122,11 +122,11 @@ storeEncrypted r buprepo (cipher, enck) k = do
withEncryptedHandle cipher (L.readFile src) $ \h ->
pipeBup params (Just h) Nothing
-retrieve :: BupRepo -> Key -> FilePath -> Annex Bool
-retrieve buprepo k f = do
+retrieve :: BupRepo -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieve buprepo k _f d = do
let params = bupParams "join" buprepo [Param $ bupRef k]
liftIO $ catchBoolIO $ do
- tofile <- openFile f WriteMode
+ tofile <- openFile d WriteMode
pipeBup params Nothing (Just tofile)
retrieveCheap :: BupRepo -> Key -> FilePath -> Annex Bool
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index f618f518e..6b158730e 100644
--- a/Remote/Directory.hs
+++ b/Remote/Directory.hs
@@ -122,8 +122,8 @@ withCheckedFiles check (Just _) d k a = go $ locations d k
withStoredFiles :: ChunkSize -> FilePath -> Key -> ([FilePath] -> IO Bool) -> IO Bool
withStoredFiles = withCheckedFiles doesFileExist
-store :: FilePath -> ChunkSize -> Key -> Annex Bool
-store d chunksize k = do
+store :: FilePath -> ChunkSize -> Key -> AssociatedFile -> Annex Bool
+store d chunksize k _f = do
src <- inRepo $ gitAnnexLocation k
metered k $ \meterupdate ->
storeHelper d chunksize k $ \dests ->
@@ -242,8 +242,8 @@ storeHelper d chunksize key a = prep <&&> check <&&> go
preventWrite dir
return (not $ null stored)
-retrieve :: FilePath -> ChunkSize -> Key -> FilePath -> Annex Bool
-retrieve d chunksize k f = metered k $ \meterupdate ->
+retrieve :: FilePath -> ChunkSize -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieve d chunksize k _ f = metered k $ \meterupdate ->
liftIO $ withStoredFiles chunksize d k $ \files ->
catchBoolIO $ do
meteredWriteFile' meterupdate f files feeder
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 60a881803..0b839c9a5 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -21,6 +21,7 @@ import qualified Git.Config
import qualified Git.Construct
import qualified Annex
import Logs.Presence
+import Logs.Transfer
import Annex.UUID
import qualified Annex.Content
import qualified Annex.BranchState
@@ -219,14 +220,19 @@ dropKey r key
]
{- Tries to copy a key's content from a remote's annex to a file. -}
-copyFromRemote :: Git.Repo -> Key -> FilePath -> Annex Bool
-copyFromRemote r key file
+copyFromRemote :: Git.Repo -> Key -> AssociatedFile -> FilePath -> Annex Bool
+copyFromRemote r key file dest
| not $ Git.repoIsUrl r = guardUsable r False $ do
params <- rsyncParams r
- loc <- liftIO $ gitAnnexLocation key r
- rsyncOrCopyFile params loc file
- | Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key file
- | Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) file
+ u <- getUUID
+ -- run copy from perspective of remote
+ liftIO $ onLocal r $ do
+ ensureInitialized
+ loc <- inRepo $ gitAnnexLocation key
+ upload u key file $
+ rsyncOrCopyFile params loc dest
+ | Git.repoIsSsh r = rsyncHelper =<< rsyncParamsRemote r True key dest
+ | Git.repoIsHttp r = Annex.Content.downloadUrl (keyUrls r key) dest
| otherwise = error "copying from non-ssh, non-http repo not supported"
copyFromRemoteCheap :: Git.Repo -> Key -> FilePath -> Annex Bool
@@ -236,23 +242,25 @@ copyFromRemoteCheap r key file
liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True
| Git.repoIsSsh r =
ifM (Annex.Content.preseedTmp key file)
- ( copyFromRemote r key file
+ ( copyFromRemote r key Nothing file
, return False
)
| otherwise = return False
{- Tries to copy a key's content to a remote's annex. -}
-copyToRemote :: Git.Repo -> Key -> Annex Bool
-copyToRemote r key
+copyToRemote :: Git.Repo -> Key -> AssociatedFile -> Annex Bool
+copyToRemote r key file
| not $ Git.repoIsUrl r = guardUsable r False $ commitOnCleanup r $ do
keysrc <- inRepo $ gitAnnexLocation key
params <- rsyncParams r
+ u <- getUUID
-- run copy from perspective of remote
liftIO $ onLocal r $ do
ensureInitialized
- Annex.Content.saveState True `after`
- Annex.Content.getViaTmp key
- (rsyncOrCopyFile params keysrc)
+ download u key file $
+ Annex.Content.saveState True `after`
+ Annex.Content.getViaTmp key
+ (rsyncOrCopyFile params keysrc)
| Git.repoIsSsh r = commitOnCleanup r $ do
keysrc <- inRepo $ gitAnnexLocation key
rsyncHelper =<< rsyncParamsRemote r False key keysrc
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs
index 789a1d996..6d5405d9e 100644
--- a/Remote/Helper/Encryptable.hs
+++ b/Remote/Helper/Encryptable.hs
@@ -59,14 +59,14 @@ encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r =
cost = cost r + encryptedRemoteCostAdj
}
where
- store k = cip k >>= maybe
- (storeKey r k)
+ store k f = cip k >>= maybe
+ (storeKey r k f)
(`storeKeyEncrypted` k)
- retrieve k f = cip k >>= maybe
- (retrieveKeyFile r k f)
- (\enck -> retrieveKeyFileEncrypted enck k f)
- retrieveCheap k f = cip k >>= maybe
- (retrieveKeyFileCheap r k f)
+ retrieve k f d = cip k >>= maybe
+ (retrieveKeyFile r k f d)
+ (\enck -> retrieveKeyFileEncrypted enck k d)
+ retrieveCheap k d = cip k >>= maybe
+ (retrieveKeyFileCheap r k d)
(\_ -> return False)
withkey a k = cip k >>= maybe (a k) (a . snd)
cip = cipherKey c
diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs
index d85959062..0a6b22081 100644
--- a/Remote/Helper/Hooks.hs
+++ b/Remote/Helper/Hooks.hs
@@ -27,8 +27,8 @@ addHooks' r Nothing Nothing = r
addHooks' r starthook stophook = r'
where
r' = r
- { storeKey = \k -> wrapper $ storeKey r k
- , retrieveKeyFile = \k f -> wrapper $ retrieveKeyFile r k f
+ { storeKey = \k f -> wrapper $ storeKey r k f
+ , retrieveKeyFile = \k f d -> wrapper $ retrieveKeyFile r k f d
, retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f
, removeKey = \k -> wrapper $ removeKey r k
, hasKey = \k -> wrapper $ hasKey r k
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 5fb793e65..9e8d3c620 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -101,8 +101,8 @@ runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype h
return False
)
-store :: String -> Key -> Annex Bool
-store h k = do
+store :: String -> Key -> AssociatedFile -> Annex Bool
+store h k _f = do
src <- inRepo $ gitAnnexLocation k
runHook h "store" k (Just src) $ return True
@@ -112,8 +112,8 @@ storeEncrypted h (cipher, enck) k = withTmp enck $ \tmp -> do
liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
runHook h "store" enck (Just tmp) $ return True
-retrieve :: String -> Key -> FilePath -> Annex Bool
-retrieve h k f = runHook h "retrieve" k (Just f) $ return True
+retrieve :: String -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieve h k _f d = runHook h "retrieve" k (Just d) $ return True
retrieveCheap :: String -> Key -> FilePath -> Annex Bool
retrieveCheap _ _ _ = return False
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index 6207e1425..887c68339 100644
--- a/Remote/Rsync.hs
+++ b/Remote/Rsync.hs
@@ -99,8 +99,8 @@ rsyncUrls o k = map use annexHashes
use h = rsyncUrl o </> h k </> rsyncEscape o (f </> f)
f = keyFile k
-store :: RsyncOpts -> Key -> Annex Bool
-store o k = rsyncSend o k <=< inRepo $ gitAnnexLocation k
+store :: RsyncOpts -> Key -> AssociatedFile -> Annex Bool
+store o k _f = rsyncSend o k <=< inRepo $ gitAnnexLocation k
storeEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> Annex Bool
storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do
@@ -108,8 +108,8 @@ storeEncrypted o (cipher, enck) k = withTmp enck $ \tmp -> do
liftIO $ withEncryptedContent cipher (L.readFile src) $ L.writeFile tmp
rsyncSend o enck tmp
-retrieve :: RsyncOpts -> Key -> FilePath -> Annex Bool
-retrieve o k f = untilTrue (rsyncUrls o k) $ \u -> rsyncRemote o
+retrieve :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieve o k _ f = untilTrue (rsyncUrls o k) $ \u -> rsyncRemote o
-- use inplace when retrieving to support resuming
[ Param "--inplace"
, Param u
@@ -117,11 +117,11 @@ retrieve o k f = untilTrue (rsyncUrls o k) $ \u -> rsyncRemote o
]
retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool
-retrieveCheap o k f = ifM (preseedTmp k f) ( retrieve o k f , return False )
+retrieveCheap o k f = ifM (preseedTmp k f) ( retrieve o k undefined f , return False )
retrieveEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
retrieveEncrypted o (cipher, enck) _ f = withTmp enck $ \tmp -> do
- ifM (retrieve o enck tmp)
+ ifM (retrieve o enck undefined tmp)
( liftIO $ catchBoolIO $ do
withDecryptedContent cipher (L.readFile tmp) $ L.writeFile f
return True
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 18d4915dc..dca08fff8 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -113,8 +113,8 @@ s3Setup u c = handlehost $ M.lookup "host" c
-- be human-readable
M.delete "bucket" defaults
-store :: Remote -> Key -> Annex Bool
-store r k = s3Action r False $ \(conn, bucket) -> do
+store :: Remote -> Key -> AssociatedFile -> Annex Bool
+store r k _f = s3Action r False $ \(conn, bucket) -> do
dest <- inRepo $ gitAnnexLocation k
res <- liftIO $ storeHelper (conn, bucket) r k dest
s3Bool res
@@ -149,12 +149,12 @@ storeHelper (conn, bucket) r k file = do
xheaders = filter isxheader $ M.assocs $ fromJust $ config r
isxheader (h, _) = "x-amz-" `isPrefixOf` h
-retrieve :: Remote -> Key -> FilePath -> Annex Bool
-retrieve r k f = s3Action r False $ \(conn, bucket) -> do
+retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool
+retrieve r k _f d = s3Action r False $ \(conn, bucket) -> do
res <- liftIO $ getObject conn $ bucketKey r bucket k
case res of
Right o -> do
- liftIO $ L.writeFile f $ obj_data o
+ liftIO $ L.writeFile d $ obj_data o
return True
Left e -> s3Warning e
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 5fc592326..2516240ab 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -51,21 +51,21 @@ gen r _ _ =
remotetype = remote
}
-downloadKey :: Key -> FilePath -> Annex Bool
-downloadKey key file = get =<< getUrls key
+downloadKey :: Key -> AssociatedFile -> FilePath -> Annex Bool
+downloadKey key _file dest = get =<< getUrls key
where
get [] = do
warning "no known url"
return False
get urls = do
showOutput -- make way for download progress bar
- downloadUrl urls file
+ downloadUrl urls dest
downloadKeyCheap :: Key -> FilePath -> Annex Bool
downloadKeyCheap _ _ = return False
-uploadKey :: Key -> Annex Bool
-uploadKey _ = do
+uploadKey :: Key -> AssociatedFile -> Annex Bool
+uploadKey _ _ = do
warning "upload to web not supported"
return False
diff --git a/Types/Remote.hs b/Types/Remote.hs
index 9bac2ca0f..c7628165c 100644
--- a/Types/Remote.hs
+++ b/Types/Remote.hs
@@ -33,6 +33,9 @@ data RemoteTypeA a = RemoteType {
instance Eq (RemoteTypeA a) where
x == y = typename x == typename y
+{- A filename associated with a Key, for display to user. -}
+type AssociatedFile = Maybe FilePath
+
{- An individual remote. -}
data RemoteA a = Remote {
-- each Remote has a unique uuid
@@ -42,9 +45,9 @@ data RemoteA a = Remote {
-- Remotes have a use cost; higher is more expensive
cost :: Int,
-- Transfers a key to the remote.
- storeKey :: Key -> a Bool,
+ storeKey :: Key -> AssociatedFile -> a Bool,
-- retrieves a key's contents to a file
- retrieveKeyFile :: Key -> FilePath -> a Bool,
+ retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> a Bool,
-- retrieves a key's contents to a tmp file, if it can be done cheaply
retrieveKeyFileCheap :: Key -> FilePath -> a Bool,
-- removes a key's contents
diff --git a/debian/changelog b/debian/changelog
index babd1786d..c279614ca 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -2,6 +2,7 @@ git-annex (3.20120630) UNRELEASED; urgency=low
* get, move, copy: Now refuse to do anything when the requested file
transfer is already in progress by another process.
+ * status: Lists transfers that are currently in progress.
-- Joey Hess <joeyh@debian.org> Sun, 01 Jul 2012 15:04:37 -0400
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-30 00:01:33 +0000