dd39e9e255
When annex.stalldetection is not enabled, and a likely stall is detected, display a suggestion to enable it. Note that the progress meter display is not taken down when displaying the message, so it will display like this: 0% 8 B 0 B/s Transfer seems to have stalled. To handle stalling transfers, configure annex.stalldetection 0% 10 B 0 B/s Although of course if it's really stalled, it will never update again after the message. Taking down the progress meter and starting a new one doesn't seem too necessary given how unusual this is, also this does help show the state it was at when it stalled. Use of uninterruptibleCancel here is ok, the thread it's canceling only does STM transactions and sleeps. The annex thread that gets forked off is separate to avoid it being canceled, so that it can be joined back at the end. A module cycle required moving from dupState the precaching of the remote list. Doing it at startConcurrency should cover all the cases where the remote list is used in concurrent actions. This commit was sponsored by Kevin Mueller on Patreon.
142 lines
4.1 KiB
Haskell
142 lines
4.1 KiB
Haskell
{- git-annex command, used internally by assistant in version
|
|
- 8.20201127 and older and provided only to avoid upgrade breakage.
|
|
- Remove at some point when such old versions of git-annex are unlikely
|
|
- to be running any longer.
|
|
-
|
|
- Copyright 2012, 2013 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
|
|
|
|
module Command.TransferKeys where
|
|
|
|
import Command
|
|
import Annex.Content
|
|
import Logs.Location
|
|
import Annex.Transfer
|
|
import qualified Remote
|
|
import Utility.SimpleProtocol (dupIoHandles)
|
|
import Git.Types (RemoteName)
|
|
import qualified Database.Keys
|
|
import Annex.BranchState
|
|
|
|
data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
|
|
|
|
cmd :: Command
|
|
cmd = command "transferkeys" SectionPlumbing "transfers keys (deprecated)"
|
|
paramNothing (withParams seek)
|
|
|
|
seek :: CmdParams -> CommandSeek
|
|
seek = withNothing (commandAction start)
|
|
|
|
start :: CommandStart
|
|
start = do
|
|
enableInteractiveBranchAccess
|
|
(readh, writeh) <- liftIO dupIoHandles
|
|
runRequests readh writeh runner
|
|
stop
|
|
where
|
|
runner (TransferRequest direction remote key file)
|
|
| direction == Upload = notifyTransfer direction file $
|
|
upload' (Remote.uuid remote) key file Nothing stdRetry $ \p -> do
|
|
tryNonAsync (Remote.storeKey remote key file p) >>= \case
|
|
Left e -> do
|
|
warning (show e)
|
|
return False
|
|
Right () -> do
|
|
Remote.logStatus remote key InfoPresent
|
|
return True
|
|
| otherwise = notifyTransfer direction file $
|
|
download' (Remote.uuid remote) key file Nothing stdRetry $ \p ->
|
|
logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
|
|
r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case
|
|
Left e -> do
|
|
warning (show e)
|
|
return (False, UnVerified)
|
|
Right v -> return (True, v)
|
|
-- Make sure we get the current
|
|
-- associated files data for the key,
|
|
-- not old cached data.
|
|
Database.Keys.closeDb
|
|
return r
|
|
|
|
runRequests
|
|
:: Handle
|
|
-> Handle
|
|
-> (TransferRequest -> Annex Bool)
|
|
-> Annex ()
|
|
runRequests readh writeh a = do
|
|
liftIO $ hSetBuffering readh NoBuffering
|
|
go =<< readrequests
|
|
where
|
|
go (d:rn:k:f:rest) = do
|
|
case (deserialize d, deserialize rn, deserialize k, deserialize f) of
|
|
(Just direction, Just remotename, Just key, Just file) -> do
|
|
mremote <- Remote.byName' remotename
|
|
case mremote of
|
|
Left _ -> sendresult False
|
|
Right remote -> sendresult =<< a
|
|
(TransferRequest direction remote key file)
|
|
_ -> sendresult False
|
|
go rest
|
|
go [] = noop
|
|
go [""] = noop
|
|
go v = error $ "transferkeys protocol error: " ++ show v
|
|
|
|
readrequests = liftIO $ split fieldSep <$> hGetContents readh
|
|
sendresult b = liftIO $ do
|
|
hPutStrLn writeh $ serialize b
|
|
hFlush writeh
|
|
|
|
sendRequest :: Transfer -> TransferInfo -> Handle -> IO ()
|
|
sendRequest t tinfo h = do
|
|
hPutStr h $ intercalate fieldSep
|
|
[ serialize (transferDirection t)
|
|
, maybe (serialize ((fromUUID (transferUUID t)) :: String))
|
|
(serialize . Remote.name)
|
|
(transferRemote tinfo)
|
|
, serialize (transferKey t)
|
|
, serialize (associatedFile tinfo)
|
|
, "" -- adds a trailing null
|
|
]
|
|
hFlush h
|
|
|
|
readResponse :: Handle -> IO Bool
|
|
readResponse h = fromMaybe False . deserialize <$> hGetLine h
|
|
|
|
fieldSep :: String
|
|
fieldSep = "\0"
|
|
|
|
class TCSerialized a where
|
|
serialize :: a -> String
|
|
deserialize :: String -> Maybe a
|
|
|
|
instance TCSerialized Bool where
|
|
serialize True = "1"
|
|
serialize False = "0"
|
|
deserialize "1" = Just True
|
|
deserialize "0" = Just False
|
|
deserialize _ = Nothing
|
|
|
|
instance TCSerialized Direction where
|
|
serialize Upload = "u"
|
|
serialize Download = "d"
|
|
deserialize "u" = Just Upload
|
|
deserialize "d" = Just Download
|
|
deserialize _ = Nothing
|
|
|
|
instance TCSerialized AssociatedFile where
|
|
serialize (AssociatedFile (Just f)) = fromRawFilePath f
|
|
serialize (AssociatedFile Nothing) = ""
|
|
deserialize "" = Just (AssociatedFile Nothing)
|
|
deserialize f = Just (AssociatedFile (Just (toRawFilePath f)))
|
|
|
|
instance TCSerialized RemoteName where
|
|
serialize n = n
|
|
deserialize n = Just n
|
|
|
|
instance TCSerialized Key where
|
|
serialize = serializeKey
|
|
deserialize = deserializeKey
|