fed509fb3e
Note that TransferInfo does not always contain the Remote, although any transfer added to the TransferQueue does have a Remote in its TransferInfo. The transferkeys command still accepts a UUID, which is useful to handle upgrades, where an old assistant version runs the new transferkeys. This commit was sponsored by Kalle Svensson.
128 lines
3.3 KiB
Haskell
128 lines
3.3 KiB
Haskell
{- git-annex command, used internally by assistant
|
|
-
|
|
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
|
|
|
|
module Command.TransferKeys where
|
|
|
|
import Common.Annex
|
|
import Command
|
|
import Annex.Content
|
|
import Logs.Location
|
|
import Annex.Transfer
|
|
import qualified Remote
|
|
import Types.Key
|
|
import Utility.SimpleProtocol (ioHandles)
|
|
import Git.Types (RemoteName)
|
|
|
|
data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
|
|
|
|
def :: [Command]
|
|
def = [command "transferkeys" paramNothing seek
|
|
SectionPlumbing "transfers keys"]
|
|
|
|
seek :: CommandSeek
|
|
seek = withNothing start
|
|
|
|
start :: CommandStart
|
|
start = do
|
|
(readh, writeh) <- liftIO ioHandles
|
|
runRequests readh writeh runner
|
|
stop
|
|
where
|
|
runner (TransferRequest direction remote key file)
|
|
| direction == Upload = notifyTransfer direction file $
|
|
upload (Remote.uuid remote) key file forwardRetry $ \p -> do
|
|
ok <- Remote.storeKey remote key file p
|
|
when ok $
|
|
Remote.logStatus remote key InfoPresent
|
|
return ok
|
|
| otherwise = notifyTransfer direction file $
|
|
download (Remote.uuid remote) key file forwardRetry $ \p ->
|
|
getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
|
|
|
|
runRequests
|
|
:: Handle
|
|
-> Handle
|
|
-> (TransferRequest -> Annex Bool)
|
|
-> Annex ()
|
|
runRequests readh writeh a = do
|
|
liftIO $ do
|
|
hSetBuffering readh NoBuffering
|
|
fileEncoding readh
|
|
fileEncoding writeh
|
|
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 info h = do
|
|
hPutStr h $ intercalate fieldSep
|
|
[ serialize (transferDirection t)
|
|
, maybe (serialize (fromUUID (transferUUID t)))
|
|
(serialize . Remote.name)
|
|
(transferRemote info)
|
|
, serialize (transferKey t)
|
|
, serialize (associatedFile info)
|
|
, "" -- 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 (Just f) = f
|
|
serialize Nothing = ""
|
|
deserialize "" = Just Nothing
|
|
deserialize f = Just $ Just f
|
|
|
|
instance TCSerialized RemoteName where
|
|
serialize n = n
|
|
deserialize n = Just n
|
|
|
|
instance TCSerialized Key where
|
|
serialize = key2file
|
|
deserialize = file2key
|