diff --git a/core-program.cabal b/core-program.cabal --- a/core-program.cabal +++ b/core-program.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: core-program -version: 0.6.3.0 +version: 0.6.5.0 synopsis: Opinionated Haskell Interoperability description: A library to help build command-line programs, both tools and longer-running daemons. diff --git a/lib/Core/Program/Arguments.hs b/lib/Core/Program/Arguments.hs --- a/lib/Core/Program/Arguments.hs +++ b/lib/Core/Program/Arguments.hs @@ -25,7 +25,9 @@ Config , blankConfig , simpleConfig + , simpleConfig' , complexConfig + , complexConfig' , baselineOptions , Parameters (..) , ParameterValue (..) @@ -115,8 +117,8 @@ -} data Config = Blank - | Simple [Options] - | Complex [Commands] + | Simple Description [Options] + | Complex Description [Commands] -- -- Those constructors are not exposed [and functions wrapping them are] partly @@ -200,9 +202,29 @@ @since 0.2.9 -} simpleConfig :: [Options] -> Config -simpleConfig options = Simple (options ++ baselineOptions) +simpleConfig options = Simple emptyRope (options ++ baselineOptions) {- | +Declare a simple configuration as with 'simpleConfig', along with a +descriptive precis that will be printed at the top of the @--help@ output. + + +@ +\$ __./snippet --help__ +A small but very useful program. + +Usage: + + snippet [OPTIONS] +... +@ + +@since 0.6.5 +-} +simpleConfig' :: Description -> [Options] -> Config +simpleConfig' description options = Simple description (options ++ baselineOptions) + +{- | Declare a complex configuration (implying a larger tool with various "[sub]commands" or "modes"} for a program. You can specify global options applicable to all commands, a list of commands, and environment variables @@ -286,9 +308,22 @@ @since 0.2.9 -} complexConfig :: [Commands] -> Config -complexConfig commands = Complex (commands ++ [Global baselineOptions]) +complexConfig commands = Complex emptyRope (commands ++ [Global baselineOptions]) {- | +Declare a complex configuration as with 'complexConfig', along with a +descriptive precis that will be printed at the top of the @--help@ output when +requesting help for the program as a whole. + +If help is requested for one of the sub commands, the description from the +'Command' constructor will be used at the top of the output. + +@since 0.6.5 +-} +complexConfig' :: Description -> [Commands] -> Config +complexConfig' precis commands = Complex precis (commands ++ [Global baselineOptions]) + +{- | Description of the command-line structure of a program which has \"commands\" (sometimes referred to as \"subcommands\") representing different modes of operation. This is familiar from tools like /git/ @@ -332,7 +367,7 @@ @ [ ... - , 'Remaining' "The files you wish to delete permanently." + , 'Remaining' \"The files you wish to delete permanently.\" , ... ] @ @@ -344,10 +379,20 @@ @ [ ... - , 'Variable' \"CRAZY_MODE\" "Specify how many crazies to activate." + , 'Variable' \"CRAZY_MODE\" \"Specify how many crazies to activate.\" , ... ] @ + +Finally, there is a 'Descriptive' constructor which allows you to put a piece +of header text as a descriptive summary in help output before it starts +enumerating the options and arguments. + +@ + [ 'Descriptive' \"A program to evaluate just how crazy you are.\" + , ... + ] +@ -} data Options = Option LongName (Maybe ShortName) ParameterValue Description @@ -360,8 +405,8 @@ appendOption option config = case config of Blank -> Blank - Simple options -> Simple (options ++ [option]) - Complex commands -> Complex (commands ++ [Global [option]]) + Simple precis options -> Simple precis (options ++ [option]) + Complex precis commands -> Complex precis (commands ++ [Global [option]]) {- | Individual parameters read in off the command-line can either have a value @@ -550,11 +595,11 @@ parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters parseCommandLine config argv = case config of Blank -> return (Parameters Nothing emptyMap [] emptyMap) - Simple options -> do + Simple _ options -> do (params, remainder) <- extractor Nothing options argv checkRemainder options remainder return (Parameters Nothing params remainder emptyMap) - Complex commands -> + Complex _ commands -> let globalOptions = extractGlobalOptions commands modes = extractValidModes commands in do @@ -655,13 +700,13 @@ Right (list, remainder) -> Right (((name, Value arg) : list), remainder) parseIndicatedCommand - :: Map LongName [Options] + :: Map LongName (Description, [Options]) -> String -> Either InvalidCommandLine (LongName, [Options]) parseIndicatedCommand modes first = let candidate = LongName first in case lookupKeyValue candidate modes of - Just options -> Right (candidate, options) + Just (_, options) -> Right (candidate, options) Nothing -> Left (UnknownCommand first) -- @@ -702,12 +747,12 @@ j (Global options) valids = options ++ valids j _ valids = valids -extractValidModes :: [Commands] -> Map LongName [Options] +extractValidModes :: [Commands] -> Map LongName (Description, [Options]) extractValidModes commands = List.foldl' k emptyMap commands where - k :: Map LongName [Options] -> Commands -> Map LongName [Options] - k modes (Command longname _ options) = insertKeyValue longname options modes + k :: Map LongName (Description, [Options]) -> Commands -> Map LongName (Description, [Options]) + k modes (Command longname description options) = insertKeyValue longname (description, options) modes k modes _ = modes {- @@ -740,8 +785,8 @@ extractValidEnvironments :: Maybe LongName -> Config -> Set LongName extractValidEnvironments mode config = case config of Blank -> emptySet - Simple options -> extractVariableNames options - Complex commands -> + Simple _ options -> extractVariableNames options + Complex _ commands -> let globals = extractGlobalOptions commands variables1 = extractVariableNames globals @@ -775,9 +820,10 @@ buildUsage :: Config -> Maybe LongName -> Doc ann buildUsage config mode = case config of Blank -> emptyDoc - Simple options -> + Simple precis options -> let (o, a, v) = partitionParameters options - in "Usage:" + in formatPrecis precis + <> "Usage:" <> hardline <> hardline <> indent @@ -799,36 +845,18 @@ <> formatParameters a <> variablesHeading v <> formatParameters v - Complex commands -> + Complex precis commands -> let globalOptions = extractGlobalOptions commands modes = extractValidModes commands (oG, _, vG) = partitionParameters globalOptions - in "Usage:" <> hardline <> hardline <> case mode of + in case mode of Nothing -> - indent - 2 - ( nest - 4 - ( fillCat - [ pretty programName - , globalSummary oG - , commandSummary modes - ] - ) - ) + formatPrecis precis + <> "Usage:" <> hardline - <> globalHeading oG - <> formatParameters oG - <> commandHeading modes - <> formatCommands commands - <> variablesHeading vG - <> formatParameters vG - Just longname -> - let (oL, aL, vL) = case lookupKeyValue longname modes of - Just localOptions -> partitionParameters localOptions - Nothing -> error "Illegal State" - in indent + <> hardline + <> indent 2 ( nest 4 @@ -836,13 +864,39 @@ [ pretty programName , globalSummary oG , commandSummary modes - , localSummary oL - , argumentsSummary aL - , remainingSummary aL ] ) ) + <> hardline + <> globalHeading oG + <> formatParameters oG + <> commandHeading modes + <> formatCommands commands + <> variablesHeading vG + <> formatParameters vG + Just longname -> + let (dL, (oL, aL, vL)) = case lookupKeyValue longname modes of + Just (description, localOptions) -> (description, partitionParameters localOptions) + Nothing -> error "Illegal State" + in formatPrecis dL + <> "Usage:" <> hardline + <> hardline + <> indent + 2 + ( nest + 4 + ( fillCat + [ pretty programName + , globalSummary oG + , commandSummary modes + , localSummary oL + , argumentsSummary aL + , remainingSummary aL + ] + ) + ) + <> hardline <> localHeading oL <> formatParameters oL <> argumentsHeading aL @@ -850,6 +904,11 @@ <> variablesHeading vL <> formatParameters vL where + formatPrecis :: Description -> Doc ann + formatPrecis precis = case widthRope precis of + 0 -> emptyDoc + _ -> reflow (fromRope precis) <> hardline <> hardline + partitionParameters :: [Options] -> ([Options], [Options], [Options]) partitionParameters options = List.foldl' f ([], [], []) options diff --git a/lib/Core/Program/Context.hs b/lib/Core/Program/Context.hs --- a/lib/Core/Program/Context.hs +++ b/lib/Core/Program/Context.hs @@ -175,7 +175,9 @@ , exitSemaphoreFrom :: MVar ExitCode , startTimeFrom :: MVar Time , verbosityLevelFrom :: MVar Verbosity + , outputSemaphoreFrom :: MVar () , outputChannelFrom :: TQueue (Maybe Rope) -- communication channels + , telemetrySemaphoreFrom :: MVar () , telemetryChannelFrom :: TQueue (Maybe Datum) -- machinery for telemetry , telemetryForwarderFrom :: Maybe Forwarder , currentScopeFrom :: TVar (Set ThreadId) @@ -370,6 +372,8 @@ columns <- getConsoleWidth coloured <- getConsoleColoured level <- newEmptyMVar + vo <- newEmptyMVar + vl <- newEmptyMVar out <- newTQueueIO tel <- newTQueueIO @@ -389,7 +393,9 @@ , exitSemaphoreFrom = q , startTimeFrom = i , verbosityLevelFrom = level -- will be filled in handleVerbosityLevel + , outputSemaphoreFrom = vo , outputChannelFrom = out + , telemetrySemaphoreFrom = vl , telemetryChannelFrom = tel , telemetryForwarderFrom = Nothing , currentScopeFrom = scope diff --git a/lib/Core/Program/Execute.hs b/lib/Core/Program/Execute.hs --- a/lib/Core/Program/Execute.hs +++ b/lib/Core/Program/Execute.hs @@ -82,7 +82,6 @@ -- * Useful actions , outputEntire , inputEntire - , execProcess , sleepThread , resetTimer , trap_ @@ -92,6 +91,10 @@ , throw , try + -- * Running processes + , readProcess + , execProcess_ + -- * Internals , Context , None (..) @@ -104,6 +107,7 @@ , lookupOptionValue , lookupArgument , lookupEnvironmentValue + , execProcess ) where @@ -117,7 +121,6 @@ import Control.Concurrent.MVar ( MVar , modifyMVar_ - , newEmptyMVar , newMVar , putMVar , readMVar @@ -176,8 +179,8 @@ ) import System.Exit (ExitCode (..)) import System.Posix.Internals (hostIsThreaded) -import System.Posix.Process qualified as Posix (exitImmediately) -import System.Process.Typed (nullStream, proc, readProcess, setStdin) +import System.Posix.Process qualified as Posix (executeFile, exitImmediately) +import System.Process.Typed qualified as Typed (nullStream, proc, readProcess, setStdin) import Prelude hiding (log) {- | @@ -253,23 +256,23 @@ level <- handleVerbosityLevel context let quit = exitSemaphoreFrom context - out = outputChannelFrom context - tel = telemetryChannelFrom context - forwarder = telemetryForwarderFrom context + let vo = outputSemaphoreFrom context + let out = outputChannelFrom context + let vl = telemetrySemaphoreFrom context + let tel = telemetryChannelFrom context + let forwarder = telemetryForwarderFrom context -- set up signal handlers _ <- forkIO $ do setupSignalHandlers quit level -- set up standard output - vo <- newEmptyMVar _ <- forkFinally (processStandardOutput out) (\_ -> putMVar vo ()) -- set up debug logger - vl <- newEmptyMVar _ <- forkFinally (processTelemetryMessages forwarder level out tel) @@ -612,7 +615,7 @@ Settings { ... } - + 'changeProgram' settings program2 program2 :: 'Program' Settings () @@ -680,7 +683,7 @@ to be enumerated separately: @ - 'execProcess' [\"\/usr\/bin\/ssh\", \"-l\", \"admin\", \"203.0.113.42\", \"\\\'remote command here\\\'\"] + 'readProcess' [\"\/usr\/bin\/ssh\", \"-l\", \"admin\", \"203.0.113.42\", \"\\\'remote command here\\\'\"] @ having to write out the individual options and arguments and deal with @@ -691,15 +694,17 @@ so if you're doing something that returns huge amounts of output you'll want to use something like __io-streams__ instead. -(this wraps __typed-process__'s 'readProcess') +(this wraps __typed-process__'s 'System.Process.Typed.readProcess') + +@since 0.6.4 -} -execProcess :: [Rope] -> Program τ (ExitCode, Rope, Rope) -execProcess [] = error "No command provided" -execProcess (cmd : args) = +readProcess :: [Rope] -> Program τ (ExitCode, Rope, Rope) +readProcess [] = error "No command provided" +readProcess (cmd : args) = let cmd' = fromRope cmd args' = fmap fromRope args - task = proc cmd' args' - task1 = setStdin nullStream task + task = Typed.proc cmd' args' + task1 = Typed.setStdin Typed.nullStream task command = mconcat (List.intersperse (singletonRope ' ') (cmd : args)) in do debug "command" command @@ -711,9 +716,68 @@ Safe.throw (CommandNotFound cmd) Just _ -> do (exit, out, err) <- liftIO $ do - readProcess task1 + Typed.readProcess task1 pure (exit, intoRope out, intoRope err) + +execProcess :: [Rope] -> Program τ (ExitCode, Rope, Rope) +execProcess = readProcess +{-# DEPRECATED execProcess "Use readProcess intead" #-} + +{- | +Execute a new external binary, replacing this Haskell program in memory and +running the new binary in this program's place. The PID of the process does +not change. + +This function does not return. + +As with 'readProcess' above, each of the arguments to the new process +must be supplied as individual values in the list. The first argument is the +name of the binary to be executed. The @PATH@ will be searched for the binary +if an absolute path is not given; an exception will be thrown if it is not +found. + +(this wraps __unix__'s 'executeFile' machinery, which results in an +/execvp(3)/ standard library function call) + +@since 0.6.4 +-} +execProcess_ :: [Rope] -> Program τ () +execProcess_ [] = error "No command provided" +execProcess_ (cmd : args) = do + context <- ask + let cmd' = fromRope cmd + let args' = fmap fromRope args + let command = mconcat (List.intersperse (singletonRope ' ') (cmd : args)) + let vo = outputSemaphoreFrom context + let out = outputChannelFrom context + let vl = telemetrySemaphoreFrom context + let tel = telemetryChannelFrom context + + debug "command" command + + probe <- liftIO $ do + findExecutable cmd' + case probe of + Nothing -> do + Safe.throw (CommandNotFound cmd) + Just _ -> do + liftIO $ do + atomically $ do + writeTQueue tel Nothing + writeTQueue out Nothing + + _ <- forkIO $ do + threadDelay 10000000 + putStrLn "error: Timeout" + Safe.throw (ExitFailure 97) + + readMVar vl + readMVar vo + + -- does not return + _ <- Posix.executeFile cmd' True args' Nothing + pure () {- | Reset the start time (used to calculate durations shown in event- and