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