git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/cliapp/src/Obelisk/CliApp/Logging.hs
252 lines 9.1 kB history raw
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9-- | Provides a logging handler that facilitates safe ouputting to terminal using MVar based locking.
10-- | Spinner.hs and Process.hs work on this guarantee.
11module Obelisk.CliApp.Logging
12 ( AsUnstructuredError (..)
13 , newCliConfig
14 , runCli
15 , verboseLogLevel
16 , isOverwrite
17 , getSeverity
18 , getLogLevel
19 , setLogLevel
20 , putLog
21 , putLogRaw
22 , failWith
23 , errorToWarning
24 , withExitFailMessage
25 , writeLog
26 , allowUserToMakeLoggingVerbose
27 , getChars
28 , fork
29 ) where
31import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay)
32import Control.Concurrent.MVar (modifyMVar_, newMVar)
33import Control.Lens (Prism', review)
34import Control.Monad (unless, void, when)
35import Control.Monad.Catch (MonadCatch, MonadMask, bracket, catch, throwM)
36import Control.Monad.Except (throwError)
37import Control.Monad.IO.Class (liftIO)
38import Control.Monad.Log (Severity (..), WithSeverity (..), logMessage, runLoggingT)
39import Control.Monad.Loops (iterateUntil)
40import Control.Monad.Reader (MonadIO, ReaderT (..))
41import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef)
42import Data.Maybe
43import Data.Semigroup ((<>))
44import Data.Text (Text)
45import qualified Data.Text as T
46import qualified Data.Text.IO as T
47import GHC.IO.Encoding.Types
48import System.Console.ANSI (Color (Red, Yellow), ColorIntensity (Vivid),
49 ConsoleIntensity (FaintIntensity), ConsoleLayer (Foreground),
50 SGR (SetColor, SetConsoleIntensity), clearLine)
51import System.Exit (ExitCode (..))
52import System.IO
54import qualified Obelisk.CliApp.TerminalString as TS
55import Obelisk.CliApp.Theme
56import Obelisk.CliApp.Types
58newCliConfig
59 :: Severity
60 -> Bool
61 -> Bool
62 -> (e -> (Text, Int))
63 -> IO (CliConfig e)
64newCliConfig sev noColor noSpinner errorLogExitCode = do
65 level <- newIORef sev
66 lock <- newMVar False
67 tipDisplayed <- newIORef False
68 stack <- newIORef ([], [])
69 textEncoding <- hGetEncoding stdout
70 let theme = if fromMaybe False $ supportsUnicode <$> textEncoding
71 then unicodeTheme
72 else noUnicodeTheme
73 return $ CliConfig level noColor noSpinner lock tipDisplayed stack errorLogExitCode theme
75runCli :: MonadIO m => CliConfig e -> CliT e m a -> m a
76runCli c =
77 flip runLoggingT (handleLog c)
78 . flip runReaderT (_cliConfig_errorLogExitCode c)
79 . unDieT
80 . flip runReaderT c
81 . unCliT
83verboseLogLevel :: Severity
84verboseLogLevel = Debug
86isOverwrite :: Output -> Bool
87isOverwrite = \case
88 Output_Overwrite _ -> True
89 _ -> False
91getSeverity :: Output -> Maybe Severity
92getSeverity = \case
93 Output_Log (WithSeverity sev _) -> Just sev
94 Output_LogRaw (WithSeverity sev _) -> Just sev
95 _ -> Nothing
97getLogLevel :: (MonadIO m, HasCliConfig e m) => m Severity
98getLogLevel = getLogLevel' =<< getCliConfig
100getLogLevel' :: MonadIO m => CliConfig e -> m Severity
101getLogLevel' = liftIO . readIORef . _cliConfig_logLevel
103setLogLevel :: (MonadIO m, HasCliConfig e m) => Severity -> m ()
104setLogLevel sev = do
105 l <- _cliConfig_logLevel <$> getCliConfig
106 liftIO $ writeIORef l sev
108handleLog :: MonadIO m => CliConfig e -> Output -> m ()
109handleLog conf output = do
110 level <- getLogLevel' conf
111 liftIO $ modifyMVar_ (_cliConfig_lock conf) $ \wasOverwriting -> do
112 let noColor = _cliConfig_noColor conf
113 case getSeverity output of
114 Nothing -> handleLog' noColor output
115 Just sev -> if sev > level
116 then return wasOverwriting -- Discard if sev is above configured log level
117 else do
118 -- If the last output was an overwrite (with cursor on same line), ...
119 when wasOverwriting $
120 void $ handleLog' noColor Output_ClearLine -- first clear it,
121 handleLog' noColor output -- then, actually write the msg.
123handleLog' :: MonadIO m => Bool -> Output -> m Bool
124handleLog' noColor output = do
125 case output of
126 Output_Log m -> liftIO $ do
127 writeLog True noColor m
128 Output_LogRaw m -> liftIO $ do
129 writeLog False noColor m
130 hFlush stdout -- Explicitly flush, as there is no newline
131 Output_Write ts -> liftIO $ do
132 T.putStrLn $ TS.render (not noColor) Nothing ts
133 hFlush stdout
134 Output_Overwrite ts -> liftIO $ do
135 width <- TS.getTerminalWidth
136 T.putStr $ "\r" <> (TS.render (not noColor) width ts)
137 hFlush stdout
138 Output_ClearLine -> liftIO $ do
139 -- Go to the first column and clear the whole line
140 putStr "\r"
141 clearLine
142 hFlush stdout
143 return $ isOverwrite output
145-- | Like `putLog` but without the implicit newline added.
146putLogRaw :: CliLog m => Severity -> Text -> m ()
147putLogRaw sev = logMessage . Output_LogRaw . WithSeverity sev
149-- | Indicates unstructured errors form one variant (or conceptual projection)
150-- of the error type.
151--
152-- Shouldn't really use this, but who has time to clean up that much!
153class AsUnstructuredError e where
154 asUnstructuredError :: Prism' e Text
156instance AsUnstructuredError Text where
157 asUnstructuredError = id
159-- | Like `putLog Alert` but also abrupts the program.
160failWith :: (CliThrow e m, AsUnstructuredError e) => Text -> m a
161failWith = throwError . review asUnstructuredError
163errorToWarning
164 :: (HasCliConfig e m, CliThrow e m, CliLog m)
165 => e -> m ()
166errorToWarning e = do
167 c <- getCliConfig
168 putLog Warning $ fst $ _cliConfig_errorLogExitCode c e
170-- | Intercept ExitFailure exceptions and log the given alert before exiting.
171--
172-- This is useful when you want to provide contextual information to a deeper failure.
173withExitFailMessage :: (CliLog m, MonadCatch m) => Text -> m a -> m a
174withExitFailMessage msg f = f `catch` \(e :: ExitCode) -> do
175 case e of
176 ExitFailure _ -> putLog Alert msg
177 ExitSuccess -> pure ()
178 throwM e
180-- | Write log to stdout, with colors (unless `noColor`)
181writeLog :: (MonadIO m, MonadMask m) => Bool -> Bool -> WithSeverity Text -> m ()
182writeLog withNewLine noColor (WithSeverity severity s)
183 | noColor && severity <= Warning = liftIO $ putFn $ T.pack (show severity) <> ": " <> s
184 | not noColor && severity <= Error = TS.putStrWithSGR errorColors h withNewLine s
185 | not noColor && severity <= Warning = TS.putStrWithSGR warningColors h withNewLine s
186 | not noColor && severity >= Debug = TS.putStrWithSGR debugColors h withNewLine s
187 | otherwise = liftIO $ putFn s
188 where
189 putFn = if withNewLine then (T.hPutStrLn h) else (T.hPutStr h)
190 h = if severity <= Error then stderr else stdout
191 errorColors = [SetColor Foreground Vivid Red]
192 warningColors = [SetColor Foreground Vivid Yellow]
193 debugColors = [SetConsoleIntensity FaintIntensity]
195-- | Allow the user to immediately switch to verbose logging upon pressing a particular key.
196--
197-- Call this function in a thread, and kill it to turn off keystroke monitoring.
198allowUserToMakeLoggingVerbose
199 :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)
200 => String -- ^ The key to press in order to make logging verbose
201 -> m ()
202allowUserToMakeLoggingVerbose keyCode = bracket showTip (liftIO . killThread) $ \_ -> do
203 unlessVerbose $ do
204 liftIO $ hSetBuffering stdin NoBuffering
205 _ <- iterateUntil (== keyCode) $ liftIO getChars
206 putLog Warning "Ctrl+e pressed; making output verbose (-v)"
207 setLogLevel verboseLogLevel
208 where
209 showTip = fork $ unlessVerbose $ do
210 conf <- getCliConfig
211 liftIO $ threadDelay $ 10*1000000 -- Only show tip for actions taking too long (10 seconds or more)
212 tipDisplayed <- liftIO $ atomicModifyIORef' (_cliConfig_tipDisplayed conf) $ (,) True
213 unless tipDisplayed $ unlessVerbose $ do -- Check again in case the user had pressed Ctrl+e recently
214 putLog Notice "Tip: Press Ctrl+e to display full output"
215 unlessVerbose f = do
216 l <- getLogLevel
217 unless (l == verboseLogLevel) f
219-- | Like `getChar` but also retrieves the subsequently pressed keys.
220--
221-- Allowing, for example, the ↑ key, which consists of the three characters
222-- ['\ESC','[','A'] to be distinguished from an actual \ESC character input.
223getChars :: IO String
224getChars = reverse <$> f mempty
225 where
226 f xs = do
227 x <- getChar
228 hReady stdin >>= \case
229 True -> f (x:xs)
230 False -> return (x:xs)
232fork :: (HasCliConfig e m, MonadIO m) => CliT e IO () -> m ThreadId
233fork f = do
234 c <- getCliConfig
235 liftIO $ forkIO $ runCli c f
237-- | Conservatively determines whether the encoding supports Unicode.
238--
239-- Currently this uses a whitelist of known-to-work encodings. In principle it
240-- could test dynamically by opening a file with this encoding, but it doesn't
241-- look like base exposes any way to determine this in a pure fashion.
242supportsUnicode :: TextEncoding -> Bool
243supportsUnicode enc = any ((textEncodingName enc ==) . textEncodingName)
244 [ utf8
245 , utf8_bom
246 , utf16
247 , utf16be
248 , utf16le
249 , utf32
250 , utf32be
251 , utf32le
252 ]