fcc9e01556Seems to work! Even progress bars. Have not tested prompting or various error message displays yet. transferkeys had to be made to operate in different modes for the Assistant and Annex monads. A bit ugly, but it did relegate that really ugly Database.Keys.closeDb in transferkeys to only the assistant code path. This commit was sponsored by Noam Kremen.
112 lines
3.6 KiB
Haskell
112 lines
3.6 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2012-2020 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Command.TransferKeys where
|
|
|
|
import Command
|
|
import qualified Annex
|
|
import Annex.Content
|
|
import Logs.Location
|
|
import Annex.Transfer
|
|
import qualified Remote
|
|
import Utility.SimpleProtocol (dupIoHandles)
|
|
import qualified Database.Keys
|
|
import Annex.BranchState
|
|
import Types.Messages
|
|
import Annex.TransferrerPool
|
|
|
|
import Text.Read (readMaybe)
|
|
|
|
cmd :: Command
|
|
cmd = command "transferkeys" SectionPlumbing "transfers keys"
|
|
paramNothing (withParams seek)
|
|
|
|
seek :: CmdParams -> CommandSeek
|
|
seek = withNothing (commandAction start)
|
|
|
|
start :: CommandStart
|
|
start = do
|
|
enableInteractiveBranchAccess
|
|
(readh, writeh) <- liftIO dupIoHandles
|
|
Annex.setOutput $ SerializedOutput
|
|
(\v -> hPutStrLn writeh (show (TransferOutput v)) >> hFlush writeh)
|
|
(readMaybe <$> hGetLine readh)
|
|
runRequests readh writeh runner
|
|
stop
|
|
where
|
|
runner (TransferRequest AnnexLevel direction _ keydata file) remote
|
|
| direction == Upload =
|
|
-- This is called by eg, Annex.Transfer.upload,
|
|
-- so caller is responsible for doing notification,
|
|
-- and for retrying.
|
|
upload' (Remote.uuid remote) key file noRetry
|
|
(Remote.action . Remote.storeKey remote key file)
|
|
noNotification
|
|
| otherwise =
|
|
-- This is called by eg, Annex.Transfer.download
|
|
-- so caller is responsible for doing notification
|
|
-- and for retrying.
|
|
let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do
|
|
Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p)
|
|
in download' (Remote.uuid remote) key file noRetry go
|
|
noNotification
|
|
where
|
|
key = mkKey (const keydata)
|
|
runner (TransferRequest AssistantLevel direction _ keydata file) remote
|
|
| direction == Upload = notifyTransfer direction file $
|
|
upload' (Remote.uuid remote) key file 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 stdRetry $ \p ->
|
|
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
|
|
where
|
|
key = mkKey (const keydata)
|
|
|
|
runRequests
|
|
:: Handle
|
|
-> Handle
|
|
-> (TransferRequest -> Remote -> Annex Bool)
|
|
-> Annex ()
|
|
runRequests readh writeh a = go Nothing Nothing
|
|
where
|
|
go lastremoteoruuid lastremote = unlessM (liftIO $ hIsEOF readh) $ do
|
|
l <- liftIO $ hGetLine readh
|
|
case readMaybe l of
|
|
Just tr@(TransferRequest _ _ remoteoruuid _ _) -> do
|
|
-- Often the same remote will be used
|
|
-- repeatedly, so cache the last one to
|
|
-- avoid looking up repeatedly.
|
|
mremote <- if lastremoteoruuid == Just remoteoruuid
|
|
then pure lastremote
|
|
else eitherToMaybe <$> Remote.byName'
|
|
(either fromUUID id remoteoruuid)
|
|
case mremote of
|
|
Just remote -> do
|
|
sendresult =<< a tr remote
|
|
go (Just remoteoruuid) mremote
|
|
Nothing -> transferKeysProtocolError l
|
|
Nothing -> transferKeysProtocolError l
|
|
|
|
sendresult b = liftIO $ do
|
|
hPutStrLn writeh $ show $ TransferResult b
|
|
hFlush writeh
|