OnRmt (empty) → 1.0.0.0
raw patch · 18 files changed
+2036/−0 lines, 18 filesdep +HUnitdep +OnRmtdep +asyncsetup-changed
Dependencies added: HUnit, OnRmt, async, base, brick, bytestring, conduit, conduit-extra, containers, control-monad-loop, data-default, itemfield, listsafe, microlens, mtl, old-locale, process, repl-toolkit, ssh-known-hosts, string-conversions, test-framework, test-framework-hunit, text, text-zipper, time, transformers, vector, void, vty
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- OnRmt.cabal +119/−0
- Setup.hs +2/−0
- compat/brick_016/BrickCompat.hs +15/−0
- compat/brick_017/BrickCompat.hs +8/−0
- onrmtssh.hs +90/−0
- sample/GetRemotes.hs +106/−0
- sample/onrmtsample.hs +30/−0
- sample/onrmtsamplecli.hs +20/−0
- src/Concurrent/Worker.hs +376/−0
- src/Data/Conduit/RemoteOp.hs +93/−0
- src/Network/OnRmt.hs +79/−0
- src/Network/OnRmt/UI.hs +44/−0
- src/Network/OnRmt/UI/BrickUI.hs +161/−0
- src/Network/OnRmt/UI/CmdLine.hs +341/−0
- src/Network/OnRmt/UI/MainScreen.hs +461/−0
- test/test_onrmt.hs +56/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+Series 1+---------++ * 1.0.0.0 -- initial release+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Kevin Quick <quick@sparq.org>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Kevin Quick <quick@sparq.org> nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ OnRmt.cabal view
@@ -0,0 +1,119 @@+name: OnRmt+version: 1.0.0.0+synopsis: Text UI library for performing parallel remote SSH operations+license: BSD3+license-file: LICENSE+author: Kevin Quick <quick@sparq.org>+maintainer: <quick@sparq.org>+copyright: Kevin Quick, 2013-2017+category: System+build-type: Simple+cabal-version: >=1.8++description:++ This library provides the ability to coordinate the remote ssh+ execution of commands on target nodes and display the results in a+ console interface. The console interface can either be a cmdline+ (CLI) or a text interface (TUI), based on brick and vty; support is+ provided for extension to other UI components as well.+ .+ Almost all of the functionality is provided in the library itself;+ it just needs an executable that will invoke it with the set of+ remote nodes. See the 'GetRemotes.hs' file for an example: remotes+ can be of any type that is an instance of @WorkEntry@ with an+ associated @WorkGroup@ grouping.+ .+ There is an onrmttest executable built that showcases the+ functionality using ssh operations to localhost, and a+ corresponding onrmttestline executable that provides a simple CLI.++data-files: CHANGELOG.md+++Flag brick017+ Description: true for Brick version 0.17 or later+ Default: True+++library+ hs-source-dirs: src+ if flag(brick017)+ hs-source-dirs: compat/brick_017+ else+ hs-source-dirs: compat/brick_016+ exposed-modules: Network.OnRmt+ , Network.OnRmt.UI.CmdLine+ , Network.OnRmt.UI.BrickUI+ other-modules: Concurrent.Worker+ , Network.OnRmt.UI+ , Data.Conduit.RemoteOp+ , Network.OnRmt.UI.MainScreen+ , BrickCompat+ build-depends: base >= 4.8 && < 5.0+ , vty + , brick >= 0.13+ , itemfield >= 1.2.0.0+ , time, old-locale+ , process, transformers, void, vector, text-zipper+ , text, bytestring, string-conversions, listsafe+ , conduit, conduit-extra, async, repl-toolkit+ , microlens, containers+ , control-monad-loop, mtl, data-default+-- ghc-options: -threaded++executable onrmtssh+ main-is: onrmtssh.hs+ buildable: True+ -- hs-source-dirs: .+ build-depends: base, OnRmt, vty, brick >= 0.13, time, old-locale+ , itemfield >= 1.2.0.0+ , process, transformers, void, vector, text-zipper+ , text, bytestring, string-conversions+ , conduit, conduit-extra, async , microlens+ , control-monad-loop, mtl, data-default+ , ssh-known-hosts+ ghc-options: -threaded++executable onrmtsample+ main-is: onrmtsample.hs+ hs-source-dirs: sample+ other-modules: GetRemotes+ build-depends: base, OnRmt, vty, brick >= 0.13, time, old-locale+ , itemfield >= 1.2.0.0+ , process, transformers, void, vector, text-zipper+ , text, bytestring, string-conversions+ , conduit, conduit-extra, async+ , microlens+ , control-monad-loop, mtl, data-default+ ghc-options: -threaded++executable onrmtsamplecli+ main-is: onrmtsamplecli.hs+ hs-source-dirs: sample+ other-modules: GetRemotes+ build-depends: base, OnRmt, time, old-locale+ , process, transformers, void, vector, text-zipper+ , text, bytestring, string-conversions, listsafe+ , conduit, conduit-extra, async, repl-toolkit+ , microlens, containers+ , control-monad-loop, mtl, data-default+ ghc-options: -threaded+++test-suite test_ops+ type: exitcode-stdio-1.0+ main-is: test_onrmt.hs+ cpp-options: -DTEST+ hs-source-dirs: src, test+ other-modules: Data.Conduit.RemoteOp+ , Concurrent.Worker+ , Network.OnRmt+ , Network.OnRmt.UI+ build-depends: base, time, transformers, old-locale, vty, brick >= 0.13+ , itemfield >= 1.2.0.0+ -- , OnRmt+ , HUnit, test-framework, test-framework-hunit+ -- , hspec+ , text, bytestring, string-conversions+ , conduit, conduit-extra, async, vector, text-zipper
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ compat/brick_016/BrickCompat.hs view
@@ -0,0 +1,15 @@+module BrickCompat+ ( BChan, newBChan, writeBChan, readBChan+ , defaultConfig+ )+ where++import Brick.BChan (BChan, newBChan, writeBChan, readBChan)+import Data.Default+import Graphics.Vty+++-- Vty 5.15 introduces defaultConfig instead of using Data.Default.def++defaultConfig :: Graphics.Vty.Config+defaultConfig = def
+ compat/brick_017/BrickCompat.hs view
@@ -0,0 +1,8 @@+module BrickCompat+ ( BChan, newBChan, writeBChan, readBChan+ , defaultConfig+ )+ where++import Brick.BChan (BChan, newBChan, writeBChan, readBChan)+import Graphics.Vty (defaultConfig)
+ onrmtssh.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}++module Main where++import Brick.Widgets.ProgressBar (progressCompleteAttr)+import Data.List (partition, mapAccumL)+import Data.Monoid+import qualified Data.Text as T+import Graphics.Vty.Attributes ( defAttr, withStyle+ , withForeColor, withBackColor+ , magenta, cyan+ )+import Network.OnRmt+import Network.OnRmt.UI.BrickUI+import Network.SSH.KnownHosts (SSHRemote, readKnownHosts+ , targetAddr+ , isIPv4Remote, isIPv6Remote+ , isDNSRemote+ )+import System.Environment+++rmtTestAttrs =+ [ (progressCompleteAttr+ , defAttr `withForeColor` magenta `withBackColor` cyan)+ ]+++params = OnRmtParams { appName = "onrmttest"+ , maxParallel = 9+ , directSSH = False }+++data SSHGroups = SSHGroups { ipv4 :: [SSHRemote]+ , ipv6 :: [SSHRemote]+ , dns :: [SSHRemote]+ , other :: [SSHRemote]+ }+++getEntries =+ do allknown <- readKnownHosts+ let (ipv4',not1) = partition isIPv4Remote allknown+ (ipv6',not2) = partition isIPv6Remote not1+ (dns',other') = partition isDNSRemote not2+ return $ SSHGroups ipv4' ipv6' dns' other'+++remoteWorkItems :: SSHGroups -> [WorkItems]+remoteWorkItems sshg =+ [ WorkGroup "IPv4" (WorkItems $ length $ ipv4 sshg)+ , WorkGroup "IPv6" (WorkItems $ length $ ipv6 sshg)+ , WorkGroup "DNS" (WorkItems $ length $ dns sshg)+ , WorkGroup "Other" (WorkItems $ length $ other sshg)+ ]++instance WorkEntry SSHRemote where+ name = fst . targetAddr+ identify r _ = name r+ rmtaddr = name++instance WorkGroup SSHGroups where+ type GroupEntry SSHGroups = SSHRemote+ getItems = remoteWorkItems+ numEntries g = sum [ length $ ipv4 g+ , length $ ipv6 g+ , length $ dns g+ , length $ other g+ ]+ getEntry g n =+ let l1 = length $ ipv4 g+ l2 = length $ ipv6 g+ l3 = length $ dns g+ l4 = length $ other g+ in if n < l1+ then ipv4 g !! n+ else if n < (l1 + l2)+ then ipv6 g !! (n - l1)+ else if n < (l1 + l2 + l3)+ then dns g !! (n - l1 - l2)+ else other g !! (n - l1 - l2 - l3)++main =+ do (uiMode, stateGen, s) <- brickUI (appName params) rmtTestAttrs+ result <- onRmt getEntries params uiMode stateGen s+ putStr "Final status: "+ putStrLn $ show result+ return ()
+ sample/GetRemotes.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module GetRemotes where++import Data.List+import Data.Maybe+import qualified Data.Text as T+import Control.Concurrent+import Network.OnRmt (WorkEntry(..), WorkGroup(..), WorkItems(..))+++data EntryData = EData T.Text (Maybe T.Text) [T.Text]+data Entry a = EGroup T.Text (Entry a) | EList [a] | Entry a :++: Entry a++summarize (EData n _ is) = T.intercalate "\n" $ n : is+identifyEnt (EData n ma is) _ = n+ `T.append` maybe "" (\a -> " @ " `T.append` a) ma+ `T.append` if null is then "" else " -- " `T.append` head is+nameEnt (EData n _ _) = n++getEntries :: IO (Entry EntryData)+getEntries = return $+ (EGroup "Server" $ EGroup "Dev" $+ EList [ EData "serverhost01" Nothing ["x86_64 dev host"+ ,"in dev lab"]+ , EData "serverhost02" Nothing ["AMD dev host"+ ,"dev Lab"]+ , EData "serverhost03" Nothing ["x32 dev host"+ ,"dev Lab"]+ ])+ :++: (EGroup "Server" $ EGroup "Test" $+ EList [ EData "testhost01" Nothing ["TEST/QA host"]+ , EData "testhost02" Nothing ["TEST/QA host"]+ ])+ :++: (EGroup "Server" $ EGroup "PROD" $+ EList [ EData "host01" Nothing ["Zone1 PRODUCTION host"+ ,"Canada Datacenter"]+ , EData "host02" Nothing ["Zone2 PRODUCTION host"+ ,"England Datacenter"]+ , EData "host03" Nothing ["Zone3 PRODUCTION host"+ ,"Singapore Datacenter"]+ ])+ :++: (EGroup "DBase" $ EGroup "PROD" $+ EList [EData "dbs001.prod.company.co"+ Nothing ["MySQL Controller"]])+ :++: (EGroup "DBase" $ EGroup "PROD" $+ (EGroup "Linux" $+ EList [ EData "dbs002"+ (Just "dbs001.prod.company.co")+ ["MySQL Primary Node"]+ , EData "dbs003" (Just "127.0.0.1") ["DB Node"]+ , EData "dbs004" (Just "127.0.0.1") ["DB Node"]+ , EData "dbs005" (Just "127.0.0.1") ["DB Node"]])+ :++: (EGroup "Windows" $+ EList [ EData "mssql01.prod.company.co" Nothing ["MSSQL Node"]+ , EData "mssql02.prod.company.co" Nothing ["MSSQL Node"]+ , EData "mssql01b" (Just "127.0.0.1") ["MSSQL Standby Node"]+ , EData "mssql02b" (Just "localhost") ["MSSQL Standby Node"]]))+ :++: (EGroup "WebServer" $ EGroup "Prod" $+ (EGroup "WestCoast" $+ EList [ EData "websrv-3" (Just "websrv-3") ["WebServer Node"]+ , EData "websrv-4" (Just "websrv-4") ["WebServer Node"]+ , EData "websrv008" (Just "websrv008") ["WebServer Node"]+ , EData "webserv009" (Just "websrv009") ["WebServer Node"]])+ :++: (EGroup "EastCoast" $+ EList [ EData "websrvec001" (Just "websrvec001") ["WebServer Node"]+ , EData "websrvec002" (Just "websrvec002") ["WebServer Node"]+ , EData "websrvec19" (Just "websrvec19") ["WebServer Node"]+ ]))++ :++: (EList (EData "localhost" Nothing ["Current system"]+ : map (\n -> EData (T.append "Host#" $ T.pack $ show n) (Just "localhost") []) [1..255]))+++segregate :: Entry a -> [WorkItems]+segregate (EList ls) = [WorkItems $ length ls]+segregate (EGroup g e) = map (WorkGroup g) $ segregate e+segregate (a :++: b) = segregate a ++ segregate b+++cntEntries :: Entry a -> Int+cntEntries (EList ls) = length ls+cntEntries (EGroup _ g) = cntEntries g+cntEntries (a :++: b) = cntEntries a + cntEntries b+++entryNum :: Entry a -> Int -> a+entryNum es n = either id (error "Invalid Entry #") $ eNum (Right n) es+ where eNum rem (EList ls) = rem >>= \n -> if n >= length ls+ then Right (n - length ls)+ else Left (ls !! n)+ eNum rem (EGroup _ s) = eNum rem s+ eNum rem (a :++: b) = eNum (eNum rem a) b+++instance WorkEntry EntryData where+ name = nameEnt+ identify = identifyEnt+ rmtaddr (EData n ma _) = maybe n id ma++instance WorkEntry a => WorkGroup (Entry a) where+ type GroupEntry (Entry a) = a+ getItems = segregate+ numEntries = cntEntries+ getEntry = entryNum
+ sample/onrmtsample.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Monoid+import GetRemotes+import Graphics.Vty.Attributes ( defAttr, withStyle+ , underline+ , withForeColor, withBackColor, magenta, cyan, bold, blue, white, red)+import Brick.Widgets.ProgressBar (progressCompleteAttr)+import Network.OnRmt+import Network.OnRmt.UI.BrickUI+++rmtTestAttrs =+ [ (progressCompleteAttr, defAttr `withForeColor` magenta `withBackColor` cyan)+ ]+++params = OnRmtParams { appName = "onrmttest"+ , maxParallel = 9+ , directSSH = False }+++main =+ do (uiMode, stateGen, s) <- brickUI (appName params) rmtTestAttrs+ result <- onRmt getEntries params uiMode stateGen s+ putStr "Final status: "+ putStrLn $ show result+ return ()
+ sample/onrmtsamplecli.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Monoid+-- import qualified Data.Text as T+import GetRemotes+import Network.OnRmt+import Network.OnRmt.UI.CmdLine (cmdLineUI, cmdLineStatus)+++main =+ do (ui, workreq, s) <- cmdLineUI (appName params)+ result <- onRmt getEntries params ui workreq s+ putStr "Completion with "+ putStrLn $ show $ cmdLineStatus result+ return ()+ where params = OnRmtParams { appName = "onrmttest"+ , maxParallel = 9+ , directSSH = False }
+ src/Concurrent/Worker.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module Concurrent.Worker+ (WorkMsg(..), StateCmd(..)+ , WorkEntry(..), WorkGroup(..)+ , WorkItems(..), WorkId, WorkState(..)+ , WorkControls(..), worker+ , DispBlk(..)+ )+where++import qualified Data.ByteString as S+import Data.Conduit+import Data.List hiding (lines)+import Data.Ratio ((%))+import Data.String.Conversions (cs)+import qualified Data.Text as T+import Data.Time.Clock+import Data.Time.Format+import Data.Conduit.List (sourceList, consume, sourceNull)+import qualified Data.Conduit.List as CL+import qualified Data.Conduit.Binary as CB+import Data.Conduit.Text (decode, utf8)+import Control.Concurrent (ThreadId, Chan, newChan+ , readChan, writeChan, forkIO)+import qualified Control.Concurrent as CC+import Control.Monad (forever, when, unless, void)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State.Lazy (StateT, evalStateT+ , gets, get, put, modify)+import Data.Conduit.RemoteOp+import System.Exit (ExitCode(..))+import Data.Monoid ((<>))+++data WorkControls = WorkControls {+ numParallel :: Int+ , useDirectSSH :: Bool+ , queryResponses :: [T.Text]+ }+++data WorkMsg = ShowSelInfo Int+ | ClearAll+ | StartRun [T.Text] [WorkId] -- command+ | FinishedErr Int+ | FinishedGood Int+ | AddOutput Int DispBlk+ | StartResponse+ | AddToResponse T.Text+ | EndResponse+ | AbandonResponse+ | IncrParallel+ | DecrParallel+ deriving Show++-- Different types of information that can be displayed in the output region+data DispBlk = DispOut [T.Text] | DispErr [T.Text] | DispInp [T.Text] | DispInfo [T.Text]+ deriving Show++data StateCmd = NewItems [WorkItems] (Maybe (WorkId -> WorkState -> T.Text))+ | ResetUI+ | ChgState WorkState WorkId+ | DisplaySet DispBlk+ | DisplayAdd DispBlk+ | SetProgress T.Text Int+ | LogInfo T.Text+ | EndOfInformation+ -- removed: | SelItem Int+++type WorkGroupName = T.Text+type WorkId = Int+type NumWorkItems = Int+data WorkItems = WorkGroup WorkGroupName WorkItems | WorkItems NumWorkItems deriving Show+data WorkState = NoWork | WorkDone | WorkFailed | WorkInProgress deriving (Show, Eq)++class WorkEntry a where+ name :: a -> T.Text+ identify :: a -> WorkState -> T.Text+ rmtaddr :: a -> T.Text++class WorkEntry (GroupEntry g) => WorkGroup g where+ type GroupEntry g+ getItems :: g -> [WorkItems]+ numEntries :: g -> Int+ getEntry :: g -> Int -> GroupEntry g+++data RunCompl = RC { total :: Int+ , completed :: Int+ , failures :: Int+ , command :: Int -> IO ThreadId+ , startTime :: UTCTime+ , pending :: [Int]+ }+ | Idle+++worker :: WorkGroup g => GenOutput -> Chan WorkMsg -> WorkControls -> g -> IO ()+worker genOutput inpWorkchan config entries =+ do let numE = numEntries entries+ noOuts = replicate numE []+ noCmds = replicate numE T.empty+ workerSt8 = WS entries config noOuts noCmds 0 Idle genOutput inpWorkchan+ genOutput $ NewItems (getItems entries) $ Just (identify . getEntry entries)+ evalStateT doWork workerSt8++type GenOutput = StateCmd -> IO ()++data WorkerState e = WS { entrieS::e -- constrained as: WorkGroup e+ , cfg :: WorkControls+ , outs::[[DispBlk]]+ , commands::[T.Text]+ , currSel::Int+ , pct::RunCompl+ , genOutput :: GenOutput+ , inpWorkChan::Chan WorkMsg+ }++doWork :: WorkGroup g => StateT (WorkerState g) IO ()+doWork = forever $+ do wmsg <- lift . readChan =<< gets inpWorkChan+ case wmsg of+ ShowSelInfo n -> do s <- get+ lift $ genOutput s $ DisplaySet $ DispInp $ T.lines $ commands s !! n+ lift $ mapM_ (genOutput s . DisplayAdd) $ outs s !! n+ lift $ genOutput s EndOfInformation+ put $ s { currSel = n }+ ClearAll -> modify $ \w ->+ let cfg' = (cfg w) { queryResponses = [] }+ outs' = replicate (numEntries $ entrieS w) []+ in w { outs = outs', cfg = cfg' }+ StartRun cmd ss -> startRun cmd ss+ FinishedErr n -> updFinish n WorkFailed+ FinishedGood n -> updFinish n WorkDone+ AddOutput n ls -> addOuts n ls+ StartResponse -> modWSQR (\qr -> qr ++ [T.empty])+ AddToResponse r -> modWSQR (\qr -> init qr +++ [last qr `T.append` r])+ EndResponse -> do modWSQR (\qr -> qr ++ [T.empty])+ s <- get+ let addedMsg = cs $ "Added response; " <>+ show respCount <> " total."+ respCount = (length . queryResponses . cfg $ s) - 1+ lift $ genOutput s $ LogInfo addedMsg+ AbandonResponse -> modWSQR init+ IncrParallel -> modifyParallelCnt succ+ DecrParallel -> modifyParallelCnt pred+++modWSQR op = modify $ \w -> let qr = queryResponses $ cfg w+ qr' = op qr+ cfg' = (cfg w) { queryResponses = qr' }+ in w { cfg = cfg' }++modifyParallelCnt op = do s <- get+ let np = numParallel $ cfg s+ np' = max 1 $ op np+ cfg' = (cfg s) { numParallel = np' }+ newParMsg = cs $ "Parallel remotes: " <> show np+ liftIO $ genOutput s $ LogInfo newParMsg+ put $ s { cfg = cfg' }+++startRun :: WorkGroup g => [T.Text] -> [Int] -> StateT (WorkerState g) IO ()+startRun cml marked = do s <- get+ let cmd = preProcCmd cml+ liftIO $ genOutput s $ DisplaySet $ DispInp cmd+ liftIO $ genOutput s $ SetProgress "Running" 0+ now <- lift getCurrentTime+ let ents = entrieS s+ workchan = inpWorkChan s+ out = outs s+ cmds = commands s+ pct' = RC numE 0 0+ (runCmd (cfg s) (writeChan workchan) cmd ents) now remss+ numE = length marked+ msg = "Running on " ++ show numE ++ " targets beginning at "+ ++ formatTime defaultTimeLocale rfc822DateFormat now+ (startss,remss) = splitAt (numParallel $ cfg s) marked+ outs' = withMarked marked (const []) out+ cmd' = T.unlines cmd+ cmds' = withMarked marked (const cmd') cmds+ lift $ genOutput s $ LogInfo $ T.pack msg+ lift $ mapM_ (command pct') startss+ modify $ \w -> w { outs=outs', commands=cmds', pct=pct' }+++preProcCmd :: [T.Text] -> [T.Text]+preProcCmd cmds = let lclfiles = filter (\l -> "{LOCALFILE:" `T.isInfixOf` l) cmds -- KWQ+ in cmds+++withMarked :: [Int] -> (a -> a) -> [a] -> [a]+withMarked marked f lst = unfoldr wMarked (0,marked,lst)+ where wMarked (_,_,[]) = Nothing+ wMarked (i,[],os) = Just (head os, (0,[],tail os))+ wMarked (i,cs,os) = let nxt_y = (i+1, tail cs, tail os)+ nxt_n = (i+1, cs, tail os)+ in if i == head cs+ then Just (f $ head os, nxt_y)+ else Just (head os, nxt_n)+++addOuts n ls =+ do genO <- gets genOutput+ oO <- gets outs+ let nw = be4 ++ [thisnw] ++ aft+ thisnw = old ++ [ls]+ (be4, andAft) = splitAt n oO+ aft = if null andAft then [] else tail andAft+ old = if null andAft then [] else head andAft+ csl <- gets currSel+ when (n == csl) $ lift $ genO $ DisplayAdd ls+ modify $ \w -> w { outs = nw }++statement = T.intercalate " " . map T.pack++updFinish n nS =+ do genO <- gets genOutput+ lift $ genO $ ChgState nS n+ pct <- gets pct+ case pct of+ RC d c f op started ps -> do+ let c' = c + 1+ f' = if nS == WorkFailed then f + 1 else f+ ps' = if null ps then ps else tail ps+ pct' = pct { completed = c'+ , failures = f'+ , pending = ps'+ }+ pbarVal = ceiling $ (c' % d) * 100+ if c' == d+ then do lift $ allDone genO pct'+ modify $ \w -> w { pct = Idle }+ else do let ptext = cs $ "Running - " ++ show c' ++ "/" ++ show d+ lift $ genO $ SetProgress ptext pbarVal+ unless (null ps) $ lift $ void $ op $ head ps+ modify $ \w -> w { pct = pct' }+ Idle -> do lift $ genO $ LogInfo $ statement+ ["Warning:", show nS+ , "completion for" ,show n+ , " rcvd in Idle mode"]+ modify $ \w -> w { pct = Idle }++allDone genO RC{..} =+ let sgood = show (total - failures) ++ " successes"+ sbad = show failures ++ " failures"+ sttl = show total ++ " targets"+ endmsg elapsed = statement [ "Run completed on", sttl+ , "with", sgood+ , "and", sbad+ , "in", show elapsed+ ]+ in do genO $ SetProgress "Idle" 0+ elapsed <- flip diffUTCTime startTime <$> getCurrentTime+ genO $ LogInfo $ endmsg elapsed+ genO EndOfInformation+++runCmd :: WorkGroup g => WorkControls -> (WorkMsg -> IO ()) -> [T.Text] -> g -> Int -> IO ThreadId+runCmd ctl reqwork cmdop entryState entryNum = do+ -- (queryResponses ctl) has the responses for password queries+ inpChan <- newChan+ let sshOp = remoteOp (useDirectSSH ctl) hostaddr cmdop (sourceChan inpChan)+ forkIO $ sshOp+ $= onStdOut CB.lines+ $= onStdErr CB.lines+ $= onStdOut (decode utf8)+ $= onStdErr (decode utf8)+ $= onStdErr (detectPasswordReq (queryResponses ctl) inpChan)+ $= onStdOut (detectPasswordReq (queryResponses ctl) inpChan)+ $= onStdOut (suppressPasswordEcho (queryResponses ctl))+ $= onStdErr (suppressPasswordEcho (queryResponses ctl))+ $$ reportOnWork reqwork entryNum+ where hostaddr = rmtaddr $ getEntry entryState entryNum++ -- can add above: $= dbgOut++dbgOut :: (Monad m, Show e, Show o) => Conduit (OpOutputType o e) m (OpOutputType o e)+dbgOut = awaitForever $ \o -> do+ yield $ DebugOut (cs $ show o)+ yield o++sourceChan inputChan = do i <- liftIO $ readChan inputChan+ case i of+ Nothing -> return ()+ Just v -> yield v >> sourceChan inputChan+++onStdOut :: Monad m => Conduit i m o -> Conduit (OpOutputType i e) m (OpOutputType o e)+onStdOut doFunc = awaitForever $ \o ->+ case o of+ StdOut l -> yield l $= doFunc $= awaitForever (yield . StdOut)+ StdErr e -> yield $ StdErr e+ StdOutEnd -> yield StdOutEnd+ StdErrEnd -> yield StdErrEnd+ Ended r -> yield $ Ended r+ DebugOut t -> yield $ DebugOut t++onStdErr :: Monad m => Conduit i m o -> Conduit (OpOutputType s i) m (OpOutputType s o)+onStdErr doFunc = awaitForever $ \o ->+ case o of+ StdOut e -> yield $ StdOut e+ StdErr l -> yield l $= doFunc $= awaitForever (yield . StdErr)+ StdOutEnd -> yield StdOutEnd+ StdErrEnd -> yield StdErrEnd+ Ended r -> yield $ Ended r+ DebugOut t -> yield $ DebugOut t+++-- reportOnWork :: MonadIO m => (WorkMsg -> IO ()) -> Int -> Sink (OpOutputType T.Text) m ()+reportOnWork reqwork entryNum = do+ start <- liftIO getCurrentTime+ awaitForever $ inner reqwork entryNum start+ where inner r e st inp = liftIO $+ case inp of+ StdOut t -> reqwork $ AddOutput entryNum $ DispOut $ T.lines $ cs t+ StdErr t -> reqwork $ AddOutput entryNum $ DispErr $ T.lines $ cs t+ DebugOut t -> reqwork $ AddOutput entryNum $ DispInfo $ T.lines $ cs t+ Ended ExitSuccess -> do+ showElapsed st+ reqwork $ FinishedGood entryNum+ Ended (ExitFailure c) -> do+ showElapsed st+ reqwork $ FinishedErr entryNum+ showElapsed st = liftIO $ do+ end <- liftIO getCurrentTime+ let elapsed = diffUTCTime end st+ emsg = cs $ "[Elapsed time: " ++ show elapsed ++ "]"+ reqwork $ AddOutput entryNum $ DispInfo $ T.lines emsg+++-- | Sometimes passwords that are offered by detectPasswordReq end up getting echoed to stdout. Catch those and suppress them!+suppressPasswordEcho :: MonadIO m => [T.Text] -> Conduit T.Text m T.Text+suppressPasswordEcho pwlst = awaitForever $ \l ->+ yield (foldr (\pw o -> T.replace pw "" o) l pwlst)++detectPasswordReq :: MonadIO m => [T.Text] -> Chan (Maybe S.ByteString) -> Conduit T.Text m T.Text+detectPasswordReq pwlst inpChan = onPwReq 0+ where onPwReq n = await >>= needsPw n+ -- onPwReq n = awaitForever $ needsPw n+ needsPw n (Just s) =+ -- do yield $ cs $ "Checking for a match n" ++ (show n) ++ " against " ++ (show $ "Password:" == s) ++ " / " ++ (show $ "[sudo] password" `T.isPrefixOf` s) ++ " ..."+ case s of+ "Password:" -> sendPw n+ "Password: " -> sendPw n+ _ | "[sudo] password" `T.isPrefixOf` s -> sendPw n+ | " password: " `T.isSuffixOf` s -> sendPw n+ | " password:" `T.isSuffixOf` s -> sendPw n+ | otherwise -> yield s >> onPwReq n+ needsPw n Nothing = return () -- yield "No more input for password checking"+ sendPw _ =+ mapM_ sendEachPW pwlst+ -- yield "Sent the passwords"+ -- liftIO $ writeChan inpChan Nothing -- do not send this or the next query will fail due to closed stdin+ sendEachPW p =+ -- do yield $ cs $ "Sending password: " ++ (show p)+ liftIO $ writeChan inpChan $ Just $ cs $ p `T.append` "\n"+ sendPW n = let pw | null pwlst = "password"+ | n > length pwlst = last pwlst+ | otherwise = pwlst !! n+ tryPw = Just $ cs $ pw `T.append` "\n"+ n' = if n + 1 >= length pwlst then 0 else n + 1+ in do+ yield $ cs $ "Sending password: " ++ show tryPw+ liftIO $ writeChan inpChan tryPw+ onPwReq n'+ yield "Pop the password"
+ src/Data/Conduit/RemoteOp.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}++module Data.Conduit.RemoteOp+ ( remoteOp+ , OpOutputType(..)+#ifdef TEST+ , sshargs+#endif+ )+where++import Control.Concurrent (readChan, writeChan, newChan)+import Control.Concurrent.Async (async)+import qualified Control.Exception as E+import Control.Monad.IO.Class (MonadIO, liftIO)+import qualified Data.ByteString as S+import Data.Conduit+import qualified Data.Conduit.List as CL+import Data.Conduit.Process ( streamingProcess, proc, ClosedStream(..)+ , waitForStreamingProcess)+import Data.Monoid ((<>))+import qualified Data.Text as T+import System.Exit (ExitCode(..))+++sshargs :: Bool -> T.Text -> [T.Text] -> [T.Text]+sshargs directSSH host command =+ let stdArgs = "-A"+ : "-o" : "ControlPath none"+ : "-o" : "VisualHostKey no"+ -- : "-n"+ -- : "-o" : "BatchMode yes"+ : "-o" : "KbdInteractiveAuthentication no"+ : "-o" : "StrictHostKeyChecking no"+ : "-o" : "CheckHostIP no"+ : "-o" : "ForwardX11 no"+ : "-o" : "ForwardX11Trusted no" : []+ bounceArgs = ["-t", "-t"] <> stdArgs <>+ ["localhost", "ssh"] <>+ map (\e -> T.append "'" (T.append e "'")) stdArgs+ targetArgs = [host, T.unlines command]+ in (if directSSH then stdArgs else bounceArgs) ++ targetArgs+++data OpOutputType t e = StdOut t+ | StdErr e+ | StdOutEnd+ | StdErrEnd+ | Ended ExitCode+ | DebugOut T.Text+ deriving Show+++remoteOp :: MonadIO m+ => Bool -> T.Text+ -> [T.Text]+ -> Producer IO S.ByteString+ -> Producer m (OpOutputType S.ByteString S.ByteString)+remoteOp directSSH host command srcConduit = do+ -- yield (DebugOut rmtProcStr)+ (toProcess, fromProcess, procErrors, cph) <- streamingProcess rmtProc+ mChan <- liftIO newChan+ let showStdout = fromProcess $$ CL.mapM_ (writeChan mChan . StdOut)+ showStderr = procErrors $$ CL.mapM_ (writeChan mChan . StdErr)+ runInput = srcConduit $$ toProcess+ handleStdout = showStdout >> writeChan mChan StdOutEnd+ handleStderr = showStderr >> writeChan mChan StdOutEnd+ liftIO $ async handleStdout+ liftIO $ async handleStderr+ liftIO $ async runInput+ yield <$> Ended =<< chanSrcMid cph mChan+ where+ rmtProc = proc "ssh" $ map T.unpack $ sshargs directSSH host command+ rmtProcStr = T.append "ssh " (T.intercalate " " $ sshargs directSSH host command)++ -- chanSrcMid will wait for and complete with the process exit+ -- code after both stderr and stdout are closed (which the process+ -- must do to exit). This does not wait for stdin to close since+ -- that can be dealt with asynchronously, but it does completely+ -- drain the process' output and error streams before completing.+ chanSrcMid ph = chanSrcMd' ph (2::Int)+ chanSrcMd' ph 0 _ = liftIO $ waitForProcess' ph+ chanSrcMd' ph n c = do rd <- liftIO $ readChan c+ case rd of+ StdOut s -> yield (StdOut s) >> chanSrcMd' ph n c+ StdErr s -> yield (StdErr s) >> chanSrcMd' ph n c+ StdOutEnd -> chanSrcMd' ph (n-1) c+ StdErrEnd -> chanSrcMd' ph (n-1) c++ waitForProcess' ph =+ waitForStreamingProcess ph `E.catch` \(E.SomeException _) -> return ExitSuccess
+ src/Network/OnRmt.hs view
@@ -0,0 +1,79 @@+{-|+Module : OnRmt+Description : Parallel remote SSH execution library+Copyright : (c) Kevin Quick, 2016, 2017+License : BSD-3+Maintainer : quick@sparq.org+Stability : stable+Portability : POSIX++The OnRmt library provides functionality for a tool that can be used+to perform operations via SSH to multiple remote machines in parallel+and report the results. Multiple operations can be performed in+succession. OnRmt can be likened to an interactive version of Fabric,+written in Haskell.++The UI is extensible and OnRmt comes with a command-line+representation (CLI) and a text user interface (TUI) based on+itemfield, brick, and vty.++OnRmt is provided as a library but is fully complete and lacks only an+invocation from a main function with the set of known remote SSH+nodes.++-}++module Network.OnRmt+ (+ -- * Exports from Concurrent.Worker+ WorkEntry(..), WorkGroup(..), WorkItems(..), WorkMsg(..)+ , WorkControls(..), StateCmd(..), DispBlk(..),+ WorkId, WorkState(..)+ -- * Main Parameters and entrypoint+ , OnRmtParams(..), onRmt+ ) where+++import Concurrent.Worker (worker, StateCmd(..), WorkMsg(..)+ , WorkGroup(..), WorkControls(..)+ , WorkEntry(..), WorkItems(..)+ , WorkId, WorkState(..), DispBlk(..))+import Control.Concurrent+import qualified Data.Text as T+import Network.OnRmt.UI+++-- | The OnRmtParams data structure specifies the operational+-- parameters for running OnRmt. These fields can be adjusted by the+-- client as desired.+data OnRmtParams = OnRmtParams+ {+ appName :: T.Text -- ^ The declared name (and version) of+ -- this app for the banner line+ , maxParallel :: Int -- ^ Number of remotes to run in parallel+ -- at any one time+ , directSSH :: Bool -- ^ ssh directly to target instead of+ -- bouncing via localhost. The localhost+ -- bounce is useful for capturing and+ -- responding to ssh key passphrases and+ -- passwords, but in general it imposes a+ -- lower limit on the maxParallel setting.+ }+++-- | The onRmt function is the main entry point. It creates the+-- vty-ui interface and provides the main operational loop for user+-- interaction and remote operations.+onRmt :: (WorkGroup a, OnRmtUI ui uistate, Show uistate)+ => IO a -> OnRmtParams -> ui -> (StateCmd -> IO ()) -> uistate -> IO uistate+onRmt getentries params ui stateGen s =+ do workRequestChan <- newChan+ entries <- getentries+ forkIO $ worker stateGen workRequestChan workCfg entries+ result <- runUI ui (writeChan workRequestChan) s+ putStr "Final status: "+ return result+ where workCfg = WorkControls { numParallel = maxParallel params+ , useDirectSSH = directSSH params+ , queryResponses = []+ }
+ src/Network/OnRmt/UI.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE TypeFamilies #-}++module Network.OnRmt.UI+ (OnRmtUI(..), runUI, stateEventHandler) where++import Concurrent.Worker (DispBlk, StateCmd(..), WorkMsg(..)+ , WorkItems(..), WorkId, WorkState)+import qualified Data.Text as T+++class Show b => OnRmtUI a b | b -> a where+ startUI :: a -> (WorkMsg -> IO ()) -> b -> IO b+ setUIItems :: b -> [WorkItems] -> Maybe (WorkId -> WorkState -> T.Text) -> IO b+ newOutput :: b -> DispBlk -> IO b+ addOutput :: b -> DispBlk -> IO b+ setProgress :: b -> T.Text -> Int -> IO b+ addLogInfo :: b -> T.Text -> IO b+ setItemState :: b -> WorkState -> WorkId -> IO b+ endInfo :: b -> IO b++-- n.b. the third argument to startUI is not strictly necessary+-- (startUI could easily be implemented absent that argument) but then+-- there's undecideability on what type b is since it never appears as+-- an argument to runUI (e.g. could not decide the Show instance for+-- uistate). The UI instances typically pass "undefined" for this+-- parameter and never expect it to be evaluated.++runUI :: (OnRmtUI ui uistate, Show uistate)+ => ui -> (WorkMsg -> IO ()) -> uistate -> IO uistate+runUI = startUI++++stateEventHandler :: OnRmtUI cfg ui => ui -> StateCmd -> IO ui+stateEventHandler ui (NewItems ns idfun) = setUIItems ui ns idfun+stateEventHandler ui (DisplaySet dsp) = newOutput ui dsp+stateEventHandler ui (DisplayAdd dsp) = addOutput ui dsp+stateEventHandler ui (SetProgress t n) = setProgress ui t n+stateEventHandler ui (LogInfo i) = addLogInfo ui i+stateEventHandler ui (ChgState s i) = setItemState ui s i+stateEventHandler ui ResetUI = putStr "No handling for ResetUI" >> return ui+stateEventHandler ui EndOfInformation = endInfo ui
+ src/Network/OnRmt/UI/BrickUI.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE MultiParamTypeClasses #-}++module Network.OnRmt.UI.BrickUI (brickUI) where++import Brick.AttrMap+import Brick.Main+import Brick.Types+import BrickCompat (BChan, newBChan, writeBChan, defaultConfig)+import Concurrent.Worker ( WorkMsg, StateCmd(..), WorkMsg(..)+ , WorkItems(..), WorkState(..)+ , WorkId, DispBlk(..))+import Control.Monad.IO.Class (liftIO)+import Data.Default (def)+import qualified Data.Text as T+import Graphics.Vty (Attr(..), Event(..), mkVty)+import Graphics.Vty.Attributes (defAttr)+import Network.OnRmt.UI (OnRmtUI(..), stateEventHandler)+import Network.OnRmt.UI.MainScreen ( Screen(..), newScreen, drawScreen+ , handleScreenEvents, chooseScreenCursor+ , ScreenElementNames, ScreenEventResult(..)+ , screenDefaultAttrs+ , setScreenItemState+ , setScreenProgress+ , resetOutput, addScreenOutput, updateScreen+ , logWrite)+import TextUI.ItemField+++type UIElementNames = ScreenElementNames++++data BrickConfig = BrickConfig { b_appName :: T.Text+ , b_userAttrs :: [(AttrName, Attr)]+ , b_eventChan :: BChan BrickUIEvent+ }+++instance OnRmtUI BrickConfig BrickState where+ startUI = startBrickUI+ setUIItems = setBrickItems+ newOutput = setBrickOutput+ addOutput = addBrickOutput+ setProgress = setBrickProgress+ addLogInfo = addBrickLog+ setItemState = setBrickItemState+ endInfo = return+++-- setBrickItems sets itemfield information from worker information+setBrickItems s i f =+ let ff = itemfield $ b_scrn s+ nf = ItemFieldWidget (itemFieldName ff) $ newItemField ni (identFunc f)+ ni = map w2i i+ w2i (WorkGroup n i) = ItemGroup n $ w2i i+ w2i (WorkItems n) = Items n+ scrn' = (b_scrn s) { itemfield = nf }+ s' = s { b_scrn = scrn' }+ identFunc Nothing = Nothing+ identFunc (Just f') = Just $ identF f'+ identF f' i s = f' i (ist82wst8 s)++ ist82wst8 Free = NoWork+ ist82wst8 Good = WorkDone+ ist82wst8 Bad = WorkFailed+ ist82wst8 Marked = NoWork+ in return s'++data BrickState = BrickState { b_cfg :: BrickConfig+ , b_scrn :: Screen+ , b_workerRequest :: WorkMsg -> IO ()+ , b_queryResponses :: [T.Text]+ }++instance Show BrickState where+ show = show . b_scrn++brickUI :: T.Text -> [(AttrName, Attr)] -> IO (BrickConfig, StateCmd -> IO (), BrickState)+brickUI appName attrs =+ do eventChan <- newBChan 100000+ return ( BrickConfig { b_appName = appName+ , b_userAttrs = attrs+ , b_eventChan = eventChan+ }+ , writeBChan eventChan . BUIE_StateEvent+ , undefined)++startBrickUI :: BrickConfig -> (WorkMsg -> IO ()) -> BrickState -> IO BrickState+startBrickUI brickCfg workerReq _ = customMain vty (Just evchan) brickApp brickState+ where brickApp =+ App { appDraw = drawUI+ , appHandleEvent = handleOnRmtEvents+ , appStartEvent = return+ , appAttrMap = const+ $ applyAttrMappings (b_userAttrs brickCfg)+ $ applyAttrMappings screenDefaultAttrs+ $ applyAttrMappings itemDefaultAttrs $ attrMap defAttr []+ , appChooseCursor = chooseUICursor+ }+ vty = mkVty defaultConfig+ evchan = b_eventChan brickCfg+ brickState = BrickState { b_cfg = brickCfg+ , b_scrn = newScreen (b_appName brickCfg) field+ , b_workerRequest = workerReq+ , b_queryResponses = []+ }+ field = newItemField nodes $ Just showf+ showf = showNode nodes+ nodes = []+ showNode a b c = T.pack "" -- $ shows "#" $ shows a $ shows " is " $ shows b ""++-- drawUI :: (Ord n, Show n) => UIControls n -> [Widget n]+drawUI = drawScreen . b_scrn++chooseUICursor = chooseScreenCursor . b_scrn++data BrickUIEvent = BUIE_StateEvent StateCmd++handleOnRmtEvents :: BrickState+ -> BrickEvent ScreenElementNames BrickUIEvent+ -> EventM ScreenElementNames (Next BrickState)+handleOnRmtEvents ui (VtyEvent ev) =+ let workop s o = liftIO (b_workerRequest ui o) >> updscrn s+ updscrn s = continue $ ui { b_scrn = s }+ workop' o = liftIO (b_workerRequest ui o) >> continue ui+ in do r <- handleScreenEvents (b_scrn ui) ev+ case r of+ Continue s -> updscrn s+ ResetAll s -> do liftIO $ b_workerRequest ui ClearAll+ continue $ ui { b_scrn = s+ , b_queryResponses = []+ }+ RequestWork s i m -> workop s $ StartRun i m+ UpdateSelection s n -> workop s $ ShowSelInfo n+ Quit -> halt ui+ MoreParallel -> workop' IncrParallel+ LessParallel -> workop' DecrParallel+ EnteredResponseGen s -> workop s StartResponse+ ResponseGenAdd s t -> workop s $ AddToResponse t+ ResponseGenRecord -> workop' EndResponse+ ExitedResponseGen s -> workop s AbandonResponse+handleOnRmtEvents ui (AppEvent (BUIE_StateEvent ev)) =+ do ui' <- liftIO $ stateEventHandler ui ev+ continue ui'+handleOnRmtEvents ui _ = continue ui+++setBrickOutput, addBrickOutput :: BrickState -> DispBlk -> IO BrickState+setBrickOutput ui o = do n <- addScreenOutput o $ resetOutput $ outRgn $ b_scrn ui+ return $ ui { b_scrn = (b_scrn ui) { outRgn = n } }+addBrickOutput ui o = do n <- addScreenOutput o $ outRgn $ b_scrn ui+ return $ ui { b_scrn = (b_scrn ui) { outRgn = n } }++setBrickProgress ui t c =+ do s <- updateScreen (b_scrn ui) (return . setScreenProgress t c)+ return $ ui { b_scrn = s }++addBrickLog ui t = return $ ui { b_scrn = logWrite t (b_scrn ui) }++setBrickItemState ui s i = return $ ui { b_scrn = setScreenItemState s i (b_scrn ui) }+
+ src/Network/OnRmt/UI/CmdLine.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++module Network.OnRmt.UI.CmdLine (cmdLineUI, cmdLineStatus) where++import Concurrent.Worker (WorkMsg, StateCmd(..), WorkMsg(..),+ WorkItems(..), WorkId, WorkState(..),+ DispBlk(..))+import Control.Concurrent+import Control.Exception (SomeException(..), toException)+import Control.Monad (unless)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.State.Lazy+import Data.Char (isSpace)+import Data.Either (rights, lefts)+import qualified Data.List.Safe as L+import Data.Maybe (fromMaybe, catMaybes, mapMaybe)+import Data.Monoid ((<>))+import qualified Data.Set as S+import qualified Data.Text as T+import Network.OnRmt.UI+import System.REPL+import qualified System.REPL.Prompt as PR+++data CmdLineCfg = CmdLineConfig T.Text (Chan StateCmd)+++data CmdLineState = CmdLineState+ -- KWQ: store the WorkGroup here; allows getEntry and name and such, especially in select+ { workItems :: [WorkItems]+ , workerDescr :: Maybe (WorkId -> WorkState -> T.Text)+ , workerStates :: [WorkState]+ , stateChan :: Chan StateCmd+ , selectedItems :: S.Set Int+ , command :: T.Text+ }++instance Show CmdLineState where+ show cls = num <> " remotes" <> breakdown+ where num = show $ length $ workItems cls+ completed = st8msg numDone "completed"+ failed = st8msg numFailed "failed"+ inProgress = st8msg numInProgress "in progress"+ numDone = st8count WorkDone+ numFailed = st8count WorkFailed+ numInProgress = st8count WorkInProgress+ st8count st8 = length $ filter (st8 ==) $ workerStates cls+ st8msg cnt label = if cnt == 0 then Nothing else Just $ show cnt <> " " <> label+ interesting = catMaybes [ completed, failed, inProgress ]+ breakdown = if null interesting then ""+ else " (" <> L.intercalate ", " interesting <> ")"+++instance OnRmtUI CmdLineCfg CmdLineState where+ startUI = startCmdLine+ setUIItems s i f = return $ CmdLineState i f [] (stateChan s) mempty "id"+ newOutput s d = do putStrLn ""+ addOutput s d+ addOutput s d = do case d of+ DispInp i -> putStrLn $ "$ " <> T.unpack (T.unwords i)+ DispOut o -> putStr $ unlines $ map T.unpack o+ DispErr e -> mapM_ (putStrLn . (" ERR> " <>) . T.unpack) e+ DispInfo i -> mapM_ (putStrLn . ("INFO> " <>) . T.unpack) i+ return s+ setProgress s txt pct = let msg = T.unpack txt <> ": " <> show pct <> "%"+ in do liftIO $ putStrLn msg+ return s+ addLogInfo s t = do putStrLn $ "-<[" <> T.unpack t <> "]>-"+ return s+ setItemState s v i = do putStrLn $ "Remote #" <> show i <> " is " <> show v+ let s'p = take i $ workerStates s <> repeat NoWork+ s's = drop (i+1) $ workerStates s+ s' = s'p <> [v] <> s's+ return $ s { workerStates = s' }+ endInfo = return+++-- Returns the final status of the CmdLineState+cmdLineStatus :: CmdLineState -> String+cmdLineStatus = const "good" --KWQ+++numItems :: [WorkItems] -> Int+numItems = sum . map numI+ where numI (WorkGroup _ i) = numI i+ numI (WorkItems n) = n+++itemRange s = [0 .. numItems (workItems s) - 1]++showItems = map (showItemEntry [])+showItemEntry pfx (WorkGroup n i) = showItemEntry (n:pfx) i+showItemEntry [] (WorkItems n) = show n <> " entries"+showItemEntry pfx (WorkItems n) = let pstr = T.intercalate "." (reverse pfx)+ in T.unpack pstr <> " : " <> show n <> " entries"+++getPrefix :: CmdLineState -> WorkId -> T.Text+getPrefix cmdState n = getpfx n $ workItems cmdState+ where getpfx :: Int -> [WorkItems] -> T.Text+ getpfx n [] = ""+ getpfx n (w:ws) =+ let (p,s) = pfxWsize w+ in if n < s+ then p+ else getpfx (n-s) ws+ pfxWsize (WorkGroup g i) =+ let (p,s) = pfxWsize i+ in if T.null p+ then if T.null g then (g,s) else (g <> ": ", s)+ else (g <> "." <> p, s)+ pfxWsize (WorkItems i) = ("", i)+++getState :: CmdLineState -> WorkId -> WorkState+getState cmdState n = if n >= length (workerStates cmdState)+ then NoWork+ else workerStates cmdState !! n++itemDesc cmdState =+ let noDescInfo a b = "#" <> T.pack (show a) <> " -- " <> T.pack (show b)+ in fromMaybe noDescInfo $ workerDescr cmdState++matchGroup grp g = or [ (grp <> ".") `T.isPrefixOf` g+ , (grp <> ":") `T.isPrefixOf` g+ ]++-- ----------------------------------------------------------------------+-- UI Functionality++cmdLineUI appName =+ do eventChan <- newChan :: IO (Chan StateCmd)+ return (CmdLineConfig appName eventChan, writeChan eventChan, undefined)+++startCmdLine :: CmdLineCfg -> (WorkMsg -> IO ()) -> CmdLineState -> IO CmdLineState+startCmdLine (CmdLineConfig appName stateChan) workReq _ =+ do putStrLn (T.unpack appName)+ event <- readChan stateChan+ ui' <- stateEventHandler initialState event+ putStrLn "Type \"help\" for a list of commands"+ putStrLn ""+ let prompt = PR.prompt' $ T.unpack appName <> "> "+ let cmd_op = makeREPL cmdlist cmd_exit cmd_unknown prompt defErrorHandler+ execStateT cmd_op ui'+ where initialState = CmdLineState [] Nothing [] stateChan mempty "id"+ cmdlist = [ cmd_list+ , cmd_show+ , cmd_info workReq+ , cmd_select+ , cmd_clear workReq+ , cmd_runtest workReq+ , cmd_setcommand+ , cmd_run workReq+ , cmd_help cmdlist+ , cmd_exit+ ]++cmd_unknown =+ makeCommandN "" (const True) "" False [] (repeat lineAsker) f+ where f t ts = unless (T.all isSpace t && L.all (T.all isSpace) ts)+ $ liftIO $ putStrLn $ "Unknown command: " <> T.unpack t+++cmd_help cmdlist = makeCommand "help / ?" (`elem` ["help", "?"])+ "Shows help information"+ $ \t -> liftIO $ summarizeCommands cmdlist+++cmd_list = makeCommand "list" ("list" ==)+ "Lists all known remotes"+ $ \t -> do cmdState <- get+ liftIO $ putStrLn $ unlines $ showItems $ workItems cmdState+ let si = selectedItems cmdState+ sel = if null si then "none" else show (S.toList si)+ liftIO $ putStrLn $ "Selection: " <> sel+ liftIO $ putStrLn ""+++cmd_show = makeCommandN "show" ("show"==)+ "Shows information about remotes. \n\+ \\t\tThe optional argument specifies which subset of remotes to show:\n\+ \\t\t selected -- shows all currently selected items\n\+ \\t\t results -- shows all non-idle remotes\n\+ \\t\t failed -- shows remotes that failed\n\+ \\t\t group -- shows remotes within the specified\n\+ \\t\t group heirarchy"+ -- KWQ: show numbers? How to see actual results? show details?+ True+ []+ [Asker "Filter? " (Right . T.unpack) (return . Right)]+ showFilteredWorkItems++cmd_clear :: (WorkMsg -> IO ()) -> Command (StateT CmdLineState IO) T.Text ()+cmd_clear workReq = makeCommand "clear" ("clear"==)+ "Clears all state and resets to initial status"+ $ \t -> do s <- get+ liftIO $ workReq ClearAll+ -- s' <- liftIO $ stateEventHandler s =<< (readChan $ stateChan s)+ -- put s'++cmd_exit = makeCommand "exit" (`elem` ["exit", "quit"])+ "Exits the application."+ $ \t -> liftIO $ putStrLn "Exiting"+++cmd_select = makeCommandN "select" ("select" ==)+ "Specifies which items to select by index or group or item name."+ True+ [asker] -- must supply at least one+ (repeat asker) -- can supply an unlimited number+ makeSelection+ where asker = Asker "Select which items? " (Right . T.unpack) (return . Right)+ makeSelection t i = selectItems $ each i+ each = foldr ((<>) . words) []++cmd_runtest :: (WorkMsg -> IO ()) -> Command (StateT CmdLineState IO) T.Text ()+cmd_runtest workReq = makeCommand "runtest" ("runtest" ==)+ "Runs a test operation on all selected remotes"+ $ \t -> runRemoteCommand workReq ["id"]++cmd_run :: (WorkMsg -> IO ()) -> Command (StateT CmdLineState IO) T.Text ()+cmd_run workReq = makeCommand "run" ("run" ==)+ "Runs the current input operation on all selected remotes"+ $ \t -> do cmdState <- get+ let cmd = command cmdState+ runRemoteCommand workReq [cmd]+++cmd_info :: (WorkMsg -> IO ()) -> Command (StateT CmdLineState IO) T.Text ()+cmd_info workReq = makeCommand1 "info" ("info"==)+ "Gets detailed information (including run results) for a single item."+ True+ itemAsker+ $ \t -> infoSelect workReq++itemAsker :: Applicative m => Asker m Int Int+itemAsker = typeAsker "Item number? "+ (\e -> SomeException $ GenericTypeError $+ T.pack $ "Must specify an integer item number, not " <> show e)++cmd_setcommand :: Command (StateT CmdLineState IO) T.Text ()+cmd_setcommand = makeCommand1 "input" ("input"==)+ "Specify the command to be run on the remote systems"+ True asker+ $ \t c -> modify (\s -> s { command = T.pack c })+ where asker = Asker "Input command? " (Right . T.unpack) (return . Right)+++-- ----------------------------------------------------------------------+-- Operations++-- Handles the show operation. The first argument is the "show"+-- command, and the second argument is a list of at most one entry+-- specifying what type of item(s) are to be shown.+showFilteredWorkItems :: T.Text -> [String] -> StateT CmdLineState IO ()+showFilteredWorkItems t f =+ let stateFilter state = null f ||+ case head f of+ "results" -> state /= NoWork+ "failed" -> state == WorkFailed+ _ -> True+ groupFilter grpPrefix = null f ||+ case head f of+ "results" -> True+ "failed" -> True+ "selected" -> True+ x -> matchGroup (T.pack x) grpPrefix+ selFilter s n = null f ||+ case head f of+ "selected" -> n `elem` selectedItems s+ _ -> True++ itemInfo cmdState = mapMaybe (getInfo cmdState) $ itemRange cmdState++ getInfo cmdState n =+ let s = getState cmdState n+ pfx = getPrefix cmdState n+ ident = "#" <> show n <> ":: " <> selmark <> " "+ selmark = if n `elem` selectedItems cmdState then "**" else " "+ inf = T.unpack $ info cmdState pfx n s+ in if stateFilter s && groupFilter pfx && selFilter cmdState n+ then Just $ ident <> show s <> "\t" <> inf+ else Nothing++ info cmdState pfx id state = pfx <> itemDesc cmdState id state++ in do cmdState <- get+ liftIO $ mapM_ putStrLn $ itemInfo cmdState++-- Called to update the current selection list; the item(s) to select+-- are specified in the first argument and can be an item number, a+-- group/subgroup sub-match, or an item name. The first argument may+-- also specify "none" to clear all previously selected items..+selectItems :: [String] -> StateT CmdLineState IO ()+selectItems itemList = -- KWQ None+ let maxItem = numItems . workItems+ inpToIds s y = case reads y of+ [(num, "")] -> if num < maxItem s && num >= 0+ then [Right num]+ else [Left $ "Ignoring " <> show num <>+ "; not in the valid range 0--" <> show (maxItem s)]+ _ -> wantSomething y $ concat [ itemsMatchingGroup s $ T.pack y+ , itemsMatchingName s $ T.pack y+ ]+ wantSomething y l = if null l+ then [Left $ "No group or item matches " <> show y <> "; ignoring"]+ else l+ itemsMatchingGroup st8 grp = map Right $ filter (matchGroup grp . getPrefix st8) $ itemRange st8+ itemsMatchingName st8 nm = map Right $ filter (nameMatch st8 nm) $ itemRange st8+ -- is numItems (workItems st8) the same as numEntries (workItems st8)?+ nameMatch s nm n = nm `T.isPrefixOf` itemDesc s n NoWork+ cvtItems s l = S.unions $ map (S.fromList . inpToIds s) l+ newItems = S.fromList . rights . S.toList+ errs = lefts . S.toList+ in do cmdState <- get+ let cI = cvtItems cmdState itemList+ liftIO $ mapM_ (putStrLn . ("Warning: " <>)) $ errs cI+ put $ cmdState { selectedItems = selectedItems cmdState <> newItems cI }+ unless (null $ errs cI) $ liftIO $ putStrLn ""+++runRemoteCommand workReq cmd =+ do cmdState <- get -- KWQ?+ liftIO $ workReq $ StartRun cmd $ S.toList $ selectedItems cmdState+ processUntilDone+ liftIO $ putStrLn ""++processUntilDone = do s <- get+ ev <- liftIO $ readChan $ stateChan s+ put =<< liftIO (stateEventHandler s ev)+ unless (isEndEvent ev) processUntilDone+ where isEndEvent EndOfInformation = True+ isEndEvent _ = False++infoSelect :: (WorkMsg -> IO ()) -> Int -> StateT CmdLineState IO ()+infoSelect workReq n = do liftIO $ workReq $ ShowSelInfo n+ processUntilDone+ liftIO $ putStrLn ""
+ src/Network/OnRmt/UI/MainScreen.hs view
@@ -0,0 +1,461 @@+{-# 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
+ test/test_onrmt.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Data.Conduit.RemoteOp (remoteOp, sshargs)+import Data.Monoid ((<>))+import Data.String.Conversions+import qualified Data.Text as T+import Network.OnRmt+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.HUnit++main = defaultMain tests++tests = [ testGroup "Parameters"+ [ testCase "App Name Parameter" test_an0+ , testCase "Parallelization Parameter" test_an1+ , testCase "Direct SSH Parameter" test_an2+ ]+ , testGroup "RemoteOps"+ [ testCase "SSH Direct Args" test_ro0+ , testCase "SSH Bounce Args" test_ro1+ -- testCase "remote echo" test_ro1+ ]+ ]+++test_an0 = "test app" @=? (appName $ OnRmtParams "test app" 0 False)+test_an1 = 0 @=? (maxParallel $ OnRmtParams "test app" 0 False)+test_an2 = False @=? (directSSH $ OnRmtParams "test app" 0 False)++common_ssh_args = [ "-A"+ , "-o", "ControlPath none"+ , "-o", "VisualHostKey no"+ , "-o", "KbdInteractiveAuthentication no"+ , "-o", "StrictHostKeyChecking no"+ , "-o", "CheckHostIP no"+ , "-o", "ForwardX11 no"+ , "-o", "ForwardX11Trusted no"+ ]+test_ro0 = common_ssh_args <> ["hostname", "foo\nbar\n"]+ @=? sshargs True "hostname" ["foo", "bar"]++test_ro1 = [ "-t", "-t" ] <> common_ssh_args <>+ [ "localhost", "ssh", "'-A'"+ , "'-o'", "'ControlPath none'"+ , "'-o'", "'VisualHostKey no'"+ , "'-o'", "'KbdInteractiveAuthentication no'"+ , "'-o'", "'StrictHostKeyChecking no'"+ , "'-o'", "'CheckHostIP no'"+ , "'-o'", "'ForwardX11 no'"+ , "'-o'", "'ForwardX11Trusted no'"+ , "host-name", "hi\n"] @=? sshargs False "host-name" ["hi"]+-- test_ro1 = "howdy ho" @=? remoteOp "localhost" "echo howdy ho" foo+