-{- git-annex command, used internally by assistant
+{- git-annex command
-
- - Copyright 2012, 2013 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-
module Command.TransferKeys where
import Command
+import qualified Annex
import Annex.Content
import Logs.Location
import Annex.Transfer
import Git.Types (RemoteName)
import qualified Database.Keys
import Annex.BranchState
+import Types.Messages
+import Types.Key
+import Messages.Internal
+
+import Text.Read (readMaybe)
+
+data TransferRequest = TransferRequest Direction (Either UUID RemoteName) KeyData AssociatedFile
+ deriving (Show, Read)
-data TransferRequest = TransferRequest Direction Remote Key AssociatedFile
+data TransferResponse
+ = TransferOutput SerializedOutput
+ | TransferResult Bool
+ deriving (Show, Read)
cmd :: Command
cmd = command "transferkeys" SectionPlumbing "transfers keys"
start = do
enableInteractiveBranchAccess
(readh, writeh) <- liftIO dupIoHandles
+ Annex.setOutput $ SerializedOutput $
+ hPutStrLn writeh . show . TransferOutput
runRequests readh writeh runner
stop
where
- runner (TransferRequest direction remote key file)
+ runner (TransferRequest 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
-- not old cached data.
Database.Keys.closeDb
return r
+ where
+ key = mkKey (const keydata)
runRequests
:: Handle
-> Handle
- -> (TransferRequest -> Annex Bool)
+ -> (TransferRequest -> Remote -> Annex Bool)
-> Annex ()
-runRequests readh writeh a = do
- liftIO $ hSetBuffering readh NoBuffering
- go =<< readrequests
+runRequests readh writeh a = go Nothing Nothing
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
+ 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
- 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
+ Just remote -> do
+ sendresult =<< a tr remote
+ go (Just remoteoruuid) mremote
+ Nothing -> protocolError l
+ Nothing -> protocolError l
- readrequests = liftIO $ split fieldSep <$> hGetContents readh
sendresult b = liftIO $ do
- hPutStrLn writeh $ serialize b
+ hPutStrLn writeh $ show $ TransferResult 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
+sendRequest t tinfo h = hPutStrLn h $ show $ TransferRequest
+ (transferDirection t)
+ (maybe (Left (transferUUID t)) (Right . Remote.name) (transferRemote tinfo))
+ (keyData (transferKey t))
+ (associatedFile tinfo)
+
+-- | Read a response from this command.
+--
+-- Each TransferOutput line that is read before the final TransferResult
+-- will be output.
+readResponse :: Handle -> Annex Bool
+readResponse h = do
+ l <- liftIO $ hGetLine h
+ case readMaybe l of
+ Just (TransferOutput so) -> do
+ emitSerializedOutput so
+ readResponse h
+ Just (TransferResult r) -> return r
+ Nothing -> protocolError l
+
+protocolError :: String -> a
+protocolError l = error $ "transferkeys protocol error: " ++ show l
| otherwise -> liftIO $ flushed $ S.putStr msg
JSONOutput _ -> void $ jsonoutputter jsonbuilder s
QuietOutput -> q
- SerializedOutput -> do
- liftIO $ outputSerialized $ OutputMessage msg
+ SerializedOutput h -> do
+ liftIO $ outputSerialized h $ OutputMessage msg
void $ jsonoutputter jsonbuilder s
-- Buffer changes to JSON until end is reached and then emit it.
bufferJSON :: JSONBuilder -> MessageState -> Annex Bool
bufferJSON jsonbuilder s = case outputType s of
JSONOutput _ -> go (flushed . JSON.emit)
- SerializedOutput -> go (outputSerialized . JSONObject . JSON.encode)
+ SerializedOutput h -> go (outputSerialized h . JSONObject . JSON.encode)
_ -> return False
where
go emitter
outputJSON :: JSONBuilder -> MessageState -> Annex Bool
outputJSON jsonbuilder s = case outputType s of
JSONOutput _ -> go (flushed . JSON.emit)
- SerializedOutput -> go (outputSerialized . JSONObject . JSON.encode)
+ SerializedOutput h -> go (outputSerialized h . JSONObject . JSON.encode)
_ -> return False
where
go emitter = do
let jb' = Just (JSON.addErrorMessage (lines msg) jb)
in Annex.changeState $ \st ->
st { Annex.output = s { jsonBuffer = jb' } }
- (SerializedOutput, _) ->
- liftIO $ outputSerialized $ OutputError msg
+ (SerializedOutput h, _) ->
+ liftIO $ outputSerialized h $ OutputError msg
_
| concurrentOutputEnabled s -> concurrentMessage s True msg go
| otherwise -> go
flushed :: IO () -> IO ()
flushed a = a >> hFlush stdout
-outputSerialized :: SerializedOutput -> IO ()
-outputSerialized = print
+outputSerialized :: (SerializedOutput -> IO ()) -> SerializedOutput -> IO ()
+outputSerialized = id
+
+emitSerializedOutput :: SerializedOutput -> Annex ()
+emitSerializedOutput (OutputMessage msg) =
+ outputMessage' nojsonoutputter nojsonbuilder msg
+ where
+ nojsonoutputter _ _ = return False
+ nojsonbuilder = id
+emitSerializedOutput (OutputError msg) = outputError msg
+emitSerializedOutput (ProgressMeter sz old new) = undefined -- TODO
+emitSerializedOutput (JSONObject b) =
+ withMessageState $ \s -> case outputType s of
+ JSONOutput _ -> liftIO $ flushed $ JSON.emit' b
+ SerializedOutput h -> liftIO $
+ outputSerialized h $ JSONObject b
+ _ -> q
projects / git-annex.git / commitdiff