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.3.2.0 +version: 0.3.4.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 @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} @@ -323,6 +324,18 @@ which ends with a full stop. For options that take values, use /upper case/ when specifying the label to be used in help output. +'Remaining' is special; it indicates that you are expecting a variable number +of additional, non-mandatory arguments. This is used for programs which take a +list of files to process, for example. It'll show up in the help with the +description you supply alongside. + +@ + [ ... + , 'Remaining' "The files you wish to delete permanently." + , ... + ] +@ + 'Variable' declares an /environment variable/ that, if present, will be read by the program and stored in its runtime context. By convention these are /upper case/. If the identifier is two or more words they are joined @@ -338,6 +351,7 @@ data Options = Option LongName (Maybe ShortName) ParameterValue Description | Argument LongName Description + | Remaining Description | Variable LongName Description appendOption :: Options -> Config -> Config @@ -406,6 +420,7 @@ data Parameters = Parameters { commandNameFrom :: Maybe LongName , parameterValuesFrom :: Map LongName ParameterValue + , remainingArgumentsFrom :: [String] , environmentValuesFrom :: Map LongName ParameterValue } deriving (Show, Eq) @@ -415,6 +430,7 @@ Parameters { commandNameFrom = Nothing , parameterValuesFrom = emptyMap + , remainingArgumentsFrom = [] , environmentValuesFrom = emptyMap } @@ -535,22 +551,24 @@ -} parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters parseCommandLine config argv = case config of - Blank -> return (Parameters Nothing emptyMap emptyMap) + Blank -> return (Parameters Nothing emptyMap [] emptyMap) Simple options -> do - params <- extractor Nothing options argv - return (Parameters Nothing params emptyMap) + (params, remainder) <- extractor Nothing options argv + checkRemainder options remainder + return (Parameters Nothing params remainder emptyMap) Complex commands -> let globalOptions = extractGlobalOptions commands modes = extractValidModes commands in do (possibles, argv') <- splitCommandLine1 argv - params1 <- extractor Nothing globalOptions possibles - (first, remainingArgs) <- splitCommandLine2 argv' + (params1, _) <- extractor Nothing globalOptions possibles + (first, moreArgs) <- splitCommandLine2 argv' (mode, localOptions) <- parseIndicatedCommand modes first - params2 <- extractor (Just mode) localOptions remainingArgs - return (Parameters (Just mode) ((<>) params1 params2) emptyMap) + (params2, remainder) <- extractor (Just mode) localOptions moreArgs + checkRemainder localOptions remainder + return (Parameters (Just mode) ((<>) params1 params2) remainder emptyMap) where - extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine (Map LongName ParameterValue) + extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine ((Map LongName ParameterValue), [String]) extractor mode options args = let (possibles, arguments) = List.partition isOption args valids = extractValidNames options @@ -558,9 +576,29 @@ needed = extractRequiredArguments options in do list1 <- parsePossibleOptions mode valids shorts possibles - list2 <- parseRequiredArguments needed arguments - return ((<>) (intoMap list1) (intoMap list2)) + (list2, arguments') <- parseRequiredArguments needed arguments + pure (((<>) (intoMap list1) (intoMap list2)), arguments') + checkRemainder :: [Options] -> [String] -> Either InvalidCommandLine () + checkRemainder options remainder = + if List.null remainder + then Right () + else + if hasRemaining options + then Right () + else Left (UnexpectedArguments remainder) + +-- is one of the options Remaining? +hasRemaining :: [Options] -> Bool +hasRemaining options = + List.foldl' + ( \acc option -> case option of + Remaining _ -> True + _ -> acc + ) + False + options + isOption :: String -> Bool isOption arg = case arg of ('-' : _) -> True @@ -603,21 +641,20 @@ parseRequiredArguments :: [LongName] -> [String] -> - Either InvalidCommandLine [(LongName, ParameterValue)] + Either InvalidCommandLine ([(LongName, ParameterValue)], [String]) parseRequiredArguments needed argv = iter needed argv where - iter :: [LongName] -> [String] -> Either InvalidCommandLine [(LongName, ParameterValue)] - - iter [] [] = Right [] + iter :: [LongName] -> [String] -> Either InvalidCommandLine ([(LongName, ParameterValue)], [String]) + iter [] [] = Right ([], []) -- more arguments supplied than expected - iter [] args = Left (UnexpectedArguments args) + iter [] args = Right ([], args) -- more arguments required, not satisfied iter (name : _) [] = Left (MissingArgument name) iter (name : names) (arg : args) = let deeper = iter names args in case deeper of Left e -> Left e - Right list -> Right ((name, Value arg) : list) + Right (list, remainder) -> Right (((name, Value arg) : list), remainder) parseIndicatedCommand :: Map LongName [Options] -> @@ -751,6 +788,7 @@ [ pretty programName , optionsSummary o , argumentsSummary a + , remainingSummary a ] ) ) @@ -796,6 +834,7 @@ , commandSummary modes , localSummary oL , argumentsSummary aL + , remainingSummary aL ] ) ) @@ -835,6 +874,9 @@ argumentsHeading as = if length as > 0 then hardline <> "Required arguments:" <> hardline else emptyDoc + remainingSummary :: [Options] -> Doc ann + remainingSummary as = if hasRemaining as then " ..." else emptyDoc + -- there is a corner case of complex config with no commands commandSummary modes = if length modes > 0 then softline <> commandName else emptyDoc commandHeading modes = if length modes > 0 then hardline <> "Available commands:" <> hardline else emptyDoc @@ -842,6 +884,7 @@ f :: Options -> ([Options], [Options]) -> ([Options], [Options]) f o@(Option _ _ _ _) (opts, args) = (o : opts, args) f a@(Argument _ _) (opts, args) = (opts, a : args) + f a@(Remaining _) (opts, args) = (opts, a : args) f (Variable _ _) (opts, args) = (opts, args) formatParameters :: [Options] -> Doc ann @@ -873,6 +916,9 @@ let l = pretty longname d = fromRope description in fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc + g (Remaining description) acc = + let d = fromRope description + in fillBreak 16 (" " <> "... ") <+> align (reflow d) <> hardline <> acc g (Variable longname description) acc = let l = pretty longname d = fromRope description 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 @@ -61,10 +61,11 @@ -- * Accessing program context getCommandLine, - lookupOptionFlag, - lookupOptionValue, - lookupArgument, - lookupEnvironmentValue, + queryOptionFlag, + queryOptionValue, + queryArgument, + queryRemaining, + queryEnvironmentValue, getProgramName, setProgramName, getVerbosityLevel, @@ -94,8 +95,12 @@ unProgram, unThread, invalid, - Boom(..), + Boom (..), loopForever, + lookupOptionFlag, + lookupOptionValue, + lookupArgument, + lookupEnvironmentValue, ) where import Chrono.TimeStamp (getCurrentTimeNanoseconds) @@ -113,6 +118,7 @@ wait, ) import Control.Concurrent.MVar ( + MVar, modifyMVar_, newMVar, putMVar, @@ -150,7 +156,7 @@ import GHC.Conc (getNumProcessors, numCapabilities, setNumCapabilities) import GHC.IO.Encoding (setLocaleEncoding, utf8) import System.Directory ( - findExecutable + findExecutable, ) import System.Exit (ExitCode (..)) import qualified System.Posix.Process as Posix (exitImmediately) @@ -280,7 +286,7 @@ -- set up debug logger l <- Async.async $ do - processTelemetryMessages forwarder out tel + processTelemetryMessages forwarder level out tel -- run actual program, ensuring to grab any otherwise uncaught exceptions. code <- @@ -311,9 +317,12 @@ ( do atomically $ do writeTQueue tel Nothing - writeTQueue out Nothing Async.wait l + + atomically $ do + writeTQueue out Nothing + Async.wait o ) ( do @@ -356,17 +365,16 @@ -- the technique used by **io-streams** to just pass along a stream of Maybes, -- with Nothing signalling end-of-stream is exactly good enough for our needs. -- -processTelemetryMessages :: Forwarder -> TQueue (Maybe Rope) -> TQueue (Maybe Datum) -> IO () -processTelemetryMessages processor out tel = do +processTelemetryMessages :: Forwarder -> MVar Verbosity -> TQueue (Maybe Rope) -> TQueue (Maybe Datum) -> IO () +processTelemetryMessages processor v out tel = do Safe.catch - (loopForever action out tel) + (loopForever action v out tel) (collapseHandler "telemetry processing collapsed") where action = telemetryHandlerFrom processor -loopForever :: ([a] -> IO ()) -> TQueue (Maybe Rope) -> TQueue (Maybe a) -> IO () -loopForever action out queue = do - start <- getCurrentTimeNanoseconds +loopForever :: ([a] -> IO ()) -> MVar Verbosity -> TQueue (Maybe Rope) -> TQueue (Maybe a) -> IO () +loopForever action v out queue = do -- block waiting for an item possibleItems <- atomically $ do cycleOverQueue [] @@ -376,20 +384,16 @@ Nothing -> pure () -- handle it and loop Just items -> do + start <- getCurrentTimeNanoseconds catch - (action (reverse items)) + ( do + action (reverse items) + reportStatus start (length items) + ) ( \(e :: SomeException) -> do - now <- getCurrentTimeNanoseconds - let result = - formatLogMessage - start - now - SeverityWarn - ("sending telemetry failed (Exception: " <> intoRope (show e) <> "); Restarting exporter.") - atomically $ do - writeTQueue out (Just result) + reportProblem start e ) - loopForever action out queue + loopForever action v out queue where cycleOverQueue items = case items of @@ -420,6 +424,35 @@ Just item -> do cycleOverQueue (item : items) + reportStatus start num = do + level <- readMVar v + when (isDebug level) $ do + now <- getCurrentTimeNanoseconds + let desc = case num of + 1 -> "1 event" + _ -> intoRope (show num) <> " events" + message = + formatLogMessage + start + now + SeverityInternal + ("telemetry: sent " <> desc) + atomically $ do + writeTQueue out (Just message) + + reportProblem start e = do + level <- readMVar v + when (isEvent level) $ do + now <- getCurrentTimeNanoseconds + let message = + formatLogMessage + start + now + SeverityWarn + ("sending telemetry failed (Exception: " <> intoRope (show e) <> "); Restarting exporter.") + atomically $ do + writeTQueue out (Just message) + {- | Safely exit the program with the supplied exit code. Current output and debug queues will be flushed, and then the process will terminate. @@ -752,8 +785,7 @@ This is available should you need to differentiate between a @Value@ and an @Empty@ 'ParameterValue', but for many cases as a convenience you can use the -'lookupOptionFlag', 'lookupOptionValue', and 'lookupArgument' functions below -(which are just wrappers around a code block like the example shown here). +'queryOptionFlag', 'queryOptionValue', and 'queryArgument' functions below. -} getCommandLine :: Program τ (Parameters) getCommandLine = do @@ -762,11 +794,24 @@ {- | Arguments are mandatory, so by the time your program is running a value -has already been identified. This returns the value for that parameter. +has already been identified. This retreives the value for that parameter. + +@ +program = do + file <- 'queryArgument' \"filename\" + ... +@ -} +queryArgument :: LongName -> Program τ Rope +queryArgument name = do + context <- ask + let params = commandLineFrom context + case lookupKeyValue name (parameterValuesFrom params) of + Nothing -> error "Attempted lookup of unconfigured argument" + Just argument -> case argument of + Empty -> error "Invalid State" + Value value -> pure (intoRope value) --- this is Maybe because you can inadvertently ask for an unconfigured name --- this could be fixed with a much stronger Config type, potentially. lookupArgument :: LongName -> Parameters -> Maybe String lookupArgument name params = case lookupKeyValue name (parameterValuesFrom params) of @@ -774,13 +819,48 @@ Just argument -> case argument of Empty -> error "Invalid State" Value value -> Just value +{-# DEPRECATED lookupArgument "Use queryArgument instead" #-} {- | +In other applications, you want to gather up the remaining arguments on the +command-line. You need to have specified 'Remaining' in the configuration. + +@ +program = do + files \<- 'queryRemaining' + ... +@ +-} +queryRemaining :: Program τ [Rope] +queryRemaining = do + context <- ask + let params = commandLineFrom context + let remaining = remainingArgumentsFrom params + pure (fmap intoRope remaining) + +{- | Look to see if the user supplied a valued option and if so, what its value -was. +was. Use of the @LambdaCase@ extension might make accessing the parameter a +bit eaiser: + +@ +program = do + count \<- 'queryOptionValue' \"count\" '>>=' \\case + 'Nothing' -> 'pure' 0 + 'Just' value -> 'pure' value + ... +@ -} +queryOptionValue :: LongName -> Program τ (Maybe Rope) +queryOptionValue name = do + context <- ask + let params = commandLineFrom context + case lookupKeyValue name (parameterValuesFrom params) of + Nothing -> pure Nothing + Just argument -> case argument of + Empty -> pure (Just emptyRope) + Value value -> pure (Just (intoRope value)) --- Should this be more severe if it encounters Empty? lookupOptionValue :: LongName -> Parameters -> Maybe String lookupOptionValue name params = case lookupKeyValue name (parameterValuesFrom params) of @@ -788,24 +868,47 @@ Just argument -> case argument of Empty -> Nothing Value value -> Just value +{-# DEPRECATED lookupOptionValue "Use queryOptionValue instead" #-} {- | -Returns @Just True@ if the option is present, and @Nothing@ if it is not. +Returns @True@ if the option is present, and @False@ if it is not. + +@ +program = do + overwrite \<- 'queryOptionValue' \"overwrite\" + ... +@ -} +queryOptionFlag :: LongName -> Program τ Bool +queryOptionFlag name = do + context <- ask + let params = commandLineFrom context + case lookupKeyValue name (parameterValuesFrom params) of + Nothing -> pure False + Just _ -> pure True --- The type is boolean to support a possible future extension of negated --- arguments. lookupOptionFlag :: LongName -> Parameters -> Maybe Bool lookupOptionFlag name params = case lookupKeyValue name (parameterValuesFrom params) of Nothing -> Nothing Just argument -> case argument of _ -> Just True -- nom, nom +{-# DEPRECATED lookupOptionFlag "Use queryOptionFlag instead" #-} {- | Look to see if the user supplied the named environment variable and if so, return what its value was. -} +queryEnvironmentValue :: LongName -> Program τ (Maybe Rope) +queryEnvironmentValue name = do + context <- ask + let params = commandLineFrom context + case lookupKeyValue name (environmentValuesFrom params) of + Nothing -> error "Attempted lookup of unconfigured environment variable" + Just param -> case param of + Empty -> pure Nothing + Value str -> pure (Just (intoRope str)) + lookupEnvironmentValue :: LongName -> Parameters -> Maybe String lookupEnvironmentValue name params = case lookupKeyValue name (environmentValuesFrom params) of @@ -813,6 +916,7 @@ Just param -> case param of Empty -> Nothing Value str -> Just str +{-# DEPRECATED lookupEnvironmentValue "Use queryEnvironment instead" #-} {- | Illegal internal state resulting from what should be unreachable code or diff --git a/lib/Core/Program/Logging.hs b/lib/Core/Program/Logging.hs --- a/lib/Core/Program/Logging.hs +++ b/lib/Core/Program/Logging.hs @@ -140,6 +140,11 @@ debug, debugS, debugR, + + -- internal + internal, + isEvent, + isDebug, ) where import Chrono.TimeStamp (TimeStamp (..), getCurrentTimeNanoseconds) @@ -167,6 +172,7 @@ | SeverityWarn | SeverityInfo | SeverityDebug + | SeverityInternal putMessage :: Context τ -> Message -> IO () putMessage context (Message now level text possiblelValue) = do @@ -204,12 +210,13 @@ -- I hate doing math in Haskell !elapsed = fromRational (toRational (now' - start') / 1e9) :: Fixed E3 - !color = case severity of + !colour = case severity of SeverityNone -> emptyRope SeverityCritical -> intoEscapes pureRed SeverityWarn -> intoEscapes pureYellow SeverityInfo -> intoEscapes dullWhite SeverityDebug -> intoEscapes pureGrey + SeverityInternal -> intoEscapes dullBlue !reset = intoEscapes resetColour in mconcat @@ -218,7 +225,7 @@ , " (" , padWithZeros 6 (show elapsed) , ") " - , color + , colour , message , reset ] @@ -448,3 +455,13 @@ let value = render columns thing !value' <- evaluate value putMessage context (Message now SeverityDebug label (Just value')) + +internal :: Rope -> Rope -> Program τ () +internal label value = do + context <- ask + liftIO $ do + level <- readMVar (verbosityLevelFrom context) + when (isDebug level) $ do + now <- getCurrentTimeNanoseconds + !value' <- evaluate value + putMessage context (Message now SeverityInternal (label <> value') Nothing)