61ccf95004
Only the assistant uses these, and only the assistant cleans them up, so make only git annex transferkeys write them, There is one behavior change from this. If glacier is being used, and a manual git annex get --from glacier fails because the file isn't available yet, the assistant will no longer later see that failed transfer file and retry the get. Hope no-one depended on that old behavior.
131 lines
3.4 KiB
Haskell
131 lines
3.4 KiB
Haskell
{- git-annex command, used internally by assistant
|
|
-
|
|
- Copyright 2012, 2013 Joey Hess <id@joeyh.name>
|
|
-
|
|
- 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 (dupIoHandles)
|
|
import Git.Types (RemoteName)
|
|
|
|
data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
|
|
|
|
cmd :: [Command]
|
|
cmd = [command "transferkeys" paramNothing seek
|
|
SectionPlumbing "transfers keys"]
|
|
|
|
seek :: CommandSeek
|
|
seek = withNothing start
|
|
|
|
start :: CommandStart
|
|
start = do
|
|
(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 forwardRetry observer $ \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 observer $ \p ->
|
|
getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p
|
|
|
|
observer False t info = recordFailedTransfer t info
|
|
observer True _ _ = noop
|
|
|
|
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
|