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

@@ -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

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 "-->"

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)

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 ]

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
+addAlert alert = notifyAlert `after` modifyDaemonStatus add
-	notice [showAlert alert]
-	notifyAlert `after` modifyDaemonStatus add
   where
 	add s = (s { lastAlertId = i, alertMap = m }, i)
 	  where

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
+debug ws = do
-
-notice :: [String] -> Assistant ()
-notice = logaction noticeM
-
-logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
-logaction a ws = do
 	ThreadName name <- getAssistant threadName
-	liftIO $ a name $ unwords $ (name ++ ":") : ws
+	liftIO $ Debug.debug (Debug.DebugSource (encodeBS name)) (unwords ws)

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

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

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
 		)

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

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:"

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"

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 ++ ")"

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 Utility.Debug
-import System.Log.Logger
 
 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

Messages.hs

@@ -1,6 +1,6 @@
 {- git-annex output messages
  -
- - Copyright 2010-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2010-2021 Joey Hess <id@joeyh.name>
  -
  - 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
+	dd <- debugDisplayer
-		<$> streamHandler stderr DEBUG
+	configureDebug dd (DebugSelector (\_ -> False))
-		<*> pure preciseLogFormatter
-	updateGlobalLogger rootLoggerName (setLevel NOTICE . setHandlers [s])
 	{- 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. -}
+debugDisplayer :: IO (S.ByteString -> IO ())
-debugEnabled :: IO Bool
+debugDisplayer = do
-debugEnabled = do
+	-- Debug output will get mixed in with any other output
-	l <- getRootLogger
+	-- made by git-annex, but use a lock to prevent two debug lines
-	return $ getLevel l <= Just DEBUG
+	-- 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? -}

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)

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"
 

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

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

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.Debug -> debug
-		AWS.Info -> infoM
+		AWS.Warning -> debug
-		AWS.Warning -> warningM
+		AWS.Error -> debug
-		AWS.Error -> errorM
+		AWS.Info -> \_ _ -> return ()
 
 s3Info :: ParsedRemoteConfig -> S3Info -> [(String, String)]
 s3Info c info = catMaybes

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

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"

Utility/Debug.hs

@@ -0,0 +1,86 @@
+{- Debug output
+ -
+ - Copyright 2021 Joey Hess <id@joeyh.name>
+ -
+ - 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)

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 () 

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

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