diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +Series 1 +--------- + + * 1.0.0.0 -- initial release + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Kevin Quick + +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 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. diff --git a/OnRmt.cabal b/OnRmt.cabal new file mode 100644 --- /dev/null +++ b/OnRmt.cabal @@ -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 +maintainer: +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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/compat/brick_016/BrickCompat.hs b/compat/brick_016/BrickCompat.hs new file mode 100644 --- /dev/null +++ b/compat/brick_016/BrickCompat.hs @@ -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 diff --git a/compat/brick_017/BrickCompat.hs b/compat/brick_017/BrickCompat.hs new file mode 100644 --- /dev/null +++ b/compat/brick_017/BrickCompat.hs @@ -0,0 +1,8 @@ +module BrickCompat + ( BChan, newBChan, writeBChan, readBChan + , defaultConfig + ) + where + +import Brick.BChan (BChan, newBChan, writeBChan, readBChan) +import Graphics.Vty (defaultConfig) diff --git a/onrmtssh.hs b/onrmtssh.hs new file mode 100644 --- /dev/null +++ b/onrmtssh.hs @@ -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 () diff --git a/sample/GetRemotes.hs b/sample/GetRemotes.hs new file mode 100644 --- /dev/null +++ b/sample/GetRemotes.hs @@ -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 diff --git a/sample/onrmtsample.hs b/sample/onrmtsample.hs new file mode 100644 --- /dev/null +++ b/sample/onrmtsample.hs @@ -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 () diff --git a/sample/onrmtsamplecli.hs b/sample/onrmtsamplecli.hs new file mode 100644 --- /dev/null +++ b/sample/onrmtsamplecli.hs @@ -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 } diff --git a/src/Concurrent/Worker.hs b/src/Concurrent/Worker.hs new file mode 100644 --- /dev/null +++ b/src/Concurrent/Worker.hs @@ -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" diff --git a/src/Data/Conduit/RemoteOp.hs b/src/Data/Conduit/RemoteOp.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/RemoteOp.hs @@ -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 diff --git a/src/Network/OnRmt.hs b/src/Network/OnRmt.hs new file mode 100644 --- /dev/null +++ b/src/Network/OnRmt.hs @@ -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 = [] + } diff --git a/src/Network/OnRmt/UI.hs b/src/Network/OnRmt/UI.hs new file mode 100644 --- /dev/null +++ b/src/Network/OnRmt/UI.hs @@ -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 diff --git a/src/Network/OnRmt/UI/BrickUI.hs b/src/Network/OnRmt/UI/BrickUI.hs new file mode 100644 --- /dev/null +++ b/src/Network/OnRmt/UI/BrickUI.hs @@ -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) } + diff --git a/src/Network/OnRmt/UI/CmdLine.hs b/src/Network/OnRmt/UI/CmdLine.hs new file mode 100644 --- /dev/null +++ b/src/Network/OnRmt/UI/CmdLine.hs @@ -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 "" diff --git a/src/Network/OnRmt/UI/MainScreen.hs b/src/Network/OnRmt/UI/MainScreen.hs new file mode 100644 --- /dev/null +++ b/src/Network/OnRmt/UI/MainScreen.hs @@ -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 diff --git a/test/test_onrmt.hs b/test/test_onrmt.hs new file mode 100644 --- /dev/null +++ b/test/test_onrmt.hs @@ -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 +