1{- git-annex command 2 - 3 - Copyright 2010 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8module Command.RecvKey where 9 10import Command 11import Annex.Content 12import Annex.Action 13import Annex 14import Utility.Rsync 15import Types.Transfer 16import Logs.Location 17import Command.SendKey (fieldTransfer) 18import qualified CmdLine.GitAnnexShell.Fields as Fields 19 20cmd :: Command 21cmd = noCommit $ command "recvkey" SectionPlumbing 22 "runs rsync in server mode to receive content" 23 paramKey (withParams seek) 24 25seek :: CmdParams -> CommandSeek 26seek = withKeys (commandAction . start) 27 28start :: (SeekInput, Key) -> CommandStart 29start (_, key) = fieldTransfer Download key $ \_p -> do 30 -- Always verify content when a repo is sending an unlocked file, 31 -- as the file could change while being transferred. 32 fromunlocked <- (isJust <$> Fields.getField Fields.unlocked) 33 <||> (isJust <$> Fields.getField Fields.direct) 34 let verify = if fromunlocked then AlwaysVerify else DefaultVerify 35 -- This matches the retrievalSecurityPolicy of Remote.Git 36 let rsp = RetrievalAllKeysSecure 37 ifM (getViaTmp rsp verify key (AssociatedFile Nothing) go) 38 ( do 39 logStatus key InfoPresent 40 -- forcibly quit after receiving one key, 41 -- and shutdown cleanly 42 _ <- shutdown True 43 return True 44 , return False 45 ) 46 where 47 go tmp = unVerified $ do 48 opts <- filterRsyncSafeOptions . maybe [] words 49 <$> getField "RsyncOptions" 50 liftIO $ rsyncServerReceive (map Param opts) (fromRawFilePath tmp) 51