summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2012-09-21 16:23:25 -0400
committerGravatar Joey Hess <joey@kitenet.net>2012-09-21 16:23:25 -0400
commit77af38ec6ce38160f88b2bf1aa60d1abb9870769 (patch)
tree6661d5f9a64727778250bb27351c6766857ea78f
parent34ca1d698cf890016f8674fba7ef83b093103b83 (diff)
git-annex-shell transferinfo command
TODO: Use this when running sendkey, to feed back transfer info from the client side rsync.
-rw-r--r--Command/TransferInfo.hs60
-rw-r--r--GitAnnexShell.hs2
-rw-r--r--Logs/Transfer.hs55
-rw-r--r--Types/Key.hs2
-rw-r--r--doc/git-annex-shell.mdwn9
5 files changed, 104 insertions, 24 deletions
diff --git a/Command/TransferInfo.hs b/Command/TransferInfo.hs
new file mode 100644
index 000000000..0e0e81609
--- /dev/null
+++ b/Command/TransferInfo.hs
@@ -0,0 +1,60 @@
+{- git-annex command
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Command.TransferInfo where
+
+import Common.Annex
+import Command
+import Annex.Content
+import Logs.Transfer
+import Types.Remote
+import Types.Key
+
+def :: [Command]
+def = [noCommit $ command "transferinfo" paramdesc seek
+ "updates sender on number of bytes of content received"]
+
+seek :: [CommandSeek]
+seek = [withWords start]
+
+paramdesc :: String
+paramdesc = paramKey `paramPair` paramUUID `paramPair` paramOptional paramFile
+
+start :: [String] -> CommandStart
+start (k:u:f:[]) = start' (file2key k) (toUUID u) (Just f) >> stop
+start (k:u:[]) = start' (file2key k) (toUUID u) Nothing >> stop
+start _ = error "wrong number of parameters"
+
+{- Security:
+ -
+ - The transfer info file contains the user-supplied key, but
+ - the built-in guards prevent slashes in it from showing up in the filename.
+ - It also contains the UUID of the remote. But slashes are also filtered
+ - out of that when generating the filename.
+ -
+ - Checks that the key being transferred is inAnnex, to prevent
+ - malicious spamming of bogus keys. Does not check that a transfer
+ - of the key is actually in progress, because this could be started
+ - concurrently with sendkey, and win the race.
+ -}
+start' :: Maybe Key -> UUID -> AssociatedFile -> Annex ()
+start' Nothing _ _ = error "bad key"
+start' (Just key) u file = whenM (inAnnex key) $ do
+ let t = Transfer
+ { transferDirection = Upload
+ , transferUUID = u
+ , transferKey = key
+ }
+ info <- liftIO $ startTransferInfo file
+ (update, tfile) <- mkProgressUpdater t info
+ liftIO $ mapM_ void
+ [ tryIO $ forever $ do
+ bytes <- readish <$> getLine
+ maybe (error "transferinfo protocol error") update bytes
+ , tryIO $ removeFile tfile
+ , exitSuccess
+ ]
diff --git a/GitAnnexShell.hs b/GitAnnexShell.hs
index d9b60c0f6..ebe280279 100644
--- a/GitAnnexShell.hs
+++ b/GitAnnexShell.hs
@@ -23,6 +23,7 @@ import qualified Command.InAnnex
import qualified Command.DropKey
import qualified Command.RecvKey
import qualified Command.SendKey
+import qualified Command.TransferInfo
import qualified Command.Commit
cmds_readonly :: [Command]
@@ -30,6 +31,7 @@ cmds_readonly = concat
[ Command.ConfigList.def
, Command.InAnnex.def
, Command.SendKey.def
+ , Command.TransferInfo.def
]
cmds_notreadonly :: [Command]
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index e9ac5bd87..7188143d6 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -89,18 +89,9 @@ download u key file a = runTransfer (Transfer Download u key) file (const a)
-}
runTransfer :: Transfer -> Maybe FilePath -> (MeterUpdate -> Annex Bool) -> Annex Bool
runTransfer t file a = do
- tfile <- fromRepo $ transferFile t
- createAnnexDirectory $ takeDirectory tfile
+ info <- liftIO $ startTransferInfo file
+ (meter, tfile) <- mkProgressUpdater t info
mode <- annexFileMode
- info <- liftIO $ TransferInfo
- <$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime)
- <*> pure Nothing -- pid not stored in file, so omitted for speed
- <*> pure Nothing -- tid ditto
- <*> pure Nothing -- not 0; transfer may be resuming
- <*> pure Nothing
- <*> pure file
- <*> pure False
- meter <- liftIO $ progressupdater tfile info
ok <- bracketIO (prep tfile mode info) (cleanup tfile) (a meter)
unless ok $ failed info
return ok
@@ -122,16 +113,24 @@ runTransfer t file a = do
failedtfile <- fromRepo $ failedTransferFile t
createAnnexDirectory $ takeDirectory failedtfile
liftIO $ writeTransferInfoFile info failedtfile
- {- Updates transfer info file as transfer progresses. -}
- progressupdater tfile info = do
- mvar <- newMVar 0
- return $ \bytes -> modifyMVar_ mvar $ \oldbytes -> do
- if (bytes - oldbytes >= mindelta)
- then do
- let info' = info { bytesComplete = Just bytes }
- writeTransferInfoFile info' tfile
- return bytes
- else return oldbytes
+
+
+{- Generates a callback that can be called as transfer progresses to update
+ - the transfer info file. Also returns the file it'll be updating. -}
+mkProgressUpdater :: Transfer -> TransferInfo -> Annex (MeterUpdate, FilePath)
+mkProgressUpdater t info = do
+ tfile <- fromRepo $ transferFile t
+ createAnnexDirectory $ takeDirectory tfile
+ mvar <- liftIO $ newMVar 0
+ return (liftIO . updater tfile mvar, tfile)
+ where
+ updater tfile mvar bytes = modifyMVar_ mvar $ \oldbytes -> do
+ if (bytes - oldbytes >= mindelta)
+ then do
+ let info' = info { bytesComplete = Just bytes }
+ writeTransferInfoFile info' tfile
+ return bytes
+ else return oldbytes
{- The minimum change in bytesComplete that is worth
- updating a transfer info file for is 1% of the total
- keySize, rounded down. -}
@@ -139,6 +138,16 @@ runTransfer t file a = do
Just sz -> sz `div` 100
Nothing -> 100 * 1024 -- arbitrarily, 100 kb
+startTransferInfo :: Maybe FilePath -> IO TransferInfo
+startTransferInfo file = TransferInfo
+ <$> (Just . utcTimeToPOSIXSeconds <$> getCurrentTime)
+ <*> pure Nothing -- pid not stored in file, so omitted for speed
+ <*> pure Nothing -- tid ditto
+ <*> pure Nothing -- not 0; transfer may be resuming
+ <*> pure Nothing
+ <*> pure file
+ <*> pure False
+
{- If a transfer is still running, returns its TransferInfo. -}
checkTransfer :: Transfer -> Annex (Maybe TransferInfo)
checkTransfer t = do
@@ -192,7 +201,7 @@ removeFailedTransfer t = do
{- The transfer information file to use for a given Transfer. -}
transferFile :: Transfer -> Git.Repo -> FilePath
transferFile (Transfer direction u key) r = transferDir direction r
- </> fromUUID u
+ </> filter (/= '/') (fromUUID u)
</> keyFile key
{- The transfer information file to use to record a failed Transfer -}
@@ -278,4 +287,4 @@ failedTransferDir :: UUID -> Direction -> Git.Repo -> FilePath
failedTransferDir u direction r = gitAnnexTransferDir r
</> "failed"
</> showLcDirection direction
- </> fromUUID u
+ </> filter (/= '/') (fromUUID u)
diff --git a/Types/Key.hs b/Types/Key.hs
index 619315aed..6794ee003 100644
--- a/Types/Key.hs
+++ b/Types/Key.hs
@@ -40,7 +40,7 @@ stubKey = Key {
fieldSep :: Char
fieldSep = '-'
-{- Converts a key to a strings that are suitable for use as a filename.
+{- Converts a key to a string that is suitable for use as a filename.
- The name field is always shown last, separated by doubled fieldSeps,
- and is the only field allowed to contain the fieldSep. -}
key2file :: Key -> FilePath
diff --git a/doc/git-annex-shell.mdwn b/doc/git-annex-shell.mdwn
index 20a9d3d37..8256da0e3 100644
--- a/doc/git-annex-shell.mdwn
+++ b/doc/git-annex-shell.mdwn
@@ -46,6 +46,15 @@ first "/~/" or "/~user/" is expanded to the specified home directory.
This runs rsync in server mode to transfer out the content of a key.
+* transferinfo directory key uuid [file]
+
+ This is typically run at the same time as sendkey is sending a key
+ to the remote with the specified uuid.
+
+ It reads lines from standard input, each giving the number of bytes
+ that have been received so far. This is optional, but is used to update
+ progress information for the transfer of the key.
+
* commit directory
This commits any staged changes to the git-annex branch.