aaba83795b
This uses a DebugSelector, rather than debug levels, which will allow for a later option like --debug-from=Process to only see debuging about running processes. The module name that contains the thing being debugged is used as the DebugSelector (in most cases; does not need to be a hard and fast rule). Debug calls were changed to add that. hslogger did not display that first parameter to debugM, but the DebugSelector does get displayed. Also fastDebug will allow doing debugging in places that are used in tight loops, with the DebugSelector coming from the Annex Reader essentially for free. Not done yet.
65 lines
1.9 KiB
Haskell
65 lines
1.9 KiB
Haskell
{- git-annex command
|
|
-
|
|
- Copyright 2010,2012 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Command.SendKey where
|
|
|
|
import Command
|
|
import Annex.Content
|
|
import Annex
|
|
import Utility.Rsync
|
|
import Annex.Transfer
|
|
import qualified CmdLine.GitAnnexShell.Fields as Fields
|
|
import Utility.Metered
|
|
import Utility.Debug
|
|
|
|
cmd :: Command
|
|
cmd = noCommit $
|
|
command "sendkey" SectionPlumbing
|
|
"runs rsync in server mode to send content"
|
|
paramKey (withParams seek)
|
|
|
|
seek :: CmdParams -> CommandSeek
|
|
seek = withKeys (commandAction . start)
|
|
|
|
start :: (SeekInput, Key) -> CommandStart
|
|
start (_, key) = do
|
|
opts <- filterRsyncSafeOptions . maybe [] words
|
|
<$> getField "RsyncOptions"
|
|
ifM (inAnnex key)
|
|
( fieldTransfer Upload key $ \_p ->
|
|
sendAnnex key rollback $ liftIO . rsyncServerSend (map Param opts)
|
|
, do
|
|
warning "requested key is not present"
|
|
liftIO exitFailure
|
|
)
|
|
where
|
|
{- No need to do any rollback; when sendAnnex fails, a nonzero
|
|
- exit will be propigated, and the remote will know the transfer
|
|
- failed. -}
|
|
rollback = noop
|
|
|
|
fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart
|
|
fieldTransfer direction key a = do
|
|
liftIO $ debug "Command.SendKey" "transfer start"
|
|
afile <- AssociatedFile . (fmap toRawFilePath)
|
|
<$> Fields.getField Fields.associatedFile
|
|
ok <- maybe (a $ const noop)
|
|
-- Using noRetry here because we're the sender.
|
|
(\u -> runner (Transfer direction (toUUID u) (fromKey id key)) afile Nothing noRetry a)
|
|
=<< Fields.getField Fields.remoteUUID
|
|
liftIO $ debug "Command.SendKey" "transfer done"
|
|
liftIO $ exitBool ok
|
|
where
|
|
{- Allow the key to be sent to the remote even if there seems to be
|
|
- another transfer of that key going on to that remote.
|
|
- That one may be stale, etc.
|
|
-}
|
|
runner
|
|
| direction == Upload = alwaysRunTransfer
|
|
| otherwise = runTransfer
|