{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -- KWQ: MicroLens makes manipulating records easier 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 -- ---------------------------------------------------------------------- -- -- ItemField Management -- 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 -- ---------------------------------------------------------------------- -- -- Log Management -- type LogType = [(Bool,T.Text)] initialLog = [] -- Called to add more lines to the log output region of the Screen 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 -- ---------------------------------------------------------------------- -- -- Progress Indicator Management -- 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) -- ---------------------------------------------------------------------- -- -- Input Management -- type InputType = Editor T.Text ScreenElementNames initialInput = editorText Name_UserInput (str . cs . T.unlines) (Just 8) "" drawInput s = withFocusRing (focus s) renderEditor $ inpRgn s -- ---------------------------------------------------------------------- -- -- Output Management -- 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