\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
    , 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"

        -- local |LogBuffer|
        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
"&nbsp;&nbsp;&nbsp;"
                  , 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
                          -- Initiate a click to current menu to update the items list after deleting.
                          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
"&nbsp;"
                , 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}