From aaba83795b97bfb39725883eecb0f85893729538 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 5 Apr 2021 13:40:31 -0400 Subject: [PATCH] switch from hslogger to purpose-built Utility.Debug 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. --- Annex/Drop.hs | 6 ++- Annex/ExternalAddonProcess.hs | 6 ++- Annex/TransferrerPool.hs | 9 ++-- Assistant.hs | 12 ++--- Assistant/DaemonStatus.hs | 4 +- Assistant/Monad.hs | 13 ++--- Assistant/Repair.hs | 2 +- Assistant/Threads/SanityChecker.hs | 6 +-- Assistant/Threads/WebApp.hs | 2 +- Backend/External.hs | 5 +- Command/Drop.hs | 8 +-- Command/ImportFeed.hs | 4 +- Command/Move.hs | 8 +-- Command/SendKey.hs | 9 ++-- Messages.hs | 40 +++++++------- P2P/IO.hs | 6 +-- Remote/External.hs | 4 +- Remote/GitLFS.hs | 6 +-- Remote/Helper/Ssh.hs | 2 +- Remote/S3.hs | 12 ++--- Remote/WebDAV.hs | 5 +- RemoteDaemon/Transport/Tor.hs | 20 ++++--- Utility/Debug.hs | 86 ++++++++++++++++++++++++++++++ Utility/Process.hs | 7 +-- Utility/Url.hs | 12 ++--- git-annex.cabal | 5 +- 26 files changed, 194 insertions(+), 105 deletions(-) create mode 100644 Utility/Debug.hs diff --git a/Annex/Drop.hs b/Annex/Drop.hs index 08654ff221..c03c06629c 100644 --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.Drop where import Annex.Common @@ -20,9 +22,9 @@ import Annex.Content import Annex.SpecialRemote.Config import qualified Database.Keys import Git.FilePath +import Utility.Debug import qualified Data.Set as S -import System.Log.Logger (debugM) type Reason = String @@ -115,7 +117,7 @@ handleDropsFrom locs rs reason fromhere key afile si preverified runner = do dodrop n@(have, numcopies, mincopies, _untrusted) u a = ifM (safely $ runner $ a numcopies mincopies) ( do - liftIO $ debugM "drop" $ unwords + liftIO $ debug "Annex.Drop" $ unwords [ "dropped" , case afile of AssociatedFile Nothing -> serializeKey key diff --git a/Annex/ExternalAddonProcess.hs b/Annex/ExternalAddonProcess.hs index 40908ccab0..13f2bbb264 100644 --- a/Annex/ExternalAddonProcess.hs +++ b/Annex/ExternalAddonProcess.hs @@ -5,16 +5,18 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Annex.ExternalAddonProcess where import qualified Annex import Annex.Common import Git.Env import Utility.Shell +import Utility.Debug import Messages.Progress import Control.Concurrent.Async -import System.Log.Logger (debugM) data ExternalAddonProcess = ExternalAddonProcess { externalSend :: Handle @@ -91,7 +93,7 @@ startExternalAddonProcess basecmd pid = do "Cannot run " ++ basecmd ++ " -- It is not installed in PATH (" ++ path ++ ")" protocolDebug :: ExternalAddonProcess -> Bool -> String -> IO () -protocolDebug external sendto line = debugM "external" $ unwords +protocolDebug external sendto line = debug "Annex.ExternalAddonProcess" $ unwords [ externalProgram external ++ "[" ++ show (externalPid external) ++ "]" , if sendto then "<--" else "-->" diff --git a/Annex/TransferrerPool.hs b/Annex/TransferrerPool.hs index 7ccb49b8dd..0b3cb30e7d 100644 --- a/Annex/TransferrerPool.hs +++ b/Annex/TransferrerPool.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE CPP #-} @@ -23,13 +24,13 @@ import Annex.Path import Annex.StallDetection import Utility.Batch import Utility.Metered +import Utility.Debug import qualified Utility.SimpleProtocol as Proto import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM hiding (check) import Control.Monad.IO.Class (MonadIO) -import System.Log.Logger (debugM) import qualified Data.Map as M #ifndef mingw32_HOST_OS import System.Posix.Signals @@ -241,7 +242,7 @@ sendRequest level t mremote afile h = do (AssistantLevel, Download) -> AssistantDownloadRequest let r = f tr (transferKey t) (TransferAssociatedFile afile) let l = unwords $ Proto.formatMessage r - debugM "transfer" ("> " ++ l) + debug "Annex.TransferrerPool" ("> " ++ l) hPutStrLn h l hFlush h @@ -249,7 +250,7 @@ sendSerializedOutputResponse :: Handle -> SerializedOutputResponse -> IO () sendSerializedOutputResponse h sor = do let l = unwords $ Proto.formatMessage $ TransferSerializedOutputResponse sor - debugM "transfer" ("> " ++ show l) + debug "Annex.TransferrerPool" ("> " ++ show l) hPutStrLn h l hFlush h @@ -260,7 +261,7 @@ sendSerializedOutputResponse h sor = do readResponse :: Handle -> IO (Either SerializedOutput Bool) readResponse h = do l <- liftIO $ hGetLine h - debugM "transfer" ("< " ++ l) + debug "Annex.TransferrerPool" ("< " ++ l) case Proto.parseMessage l of Just (TransferOutput so) -> return (Left so) Just (TransferResult r) -> return (Right r) diff --git a/Assistant.hs b/Assistant.hs index d7e75e23de..ce9ef930f9 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module Assistant where @@ -48,7 +49,6 @@ import Assistant.Types.UrlRenderer import qualified Utility.Daemon import Utility.ThreadScheduler import Utility.HumanTime -import qualified BuildInfo import Annex.Perms import Annex.BranchState import Utility.LogFile @@ -57,8 +57,8 @@ import Utility.Env import Annex.Path import System.Environment (getArgs) #endif +import qualified Utility.Debug as Debug -import System.Log.Logger import Network.Socket (HostName) stopDaemon :: Annex () @@ -76,7 +76,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = enableInteractiveBranchAccess pidfile <- fromRepo gitAnnexPidFile logfile <- fromRepo gitAnnexDaemonLogFile - liftIO $ debugM desc $ "logging to " ++ fromRawFilePath logfile + liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile createAnnexDirectory (parentDir pidfile) #ifndef mingw32_HOST_OS createAnnexDirectory (parentDir logfile) @@ -122,14 +122,11 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = ) #endif where - desc - | assistant = "assistant" - | otherwise = "watch" start daemonize webappwaiter = withThreadState $ \st -> do checkCanWatch dstatus <- startDaemonStatus logfile <- fromRepo gitAnnexDaemonLogFile - liftIO $ debugM desc $ "logging to " ++ fromRawFilePath logfile + liftIO $ Debug.debug "Assistant" $ "logging to " ++ fromRawFilePath logfile liftIO $ daemonize $ flip runAssistant (go webappwaiter) =<< newAssistantData st dstatus @@ -140,7 +137,6 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = #else go _webappwaiter = do #endif - notice ["starting", desc, "version", BuildInfo.packageversion] urlrenderer <- liftIO newUrlRenderer #ifdef WITH_WEBAPP let webappthread = [ assist $ webAppThread d urlrenderer False cannotrun Nothing listenhost webappwaiter ] diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs index 34e34073ba..1dbb27fd4e 100644 --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -221,9 +221,7 @@ notifyAlert = do {- Returns the alert's identifier, which can be used to remove it. -} addAlert :: Alert -> Assistant AlertId -addAlert alert = do - notice [showAlert alert] - notifyAlert `after` modifyDaemonStatus add +addAlert alert = notifyAlert `after` modifyDaemonStatus add where add s = (s { lastAlertId = i, alertMap = m }, i) where diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index ff79f5f173..fd886bb949 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -22,11 +22,9 @@ module Assistant.Monad ( asIO2, ThreadName, debug, - notice ) where import "mtl" Control.Monad.Reader -import System.Log.Logger import qualified Control.Monad.Fail as Fail import Annex.Common @@ -43,6 +41,7 @@ import Assistant.Types.RepoProblem import Assistant.Types.ThreadName import Assistant.Types.RemoteControl import Assistant.Types.CredPairCache +import qualified Utility.Debug as Debug newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a } deriving ( @@ -139,12 +138,6 @@ asIO2 a = do io <<~ v = reader v >>= liftIO . io debug :: [String] -> Assistant () -debug = logaction debugM - -notice :: [String] -> Assistant () -notice = logaction noticeM - -logaction :: (String -> String -> IO ()) -> [String] -> Assistant () -logaction a ws = do +debug ws = do ThreadName name <- getAssistant threadName - liftIO $ a name $ unwords $ (name ++ ":") : ws + liftIO $ Debug.debug (Debug.DebugSource (encodeBS name)) (unwords ws) diff --git a/Assistant/Repair.hs b/Assistant/Repair.hs index 96e8e1904a..71d4e35c1f 100644 --- a/Assistant/Repair.hs +++ b/Assistant/Repair.hs @@ -157,5 +157,5 @@ repairStaleLocks lockfiles = go =<< getsizes go =<< getsizes ) waitforit why = do - notice ["Waiting for 60 seconds", why] + debug ["Waiting for 60 seconds", why] liftIO $ threadDelaySeconds $ Seconds 60 diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 191f814000..34f46c8003 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -66,7 +66,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta - all, so detect and repair. -} ifM (not <$> liftAnnex (inRepo checkIndexFast)) ( do - notice ["corrupt index file found at startup; removing and restaging"] + debug ["corrupt index file found at startup; removing and restaging"] liftAnnex $ inRepo $ removeWhenExistsWith R.removeLink . indexFile {- Normally the startup scan avoids re-staging files, - but with the index deleted, everything needs to be @@ -80,7 +80,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta - the data from the git-annex branch will be used, and the index - will be automatically regenerated. -} unlessM (liftAnnex $ Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndexFast) $ do - notice ["corrupt annex/index file found at startup; removing"] + debug ["corrupt annex/index file found at startup; removing"] liftAnnex $ liftIO . removeWhenExistsWith R.removeLink =<< fromRepo gitAnnexIndex {- Fix up ssh remotes set up by past versions of the assistant. -} @@ -226,7 +226,7 @@ checkLogSize n = do logs <- liftIO $ listLogs f totalsize <- liftIO $ sum <$> mapM (getFileSize . toRawFilePath) logs when (totalsize > 2 * oneMegabyte) $ do - notice ["Rotated logs due to size:", show totalsize] + debug ["Rotated logs due to size:", show totalsize] liftIO $ openLog f >>= handleToFd >>= redirLog when (n < maxLogs + 1) $ do df <- liftIO $ getDiskFree $ takeDirectory f diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 28c04dfc48..f8b3a2b41e 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -80,7 +80,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost <*> newWormholePairingState setUrlRenderer urlrenderer $ yesodRender webapp (pack "") app <- toWaiAppPlain webapp - app' <- ifM debugEnabled + app' <- ifM (fromMaybe False <$> (getAnnex $ Just . annexDebug <$> Annex.getGitConfig)) ( return $ logStdout app , return app ) diff --git a/Backend/External.hs b/Backend/External.hs index 7ad8303f8c..7fd6cbc7e0 100644 --- a/Backend/External.hs +++ b/Backend/External.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} module Backend.External (makeBackend) where @@ -16,6 +17,7 @@ import Types.Key import Types.Backend import Types.KeySource import Utility.Metered +import Utility.Debug import qualified Utility.SimpleProtocol as Proto import qualified Data.ByteString as S @@ -23,7 +25,6 @@ import qualified Data.Map.Strict as M import Data.Char import Control.Concurrent import System.IO.Unsafe (unsafePerformIO) -import System.Log.Logger (debugM) newtype ExternalBackendName = ExternalBackendName S.ByteString deriving (Show, Eq, Ord) @@ -141,7 +142,7 @@ handleRequest st req whenunavail responsehandler = warning ("external special remote error: " ++ err) whenunavail handleExceptionalMessage loop (DEBUG msg) = do - liftIO $ debugM "external" msg + liftIO $ debug "Backend.External" msg loop withExternalAddon :: ExternalState -> a -> (ExternalAddonProcess -> a) -> a diff --git a/Command/Drop.hs b/Command/Drop.hs index acd863c6ae..6de54e8ad2 100644 --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.Drop where import Command @@ -18,8 +20,8 @@ import Annex.NumCopies import Annex.Content import Annex.Wanted import Annex.Notification +import Utility.Debug -import System.Log.Logger (debugM) import qualified Data.Set as S cmd :: Command @@ -113,7 +115,7 @@ performLocal key afile numcopies mincopies preverified = lockContentForRemoval k (tocheck, verified) <- verifiableCopies key [u] doDrop u (Just contentlock) key afile numcopies mincopies [] (preverified ++ verified) tocheck ( \proof -> do - liftIO $ debugM "drop" $ unwords + liftIO $ debug "Command.Drop" $ unwords [ "Dropping from here" , "proof:" , show proof @@ -140,7 +142,7 @@ performRemote key afile numcopies mincopies remote = do (tocheck, verified) <- verifiableCopies key [uuid] doDrop uuid Nothing key afile numcopies mincopies [uuid] verified tocheck ( \proof -> do - liftIO $ debugM "drop" $ unwords + liftIO $ debug "Command.Drop" $ unwords [ "Dropping from remote" , show remote , "proof:" diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs index dc21885ecb..cc8ca5d7af 100644 --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -20,7 +20,6 @@ import Data.Time.Format import Data.Time.Calendar import Data.Time.LocalTime import qualified Data.Text as T -import System.Log.Logger import Control.Concurrent.Async import qualified System.FilePath.ByteString as P @@ -50,6 +49,7 @@ import qualified Git.Ref import qualified Annex.Branch import Logs import Git.CatFile (catObjectStream) +import Utility.Debug cmd :: Command cmd = notBareRepo $ @@ -96,7 +96,7 @@ getFeed addunlockedmatcher opts cache url = do ) where debugfeedcontent feedcontent msg = do - liftIO $ debugM "feed content" $ unlines + liftIO $ debug "Command.ImportFeed" $ unlines [ "start of feed content" , feedcontent , "end of feed content" diff --git a/Command/Move.hs b/Command/Move.hs index 84533506af..b0b853c371 100644 --- a/Command/Move.hs +++ b/Command/Move.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.Move where import Command @@ -18,8 +20,8 @@ import Logs.Presence import Logs.Trust import Logs.File import Annex.NumCopies +import Utility.Debug -import System.Log.Logger (debugM) import qualified Data.ByteString.Char8 as B8 import qualified Data.ByteString.Lazy as L @@ -175,7 +177,7 @@ toPerform dest removewhen key afile fastcheck isthere = do DropWorse -> faileddrophere setpresentremote showproof proof = "proof: " ++ show proof drophere setpresentremote contentlock reason = do - liftIO $ debugM "move" $ unwords + liftIO $ debug "Command.Move" $ unwords [ "Dropping from here" , "(" ++ reason ++ ")" ] @@ -255,7 +257,7 @@ fromPerform src removewhen key afile = do showproof proof = "proof: " ++ show proof dropremote reason = do - liftIO $ debugM "move" $ unwords + liftIO $ debug "Command.Move" $ unwords [ "Dropping from remote" , show src , "(" ++ reason ++ ")" diff --git a/Command/SendKey.hs b/Command/SendKey.hs index 36cee8f73c..7d5c70fa84 100644 --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Command.SendKey where import Command @@ -14,8 +16,7 @@ import Utility.Rsync import Annex.Transfer import qualified CmdLine.GitAnnexShell.Fields as Fields import Utility.Metered - -import System.Log.Logger +import Utility.Debug cmd :: Command cmd = noCommit $ @@ -45,14 +46,14 @@ start (_, key) = do fieldTransfer :: Direction -> Key -> (MeterUpdate -> Annex Bool) -> CommandStart fieldTransfer direction key a = do - liftIO $ debugM "fieldTransfer" "transfer start" + 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 $ debugM "fieldTransfer" "transfer done" + 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 diff --git a/Messages.hs b/Messages.hs index ce6e7a2334..4a50531e85 100644 --- a/Messages.hs +++ b/Messages.hs @@ -1,6 +1,6 @@ {- git-annex output messages - - - Copyright 2010-2020 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -43,7 +43,6 @@ module Messages ( setupConsole, enableDebugOutput, disableDebugOutput, - debugEnabled, commandProgressDisabled, jsonOutputEnabled, outputMessage, @@ -52,10 +51,6 @@ module Messages ( mkPrompter, ) where -import System.Log.Logger -import System.Log.Formatter -import System.Log.Handler (setFormatter) -import System.Log.Handler.Simple import Control.Concurrent import Control.Monad.IO.Class import qualified Data.ByteString as S @@ -69,6 +64,7 @@ import Types.Command (StartMessage(..), SeekInput) import Types.Transfer (transferKey) import Messages.Internal import Messages.Concurrent +import Utility.Debug import Annex.Concurrent.Utility import qualified Messages.JSON as JSON import qualified Annex @@ -254,31 +250,33 @@ showRaw s = outputMessage JSON.none (s <> "\n") setupConsole :: IO () setupConsole = do - s <- setFormatter - <$> streamHandler stderr DEBUG - <*> pure preciseLogFormatter - updateGlobalLogger rootLoggerName (setLevel NOTICE . setHandlers [s]) + dd <- debugDisplayer + configureDebug dd (DebugSelector (\_ -> False)) {- Force output to be line buffered. This is normally the case when - it's connected to a terminal, but may not be when redirected to - a file or a pipe. -} hSetBuffering stdout LineBuffering hSetBuffering stderr LineBuffering -{- Log formatter with precision into fractions of a second. -} -preciseLogFormatter :: LogFormatter a -preciseLogFormatter = tfLogFormatter "%F %X%Q" "[$time] $msg" - enableDebugOutput :: IO () -enableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel DEBUG +enableDebugOutput = do + dd <- debugDisplayer + configureDebug dd (DebugSelector (\_ -> True)) disableDebugOutput :: IO () -disableDebugOutput = updateGlobalLogger rootLoggerName $ setLevel NOTICE +disableDebugOutput = do + dd <- debugDisplayer + configureDebug dd (DebugSelector (\_ -> False)) -{- Checks if debugging is enabled. -} -debugEnabled :: IO Bool -debugEnabled = do - l <- getRootLogger - return $ getLevel l <= Just DEBUG +debugDisplayer :: IO (S.ByteString -> IO ()) +debugDisplayer = do + -- Debug output will get mixed in with any other output + -- made by git-annex, but use a lock to prevent two debug lines + -- that are displayed at the same time from mixing together. + lock <- newMVar () + return $ \s -> withMVar lock $ \() -> do + S.putStr (s <> "\n") + hFlush stderr {- Should commands that normally output progress messages have that - output disabled? -} diff --git a/P2P/IO.hs b/P2P/IO.hs index d089f1eb00..875ed02f09 100644 --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -5,7 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE RankNTypes, FlexibleContexts, CPP #-} +{-# LANGUAGE RankNTypes, FlexibleContexts, OverloadedStrings, CPP #-} module P2P.IO ( RunProto @@ -35,6 +35,7 @@ import Utility.SimpleProtocol import Utility.Metered import Utility.Tor import Utility.FileMode +import Utility.Debug import Types.UUID import Annex.ChangedRefs import qualified Utility.RawFilePath as R @@ -48,7 +49,6 @@ import Control.Concurrent.Async import Control.Concurrent.STM import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -import System.Log.Logger (debugM) import qualified Network.Socket as S -- Type of interpreters of the Proto free monad. @@ -235,7 +235,7 @@ runNet runst conn runner f = case f of debugMessage :: P2PConnection -> String -> Message -> IO () debugMessage conn prefix m = do tid <- myThreadId - debugM "p2p" $ concat $ catMaybes $ + debug "P2P.IO" $ concat $ catMaybes $ [ (\ident -> "[" ++ ident ++ "] ") <$> mident , Just $ "[" ++ show tid ++ "] " , Just $ prefix ++ " " ++ unwords (formatMessage safem) diff --git a/Remote/External.hs b/Remote/External.hs index b4d2822d88..e26dd84992 100644 --- a/Remote/External.hs +++ b/Remote/External.hs @@ -38,9 +38,9 @@ import Annex.Content import Annex.Url import Annex.UUID import Creds +import Utility.Debug import Control.Concurrent.STM -import System.Log.Logger (debugM) import qualified Data.Map as M import qualified Data.Set as S @@ -494,7 +494,7 @@ handleRequest' st external req mp responsehandler handleRemoteRequest (GETURLS key prefix) = do mapM_ (send . VALUE) =<< getUrlsWithPrefix key prefix send (VALUE "") -- end of list - handleRemoteRequest (DEBUG msg) = liftIO $ debugM "external" msg + handleRemoteRequest (DEBUG msg) = liftIO $ debug "Remote.External" msg handleRemoteRequest (INFO msg) = showInfo msg handleRemoteRequest (VERSION _) = senderror "too late to send VERSION" diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs index 2cee5b1244..9cc9bf3b52 100644 --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -39,6 +39,7 @@ import Backend.Hash import Utility.Hash import Utility.SshHost import Utility.Url +import Utility.Debug import Logs.Remote import Logs.RemoteState import qualified Git.Config @@ -53,7 +54,6 @@ import Control.Concurrent.STM import Data.String import Network.HTTP.Types import Network.HTTP.Client hiding (port) -import System.Log.Logger import qualified Data.Map as M import qualified Data.ByteString.Lazy as L import qualified Data.Text as T @@ -349,11 +349,11 @@ makeSmallAPIRequest :: Request -> Annex (Response L.ByteString) makeSmallAPIRequest req = do uo <- getUrlOptions let req' = applyRequest uo req - liftIO $ debugM "git-lfs" (show req') + liftIO $ debug "Remote.GitLFS" (show req') resp <- liftIO $ httpLbs req' (httpManager uo) -- Only debug the http status code, not the json -- which may include an authentication token. - liftIO $ debugM "git-lfs" (show $ responseStatus resp) + liftIO $ debug "Remote.GitLFS" (show $ responseStatus resp) return resp sendTransferRequest diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 51774a1bf9..351471d222 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -59,7 +59,7 @@ git_annex_shell cs r command params fields dir = Git.repoPath r shellcmd = "git-annex-shell" getshellopts = do - debug <- liftIO debugEnabled + debug <- annexDebug <$> Annex.getGitConfig let params' = if debug then Param "--debug" : params else params diff --git a/Remote/S3.hs b/Remote/S3.hs index 53dd9f3e6a..61a0fa0d27 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -33,7 +33,6 @@ import Network.URI import Control.Monad.Trans.Resource import Control.Monad.Catch import Data.IORef -import System.Log.Logger import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar import Data.Maybe @@ -67,6 +66,7 @@ import qualified Annex.Url as Url import Utility.Url (extractFromResourceT) import Annex.Url (getUrlOptions, withUrlOptions, UrlOptions(..)) import Utility.Env +import Utility.Debug type BucketName = String type BucketObject = String @@ -1069,13 +1069,13 @@ mkLocationConstraint "US" = S3.locationUsClassic mkLocationConstraint r = r debugMapper :: AWS.Logger -debugMapper level t = forward "S3" (T.unpack t) +debugMapper level t = forward "Remote.S3" (T.unpack t) where forward = case level of - AWS.Debug -> debugM - AWS.Info -> infoM - AWS.Warning -> warningM - AWS.Error -> errorM + AWS.Debug -> debug + AWS.Warning -> debug + AWS.Error -> debug + AWS.Info -> \_ _ -> return () s3Info :: ParsedRemoteConfig -> S3Info -> [(String, String)] s3Info c info = catMaybes diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index a816df4338..693862c3be 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module Remote.WebDAV (remote, davCreds, configUrl) where @@ -21,7 +22,6 @@ import Network.HTTP.Types import System.IO.Error import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO) -import System.Log.Logger (debugM) import Control.Concurrent.STM hiding (check) import Annex.Common @@ -43,6 +43,7 @@ import Utility.Url (URLString, matchStatusCodeException, matchHttpExceptionConte import Annex.UUID import Remote.WebDAV.DavLocation import Types.ProposedAccepted +import Utility.Debug remote :: RemoteType remote = specialRemoteType $ RemoteType @@ -533,4 +534,4 @@ withStoredFilesLegacyChunked k dav onerr a = do keyloc = keyLocation k debugDav :: MonadIO m => String -> DAVT m () -debugDav msg = liftIO $ debugM "WebDAV" msg +debugDav msg = liftIO $ debug "Remote.WebDAV" msg diff --git a/RemoteDaemon/Transport/Tor.hs b/RemoteDaemon/Transport/Tor.hs index 8f5ca5acdc..7ec4249123 100644 --- a/RemoteDaemon/Transport/Tor.hs +++ b/RemoteDaemon/Transport/Tor.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} module RemoteDaemon.Transport.Tor (server, transport, torSocketFile) where @@ -27,9 +28,9 @@ import Types.UUID import Messages import Git import Git.Command +import Utility.Debug import Control.Concurrent -import System.Log.Logger (debugM) import Control.Concurrent.STM import Control.Concurrent.STM.TBMQueue import Control.Concurrent.Async @@ -48,7 +49,7 @@ server ichan th@(TransportHandle (LocalRepo r) _ _) = go msock <- liftAnnex th torSocketFile case msock of Nothing -> do - debugM "remotedaemon" "Tor hidden service not enabled" + debugTor "Tor hidden service not enabled" return False Just sock -> do void $ async $ startservice sock u @@ -59,7 +60,7 @@ server ichan th@(TransportHandle (LocalRepo r) _ _) = go replicateM_ maxConnections $ forkIO $ forever $ serveClient th u r q - debugM "remotedaemon" "Tor hidden service running" + debugTor "Tor hidden service running" serveUnixSocket sock $ \conn -> do ok <- atomically $ ifM (isFullTBMQueue q) ( return False @@ -92,12 +93,12 @@ serveClient th@(TransportHandle _ _ rd) u r q = bracket setup cleanup start where setup = do h <- atomically $ readTBMQueue q - debugM "remotedaemon" "serving a Tor connection" + debugTor "serving a Tor connection" return h cleanup Nothing = return () cleanup (Just h) = do - debugM "remotedaemon" "done with Tor connection" + debugTor "done with Tor connection" hClose h start Nothing = return () @@ -121,9 +122,9 @@ serveClient th@(TransportHandle _ _ rd) u r q = bracket setup cleanup start v <- liftIO $ runNetProto runstauth conn $ P2P.serveAuth u case v of Right (Just theiruuid) -> authed conn theiruuid - Right Nothing -> liftIO $ debugM "remotedaemon" + Right Nothing -> liftIO $ debugTor "Tor connection failed to authenticate" - Left e -> liftIO $ debugM "remotedaemon" $ + Left e -> liftIO $ debugTor $ "Tor connection error before authentication: " ++ describeProtoFailure e -- Merge the duplicated state back in. liftAnnex th $ mergeState st' @@ -135,7 +136,7 @@ serveClient th@(TransportHandle _ _ rd) u r q = bracket setup cleanup start P2P.serveAuthed P2P.ServeReadWrite u case v' of Right () -> return () - Left e -> liftIO $ debugM "remotedaemon" $ + Left e -> liftIO $ debugTor $ "Tor connection error: " ++ describeProtoFailure e -- Connect to peer's tor hidden service. @@ -200,3 +201,6 @@ torSocketFile = do let uid = 0 #endif liftIO $ getHiddenServiceSocketFile torAppName uid ident + +debugTor :: String -> IO () +debugTor = debug "RemoteDaemon.Transport.Tor" diff --git a/Utility/Debug.hs b/Utility/Debug.hs new file mode 100644 index 0000000000..f5a8a293a5 --- /dev/null +++ b/Utility/Debug.hs @@ -0,0 +1,86 @@ +{- Debug output + - + - Copyright 2021 Joey Hess + - + - License: BSD-2-clause + -} + +{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances #-} +{-# OPTIONS_GHC -fno-warn-tabs -w #-} + +module Utility.Debug ( + DebugSource(..), + DebugSelector(..), + configureDebug, + getDebugSelector, + debug, + fastDebug +) where + +import qualified Data.ByteString as S +import Data.IORef +import Data.String +import Data.Time +import System.IO.Unsafe (unsafePerformIO) + +import Utility.FileSystemEncoding + +-- | The source of a debug message. For example, this could be a module or +-- function name. +newtype DebugSource = DebugSource S.ByteString + deriving (Eq, Show) + +instance IsString DebugSource where + fromString = DebugSource . encodeBS' + +-- | Selects whether to display a message from a source. +newtype DebugSelector = DebugSelector (DebugSource -> Bool) + +-- | Configures debugging. +configureDebug + :: (S.ByteString -> IO ()) + -- ^ Used to display debug output. + -> DebugSelector + -> IO () +configureDebug src p = writeIORef debugConfigGlobal (src, p) + +-- | Gets the currently configured DebugSelector. +getDebugSelector :: IO DebugSelector +getDebugSelector = snd <$> readIORef debugConfigGlobal + +-- A global variable for the debug configuration. +{-# NOINLINE debugConfigGlobal #-} +debugConfigGlobal :: IORef (S.ByteString -> IO (), DebugSelector) +debugConfigGlobal = unsafePerformIO $ newIORef (dontshow, selectnone) + where + dontshow _ = return () + selectnone = DebugSelector (\_ -> False) + +-- | Displays a debug message, if that has been enabled by configureDebug. +-- +-- This is reasonably fast when debugging is not enabled, but since it does +-- have to consult a IORef each time, using it in a tight loop may slow +-- down the program. +debug :: DebugSource -> String -> IO () +debug src msg = do + (displayer, DebugSelector p) <- readIORef debugConfigGlobal + if p src + then displayer =<< formatDebugMessage src msg + else return () + +-- | Displays a debug message, if the DebugSelector allows. +-- +-- When the DebugSelector does not let the message be displayed, this runs +-- very quickly, allowing it to be used inside tight loops. +fastDebug :: DebugSelector -> DebugSource -> String -> IO () +fastDebug (DebugSelector p) src msg + | p src = do + (displayer, _) <- readIORef debugConfigGlobal + displayer =<< formatDebugMessage src msg + | otherwise = return () + +formatDebugMessage :: DebugSource -> String -> IO S.ByteString +formatDebugMessage (DebugSource src) msg = do + t <- encodeBS' . formatTime defaultTimeLocale "[%F %X%Q]" + <$> getZonedTime + return (t <> " (" <> src <> ") " <> encodeBS msg) diff --git a/Utility/Process.hs b/Utility/Process.hs index 4a725c858a..4cf61054b4 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -7,6 +7,7 @@ -} {-# LANGUAGE CPP, Rank2Types, LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-tabs #-} module Utility.Process ( @@ -38,10 +39,10 @@ import Utility.Process.Shim as X (CreateProcess(..), ProcessHandle, StdStream(.. import Utility.Misc import Utility.Exception import Utility.Monad +import Utility.Debug import System.Exit import System.IO -import System.Log.Logger import Control.Monad.IO.Class import Control.Concurrent.Async import qualified Data.ByteString as S @@ -187,7 +188,7 @@ withCreateProcess p action = bracket (createProcess p) cleanupProcess debugProcess :: CreateProcess -> ProcessHandle -> IO () debugProcess p h = do pid <- getPid h - debugM "Utility.Process" $ unwords + debug "Utility.Process" $ unwords [ describePid pid , action ++ ":" , showCmd p @@ -211,7 +212,7 @@ waitForProcess h = do -- Have to get pid before waiting, which closes the ProcessHandle. pid <- getPid h r <- Utility.Process.Shim.waitForProcess h - debugM "Utility.Process" (describePid pid ++ " done " ++ show r) + debug "Utility.Process" (describePid pid ++ " done " ++ show r) return r cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () diff --git a/Utility/Url.hs b/Utility/Url.hs index 4d385508eb..62663321d8 100644 --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -44,6 +44,7 @@ module Utility.Url ( ) where import Common +import Utility.Debug import Utility.Metered #ifdef WITH_HTTP_CLIENT_RESTRICTED import Network.HTTP.Client.Restricted @@ -73,7 +74,6 @@ import Network.BSD (getProtocolNumber) import Data.Either import Data.Conduit import Text.Read -import System.Log.Logger type URLString = String @@ -269,7 +269,7 @@ getUrlInfo url uo = case parseURIRelaxed url of existsconduit' req uo' = do let req' = headRequest (applyRequest uo req) - debugM "url" (show req') + debug "Utility.Url" (show req') join $ runResourceT $ do resp <- http req' (httpManager uo) if responseStatus resp == ok200 @@ -383,7 +383,7 @@ download' nocurlerror meterupdate url file uo = | isfileurl u -> downloadfile u | otherwise -> downloadcurl url basecurlparams Nothing -> do - liftIO $ debugM "url" url + liftIO $ debug "Utility.Url" url dlfailed "invalid url" isfileurl u = uriScheme u == "file:" @@ -458,7 +458,7 @@ downloadConduit meterupdate req file uo = catchMaybeIO (getFileSize (toRawFilePath file)) >>= \case Just sz | sz > 0 -> resumedownload sz _ -> join $ runResourceT $ do - liftIO $ debugM "url" (show req') + liftIO $ debug "Utility.Url" (show req') resp <- http req' (httpManager uo) if responseStatus resp == ok200 then do @@ -490,7 +490,7 @@ downloadConduit meterupdate req file uo = -- send the whole file rather than resuming. resumedownload sz = join $ runResourceT $ do let req'' = req' { requestHeaders = resumeFromHeader sz : requestHeaders req' } - liftIO $ debugM "url" (show req'') + liftIO $ debug "Urility.Url" (show req'') resp <- http req'' (httpManager uo) if responseStatus resp == partialContent206 then do @@ -579,7 +579,7 @@ downloadPartial url uo n = case parseURIRelaxed url of Nothing -> return Nothing Just req -> do let req' = applyRequest uo req - liftIO $ debugM "url" (show req') + liftIO $ debug "Utility.Url" (show req') withResponse req' (httpManager uo) $ \resp -> if responseStatus resp == ok200 then Just <$> brReadSome (responseBody resp) n diff --git a/git-annex.cabal b/git-annex.cabal index 92c0cba2d7..6860216dbe 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -297,10 +297,11 @@ source-repository head location: git://git-annex.branchable.com/ custom-setup - Setup-Depends: base (>= 4.11.1.0), hslogger, split, unix-compat, + Setup-Depends: base (>= 4.11.1.0), split, unix-compat, filepath, exceptions, bytestring, directory, IfElse, data-default, filepath-bytestring (>= 1.4.2.1.4), process (>= 1.6.3), + time (>= 1.5.0), async, utf8-string, transformers, Cabal Executable git-annex @@ -327,7 +328,6 @@ Executable git-annex filepath, filepath-bytestring (>= 1.4.2.1.1), IfElse, - hslogger, monad-logger (>= 0.3.10), free, utf8-string, @@ -1068,6 +1068,7 @@ Executable git-annex Utility.Daemon Utility.Data Utility.DataUnits + Utility.Debug Utility.DebugLocks Utility.DirWatcher Utility.DirWatcher.Types