module Network.OnRmt.UI.MainScreen
( Screen(..), newScreen
, drawScreen, screenDefaultAttrs
, handleScreenEvents
, ScreenElementNames(..)
, chooseScreenCursor
, ScreenEventResult(..)
, setScreenItemState
, setScreenProgress
, resetOutput, addScreenOutput
, logWrite
, updateScreen
) where
import Brick.AttrMap
import Brick.Focus
import Brick.Main
import Brick.Types
import Brick.Util (fg)
import Brick.Widgets.Border
import Brick.Widgets.Center
import Brick.Widgets.Core
import Brick.Widgets.Edit
import Brick.Widgets.List
import Brick.Widgets.ProgressBar
import Concurrent.Worker (DispBlk(..), WorkState(..), WorkId)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.List (intercalate, intersperse)
import Data.Maybe (fromJust, isJust)
import Data.Monoid ((<>))
import Data.String.Conversions (cs)
import qualified Data.Text as T
import Data.Text.Zipper (clearZipper)
import Data.Time.Format (formatTime, defaultTimeLocale, rfc822DateFormat)
import Data.Time.LocalTime (getZonedTime)
import qualified Data.Vector as Vec
import Graphics.Vty ( Key(..), Event(..))
import Graphics.Vty.Attributes
import Lens.Micro ((^.))
import TextUI.ItemField (ItemState(..), ItemField(..), ItemFieldWidget(..)
, itemFieldWidget
, setItemState, getMarkedItems
, getSelectedItem, handleItemFieldEvent)
data ScreenElementNames = Name_ItemField
| Name_UserInput
| Name_RemoteOutput
| Name_ClearButton
| Name_TestButton
| Name_RunButton
| Name_ResponseButton
| Name_QuitButton
| Name_LogRegion
deriving (Eq, Ord, Show)
data Screen =
Screen { screenName :: T.Text
, screenTime :: Maybe T.Text
, itemfield :: ItemsType
, logRgn :: LogType
, outRgn :: OutputType
, inpRgn :: InputType
, progress :: ProgressType
, focus :: FocusRing ScreenElementNames
}
instance Show Screen where
show s = let st8s = itemst8 $ itemField $ itemfield s
summary st8 = case showNum st8 of
0 -> Nothing
n -> Just $ show n <> " " <> st8str st8
showNum = flip numSt8 st8s
numSt8 st8 = length . filter (st8 ==)
st8str Good = "completed"
st8str Bad = "failed"
st8str Pending = "in progress..."
st8str x = "unknown: " <> show x
in intercalate ", " $ map fromJust $ filter isJust
[ Just $ show (length st8s) <> " remotes"
, summary Good
, summary Pending
, summary Bad
]
newScreen :: T.Text -> ItemField -> Screen
newScreen screenName field =
Screen { screenName = screenName
, screenTime = Nothing
, itemfield = initialItems field
, inpRgn = initialInput
, outRgn = initialOutput
, logRgn = initialLog
, focus = focusRing [ Name_ItemField
, Name_RemoteOutput
, Name_ClearButton
, Name_TestButton
, Name_RunButton
, Name_ResponseButton
, Name_QuitButton
, Name_UserInput
]
, progress = initialProgress
}
usage :: [T.Text]
usage =
["How to use this utility:"
,"| 1. select one or more remote systems in the field above"
,"| arrows to move, < or > to move by 15"
,"| toggle selection: space = current, L = line, G = group, A = all"
,"| + ~ ! = select all matching mark"
,"| s f = select + or !, clear all others"
,"| mouse = move, or toggle group if on groupname"
,"| 2. Tab to the Test button to test connectivity to the remotes"
,"| 3. Tab down to the edit area below and enter commands to run"
,"| 4. Tab to the Run button to execute the commands"
,"| 5. Check the results by selecting systems above; the output is shown here."
," "
,"Logging output is shown in the bottom window."
," "
,"Select the AddResp button (via Tab), type in a response to be supplied"
,"for password or passphrase prompts from the remote, and then click"
,"the button (hit Enter) to save that response; tab away from the button."
,"to cancel entering a response."
," "
,"The Clear button clears all fields, responses, and output."
," "
,"Typing + or - while the Run key is selected will increase or decrease"
,"the parallelism for the next run (as noted in the logging window)."
]
updateScreen s f =
let tick scrn = updateClock scrn . cs . (++) "Updated " . ftime
ftime = formatTime defaultTimeLocale rfc822DateFormat
updateClock scrn t = scrn { screenTime = Just t }
in do s' <- f s
liftIO $ tick s' <$> getZonedTime
screenAttr = attrName "screen"
screenBannerAttr = screenAttr <> "banner"
screenClockAttr = screenAttr <> "clock"
screenProgressBarDoneAttr = screenAttr <> "progress bar: done"
screenProgressBarRemainingAttr = screenAttr <> "progress bar: remaining"
screenButtonAttr = screenAttr <> "button"
screenButtonSelectedAttr = screenButtonAttr <> "selected"
screenOutputAttr = screenAttr <> "output"
screenOutputInputAttr = screenOutputAttr <> "disp:input"
screenOutputOutputAttr = screenOutputAttr <> "disp:output"
screenOutputErrorAttr = screenOutputAttr <> "disp:error"
screenOutputInfoAttr = screenOutputAttr <> "disp:info"
screenOutputSelectedAttr = screenOutputAttr <> "selected"
screenLogAttr = screenAttr <> "log"
screenLogOldAttr = screenLogAttr <> "old"
screenLogNewAttr = screenLogAttr <> "new"
screenDefaultAttrs =
[ (screenBannerAttr, defAttr `withStyle` bold `withStyle` underline)
, (screenProgressBarDoneAttr,
defAttr `withStyle` bold `withForeColor` blue `withBackColor` white)
, (screenProgressBarRemainingAttr, defAttr `withStyle` bold `withForeColor` white)
, (screenButtonAttr, defAttr `withBackColor` brightBlack)
, (screenButtonSelectedAttr, defAttr `withStyle` reverseVideo)
, (screenOutputSelectedAttr, defAttr `withStyle` reverseVideo)
, (screenOutputOutputAttr, fg green)
, (screenOutputErrorAttr, fg red `withStyle` bold)
, (screenOutputInfoAttr, fg cyan)
, (screenLogNewAttr, defAttr `withStyle` bold)
]
button :: Maybe Int -> Bool -> (n, T.Text) -> Widget n
button mbsize selected ident =
let battr = if selected then screenButtonSelectedAttr else screenButtonAttr
t = snd ident
pfxSize = maybe 2 (\s -> max 2 ((s T.length t) `div` 2)) mbsize
sfxSize = maybe 2 (\s -> max 2 (s T.length t pfxSize)) mbsize
pfx = T.replicate pfxSize $ T.pack " "
sfx = T.replicate sfxSize $ T.pack " "
in withDefAttr battr $ str $ T.unpack $ pfx <> t <> sfx
instance Named (ScreenElementNames, T.Text) ScreenElementNames where
getName = fst
buttonGroup :: FocusRing ScreenElementNames
-> [(ScreenElementNames, T.Text)]
-> Widget ScreenElementNames
buttonGroup focusring idents =
let labels = map snd idents
names = map fst idents
max_battr = 4 + maximum (map T.length labels)
mkButton n i = withFocusRing focusring (button (Just max_battr)) n
in hBox $ intersperse (str " ") $ zipWith mkButton idents [1..]
data ScreenEventResult n = Quit
| Continue Screen
| RequestWork Screen [T.Text] [Int]
| ResetAll Screen
| UpdateSelection Screen Int
| MoreParallel
| LessParallel
| EnteredResponseGen Screen
| ResponseGenAdd Screen T.Text
| ResponseGenRecord
| ExitedResponseGen Screen
handleScreenEvents scrn (EvResize _ _) = return $ Continue scrn
handleScreenEvents scrn e@(EvKey key mod) =
let focused = focusGetCurrent $ focus scrn
onFocus f op = case focused of
Just f -> op
_ -> handleScreenDefaultEvent False scrn e
in case key of
KChar '\t' -> adjustFocus scrn focusNext
KBackTab -> adjustFocus scrn focusPrev
KChar '+' ->
case focused of
Just Name_RunButton -> onFocus Name_RunButton $ return MoreParallel
_ -> handleScreenDefaultEvent False scrn e
KChar '-' ->
case focused of
Just Name_RunButton -> onFocus Name_RunButton $ return LessParallel
_ -> handleScreenDefaultEvent False scrn e
KEnter ->
case focused of
Just Name_ClearButton -> resetAll scrn
Just Name_TestButton -> requestWork scrn ["id"]
Just Name_RunButton -> requestWork scrn $ getEditContents $ inpRgn scrn
Just Name_ResponseButton -> return ResponseGenRecord
Just Name_QuitButton -> return Quit
Just Name_RemoteOutput -> Continue <$> handleOutputEvent scrn e
_ -> handleScreenDefaultEvent False scrn e
_ -> handleScreenDefaultEvent False scrn e
handleScreenEvents scrn ev = handleScreenDefaultEvent False scrn ev
adjustFocus scrn adj =
let wasResponse = case focusGetCurrent $ focus scrn of
Just Name_ResponseButton -> True
_ -> False
s' = scrn { focus = adj $ focus scrn }
isNowResponse = case focusGetCurrent $ focus s' of
Just Name_ResponseButton -> True
_ -> False
in return $ if wasResponse
then ExitedResponseGen s'
else if isNowResponse
then EnteredResponseGen s'
else Continue s'
resetAll scrn =
let ff = itemfield scrn
numSt8s = length (itemst8 $ itemField ff) 1
f' = foldl (setItemState Free) ff [0 .. numSt8s]
in return $ ResetAll $ scrn { inpRgn = applyEdit clearZipper $ inpRgn scrn
, outRgn = resetOutput $ outRgn scrn
, logRgn = []
, itemfield = f'
}
requestWork scrn cmd =
let marked = getMarkedItems $ itemfield scrn
noSelectionMsg = T.pack "Please select one or more remote hosts."
in return $ if null marked
then Continue $ scrn { logRgn = logRgn scrn <> [(True,noSelectionMsg)] }
else RequestWork scrn cmd marked
handleScreenDefaultEvent :: Bool -> Screen
-> Event
-> EventM ScreenElementNames (ScreenEventResult ScreenElementNames)
handleScreenDefaultEvent mismatchWarn scrn ev =
case focusGetCurrent $ focus scrn of
Just Name_ItemField -> handleItmEvent ev scrn
Just Name_UserInput -> handleUserInpEvent ev scrn
Just Name_RemoteOutput -> Continue <$> handleOutputEvent scrn ev
Just Name_ResponseButton ->
case ev of
(EvKey (KChar k) []) -> return $ ResponseGenAdd scrn $ T.singleton k
_ -> return $ Continue scrn
_ -> do when mismatchWarn $ liftIO $ putStrLn "no focus element for general event"
return $ Continue scrn
handleUserInpEvent :: Event -> Screen -> EventM ScreenElementNames (ScreenEventResult ScreenElementNames)
handleUserInpEvent ev scrn =
Continue . scrnUpdUserInp scrn <$> handleEditorEvent ev (inpRgn scrn)
scrnUpdItemField s i = s { itemfield = i }
scrnUpdUserInp s i = s { inpRgn = i }
scrnUpdRmtOut s o = s { outRgn = o }
handleItmEvent ev scrn =
do let field = itemfield scrn
sp = getSelectedItem field
f' <- handleItemFieldEvent ev field
let np = getSelectedItem f'
return $ if sp == np
then Continue . scrnUpdItemField scrn $ f'
else UpdateSelection (scrnUpdItemField scrn f') np
drawScreen :: Screen -> [Widget ScreenElementNames]
drawScreen s =
let banner = withDefAttr screenBannerAttr $ str $ cs $ screenName s
clock = withDefAttr screenClockAttr $ str $ maybe "Initial" cs $ screenTime s
title = banner <+> hCenter (drawProgress s) <+> clock
field = drawItems s
buttons = hCenter $ buttonGroup (focus s)
[ (Name_ClearButton, "Clear")
, (Name_TestButton, "Test")
, (Name_RunButton, "Run")
, (Name_ResponseButton, "Add Response")
, (Name_QuitButton, "Quit")
]
userInp = drawInput s
outrgn = drawOutput s
logrgn = vLimit 5 $ drawLog s
in title
<=> field
<=> hBorderWithLabel (str "Output")
<=> outrgn
<=> buttons
<=> hBorderWithLabel (str "Command Editing")
<=> userInp
<=> hBorderWithLabel (str "Log")
<=> logrgn
: []
chooseScreenCursor = focusRingCursor focus
type ItemsType = ItemFieldWidget ScreenElementNames
initialItems = ItemFieldWidget Name_ItemField
drawItems s = itemFieldWidget (itemfield s)
setScreenItemState :: WorkState -> WorkId -> Screen -> Screen
setScreenItemState st8 i scrn =
let s = itemfield scrn
s' = setItemState (workState2itemState st8) s i
in scrn { itemfield = s' }
workState2itemState NoWork = Free
workState2itemState WorkDone = Good
workState2itemState WorkFailed = Bad
type LogType = [(Bool,T.Text)]
initialLog = []
logWrite new scrn =
let old = logRgn scrn
upd = takeLast 99 $ oldl <> newl
takeLast n = reverse . take n . reverse
oldl = [(False, snd l) | l <- old]
newl = [(True, n) | n <- T.lines new]
in scrn { logRgn = upd }
drawLog s = viewport Name_LogRegion Vertical $ vBox $ map drawLine $ logRgn s
where drawLine (a,t) = attr a $ str $ T.unpack t
attr isNew = if isNew
then visible . withAttr screenLogNewAttr
else withAttr screenLogOldAttr
type ProgressType = (T.Text, Int)
initialProgress = ("Idle", 0)
setScreenProgress t l s = s { progress = (t,l) }
drawProgress s =
let (pt, pl) = progress s
attrmap = [ (screenProgressBarDoneAttr, progressCompleteAttr)
, (screenProgressBarRemainingAttr, progressIncompleteAttr)
]
in updateAttrMap (mapAttrNames attrmap) $
progressBar (Just $ T.unpack pt) (toEnum pl / 100)
type InputType = Editor T.Text ScreenElementNames
initialInput = editorText Name_UserInput (str . cs . T.unlines) (Just 8) ""
drawInput s = withFocusRing (focus s) renderEditor $ inpRgn s
type OutputType = List ScreenElementNames DispBlk
initialOutput = list Name_RemoteOutput (Vec.fromList usageInfo) 1
where usageInfo = map uinf usage
uinf u = DispInfo [u]
handleOutputEvent scrn e = scrnUpdRmtOut scrn <$> handleListEvent e (outRgn scrn)
resetOutput :: OutputType -> OutputType
resetOutput = listClear
addScreenOutput :: Monad m => DispBlk -> OutputType -> m OutputType
addScreenOutput newout oO = return $ foldr listAppend oO [newout]
listAppend e l = listInsert (length l) e l
drawOutput s =
let o = outRgn s
es = o^.listElementsL
renderItem isSel dispitem =
case dispitem of
DispOut t -> withAttr screenOutputOutputAttr $ renderTexts t
DispInp t -> withAttr screenOutputInputAttr $ renderTexts t
DispErr t -> withAttr screenOutputErrorAttr $ renderTexts t
DispInfo t -> withAttr screenOutputInputAttr $ renderTexts t
renderTexts = str . unlines . map (T.unpack . T.strip)
in updateAttrMap
(mapAttrNames [ (screenOutputAttr, listAttr)
, (screenOutputSelectedAttr, listSelectedFocusedAttr)
])
$ withFocusRing (focus s) (renderList renderItem) o