Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add arguments to direct logs to various locations #3665

Merged
merged 3 commits into from
Jun 23, 2023
Merged

Add arguments to direct logs to various locations #3665

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
1e2e986
Add arguments to direct logs to various locations
michaelpj Jun 12, 2023
fc13e05
Remove weird test
michaelpj Jun 20, 2023
4129c81
Fix warning
michaelpj Jun 23, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
94 changes: 56 additions & 38 deletions exe/Main.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,22 +1,26 @@
-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Main(main) where

import Control.Arrow ((&&&))
import Control.Exception (displayException)
import Control.Monad.IO.Class (liftIO)
import Data.Bifunctor (first)
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Maybe (catMaybes)
import Data.Text (Text)
import qualified Development.IDE.Main as GhcideMain
import Development.IDE.Types.Logger (Doc, Priority (Error, Info),
Recorder,
WithPriority (WithPriority, priority),
cfilter, cmapWithPrio,
defaultLayoutOptions,
layoutPretty,
layoutPretty, logWith,
makeDefaultStderrRecorder,
payload, renderStrict,
withDefaultRecorder)
renderStrict, withFileRecorder)
import qualified Development.IDE.Types.Logger as Logger
import qualified HlsPlugins as Plugins
import Ide.Arguments (Arguments (..),
Expand All @@ -30,7 +34,7 @@ import Ide.Types (PluginDescriptor (pluginNotifica
mkPluginNotificationHandler)
import Language.LSP.Protocol.Message as LSP
import Language.LSP.Server as LSP
import Prettyprinter (Pretty (pretty), vsep)
import Prettyprinter (Pretty (pretty), vcat, vsep)

data Log
= LogIdeMain IdeMain.Log
Expand All @@ -43,13 +47,27 @@ instance Pretty Log where

main :: IO ()
main = do
stderrRecorder <- makeDefaultStderrRecorder Nothing
-- plugin cli commands use stderr logger for now unless we change the args
-- parser to get logging arguments first or do more complicated things
pluginCliRecorder <- cmapWithPrio pretty <$> makeDefaultStderrRecorder Nothing
let pluginCliRecorder = cmapWithPrio pretty stderrRecorder
args <- getArguments "haskell-language-server" (Plugins.idePlugins (cmapWithPrio LogPlugins pluginCliRecorder))

(lspLogRecorder, cb1) <- Logger.withBacklog Logger.lspClientLogRecorder
(lspMessageRecorder, cb2) <- Logger.withBacklog Logger.lspClientMessageRecorder
-- Recorder that logs to the LSP client with logMessage
(lspLogRecorder, cb1) <-
Logger.withBacklog Logger.lspClientLogRecorder
<&> first (cmapWithPrio renderDoc)
-- Recorder that logs to the LSP client with showMessage
(lspMessageRecorder, cb2) <-
Logger.withBacklog Logger.lspClientMessageRecorder
<&> first (cmapWithPrio renderDoc)
-- Recorder that logs Error severity logs to the client with showMessage and some extra text
let lspErrorMessageRecorder = lspMessageRecorder
& cfilter (\WithPriority{ priority } -> priority >= Error)
& cmapWithPrio (\msg -> vsep
["Error condition, please check your setup and/or the [issue tracker](" <> issueTrackerUrl <> "): "
, msg
])
-- This plugin just installs a handler for the `initialized` notification, which then
-- picks up the LSP environment and feeds it to our recorders
let lspRecorderPlugin = (defaultPluginDescriptor "LSPRecorderCallback")
Expand All @@ -58,28 +76,35 @@ main = do
liftIO $ (cb1 <> cb2) env
}

let (argsTesting, minPriority, logFilePath) =
let (minPriority, logFilePath, logStderr, logClient) =
case args of
Ghcide GhcideArguments{ argsTesting, argsLogLevel, argsLogFile} ->
(argsTesting, argsLogLevel, argsLogFile)
_ -> (False, Info, Nothing)
Ghcide GhcideArguments{ argsLogLevel, argsLogFile, argsLogStderr, argsLogClient} ->
(argsLogLevel, argsLogFile, argsLogStderr, argsLogClient)
_ -> (Info, Nothing, True, False)

withDefaultRecorder logFilePath Nothing $ \textWithPriorityRecorder -> do
-- Adapter for withFileRecorder to handle the case where we don't want to log to a file
let withLogFileRecorder action = case logFilePath of
Just p -> withFileRecorder p Nothing $ \case
Left e -> do
let exceptionMessage = pretty $ displayException e
let message = vcat [exceptionMessage, "Couldn't open log file; not logging to it."]
logWith stderrRecorder Error message
action Nothing
Right r -> action (Just r)
Nothing -> action Nothing

withLogFileRecorder $ \logFileRecorder -> do
let
recorder = cmapWithPrio (pretty &&& id) $ mconcat
[textWithPriorityRecorder
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
& cmapWithPrio fst
, lspMessageRecorder
& cfilter (\WithPriority{ priority } -> priority >= Error)
& cmapWithPrio (renderDoc . fst)
, lspLogRecorder
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
& cmapWithPrio (renderStrict . layoutPretty defaultLayoutOptions . fst)
-- do not log heap stats to the LSP log as they interfere with the
-- ability of lsp-test to detect a stuck server in tests and benchmarks
& if argsTesting then cfilter (not . heapStats . snd . payload) else id
Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

We don't need this any more since we're not logging to the client by default.

]
lfr = logFileRecorder
ser = if logStderr then Just stderrRecorder else Nothing
lemr = Just lspErrorMessageRecorder
llr = if logClient then Just lspLogRecorder else Nothing
recorder :: Recorder (WithPriority Log) =
[lfr, ser, lemr, llr]
& catMaybes
& mconcat
& cmapWithPrio pretty
& cfilter (\WithPriority{ priority } -> priority >= minPriority)
plugins = Plugins.idePlugins (cmapWithPrio LogPlugins recorder)

defaultMain
Expand All @@ -88,14 +113,7 @@ main = do
(plugins <> pluginDescToIdePlugins [lspRecorderPlugin])

renderDoc :: Doc a -> Text
renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions $ vsep
["Error condition, please check your setup and/or the [issue tracker](" <> issueTrackerUrl <> "): "
,d
]
renderDoc d = renderStrict $ layoutPretty defaultLayoutOptions d

issueTrackerUrl :: Doc a
issueTrackerUrl = "https://github.com/haskell/haskell-language-server/issues"

heapStats :: Log -> Bool
heapStats (LogIdeMain (IdeMain.LogIDEMain (GhcideMain.LogHeapStats _))) = True
heapStats _ = False
35 changes: 11 additions & 24 deletions ghcide/src/Development/IDE/Types/Logger.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -16,7 +16,7 @@ module Development.IDE.Types.Logger
, cmap
, cmapIO
, cfilter
, withDefaultRecorder
, withFileRecorder
, makeDefaultStderrRecorder
, makeDefaultHandleRecorder
, LoggingColumn(..)
Expand Down Expand Up @@ -157,35 +157,22 @@ makeDefaultStderrRecorder columns = do
lock <- liftIO newLock
makeDefaultHandleRecorder columns lock stderr

-- | If no path given then use stderr, otherwise use file.
withDefaultRecorder
withFileRecorder
:: MonadUnliftIO m
=> Maybe FilePath
-- ^ Log file path. `Nothing` uses stderr
=> FilePath
-- ^ Log file path.
-> Maybe [LoggingColumn]
-- ^ logging columns to display. `Nothing` uses `defaultLoggingColumns`
-> (Recorder (WithPriority (Doc d)) -> m a)
-- ^ action given a recorder
-> (Either IOException (Recorder (WithPriority (Doc d))) -> m a)
-- ^ action given a recorder, or the exception if we failed to open the file
-> m a
withDefaultRecorder path columns action = do
withFileRecorder path columns action = do
lock <- liftIO newLock
let makeHandleRecorder = makeDefaultHandleRecorder columns lock
case path of
Nothing -> do
recorder <- makeHandleRecorder stderr
let message = "No log file specified; using stderr."
logWith recorder Info message
action recorder
Just path -> do
fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode)
case fileHandle of
Left e -> do
recorder <- makeHandleRecorder stderr
let exceptionMessage = pretty $ displayException e
let message = vcat [exceptionMessage, "Couldn't open log file" <+> pretty path <> "; falling back to stderr."]
logWith recorder Warning message
action recorder
Right fileHandle -> finally (makeHandleRecorder fileHandle >>= action) (liftIO $ hClose fileHandle)
fileHandle :: Either IOException Handle <- liftIO $ try (openFile path AppendMode)
case fileHandle of
Left e -> action $ Left e
Right fileHandle -> finally ((Right <$> makeHandleRecorder fileHandle) >>= action) (liftIO $ hClose fileHandle)

makeDefaultHandleRecorder
:: MonadIO m
Expand Down
50 changes: 40 additions & 10 deletions src/Ide/Arguments.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -40,14 +40,16 @@ data Arguments
| PrintLibDir

data GhcideArguments = GhcideArguments
{argsCommand :: Command
,argsCwd :: Maybe FilePath
,argsShakeProfiling :: Maybe FilePath
,argsTesting :: Bool
,argsExamplePlugin :: Bool
{ argsCommand :: Command
, argsCwd :: Maybe FilePath
, argsShakeProfiling :: Maybe FilePath
, argsTesting :: Bool
, argsExamplePlugin :: Bool
, argsLogLevel :: Priority
, argsLogFile :: Maybe String
-- ^ the minimum log level to show
, argsLogStderr :: Bool
, argsLogClient :: Bool
, argsThreads :: Int
, argsProjectGhcVersion :: Bool
} deriving Show
Expand Down Expand Up @@ -138,12 +140,40 @@ arguments plugins = GhcideArguments
<> help "Sets the log level to Debug, alias for '--log-level Debug'"
)
)
<*> optional (strOption
(long "logfile"
<> short 'l'
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I would suggest keeping the short form for at least one release cycle.
I just got bitten by this, and had to re-configure my emacs to use it

  :custom
  (lsp-haskell-server-args `("-d" "--log-file" ,lsp-haskell-server-log-file))

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ah sorry, that was an oversight, I meant to leave the old options in! I left the old spelling but missed the short option.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Although I don't think leaving it in for a release cycle helps all that much: it just means that people will be surprised by it one cycle later. It's only useful if you're switching between and old and new version.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

(... then why am I leaving the old spelling in? I guess we could just never remove it)

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The one release cycle thing is so you could update clients to use the new one, but if people still ran an older server it would still work. Then in time get rid of it.
To me, keeping the short form is the best option

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

#3672

-- This option is a little inconsistent with the other log options, since
-- it's not a boolean and there is no way to turn it off. That's okay
-- since the default is off.
<*> (optional (strOption
( long "log-file"
<> metavar "LOGFILE"
<> help "File to log to, defaults to stdout"
))
<> help "Send logs to a file"
)) <|> (optional (strOption
( long "logfile"
<> metavar "LOGFILE"
<> help "Send logs to a file"
-- deprecated alias so users don't need to update their CLI calls
-- immediately
<> internal
)))
)
-- Boolean option so we can toggle the default in a consistent way
<*> option auto
( long "log-stderr"
<> help "Send logs to stderr"
<> metavar "BOOL"
<> value True
<> showDefault
)
-- Boolean option so we can toggle the default in a consistent way
<*> option auto
( long "log-client"
<> help "Send logs to the client using the window/logMessage LSP method"
<> metavar "BOOL"
-- This is off by default, since some clients will show duplicate logs
-- if we log both to stderr and the client
<> value False
<> showDefault
)
<*> option auto
(short 'j'
<> help "Number of threads (0: automatic)"
Expand Down
48 changes: 11 additions & 37 deletions test/functional/Config.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -6,59 +6,33 @@
module Config (tests) where

import Control.DeepSeq
import Control.Lens hiding (List, (.=))
import Control.Monad
import Data.Aeson
import Data.Hashable
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as Map
import Data.Proxy
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Development.IDE (RuleResult, action, define,
getFilesOfInterestUntracked,
getPluginConfigAction,
ideErrorText, uses_)
import Development.IDE.Test (expectDiagnostics)
import qualified Data.HashMap.Strict as HM
import qualified Data.Map as Map
import Data.Typeable (Typeable)
import Development.IDE (RuleResult, action, define,
getFilesOfInterestUntracked,
getPluginConfigAction, ideErrorText,
uses_)
import Development.IDE.Test (expectDiagnostics)
import GHC.Generics
import Ide.Plugin.Config
import Ide.Types
import qualified Language.LSP.Protocol.Lens as L
import Language.LSP.Test as Test
import System.FilePath ((</>))
import Language.LSP.Test as Test
import System.FilePath ((</>))
import Test.Hls
import Test.Hls.Command

{-# ANN module ("HLint: ignore Reduce duplication"::String) #-}

tests :: TestTree
tests = testGroup "plugin config" [
-- Note: there are more comprehensive tests over config in hls-hlint-plugin
-- TODO: Add generic tests over some example plugin
configParsingTests, genericConfigTests
genericConfigTests
]

configParsingTests :: TestTree
configParsingTests = testGroup "config parsing"
[ testCase "empty object as user configuration should not send error logMessage" $ runConfigSession "" $ do
let config = object []
sendConfigurationChanged (toJSON config)

-- Send custom request so server returns a response to prevent blocking
void $ sendNotification (SMethod_CustomMethod (Proxy @"non-existent-method")) Null

logNot <- skipManyTill Test.anyMessage (message SMethod_WindowLogMessage)

liftIO $ (logNot ^. L.params . L.type_) > MessageType_Error
|| "non-existent-method" `T.isInfixOf` (logNot ^. L.params . L.message)
@? "Server sends logMessage with MessageType = Error"
]

where
runConfigSession :: FilePath -> Session a -> IO a
runConfigSession subdir =
failIfSessionTimeout . runSession hlsCommand fullCaps ("test/testdata" </> subdir)

genericConfigTests :: TestTree
genericConfigTests = testGroup "generic plugin config"
[
Expand Down