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
{ 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
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 (ns) 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
]
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"
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
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]
(repeat asker)
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)
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
selectItems :: [String] -> StateT CmdLineState IO ()
selectItems itemList =
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
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
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 ""