diff options
-rw-r--r-- | Assistant/Threads/WebApp.hs | 7 | ||||
-rw-r--r-- | Messages.hs | 7 | ||||
-rw-r--r-- | Remote/Helper/Ssh.hs | 24 | ||||
-rw-r--r-- | debian/changelog | 1 |
4 files changed, 24 insertions, 15 deletions
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index fd78ba8d8..33d11a0d5 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -49,7 +49,6 @@ import Network.Socket (SockAddr, HostName) import Data.Text (pack, unpack) import qualified Network.Wai.Handler.WarpTLS as TLS import Network.Wai.Middleware.RequestLogger -import System.Log.Logger mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") @@ -138,9 +137,3 @@ getTlsSettings = do #else return Nothing #endif - -{- Checks if debugging is actually enabled. -} -debugEnabled :: IO Bool -debugEnabled = do - l <- getRootLogger - return $ getLevel l <= Just DEBUG diff --git a/Messages.hs b/Messages.hs index c6d033402..026fca51e 100644 --- a/Messages.hs +++ b/Messages.hs @@ -32,6 +32,7 @@ module Messages ( setupConsole, enableDebugOutput, disableDebugOutput, + debugEnabled, commandProgressDisabled, ) where @@ -191,6 +192,12 @@ enableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel DEBUG disableDebugOutput :: IO () disableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel NOTICE +{- Checks if debugging is enabled. -} +debugEnabled :: IO Bool +debugEnabled = do + l <- getRootLogger + return $ getLevel l <= Just DEBUG + {- Should commands that normally output progress messages have that - output disabled? -} commandProgressDisabled :: Annex Bool diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 1e4daa1ad..162c34f4e 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -38,22 +38,30 @@ toRepo r gc sshcmd = do - repository. -} git_annex_shell :: Git.Repo -> String -> [CommandParam] -> [(Field, String)] -> Annex (Maybe (FilePath, [CommandParam])) git_annex_shell r command params fields - | not $ Git.repoIsUrl r = return $ Just (shellcmd, shellopts ++ fieldopts) + | not $ Git.repoIsUrl r = do + shellopts <- getshellopts + return $ Just (shellcmd, shellopts ++ fieldopts) | Git.repoIsSsh r = do gc <- Annex.getRemoteGitConfig r u <- getRepoUUID r - sshparams <- toRepo r gc [Param $ sshcmd u gc] + shellopts <- getshellopts + let sshcmd = unwords $ + fromMaybe shellcmd (remoteAnnexShell gc) + : map shellEscape (toCommand shellopts) ++ + uuidcheck u ++ + map shellEscape (toCommand fieldopts) + sshparams <- toRepo r gc [Param sshcmd] return $ Just ("ssh", sshparams) | otherwise = return Nothing where dir = Git.repoPath r shellcmd = "git-annex-shell" - shellopts = Param command : File dir : params - sshcmd u gc = unwords $ - fromMaybe shellcmd (remoteAnnexShell gc) - : map shellEscape (toCommand shellopts) ++ - uuidcheck u ++ - map shellEscape (toCommand fieldopts) + getshellopts = do + debug <- liftIO debugEnabled + let params' = if debug + then Param "--debug" : params + else params + return (Param command : File dir : params') uuidcheck NoUUID = [] uuidcheck (UUID u) = ["--uuid", u] fieldopts diff --git a/debian/changelog b/debian/changelog index cbb2601eb..0b5c84edb 100644 --- a/debian/changelog +++ b/debian/changelog @@ -3,6 +3,7 @@ git-annex (5.20150813) UNRELEASED; urgency=medium * --debug log messages are now timestamped with fractional seconds. * Sped up downloads of files from ssh remotes, reducing the non-data-transfer overhead 6x. + * --debug is passed along to git-annex-shell when git-annex is in debug mode. -- Joey Hess <id@joeyh.name> Wed, 12 Aug 2015 14:31:01 -0400 |