84 lines
		
	
	
	
		
			2.3 KiB
			
		
	
	
	
		
			Haskell
		
	
	
	
	
	
			
		
		
	
	
			84 lines
		
	
	
	
		
			2.3 KiB
			
		
	
	
	
		
			Haskell
		
	
	
	
	
	
{- git-annex command
 | 
						|
 -
 | 
						|
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 | 
						|
 -
 | 
						|
 - Licensed under the GNU GPL version 3 or higher.
 | 
						|
 -}
 | 
						|
 | 
						|
module Command.RecvKey where
 | 
						|
 | 
						|
import Common.Annex
 | 
						|
import Command
 | 
						|
import CmdLine
 | 
						|
import Annex.Content
 | 
						|
import Annex
 | 
						|
import Utility.Rsync
 | 
						|
import Logs.Transfer
 | 
						|
import Command.SendKey (fieldTransfer)
 | 
						|
import qualified CmdLine.GitAnnexShell.Fields as Fields
 | 
						|
import qualified Types.Key
 | 
						|
import qualified Types.Backend
 | 
						|
import qualified Backend
 | 
						|
 | 
						|
cmd :: [Command]
 | 
						|
cmd = [noCommit $ command "recvkey" paramKey seek
 | 
						|
	SectionPlumbing "runs rsync in server mode to receive content"]
 | 
						|
 | 
						|
seek :: CommandSeek
 | 
						|
seek = withKeys start
 | 
						|
 | 
						|
start :: Key -> CommandStart
 | 
						|
start key = fieldTransfer Download key $ \_p ->
 | 
						|
	ifM (getViaTmp key go)
 | 
						|
		( do
 | 
						|
			-- forcibly quit after receiving one key,
 | 
						|
			-- and shutdown cleanly
 | 
						|
			_ <- shutdown True
 | 
						|
			return True
 | 
						|
		, return False
 | 
						|
		)
 | 
						|
  where
 | 
						|
	go tmp = do
 | 
						|
		opts <- filterRsyncSafeOptions . maybe [] words
 | 
						|
			<$> getField "RsyncOptions"
 | 
						|
		ok <- liftIO $ rsyncServerReceive (map Param opts) tmp
 | 
						|
 | 
						|
		-- The file could have been received with permissions that
 | 
						|
		-- do not allow reading it, so this is done before the
 | 
						|
		-- directcheck.
 | 
						|
		freezeContent tmp
 | 
						|
 | 
						|
		if ok
 | 
						|
			then ifM (isJust <$> Fields.getField Fields.direct)
 | 
						|
				( directcheck tmp
 | 
						|
				, return True
 | 
						|
				)
 | 
						|
			else return False
 | 
						|
	{- If the sending repository uses direct mode, the file
 | 
						|
	 - it sends could be modified as it's sending it. So check
 | 
						|
	 - that the right size file was received, and that the key/value
 | 
						|
	 - Backend is happy with it. -}
 | 
						|
	directcheck tmp = do
 | 
						|
		oksize <- case Types.Key.keySize key of
 | 
						|
		        Nothing -> return True
 | 
						|
		        Just size -> do
 | 
						|
				size' <- fromIntegral . fileSize
 | 
						|
					<$> liftIO (getFileStatus tmp)
 | 
						|
				return $ size == size'
 | 
						|
		if oksize
 | 
						|
			then case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
 | 
						|
				Nothing -> do
 | 
						|
					warning "recvkey: received key from direct mode repository using unknown backend; cannot check; discarding"
 | 
						|
					return False
 | 
						|
				Just backend -> maybe (return True) runfsck
 | 
						|
					(Types.Backend.fsckKey backend)
 | 
						|
			else do
 | 
						|
				warning "recvkey: received key with wrong size; discarding"
 | 
						|
				return False
 | 
						|
	  where
 | 
						|
		runfsck check = ifM (check key tmp)
 | 
						|
			( return True
 | 
						|
			, do
 | 
						|
				warning "recvkey: received key from direct mode repository seems to have changed as it was transferred; discarding"
 | 
						|
				return False
 | 
						|
			)
 |