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.
This commit is contained in:
Joey Hess
parent
19c672e710
commit
aaba83795b
26 changed files with 194 additions and 105 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 "-->"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
12
Assistant.hs
12
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 ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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:"
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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 ++ ")"
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
40
Messages.hs
40
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
|
||||
<$> 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? -}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
12
Remote/S3.hs
12
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
86
Utility/Debug.hs
Normal file
86
Utility/Debug.hs
Normal file
|
|
@ -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)
|
||||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue