\subsection{Cardano.BM.Backend.Editor}
\label{code:Cardano.BM.Backend.Editor}
%if style == newcode
\begin{code}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cardano.BM.Backend.Editor
(
Editor
, plugin
) where
import Prelude hiding (lookup)
import qualified Control.Concurrent.Async as Async
import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, swapMVar, readMVar, withMVar)
import Control.Exception.Safe (IOException, SomeException, catch)
import Control.Monad (void, when, forM_)
import Data.Aeson (FromJSON, ToJSON, encode)
import qualified Data.ByteString.Lazy.Char8 as BS8
import qualified Data.HashMap.Strict as HM
import Data.List (delete)
import Data.Text (pack, unpack)
import qualified Data.Text.IO as TIO
import Data.Time (getCurrentTime)
import Data.Time.Format (defaultTimeLocale, formatTime)
import Safe (readMay)
import System.Directory (createDirectoryIfMissing, getCurrentDirectory)
import System.FilePath ((</>))
import System.IO (stderr)
import qualified Graphics.UI.Threepenny as UI
import Graphics.UI.Threepenny.Core hiding (delete)
import Cardano.BM.Configuration
import qualified Cardano.BM.Configuration.Model as CM
import Cardano.BM.Data.AggregatedKind
import Cardano.BM.Data.Backend
import Cardano.BM.Data.BackendKind (BackendKind (EditorBK))
import Cardano.BM.Data.LogItem
import Cardano.BM.Data.Output (ScribeId)
import Cardano.BM.Data.Severity
import Cardano.BM.Data.SubTrace
import Cardano.BM.Data.Trace
import Cardano.BM.Data.Tracer (nullTracer, traceWith)
import Cardano.BM.Backend.LogBuffer
import Cardano.BM.Plugin (Plugin (..))
import Cardano.BM.Rotator (tsformat)
\end{code}
%endif
This simple configuration editor is accessible through a browser on
\url{http://127.0.0.1:13789}, or whatever port has been set in the
configuration.
A number of maps that relate logging context name to behaviour can be
changed.
And, most importantly, the global minimum severity that defines the filtering
of log messages.
\subsubsection{links}
The GUI is built on top of \emph{Threepenny-GUI} (\url{http://hackage.haskell.org/package/threepenny-gui}).
The appearance is due to \emph{w3-css} (\url{https://www.w3schools.com/w3css}).
\subsubsection{Plugin definition}
\begin{code}
plugin :: (IsEffectuator s a, ToJSON a, FromJSON a)
=> Configuration -> Trace IO a -> s a -> IO (Plugin a)
plugin :: Configuration -> Trace IO a -> s a -> IO (Plugin a)
plugin Configuration
config Trace IO a
trace s a
sb = do
Editor a
be :: Cardano.BM.Backend.Editor.Editor a <- Configuration -> Trace IO a -> s a -> IO (Editor a)
forall (t :: * -> *) a (s :: * -> *).
(IsBackend t a, IsEffectuator s a) =>
Configuration -> Trace IO a -> s a -> IO (t a)
realizefrom Configuration
config Trace IO a
trace s a
sb
Plugin a -> IO (Plugin a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Plugin a -> IO (Plugin a)) -> Plugin a -> IO (Plugin a)
forall a b. (a -> b) -> a -> b
$ Backend a -> BackendKind -> Plugin a
forall a. Backend a -> BackendKind -> Plugin a
BackendPlugin
(MkBackend :: forall a. (LogObject a -> IO ()) -> IO () -> Backend a
MkBackend { bEffectuate :: LogObject a -> IO ()
bEffectuate = Editor a -> LogObject a -> IO ()
forall (t :: * -> *) a.
IsEffectuator t a =>
t a -> LogObject a -> IO ()
effectuate Editor a
be, bUnrealize :: IO ()
bUnrealize = Editor a -> IO ()
forall (t :: * -> *) a. IsBackend t a => t a -> IO ()
unrealize Editor a
be })
(Editor a -> BackendKind
forall (t :: * -> *) a. IsBackend t a => t a -> BackendKind
bekind Editor a
be)
\end{code}
\subsubsection{Structure of Editor}\label{code:Editor}\index{Editor}
\begin{code}
type EditorMVar a = MVar (EditorInternal a)
newtype Editor a = Editor
{ Editor a -> EditorMVar a
getEd :: EditorMVar a }
data EditorInternal a = EditorInternal
{ EditorInternal a -> Trace IO a
edSBtrace :: Trace IO a
, EditorInternal a -> Async ()
edThread :: Async.Async ()
, EditorInternal a -> LogBuffer a
edBuffer :: !(LogBuffer a)
}
\end{code}
\subsubsection{|Editor| implements |Backend| functions}\index{Editor!instance of IsBackend}
|Editor| is an |IsBackend|
\begin{code}
instance (ToJSON a, FromJSON a) => IsBackend Editor a where
bekind :: Editor a -> BackendKind
bekind Editor a
_ = BackendKind
EditorBK
realize :: Configuration -> IO (Editor a)
realize Configuration
_ = String -> IO (Editor a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Editor cannot be instantiated by 'realize'"
realizefrom :: Configuration -> Trace IO a -> s a -> IO (Editor a)
realizefrom Configuration
config Trace IO a
sbtrace s a
_ = mdo
MVar (EditorInternal a)
gref <- IO (MVar (EditorInternal a))
forall a. IO (MVar a)
newEmptyMVar
let gui :: Editor a
gui = MVar (EditorInternal a) -> Editor a
forall a. EditorMVar a -> Editor a
Editor MVar (EditorInternal a)
gref
Int
port <- Configuration -> IO Int
getGUIport Configuration
config
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
port Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"cannot create GUI"
LogBuffer a
logbuf :: Cardano.BM.Backend.LogBuffer.LogBuffer a <- Configuration -> IO (LogBuffer a)
forall (t :: * -> *) a. IsBackend t a => Configuration -> IO (t a)
Cardano.BM.Backend.LogBuffer.realize Configuration
config
Async ()
thd <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
Async.async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
Config -> (Window -> UI ()) -> IO ()
startGUI Config
defaultConfig { jsPort :: Maybe Int
jsPort = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
port
, jsAddr :: Maybe ByteString
jsAddr = ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
"127.0.0.1"
, jsStatic :: Maybe String
jsStatic = String -> Maybe String
forall a. a -> Maybe a
Just String
"iohk-monitoring/static"
, jsCustomHTML :: Maybe String
jsCustomHTML = String -> Maybe String
forall a. a -> Maybe a
Just String
"configuration-editor.html"
} ((Window -> UI ()) -> IO ()) -> (Window -> UI ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ Editor a -> Configuration -> Window -> UI ()
forall a. ToJSON a => Editor a -> Configuration -> Window -> UI ()
prepare Editor a
gui Configuration
config
IO () -> (SomeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` Trace IO a
-> MVar (EditorInternal a)
-> EditorInternal a
-> SomeException
-> IO ()
nullSetup Trace IO a
sbtrace MVar (EditorInternal a)
gref
EditorInternal :: forall a. Trace IO a -> Async () -> LogBuffer a -> EditorInternal a
EditorInternal
{ edSBtrace :: Trace IO a
edSBtrace = Trace IO a
forall (m :: * -> *) a. Applicative m => Tracer m a
nullTracer
, edThread :: Async ()
edThread = Async ()
thd
, edBuffer :: LogBuffer a
edBuffer = LogBuffer a
logbuf
}
Async () -> IO ()
forall a. Async a -> IO ()
Async.link Async ()
thd
MVar (EditorInternal a) -> EditorInternal a -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar (EditorInternal a)
gref (EditorInternal a -> IO ()) -> EditorInternal a -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorInternal :: forall a. Trace IO a -> Async () -> LogBuffer a -> EditorInternal a
EditorInternal
{ edSBtrace :: Trace IO a
edSBtrace = Trace IO a
sbtrace
, edThread :: Async ()
edThread = Async ()
thd
, edBuffer :: LogBuffer a
edBuffer = LogBuffer a
logbuf
}
Editor a -> IO (Editor a)
forall (m :: * -> *) a. Monad m => a -> m a
return Editor a
gui
where
nullSetup
:: Trace IO a
-> EditorMVar a
-> EditorInternal a
-> SomeException
-> IO ()
nullSetup :: Trace IO a
-> MVar (EditorInternal a)
-> EditorInternal a
-> SomeException
-> IO ()
nullSetup Trace IO a
trace MVar (EditorInternal a)
mvar EditorInternal a
nullEditor SomeException
e = do
LOMeta
meta <- Severity -> PrivacyAnnotation -> IO LOMeta
forall (m :: * -> *).
MonadIO m =>
Severity -> PrivacyAnnotation -> m LOMeta
mkLOMeta Severity
Error PrivacyAnnotation
Public
Trace IO a -> (LoggerName, LogObject a) -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Trace IO a
trace ((LoggerName, LogObject a) -> IO ())
-> (LoggerName, LogObject a) -> IO ()
forall a b. (a -> b) -> a -> b
$ (LoggerName
"#editor.realizeFrom", LoggerName -> LOMeta -> LOContent a -> LogObject a
forall a. LoggerName -> LOMeta -> LOContent a -> LogObject a
LogObject LoggerName
"#editor.realizeFrom" LOMeta
meta (LOContent a -> LogObject a) -> LOContent a -> LogObject a
forall a b. (a -> b) -> a -> b
$
LoggerName -> LOContent a
forall a. LoggerName -> LOContent a
LogError (LoggerName -> LOContent a) -> LoggerName -> LOContent a
forall a b. (a -> b) -> a -> b
$ LoggerName
"Editor backend disabled due to initialisation error: " LoggerName -> LoggerName -> LoggerName
forall a. Semigroup a => a -> a -> a
<> (String -> LoggerName
pack (String -> LoggerName) -> String -> LoggerName
forall a b. (a -> b) -> a -> b
$ SomeException -> String
forall a. Show a => a -> String
show SomeException
e))
EditorInternal a
_ <- MVar (EditorInternal a)
-> EditorInternal a -> IO (EditorInternal a)
forall a. MVar a -> a -> IO a
swapMVar MVar (EditorInternal a)
mvar EditorInternal a
nullEditor
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
unrealize :: Editor a -> IO ()
unrealize Editor a
editor =
MVar (EditorInternal a) -> (EditorInternal a -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Editor a -> MVar (EditorInternal a)
forall a. Editor a -> EditorMVar a
getEd Editor a
editor) ((EditorInternal a -> IO ()) -> IO ())
-> (EditorInternal a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \EditorInternal a
ed ->
Async () -> IO ()
forall a. Async a -> IO ()
Async.cancel (Async () -> IO ()) -> Async () -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorInternal a -> Async ()
forall a. EditorInternal a -> Async ()
edThread EditorInternal a
ed
\end{code}
\subsubsection{Editor is an effectuator}\index{Editor!instance of IsEffectuator}
Function |effectuate| is called to pass in a |LogObject| for display in the GUI.
\begin{code}
instance IsEffectuator Editor a where
effectuate :: Editor a -> LogObject a -> IO ()
effectuate Editor a
editor LogObject a
item =
MVar (EditorInternal a) -> (EditorInternal a -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (Editor a -> MVar (EditorInternal a)
forall a. Editor a -> EditorMVar a
getEd Editor a
editor) ((EditorInternal a -> IO ()) -> IO ())
-> (EditorInternal a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \EditorInternal a
ed ->
LogBuffer a -> LogObject a -> IO ()
forall (t :: * -> *) a.
IsEffectuator t a =>
t a -> LogObject a -> IO ()
effectuate (EditorInternal a -> LogBuffer a
forall a. EditorInternal a -> LogBuffer a
edBuffer EditorInternal a
ed) LogObject a
item
handleOverflow :: Editor a -> IO ()
handleOverflow Editor a
_ = Handle -> LoggerName -> IO ()
TIO.hPutStrLn Handle
stderr LoggerName
"Notice: overflow in Editor!"
\end{code}
\subsubsection{Prepare the view}
\begin{code}
data Cmd = Backends | Scribes | Severities | SubTrace | Aggregation | Buffer | ExportConfiguration
deriving (Int -> Cmd
Cmd -> Int
Cmd -> [Cmd]
Cmd -> Cmd
Cmd -> Cmd -> [Cmd]
Cmd -> Cmd -> Cmd -> [Cmd]
(Cmd -> Cmd)
-> (Cmd -> Cmd)
-> (Int -> Cmd)
-> (Cmd -> Int)
-> (Cmd -> [Cmd])
-> (Cmd -> Cmd -> [Cmd])
-> (Cmd -> Cmd -> [Cmd])
-> (Cmd -> Cmd -> Cmd -> [Cmd])
-> Enum Cmd
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Cmd -> Cmd -> Cmd -> [Cmd]
$cenumFromThenTo :: Cmd -> Cmd -> Cmd -> [Cmd]
enumFromTo :: Cmd -> Cmd -> [Cmd]
$cenumFromTo :: Cmd -> Cmd -> [Cmd]
enumFromThen :: Cmd -> Cmd -> [Cmd]
$cenumFromThen :: Cmd -> Cmd -> [Cmd]
enumFrom :: Cmd -> [Cmd]
$cenumFrom :: Cmd -> [Cmd]
fromEnum :: Cmd -> Int
$cfromEnum :: Cmd -> Int
toEnum :: Int -> Cmd
$ctoEnum :: Int -> Cmd
pred :: Cmd -> Cmd
$cpred :: Cmd -> Cmd
succ :: Cmd -> Cmd
$csucc :: Cmd -> Cmd
Enum, Cmd -> Cmd -> Bool
(Cmd -> Cmd -> Bool) -> (Cmd -> Cmd -> Bool) -> Eq Cmd
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cmd -> Cmd -> Bool
$c/= :: Cmd -> Cmd -> Bool
== :: Cmd -> Cmd -> Bool
$c== :: Cmd -> Cmd -> Bool
Eq, Int -> Cmd -> ShowS
[Cmd] -> ShowS
Cmd -> String
(Int -> Cmd -> ShowS)
-> (Cmd -> String) -> ([Cmd] -> ShowS) -> Show Cmd
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Cmd] -> ShowS
$cshowList :: [Cmd] -> ShowS
show :: Cmd -> String
$cshow :: Cmd -> String
showsPrec :: Int -> Cmd -> ShowS
$cshowsPrec :: Int -> Cmd -> ShowS
Show, ReadPrec [Cmd]
ReadPrec Cmd
Int -> ReadS Cmd
ReadS [Cmd]
(Int -> ReadS Cmd)
-> ReadS [Cmd] -> ReadPrec Cmd -> ReadPrec [Cmd] -> Read Cmd
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Cmd]
$creadListPrec :: ReadPrec [Cmd]
readPrec :: ReadPrec Cmd
$creadPrec :: ReadPrec Cmd
readList :: ReadS [Cmd]
$creadList :: ReadS [Cmd]
readsPrec :: Int -> ReadS Cmd
$creadsPrec :: Int -> ReadS Cmd
Read)
prepare :: ToJSON a => Editor a -> Configuration -> Window -> UI ()
prepare :: Editor a -> Configuration -> Window -> UI ()
prepare Editor a
editor Configuration
config Window
window = UI () -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI () -> UI ()) -> UI () -> UI ()
forall a b. (a -> b) -> a -> b
$ do
let commands :: [Cmd]
commands = [Cmd
Backends .. ]
Element
inputKey <- UI Element
UI.input UI Element -> String -> UI Element
#. String
"w3-input w3-border" UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element String ()
-> String -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Element String ()
UI.size String
"34"
Element
inputValue <- UI Element
UI.input UI Element -> String -> UI Element
#. String
"w3-input w3-border" UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element String ()
-> String -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Element String ()
UI.size String
"60"
Element
outputMsg <- UI Element
UI.input UI Element -> String -> UI Element
#. String
"w3-input w3-border"
Element
currentCmd <- UI Element
UI.p UI Element -> String -> UI Element
#. String
"current-cmd"
let performActionOnId :: String -> (Element -> UI ()) -> UI ()
performActionOnId String
anId Element -> UI ()
action =
Window -> String -> UI (Maybe Element)
getElementById Window
window String
anId UI (Maybe Element) -> (Maybe Element -> UI ()) -> UI ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Element
Nothing -> () -> UI ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Element
anElement -> Element -> UI ()
action Element
anElement
let turn :: w -> Bool -> UI ()
turn w
anElement Bool
toState = UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ w -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element w
anElement UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element Bool Bool -> Bool -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Element Bool Bool
UI.enabled Bool
toState
let setValueOf :: w -> String -> UI ()
setValueOf w
anElement String
aValue = UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ w -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element w
anElement UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element String String
-> String -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Element String String
UI.value String
aValue
let setClasses :: String -> w -> UI ()
setClasses String
classes w
anElement = UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ w -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element w
anElement UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element String ()
-> String -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Element String ()
UI.class_ String
classes
let setError :: String -> UI ()
setError String
m = Element -> String -> UI ()
forall w. Widget w => w -> String -> UI ()
setValueOf Element
outputMsg (String
"ERROR: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
m)
let setMessage :: String -> UI ()
setMessage String
m = Element -> String -> UI ()
forall w. Widget w => w -> String -> UI ()
setValueOf Element
outputMsg String
m
let enable :: w -> UI ()
enable w
anElement = w -> Bool -> UI ()
forall w. Widget w => w -> Bool -> UI ()
turn w
anElement Bool
True
let disable :: w -> UI ()
disable w
anElement = w -> Bool -> UI ()
forall w. Widget w => w -> Bool -> UI ()
turn w
anElement Bool
False
let clean :: w -> UI ()
clean w
anElement = w -> String -> UI ()
forall w. Widget w => w -> String -> UI ()
setValueOf w
anElement String
""
let cleanAndDisable :: w -> UI ()
cleanAndDisable w
anElement = w -> UI ()
forall w. Widget w => w -> UI ()
clean w
anElement UI () -> UI () -> UI ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> w -> UI ()
forall w. Widget w => w -> UI ()
disable w
anElement
let rememberCurrent :: a -> UI ()
rememberCurrent a
cmd = Element -> String -> UI ()
forall w. Widget w => w -> String -> UI ()
setValueOf Element
currentCmd (String -> UI ()) -> String -> UI ()
forall a b. (a -> b) -> a -> b
$ a -> String
forall a. Show a => a -> String
show a
cmd
let removeItem :: Cmd -> LoggerName -> IO ()
removeItem Cmd
Backends LoggerName
k = Configuration -> LoggerName -> Maybe [BackendKind] -> IO ()
CM.setBackends Configuration
config LoggerName
k Maybe [BackendKind]
forall a. Maybe a
Nothing
removeItem Cmd
Severities LoggerName
k = Configuration -> LoggerName -> Maybe Severity -> IO ()
CM.setSeverity Configuration
config LoggerName
k Maybe Severity
forall a. Maybe a
Nothing
removeItem Cmd
Scribes LoggerName
k = Configuration -> LoggerName -> Maybe [LoggerName] -> IO ()
CM.setScribes Configuration
config LoggerName
k Maybe [LoggerName]
forall a. Maybe a
Nothing
removeItem Cmd
SubTrace LoggerName
k = Configuration -> LoggerName -> Maybe SubTrace -> IO ()
CM.setSubTrace Configuration
config LoggerName
k Maybe SubTrace
forall a. Maybe a
Nothing
removeItem Cmd
Aggregation LoggerName
k = Configuration -> LoggerName -> Maybe AggregatedKind -> IO ()
CM.setAggregatedKind Configuration
config LoggerName
k Maybe AggregatedKind
forall a. Maybe a
Nothing
removeItem Cmd
_ LoggerName
_ = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
let updateItem :: Cmd -> LoggerName -> String -> UI ()
updateItem Cmd
Backends LoggerName
k String
v = case (String -> Maybe [BackendKind]
forall a. Read a => String -> Maybe a
readMay String
v :: Maybe [BackendKind]) of
Maybe [BackendKind]
Nothing -> String -> UI ()
setError String
"parse error on backend list"
Just [BackendKind]
v' -> IO () -> UI ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> UI ()) -> IO () -> UI ()
forall a b. (a -> b) -> a -> b
$ Configuration -> LoggerName -> Maybe [BackendKind] -> IO ()
CM.setBackends Configuration
config LoggerName
k (Maybe [BackendKind] -> IO ()) -> Maybe [BackendKind] -> IO ()
forall a b. (a -> b) -> a -> b
$ [BackendKind] -> Maybe [BackendKind]
forall a. a -> Maybe a
Just [BackendKind]
v'
updateItem Cmd
Severities LoggerName
k String
v = case (String -> Maybe Severity
forall a. Read a => String -> Maybe a
readMay String
v :: Maybe Severity) of
Maybe Severity
Nothing -> String -> UI ()
setError String
"parse error on severity"
Just Severity
v' -> IO () -> UI ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> UI ()) -> IO () -> UI ()
forall a b. (a -> b) -> a -> b
$ Configuration -> LoggerName -> Maybe Severity -> IO ()
CM.setSeverity Configuration
config LoggerName
k (Maybe Severity -> IO ()) -> Maybe Severity -> IO ()
forall a b. (a -> b) -> a -> b
$ Severity -> Maybe Severity
forall a. a -> Maybe a
Just Severity
v'
updateItem Cmd
Scribes LoggerName
k String
v = case (String -> Maybe [LoggerName]
forall a. Read a => String -> Maybe a
readMay String
v :: Maybe [ScribeId]) of
Maybe [LoggerName]
Nothing -> String -> UI ()
setError String
"parse error on scribe list"
Just [LoggerName]
v' -> IO () -> UI ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> UI ()) -> IO () -> UI ()
forall a b. (a -> b) -> a -> b
$ Configuration -> LoggerName -> Maybe [LoggerName] -> IO ()
CM.setScribes Configuration
config LoggerName
k (Maybe [LoggerName] -> IO ()) -> Maybe [LoggerName] -> IO ()
forall a b. (a -> b) -> a -> b
$ [LoggerName] -> Maybe [LoggerName]
forall a. a -> Maybe a
Just [LoggerName]
v'
updateItem Cmd
SubTrace LoggerName
k String
v = case (String -> Maybe SubTrace
forall a. Read a => String -> Maybe a
readMay String
v :: Maybe SubTrace) of
Maybe SubTrace
Nothing -> String -> UI ()
setError String
"parse error on subtrace"
Just SubTrace
v' -> IO () -> UI ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> UI ()) -> IO () -> UI ()
forall a b. (a -> b) -> a -> b
$ Configuration -> LoggerName -> Maybe SubTrace -> IO ()
CM.setSubTrace Configuration
config LoggerName
k (Maybe SubTrace -> IO ()) -> Maybe SubTrace -> IO ()
forall a b. (a -> b) -> a -> b
$ SubTrace -> Maybe SubTrace
forall a. a -> Maybe a
Just SubTrace
v'
updateItem Cmd
Aggregation LoggerName
k String
v = case (String -> Maybe AggregatedKind
forall a. Read a => String -> Maybe a
readMay String
v :: Maybe AggregatedKind) of
Maybe AggregatedKind
Nothing -> String -> UI ()
setError String
"parse error on aggregated kind"
Just AggregatedKind
v' -> IO () -> UI ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> UI ()) -> IO () -> UI ()
forall a b. (a -> b) -> a -> b
$ Configuration -> LoggerName -> Maybe AggregatedKind -> IO ()
CM.setAggregatedKind Configuration
config LoggerName
k (Maybe AggregatedKind -> IO ()) -> Maybe AggregatedKind -> IO ()
forall a b. (a -> b) -> a -> b
$ AggregatedKind -> Maybe AggregatedKind
forall a. a -> Maybe a
Just AggregatedKind
v'
updateItem Cmd
_ LoggerName
_ String
_ = () -> UI ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Element -> UI ()
forall w. Widget w => w -> UI ()
disable Element
inputKey
Element -> UI ()
forall w. Widget w => w -> UI ()
disable Element
inputValue
Element -> UI ()
forall w. Widget w => w -> UI ()
disable Element
outputMsg
let saveItemButtonId :: String
saveItemButtonId = String
"save-item-button"
let cancelSaveItemButtonId :: String
cancelSaveItemButtonId = String
"cancel-save-item-button"
let addItemButtonId :: String
addItemButtonId = String
"add-item-button"
let outputTableId :: String
outputTableId = String
"output-table"
let addItemButton :: (Element -> UI ()) -> UI ()
addItemButton = String -> (Element -> UI ()) -> UI ()
performActionOnId String
addItemButtonId
let saveItemButton :: (Element -> UI ()) -> UI ()
saveItemButton = String -> (Element -> UI ()) -> UI ()
performActionOnId String
saveItemButtonId
let cancelSaveItemButton :: (Element -> UI ()) -> UI ()
cancelSaveItemButton = String -> (Element -> UI ()) -> UI ()
performActionOnId String
cancelSaveItemButtonId
let cleanOutputTable :: UI ()
cleanOutputTable = String -> (Element -> UI ()) -> UI ()
performActionOnId String
outputTableId ((Element -> UI ()) -> UI ()) -> (Element -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ \Element
t -> UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
t UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element [Element] ()
-> [Element] -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Element [Element] ()
children []
let mkLinkToFile :: String -> FilePath -> UI Element
mkLinkToFile :: String -> String -> UI Element
mkLinkToFile String
str String
file = UI Element
UI.anchor UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element String ()
-> String -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set (String -> ReadWriteAttr Element String ()
attr String
"href") String
file
# set (attr "target") "_blank"
#+ [ string str ]
let mkSimpleRow :: ToJSON a => LoggerName -> LogObject a -> UI Element
mkSimpleRow :: LoggerName -> LogObject a -> UI Element
mkSimpleRow LoggerName
n lo :: LogObject a
lo@(LogObject LoggerName
_lonm LOMeta
_lometa LOContent a
_lov) = UI Element
UI.tr UI Element -> String -> UI Element
#. String
"itemrow" UI Element -> [UI Element] -> UI Element
#+
[ UI Element
UI.td UI Element -> [UI Element] -> UI Element
#+ [ String -> UI Element
string (LoggerName -> String
unpack LoggerName
n) ]
, UI Element
UI.td UI Element -> [UI Element] -> UI Element
#+ [ String -> UI Element
string (String -> UI Element) -> String -> UI Element
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ LogObject a -> ByteString
forall a. ToJSON a => a -> ByteString
encode LogObject a
lo ]
]
let mkTableRow :: Show t => Cmd -> LoggerName -> t -> UI Element
mkTableRow :: Cmd -> LoggerName -> t -> UI Element
mkTableRow Cmd
cmd LoggerName
n t
v = UI Element
UI.tr UI Element -> String -> UI Element
#. String
"itemrow" UI Element -> [UI Element] -> UI Element
#+
[ UI Element
UI.td UI Element -> [UI Element] -> UI Element
#+ [ String -> UI Element
string (LoggerName -> String
unpack LoggerName
n) ]
, UI Element
UI.td UI Element -> [UI Element] -> UI Element
#+ [ String -> UI Element
string (t -> String
forall a. Show a => a -> String
show t
v) ]
, UI Element
UI.td UI Element -> [UI Element] -> UI Element
#+
[ do
Element
b <- UI Element
UI.button UI Element -> String -> UI Element
#. String
"w3-small w3-btn w3-ripple w3-orange edit-item-button"
#+ [ UI.bold #+ [ string "Edit" ] ]
(Element -> Event ()) -> Element -> (() -> UI ()) -> UI ()
forall element a void.
(element -> Event a) -> element -> (a -> UI void) -> UI ()
on Element -> Event ()
UI.click Element
b ((() -> UI ()) -> UI ()) -> (() -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ UI () -> () -> UI ()
forall a b. a -> b -> a
const (UI () -> () -> UI ()) -> UI () -> () -> UI ()
forall a b. (a -> b) -> a -> b
$ do
(Element -> UI ()) -> UI ()
saveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
enable
(Element -> UI ()) -> UI ()
cancelSaveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
enable
Element -> UI ()
forall w. Widget w => w -> UI ()
clean Element
outputMsg
Element -> UI ()
forall w. Widget w => w -> UI ()
enable Element
inputKey
Element -> UI ()
forall w. Widget w => w -> UI ()
enable Element
inputValue
Element -> String -> UI ()
forall w. Widget w => w -> String -> UI ()
setValueOf Element
inputKey (LoggerName -> String
unpack LoggerName
n)
Element -> String -> UI ()
forall w. Widget w => w -> String -> UI ()
setValueOf Element
inputValue (t -> String
forall a. Show a => a -> String
show t
v)
Cmd -> UI ()
forall a. Show a => a -> UI ()
rememberCurrent Cmd
cmd
Element -> UI Element
forall (m :: * -> *) a. Monad m => a -> m a
return Element
b
, UI Element
UI.span UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element String ()
-> String -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Element String ()
html String
" "
, do
Element
b <- UI Element
UI.button UI Element -> String -> UI Element
#. String
"w3-small w3-btn w3-ripple w3-red"
#+ [ UI.bold #+ [ string "Delete" ] ]
(Element -> Event ()) -> Element -> (() -> UI ()) -> UI ()
forall element a void.
(element -> Event a) -> element -> (a -> UI void) -> UI ()
on Element -> Event ()
UI.click Element
b ((() -> UI ()) -> UI ()) -> (() -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ UI () -> () -> UI ()
forall a b. a -> b -> a
const (UI () -> () -> UI ()) -> UI () -> () -> UI ()
forall a b. (a -> b) -> a -> b
$ do
IO () -> UI ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> UI ()) -> IO () -> UI ()
forall a b. (a -> b) -> a -> b
$ Cmd -> LoggerName -> IO ()
removeItem Cmd
cmd LoggerName
n
Element -> UI ()
forall w. Widget w => w -> UI ()
cleanAndDisable Element
inputKey
Element -> UI ()
forall w. Widget w => w -> UI ()
cleanAndDisable Element
inputValue
String -> (Element -> UI ()) -> UI ()
performActionOnId (Cmd -> String
forall a. Show a => a -> String
show Cmd
cmd) ((Element -> UI ()) -> UI ()) -> (Element -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ JSFunction () -> UI ()
runFunction (JSFunction () -> UI ())
-> (Element -> JSFunction ()) -> Element -> UI ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Element -> JSFunction ()
forall a. FFI a => String -> a
ffi String
"$(%1).click()"
Element -> UI Element
forall (m :: * -> *) a. Monad m => a -> m a
return Element
b
]
]
let showCurrentTab :: Cmd -> UI ()
showCurrentTab Cmd
cmd = do
let baseClasses :: String
baseClasses = String
"w3-bar-item w3-button"
classesForCurrentTab :: String
classesForCurrentTab = String
baseClasses String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"w3-light-grey"
String -> (Element -> UI ()) -> UI ()
performActionOnId (Cmd -> String
forall a. Show a => a -> String
show Cmd
cmd) ((Element -> UI ()) -> UI ()) -> (Element -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ String -> Element -> UI ()
forall w. Widget w => String -> w -> UI ()
setClasses String
classesForCurrentTab
let otherTabs :: [Cmd]
otherTabs = Cmd -> [Cmd] -> [Cmd]
forall a. Eq a => a -> [a] -> [a]
delete Cmd
cmd [Cmd]
commands
[Cmd] -> (Cmd -> UI ()) -> UI ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Cmd]
otherTabs ((Cmd -> UI ()) -> UI ()) -> (Cmd -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ \Cmd
tabName ->
String -> (Element -> UI ()) -> UI ()
performActionOnId (Cmd -> String
forall a. Show a => a -> String
show Cmd
tabName) ((Element -> UI ()) -> UI ()) -> (Element -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ String -> Element -> UI ()
forall w. Widget w => String -> w -> UI ()
setClasses String
baseClasses
let displayItems :: Cmd -> (ConfigurationInternal -> HashMap LoggerName t) -> UI ()
displayItems Cmd
cmd ConfigurationInternal -> HashMap LoggerName t
sel = do
Cmd -> UI ()
showCurrentTab Cmd
cmd
Cmd -> UI ()
forall a. Show a => a -> UI ()
rememberCurrent Cmd
cmd
(Element -> UI ()) -> UI ()
saveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
disable
(Element -> UI ()) -> UI ()
cancelSaveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
disable
(Element -> UI ()) -> UI ()
addItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
enable
UI ()
cleanOutputTable
String -> (Element -> UI ()) -> UI ()
performActionOnId String
outputTableId ((Element -> UI ()) -> UI ()) -> (Element -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$
\Element
t -> UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
t UI Element -> [UI Element] -> UI Element
#+
[ UI Element
UI.tr UI Element -> [UI Element] -> UI Element
#+
[ UI Element
UI.th UI Element -> [UI Element] -> UI Element
#+ [ String -> UI Element
string String
"LoggerName" ]
, UI Element
UI.th UI Element -> [UI Element] -> UI Element
#+ [ String -> UI Element
string (String -> UI Element) -> String -> UI Element
forall a b. (a -> b) -> a -> b
$ Cmd -> String
forall a. Show a => a -> String
show Cmd
cmd String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" value" ]
, UI Element
UI.th UI Element -> [UI Element] -> UI Element
#+ [ String -> UI Element
string String
"" ]
]
]
ConfigurationInternal
cg <- IO ConfigurationInternal -> UI ConfigurationInternal
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ConfigurationInternal -> UI ConfigurationInternal)
-> IO ConfigurationInternal -> UI ConfigurationInternal
forall a b. (a -> b) -> a -> b
$ MVar ConfigurationInternal -> IO ConfigurationInternal
forall a. MVar a -> IO a
readMVar (Configuration -> MVar ConfigurationInternal
CM.getCG Configuration
config)
[(LoggerName, t)] -> ((LoggerName, t) -> UI ()) -> UI ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (HashMap LoggerName t -> [(LoggerName, t)]
forall k v. HashMap k v -> [(k, v)]
HM.toList (HashMap LoggerName t -> [(LoggerName, t)])
-> HashMap LoggerName t -> [(LoggerName, t)]
forall a b. (a -> b) -> a -> b
$ ConfigurationInternal -> HashMap LoggerName t
sel ConfigurationInternal
cg) (((LoggerName, t) -> UI ()) -> UI ())
-> ((LoggerName, t) -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$
\(LoggerName
n,t
v) -> String -> (Element -> UI ()) -> UI ()
performActionOnId String
outputTableId ((Element -> UI ()) -> UI ()) -> (Element -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$
\Element
t -> UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
t UI Element -> [UI Element] -> UI Element
#+ [ Cmd -> LoggerName -> t -> UI Element
forall t. Show t => Cmd -> LoggerName -> t -> UI Element
mkTableRow Cmd
cmd LoggerName
n t
v ]
let displayBuffer :: ToJSON a => Cmd -> [(LoggerName, LogObject a)] -> UI ()
displayBuffer :: Cmd -> [(LoggerName, LogObject a)] -> UI ()
displayBuffer Cmd
cmd [(LoggerName, LogObject a)]
sel = do
Cmd -> UI ()
showCurrentTab Cmd
cmd
Cmd -> UI ()
forall a. Show a => a -> UI ()
rememberCurrent Cmd
cmd
(Element -> UI ()) -> UI ()
saveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
disable
(Element -> UI ()) -> UI ()
cancelSaveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
disable
(Element -> UI ()) -> UI ()
addItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
disable
UI ()
cleanOutputTable
String -> (Element -> UI ()) -> UI ()
performActionOnId String
outputTableId ((Element -> UI ()) -> UI ()) -> (Element -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$
\Element
t -> UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
t UI Element -> [UI Element] -> UI Element
#+
[ UI Element
UI.tr UI Element -> [UI Element] -> UI Element
#+
[ UI Element
UI.th UI Element -> [UI Element] -> UI Element
#+ [ String -> UI Element
string String
"LoggerName" ]
, UI Element
UI.th UI Element -> [UI Element] -> UI Element
#+ [ String -> UI Element
string (String -> UI Element) -> String -> UI Element
forall a b. (a -> b) -> a -> b
$ Cmd -> String
forall a. Show a => a -> String
show Cmd
cmd String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" value" ]
, UI Element
UI.th UI Element -> [UI Element] -> UI Element
#+ [ String -> UI Element
string String
"" ]
]
]
[(LoggerName, LogObject a)]
-> ((LoggerName, LogObject a) -> UI ()) -> UI ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(LoggerName, LogObject a)]
sel (((LoggerName, LogObject a) -> UI ()) -> UI ())
-> ((LoggerName, LogObject a) -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$
\(LoggerName
n,LogObject a
v) -> String -> (Element -> UI ()) -> UI ()
performActionOnId String
outputTableId ((Element -> UI ()) -> UI ()) -> (Element -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$
\Element
t -> UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
t UI Element -> [UI Element] -> UI Element
#+ [ LoggerName -> LogObject a -> UI Element
forall a. ToJSON a => LoggerName -> LogObject a -> UI Element
mkSimpleRow LoggerName
n LogObject a
v ]
let accessBufferMap :: UI [(LoggerName, LogObject a)]
accessBufferMap = do
EditorInternal a
ed <- IO (EditorInternal a) -> UI (EditorInternal a)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (EditorInternal a) -> UI (EditorInternal a))
-> IO (EditorInternal a) -> UI (EditorInternal a)
forall a b. (a -> b) -> a -> b
$ MVar (EditorInternal a) -> IO (EditorInternal a)
forall a. MVar a -> IO a
readMVar (Editor a -> MVar (EditorInternal a)
forall a. Editor a -> EditorMVar a
getEd Editor a
editor)
IO [(LoggerName, LogObject a)] -> UI [(LoggerName, LogObject a)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(LoggerName, LogObject a)] -> UI [(LoggerName, LogObject a)])
-> IO [(LoggerName, LogObject a)] -> UI [(LoggerName, LogObject a)]
forall a b. (a -> b) -> a -> b
$ LogBuffer a -> IO [(LoggerName, LogObject a)]
forall a. LogBuffer a -> IO [(LoggerName, LogObject a)]
readBuffer (LogBuffer a -> IO [(LoggerName, LogObject a)])
-> LogBuffer a -> IO [(LoggerName, LogObject a)]
forall a b. (a -> b) -> a -> b
$ EditorInternal a -> LogBuffer a
forall a. EditorInternal a -> LogBuffer a
edBuffer EditorInternal a
ed
let exportConfiguration :: UI ()
exportConfiguration = do
String
currentDir <- IO String -> UI String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getCurrentDirectory
let dir :: String
dir = String
currentDir String -> ShowS
</> String
"iohk-monitoring/static/conf"
IO () -> UI ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> UI ()) -> IO () -> UI ()
forall a b. (a -> b) -> a -> b
$ Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
dir
String
tsnow <- TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
tsformat (UTCTime -> String) -> UI UTCTime -> UI String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime -> UI UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let filename :: String
filename = String
"config.yaml" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
tsnow
filepath :: String
filepath = String
dir String -> ShowS
</> String
filename
String
res <- IO String -> UI String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> UI String) -> IO String -> UI String
forall a b. (a -> b) -> a -> b
$ IO String -> (IOException -> IO String) -> IO String
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch
(Configuration -> String -> IO ()
CM.exportConfiguration Configuration
config String
filepath IO () -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"Configuration was exported to the file: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
filepath))
(\(IOException
e :: IOException) -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show IOException
e)
String -> UI ()
setMessage String
res
String -> (Element -> UI ()) -> UI ()
performActionOnId String
outputTableId ((Element -> UI ()) -> UI ()) -> (Element -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$
\Element
t -> UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
t UI Element -> [UI Element] -> UI Element
#+ [ String -> String -> UI Element
mkLinkToFile
String
"Link to configuration file"
(String
"/static/conf" String -> ShowS
</> String
filename)
]
let displayExport :: Cmd -> UI ()
displayExport Cmd
cmd = do
Cmd -> UI ()
showCurrentTab Cmd
cmd
Cmd -> UI ()
forall a. Show a => a -> UI ()
rememberCurrent Cmd
cmd
(Element -> UI ()) -> UI ()
saveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
disable
(Element -> UI ()) -> UI ()
cancelSaveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
disable
(Element -> UI ()) -> UI ()
addItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
disable
UI ()
cleanOutputTable
UI ()
exportConfiguration
let switchToTab :: Cmd -> UI ()
switchToTab c :: Cmd
c@Cmd
Backends = Cmd
-> (ConfigurationInternal -> HashMap LoggerName [BackendKind])
-> UI ()
forall t.
Show t =>
Cmd -> (ConfigurationInternal -> HashMap LoggerName t) -> UI ()
displayItems Cmd
c ConfigurationInternal -> HashMap LoggerName [BackendKind]
CM.cgMapBackend
switchToTab c :: Cmd
c@Cmd
Severities = Cmd
-> (ConfigurationInternal -> HashMap LoggerName Severity) -> UI ()
forall t.
Show t =>
Cmd -> (ConfigurationInternal -> HashMap LoggerName t) -> UI ()
displayItems Cmd
c ConfigurationInternal -> HashMap LoggerName Severity
CM.cgMapSeverity
switchToTab c :: Cmd
c@Cmd
Scribes = Cmd
-> (ConfigurationInternal -> HashMap LoggerName [LoggerName])
-> UI ()
forall t.
Show t =>
Cmd -> (ConfigurationInternal -> HashMap LoggerName t) -> UI ()
displayItems Cmd
c ConfigurationInternal -> HashMap LoggerName [LoggerName]
CM.cgMapScribe
switchToTab c :: Cmd
c@Cmd
SubTrace = Cmd
-> (ConfigurationInternal -> HashMap LoggerName SubTrace) -> UI ()
forall t.
Show t =>
Cmd -> (ConfigurationInternal -> HashMap LoggerName t) -> UI ()
displayItems Cmd
c ConfigurationInternal -> HashMap LoggerName SubTrace
CM.cgMapSubtrace
switchToTab c :: Cmd
c@Cmd
Aggregation = Cmd
-> (ConfigurationInternal -> HashMap LoggerName AggregatedKind)
-> UI ()
forall t.
Show t =>
Cmd -> (ConfigurationInternal -> HashMap LoggerName t) -> UI ()
displayItems Cmd
c ConfigurationInternal -> HashMap LoggerName AggregatedKind
CM.cgMapAggregatedKind
switchToTab c :: Cmd
c@Cmd
Buffer = UI [(LoggerName, LogObject a)]
accessBufferMap UI [(LoggerName, LogObject a)]
-> ([(LoggerName, LogObject a)] -> UI ()) -> UI ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Cmd -> [(LoggerName, LogObject a)] -> UI ()
forall a. ToJSON a => Cmd -> [(LoggerName, LogObject a)] -> UI ()
displayBuffer Cmd
c
switchToTab c :: Cmd
c@Cmd
ExportConfiguration = Cmd -> UI ()
displayExport Cmd
c
let mkEditInputs :: UI Element
mkEditInputs =
[UI Element] -> UI Element
row [ Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
inputKey
, UI Element
UI.span UI Element -> String -> UI Element
#. String
"key-value-separator" UI Element -> [UI Element] -> UI Element
#+ [String -> UI Element
string String
":"]
, Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
inputValue
, UI Element
UI.span UI Element -> String -> UI Element
#. String
"key-value-separator" UI Element -> [UI Element] -> UI Element
#+ [String -> UI Element
string String
""]
, do
Element
b <- UI Element
UI.button UI Element -> String -> UI Element
#. String
"w3-btn w3-ripple w3-green save-item-button"
# set (UI.attr "id") addItemButtonId
# set UI.enabled False
#+ [UI.bold #+ [string "New"]]
(Element -> Event ()) -> Element -> (() -> UI ()) -> UI ()
forall element a void.
(element -> Event a) -> element -> (a -> UI void) -> UI ()
on Element -> Event ()
UI.click Element
b ((() -> UI ()) -> UI ()) -> (() -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ UI () -> () -> UI ()
forall a b. a -> b -> a
const (UI () -> () -> UI ()) -> UI () -> () -> UI ()
forall a b. (a -> b) -> a -> b
$ do
Element -> UI ()
forall w. Widget w => w -> UI ()
enable Element
inputKey
Element -> UI ()
forall w. Widget w => w -> UI ()
enable Element
inputValue
(Element -> UI ()) -> UI ()
saveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
enable
(Element -> UI ()) -> UI ()
cancelSaveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
enable
Element -> UI Element
forall (m :: * -> *) a. Monad m => a -> m a
return Element
b
, UI Element
UI.span UI Element -> String -> UI Element
#. String
"key-value-separator" UI Element -> [UI Element] -> UI Element
#+ [String -> UI Element
string String
""]
, do
Element
b <- UI Element
UI.button UI Element -> String -> UI Element
#. String
"w3-btn w3-ripple w3-lime save-item-button"
# set (UI.attr "id") saveItemButtonId
# set UI.enabled False
#+ [UI.bold #+ [string "Save"]]
(Element -> Event ()) -> Element -> (() -> UI ()) -> UI ()
forall element a void.
(element -> Event a) -> element -> (a -> UI void) -> UI ()
on Element -> Event ()
UI.click Element
b ((() -> UI ()) -> UI ()) -> (() -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ UI () -> () -> UI ()
forall a b. a -> b -> a
const (UI () -> () -> UI ()) -> UI () -> () -> UI ()
forall a b. (a -> b) -> a -> b
$ do
String
k <- Element
inputKey Element -> (Element -> UI String) -> UI String
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element String String -> Element -> UI String
forall x i o. ReadWriteAttr x i o -> x -> UI o
get ReadWriteAttr Element String String
UI.value
String
v <- Element
inputValue Element -> (Element -> UI String) -> UI String
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element String String -> Element -> UI String
forall x i o. ReadWriteAttr x i o -> x -> UI o
get ReadWriteAttr Element String String
UI.value
String
m <- Element
currentCmd Element -> (Element -> UI String) -> UI String
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element String String -> Element -> UI String
forall x i o. ReadWriteAttr x i o -> x -> UI o
get ReadWriteAttr Element String String
UI.value
case (String -> Maybe Cmd
forall a. Read a => String -> Maybe a
readMay String
m :: Maybe Cmd) of
Maybe Cmd
Nothing -> String -> UI ()
setError String
"parse error on cmd"
Just Cmd
c -> do
Element -> UI ()
forall w. Widget w => w -> UI ()
cleanAndDisable Element
inputKey
Element -> UI ()
forall w. Widget w => w -> UI ()
cleanAndDisable Element
inputValue
(Element -> UI ()) -> UI ()
saveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
disable
(Element -> UI ()) -> UI ()
cancelSaveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
disable
String -> UI ()
setMessage (String -> UI ()) -> String -> UI ()
forall a b. (a -> b) -> a -> b
$ String
"Setting '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' to '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"' in " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
m
Cmd -> LoggerName -> String -> UI ()
updateItem Cmd
c (String -> LoggerName
pack String
k) String
v
Cmd -> UI ()
switchToTab Cmd
c
Element -> UI Element
forall (m :: * -> *) a. Monad m => a -> m a
return Element
b
, UI Element
UI.span UI Element -> String -> UI Element
#. String
"key-value-separator" UI Element -> [UI Element] -> UI Element
#+ [String -> UI Element
string String
""]
, do
Element
b <- UI Element
UI.button UI Element -> String -> UI Element
#. String
"w3-btn w3-ripple w3-white"
# set (UI.attr "id") cancelSaveItemButtonId
# set UI.enabled False
#+ [UI.bold #+ [string "Cancel"]]
(Element -> Event ()) -> Element -> (() -> UI ()) -> UI ()
forall element a void.
(element -> Event a) -> element -> (a -> UI void) -> UI ()
on Element -> Event ()
UI.click Element
b ((() -> UI ()) -> UI ()) -> (() -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ UI () -> () -> UI ()
forall a b. a -> b -> a
const (UI () -> () -> UI ()) -> UI () -> () -> UI ()
forall a b. (a -> b) -> a -> b
$ do
Element -> UI ()
forall w. Widget w => w -> UI ()
cleanAndDisable Element
inputKey
Element -> UI ()
forall w. Widget w => w -> UI ()
cleanAndDisable Element
inputValue
(Element -> UI ()) -> UI ()
saveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
disable
(Element -> UI ()) -> UI ()
cancelSaveItemButton Element -> UI ()
forall w. Widget w => w -> UI ()
disable
Element -> UI Element
forall (m :: * -> *) a. Monad m => a -> m a
return Element
b
]
let minimumSeveritySelection :: UI Element
minimumSeveritySelection = do
Severity
confMinSev <- IO Severity -> UI Severity
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Severity -> UI Severity) -> IO Severity -> UI Severity
forall a b. (a -> b) -> a -> b
$ Configuration -> IO Severity
minSeverity Configuration
config
let setMinSev :: p -> Maybe Int -> f ()
setMinSev p
_el Maybe Int
Nothing = () -> f ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
setMinSev p
_el (Just Int
sev) = IO () -> f ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> f ()) -> IO () -> f ()
forall a b. (a -> b) -> a -> b
$
Configuration -> Severity -> IO ()
setMinSeverity Configuration
config (Int -> Severity
forall a. Enum a => Int -> a
toEnum Int
sev :: Severity)
mkSevOption :: Severity -> UI Element
mkSevOption Severity
sev = UI Element
UI.option UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element String ()
-> String -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Element String ()
UI.text (Severity -> String
forall a. Show a => a -> String
show Severity
sev)
# set UI.value (show sev)
# if confMinSev == sev then set UI.selected True else id
Element
minsev <- UI Element
UI.select UI Element -> String -> UI Element
#. String
"minsevfield" UI Element -> [UI Element] -> UI Element
#+
(Severity -> UI Element) -> [Severity] -> [UI Element]
forall a b. (a -> b) -> [a] -> [b]
map Severity -> UI Element
mkSevOption (Severity -> [Severity]
forall a. Enum a => a -> [a]
enumFrom Severity
Debug)
(Element -> Event (Maybe Int))
-> Element -> (Maybe Int -> UI ()) -> UI ()
forall element a void.
(element -> Event a) -> element -> (a -> UI void) -> UI ()
on Element -> Event (Maybe Int)
UI.selectionChange Element
minsev ((Maybe Int -> UI ()) -> UI ()) -> (Maybe Int -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ Element -> Maybe Int -> UI ()
forall (f :: * -> *) p. MonadIO f => p -> Maybe Int -> f ()
setMinSev Element
minsev
[UI Element] -> UI Element
row [ String -> UI Element
string String
"Set minimum severity to:"
, UI Element
UI.span UI Element -> (UI Element -> UI Element) -> UI Element
forall a b. a -> (a -> b) -> b
# ReadWriteAttr Element String ()
-> String -> UI Element -> UI Element
forall x i o. ReadWriteAttr x i o -> i -> UI x -> UI x
set ReadWriteAttr Element String ()
html String
" "
, UI Element
UI.span UI Element -> String -> UI Element
#. String
"severity-dropdown big" UI Element -> [UI Element] -> UI Element
#+ [ Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
minsev ]
]
let commandTabs :: UI Element
commandTabs =
[UI Element] -> UI Element
row ([UI Element] -> UI Element) -> [UI Element] -> UI Element
forall a b. (a -> b) -> a -> b
$ ((Cmd -> UI Element) -> [Cmd] -> [UI Element])
-> [Cmd] -> (Cmd -> UI Element) -> [UI Element]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Cmd -> UI Element) -> [Cmd] -> [UI Element]
forall a b. (a -> b) -> [a] -> [b]
map [Cmd]
commands ((Cmd -> UI Element) -> [UI Element])
-> (Cmd -> UI Element) -> [UI Element]
forall a b. (a -> b) -> a -> b
$ \Cmd
cmd -> do
Element
b <- UI Element
UI.button UI Element -> String -> UI Element
#. String
"w3-bar-item w3-button w3-grey"
# set (UI.attr "id") (show cmd)
#+ [ UI.bold #+ [ string (show cmd) ] ]
(Element -> Event ()) -> Element -> (() -> UI ()) -> UI ()
forall element a void.
(element -> Event a) -> element -> (a -> UI void) -> UI ()
on Element -> Event ()
UI.click Element
b ((() -> UI ()) -> UI ()) -> (() -> UI ()) -> UI ()
forall a b. (a -> b) -> a -> b
$ UI () -> () -> UI ()
forall a b. a -> b -> a
const (UI () -> () -> UI ()) -> UI () -> () -> UI ()
forall a b. (a -> b) -> a -> b
$ do
Element -> UI ()
forall w. Widget w => w -> UI ()
cleanAndDisable Element
inputKey
Element -> UI ()
forall w. Widget w => w -> UI ()
cleanAndDisable Element
inputValue
Element -> UI ()
forall w. Widget w => w -> UI ()
clean Element
outputMsg
Cmd -> UI ()
switchToTab Cmd
cmd
Element -> UI Element
forall (m :: * -> *) a. Monad m => a -> m a
return Element
b
Window -> String -> UI (Maybe Element)
getElementById Window
window String
"main-section" UI (Maybe Element) -> (Maybe Element -> UI ()) -> UI ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Element
Nothing -> () -> UI ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Element
mainSection -> UI Element -> UI ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (UI Element -> UI ()) -> UI Element -> UI ()
forall a b. (a -> b) -> a -> b
$ Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
mainSection UI Element -> [UI Element] -> UI Element
#+
[ UI Element
UI.div UI Element -> String -> UI Element
#. String
"w3-panel" UI Element -> [UI Element] -> UI Element
#+
[ UI Element
UI.div UI Element -> String -> UI Element
#. String
"w3-border w3-border-dark-grey" UI Element -> [UI Element] -> UI Element
#+
[ UI Element
UI.div UI Element -> String -> UI Element
#. String
"w3-panel" UI Element -> [UI Element] -> UI Element
#+ [ UI Element
minimumSeveritySelection ]
]
, UI Element
UI.div UI Element -> String -> UI Element
#. String
"w3-panel" UI Element -> [UI Element] -> UI Element
#+ []
, UI Element
UI.div UI Element -> String -> UI Element
#. String
"w3-border w3-border-dark-grey" UI Element -> [UI Element] -> UI Element
#+
[ UI Element
UI.div UI Element -> String -> UI Element
#. String
"w3-bar w3-grey" UI Element -> [UI Element] -> UI Element
#+ [ UI Element
commandTabs ]
, UI Element
UI.div UI Element -> String -> UI Element
#. String
"w3-panel" UI Element -> [UI Element] -> UI Element
#+ [ UI Element
mkEditInputs ]
, UI Element
UI.div UI Element -> String -> UI Element
#. String
"w3-panel" UI Element -> [UI Element] -> UI Element
#+ [ Element -> UI Element
forall (m :: * -> *) w. (MonadIO m, Widget w) => w -> m Element
element Element
outputMsg ]
]
]
]
\end{code}