diff --git a/LICENCE b/LICENCE new file mode 100644 --- /dev/null +++ b/LICENCE @@ -0,0 +1,32 @@ +Opinionated Haskell Interoperability + +Copyright © 2018-2019 Operational Dynamics Consulting, Pty Ltd and Others +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. 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. + + 3. Neither the name of the project nor the names of its 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/core-program.cabal b/core-program.cabal new file mode 100644 --- /dev/null +++ b/core-program.cabal @@ -0,0 +1,69 @@ +cabal-version: 1.12 +name: core-program +version: 0.2.0.0 +license: BSD3 +license-file: LICENCE +copyright: © 2018-2019 Operational Dynamics Consulting Pty Ltd, and Others +maintainer: Andrew Cowie +author: Andrew Cowie +stability: experimental +tested-with: ghc ==8.6.5 +homepage: https://github.com/oprdyn/unbeliever#readme +bug-reports: https://github.com/oprdyn/unbeliever/issues +synopsis: Opinionated Haskell Interoperability +description: + A library to help build command-line programs, both tools and + longer-running daemons. + . + A description of this package, a list of features, and some background + to its design is contained in the + + on GitHub. + . + See "Core.Program.Execute" to get started. +category: System +build-type: Simple + +source-repository head + type: git + location: https://github.com/oprdyn/unbeliever + +library + exposed-modules: + Core.Program + Core.Program.Arguments + Core.Program.Execute + Core.Program.Logging + Core.Program.Metadata + Core.Program.Unlift + Core.System + Core.System.Base + Core.System.External + hs-source-dirs: lib + other-modules: + Core.Program.Context + Core.Program.Signal + default-language: Haskell2010 + ghc-options: -Wall -Wwarn -fwarn-tabs + build-depends: + async >=2.2.2 && <2.3, + base >=4.11 && <5, + bytestring >=0.10.8.2 && <0.11, + chronologique >=0.3.1.1 && <0.4, + core-data >=0.2.0.0 && <0.3, + core-text >=0.2.0.0 && <0.3, + directory >=1.3.3.0 && <1.4, + exceptions >=0.10.2 && <0.11, + hashable >=1.2.7.0 && <1.3, + hourglass >=0.2.12 && <0.3, + mtl >=2.2.2 && <2.3, + prettyprinter >=1.2.1 && <1.3, + prettyprinter-ansi-terminal >=1.1.1.2 && <1.2, + safe-exceptions >=0.1.7.0 && <0.2, + stm >=2.5.0.0 && <2.6, + template-haskell >=2.14.0.0 && <2.15, + terminal-size >=0.3.2.1 && <0.4, + text >=1.2.3.1 && <1.3, + text-short >=0.1.2 && <0.2, + transformers >=0.5.6.2 && <0.6, + unix >=2.7.2.2 && <2.8 diff --git a/lib/Core/Program.hs b/lib/Core/Program.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program.hs @@ -0,0 +1,46 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-| +Support for building command-line programs, ranging from simple tools to +long-running daemons. + +This is intended to be used directly: + +@ +import "Core.Program" +@ + +the submodules are mostly there to group documentation. +-} +-- actually, they're there to group implementation too, but hey. +module Core.Program + ( + {-* Executing a program -} +{-| +A top-level Program type giving you unified access to logging, concurrency, +and more. +-} + module Core.Program.Execute + , module Core.Program.Unlift + , module Core.Program.Metadata + + {-* Command-line argument parsing -} +{-| +Including declaring what options your program accepts, generating help, and +for more complex cases [sub]commands, mandatory arguments, and environment +variable handling. +-} + , module Core.Program.Arguments + {-* Logging facilities -} +{-| +Facilities for noting events through your program and doing debugging. +-} + , module Core.Program.Logging + ) where + +import Core.Program.Arguments +import Core.Program.Execute +import Core.Program.Logging +import Core.Program.Metadata +import Core.Program.Unlift + diff --git a/lib/Core/Program/Arguments.hs b/lib/Core/Program/Arguments.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Arguments.hs @@ -0,0 +1,841 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StrictData #-} +{-# OPTIONS_HADDOCK prune #-} + +{-| +Invoking a command-line program (be it tool or daemon) consists of listing +the name of its binary, optionally supplying various options to adjust the +behaviour of the program, and then supplying mandatory arguments, if any +are specified. + +On startup, we parse any arguments passed in from the shell into +@name,value@ pairs and incorporated into the resultant configuration stored +in the program's Context. + +Additionally, this module allows you to specify environment variables that, +if present, will be incorporated into the stored configuration. +-} +module Core.Program.Arguments + ( + {-* Setup -} + Config + , blank + , simple + , complex + , baselineOptions + , Parameters(..) + , ParameterValue(..) + {-* Options and Arguments -} + , LongName(..) + , ShortName + , Description + , Options(..) + {-* Programs with Commands -} + , Commands(..) + {-* Internals -} + , parseCommandLine + , extractValidEnvironments + , InvalidCommandLine(..) + , buildUsage + , buildVersion + ) where + +import Control.Exception.Safe (Exception(displayException)) +import Data.Hashable (Hashable) +import qualified Data.List as List +import Data.Maybe (fromMaybe) +import Data.Text.Prettyprint.Doc (Doc, Pretty(..), nest, fillCat + , emptyDoc, hardline, softline, fillBreak, align, (<+>), fillSep, indent) +import Data.Text.Prettyprint.Doc.Util (reflow) +import Data.String +import System.Environment (getProgName) + +import Core.Data.Structures +import Core.System.Base +import Core.Text.Rope +import Core.Text.Utilities +import Core.Program.Metadata + +{-| +Single letter "short" options (omitting the "@-@" prefix, obviously). +-} +type ShortName = Char + +{-| +The description of an option, command, or environment variable (for use +when rendering usage information in response to @--help@ on the +command-line). +-} +type Description = Rope + +{-| +The name of an option, command, or agument (omitting the "@--@" prefix in +the case of options). This identifier will be used to generate usage text +in response to @--help@ and by you later when retreiving the values of the +supplied parameters after the program has initialized. + +Turn on __@OverloadedStrings@__ when specifying configurations, obviously. +-} +newtype LongName = LongName String + deriving (Show, IsString, Eq, Hashable, Ord) + +instance Key LongName + +instance Pretty LongName where + pretty (LongName name) = pretty name + +{-| +The setup for parsing the command-line arguments of your program. You build +a @Config@ with 'simple' or 'complex', and pass it to +'Core.Program.Context.configure'. +-} +data Config + = Blank + | Simple [Options] + | Complex [Commands] + +-- +-- Those constructors are not exposed [and functions wrapping them are] partly +-- for documentation convenience, partly for aesthetics (after a point too many +-- constructors got a bit hard to differentiate betwen), and mostly so that if +-- configure's argument turns into a monad like RequestBuilder we have +-- somewhere to make that change. +-- + +{-| +A completely empty configuration, without the default debugging and logging +options. Your program won't process any command-line options or arguments, +which would be weird in most cases. Prefer 'simple'. +-} +blank :: Config +blank = Blank + +{-| +Declare a simple (as in normal) configuration for a program with any number +of optional parameters and mandatory arguments. For example: + +@ +main :: 'IO' () +main = do + context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('simple' + [ 'Option' "host" ('Just' \'h\') 'Empty' ['quote'| + Specify an alternate host to connect to when performing the + frobnication. The default is \"localhost\". + |] + , 'Option' "port" ('Just' \'p\') 'Empty' ['quote'| + Specify an alternate port to connect to when frobnicating. + |] + , 'Option' "dry-run" 'Nothing' ('Value' \"TIME\") ['quote'| + Perform a trial run at the specified time but don't actually + do anything. + |] + , 'Option' "quiet" ('Just' \'q\') 'Empty' ['quote'| + Supress normal output. + |] + , 'Argument' "filename" ['quote'| + The file you want to frobnicate. + |] + ]) + + 'Core.Program.Execute.executeWith' context program +@ + +which, if you build that into an executable called @snippet@ and invoke it +with @--help@, would result in: + +@ +$ __./snippet --help__ +Usage: + + snippet [OPTIONS] filename + +Available options: + + -h, --host Specify an alternate host to connect to when performing the + frobnication. The default is \"localhost\". + -p, --port Specify an alternate port to connect to when frobnicating. + --dry-run=TIME + Perform a trial run at the specified time but don't + actually do anything. + -q, --quiet Supress normal output. + -v, --verbose Turn on event tracing. By default the logging stream will go + to standard output on your terminal. + --debug Turn on debug level logging. Implies --verbose. + +Required arguments: + + filename The file you want to frobnicate. +$ __|__ +@ + +For information on how to use the multi-line string literals shown here, +see 'quote' in "Core.Text.Utilities". +-} +simple :: [Options] -> Config +simple options = Simple (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 +that will be honoured by the program. Each command can have a list of local +options and arguments as needed. For example: + +@ +program :: 'Core.Program.Execute.Program' MusicAppStatus () +program = ... + +main :: 'IO' () +main = do + context <- 'Core.Program.Execute.configure' ('Core.Program.Execute.fromPackage' version) 'mempty' ('complex' + [ 'Global' + [ 'Option' "station-name" 'Nothing' ('Value' \"NAME\") ['quote'| + Specify an alternate radio station to connect to when performing + actions. The default is \"BBC Radio 1\". + |] + , 'Variable' \"PLAYER_FORCE_HEADPHONES\" ['quote'| + If set to @1@, override the audio subsystem to force output + to go to the user's headphone jack. + |] + ] + , 'Command' \"play\" \"Play the music.\" + [ 'Option' "repeat" 'Nothing' 'Empty' ['quote'| + Request that they play the same song over and over and over + again, simulating the effect of listening to a Top 40 radio + station. + |] + ] + , 'Command' \"rate\" \"Vote on whether you like the song or not.\" + [ 'Option' "academic" 'Nothing' 'Empty' ['quote'| + The rating you wish to apply, from A+ to F. This is the + default, so there is no reason whatsoever to specify this. + But some people are obsessive, compulsive, and have time on + their hands. + |] + , 'Option' "numeric" 'Nothing' 'Empty' ['quote'| + Specify a score as a number from 0 to 100 instead of an + academic style letter grade. Note that negative values are + not valid scores, despite how vicerally satisfying that + would be for music produced in the 1970s. + |] + , 'Option' "unicode" ('Just' \'c\') 'Empty' ['quote'| + Instead of a score, indicate your rating with a single + character. This allows you to use emoji, so that you can + rate a piece \'💩\', as so many songs deserve. + |] + , 'Argument' "score" ['quote'| + The rating you wish to apply. + |] + ] + ]) + + 'Core.Program.Execute.executeWith' context program +@ + +is a program with one global option (in addition to the default ones) [and +an environment variable] and two commands: @play@, with one option; and +@rate@, with two options and a required argument. It also is set up to +carry its top-level application state around in a type called +@MusicAppStatus@ (implementing 'Monoid' and so initialized here with +'mempty'. This is a good pattern to use given we are so early in the +program's lifetime). + +The resultant program could be invoked as in these examples: + +@ +$ __./player --station-name=\"KBBL-FM 102.5\" play__ +$ +@ + +@ +$ __./player -v rate --numeric 76__ +$ +@ + +For information on how to use the multi-line string literals shown here, +see 'quote' in "Core.Text.Utilities". +-} +complex :: [Commands] -> Config +complex commands = Complex (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/ +and /docker/. +-} +data Commands + = Global [Options] + | Command LongName Description [Options] + +{-| +Declaration of an optional switch or mandatory argument expected by a +program. + +'Option' takes a long name for the option, a short single character +abbreviation if offered for convenience, whether or not the option takes a +value (and what label to show in help output) and a description for use +when displaying usage via @--help@. + +'Argument' indicates a mandatory argument and takes the long name used +to identify the parsed value from the command-line, and likewise a +description for @--help@ output. + +By convention option and argument names are both /lower case/. If the +identifier is two or more words they are joined with a hyphen. Examples: + +@ + [ 'Option' \"quiet\" ('Just' \'q'\) 'Empty' \"Keep the noise to a minimum.\" + , 'Option' \"dry-run\" 'Nothing' ('Value' \"TIME\") \"Run a simulation of what would happen at the specified time.\" + , 'Argument' \"username\" \"The user to delete from the system.\" + ] +@ + +By convention a /description/ is one or more complete sentences each of +which ends with a full stop. For options that take values, use /upper case/ +when specifying the label to be used in help output. + +'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 +with an underscore: + +@ + [ ... + , 'Variable' \"CRAZY_MODE\" "Specify how many crazies to activate." + , ... + ] +@ +-} +data Options + = Option LongName (Maybe ShortName) ParameterValue Description + | Argument LongName Description + | Variable LongName Description + + +{-| +Individual parameters read in off the command-line can either have a value +(in the case of arguments and options taking a value) or be empty (in the +case of options that are just flags). +-} +data ParameterValue + = Value String + | Empty + deriving (Show, Eq) + +instance IsString ParameterValue where + fromString x = Value x + +{-| +Result of having processed the command-line and the environment. You get at +the parsed command-line options and arguments by calling +'Core.Program.Execute.getCommandLine' within a +'Core.Program.Execute.Program' block. + +Each option and mandatory argument parsed from the command-line is either +standalone (in the case of switches and flags, such as @--quiet@) or has an +associated value. In the case of options the key is the name of the option, +and for arguments it is the implicit name specified when setting up the +program. For example, in: + +@ +$ ./submit --username=gbmh GraceHopper_Resume.pdf +@ + +the option has parameter name \"@username@\" and value \"@gmbh@\"; the +argument has parameter name \"filename\" (assuming that is what was +declared in the 'Argument' entry) and a value being the Admiral's CV. This +would be returned as: + +@ +'Parameters' 'Nothing' [("username","gbmh"), ("filename","GraceHopper_Resume.pdf")] [] +@ + +The case of a complex command such as /git/ or /stack/, you get the specific +mode chosen by the user returned in the first position: + +@ +$ missiles launch --all +@ + +would be parsed as: + +@ +'Parameters' ('Just' \"launch\") [("all",Empty)] [] +@ + +-} +data Parameters + = Parameters { + commandNameFrom :: Maybe LongName + , parameterValuesFrom :: Map LongName ParameterValue + , environmentValuesFrom :: Map LongName ParameterValue + } deriving (Show, Eq) + + +baselineOptions :: [Options] +baselineOptions = + [ Option "verbose" (Just 'v') Empty [quote| + Turn on event tracing. By default the logging stream will go to + standard output on your terminal. + |] + , Option "debug" Nothing Empty [quote| + Turn on debug level logging. Implies --verbose. + |] + ] + +{-| +Different ways parsing a simple or complex command-line can fail. +-} +data InvalidCommandLine + = InvalidOption String {-^ Something was wrong with the way the user specified [usually a short] option. -} + | UnknownOption String {-^ User specified an option that doesn't match any in the supplied configuration. -} + | MissingArgument LongName + {-^ Arguments are mandatory, and this one is missing. -} + | UnexpectedArguments [String] + {-^ Arguments are present we weren't expecting. -} + | UnknownCommand String {-^ In a complex configuration, user specified a command that doesn't match any in the configuration. -} + | NoCommandFound {-^ In a complex configuration, user didn't specify a command. -} + | HelpRequest (Maybe LongName) + {-^ In a complex configuration, usage information was requested with @--help@, either globally or for the supplied command. -} + | VersionRequest + {-^ Display of the program version requested with @--version@. -} + deriving (Show, Eq) + +instance Exception InvalidCommandLine where + displayException e = case e of + InvalidOption arg -> + let + one = "Option '" ++ arg ++ "' illegal.\n\n" + two = [quote| +Options must either be long form with a double dash, for example: + + --verbose + +or, when available with a short version, a single dash and a single +character. They need to be listed individually: + + -v -a + +When an option takes a value it has to be in long form and the value +indicated with an equals sign, for example: + + --tempdir=/tmp + +with complex values escaped according to the rules of your shell: + + --username="Ada Lovelace" + +For options valid in this program, please see --help. + |] + in + one ++ two + UnknownOption name -> "Sorry, option '" ++ name ++ "' not recognized." + MissingArgument (LongName name) -> "Mandatory argument '" ++ name ++ "' missing." + UnexpectedArguments args -> + let + quoted = List.intercalate "', '" args + in [quote| +Unexpected trailing arguments: + +|] ++ quoted ++ [quote| + +For arguments expected by this program, please see --help. +|] + UnknownCommand first -> "Hm. Command '" ++ first ++ "' not recognized." + NoCommandFound -> [quote| +No command specified. +Usage is of the form: + + |] ++ programName ++ [quote| [GLOBAL OPTIONS] COMMAND [LOCAL OPTIONS] [ARGUMENTS] + +See --help for details. +|] + -- handled by parent module calling back into here buildUsage + HelpRequest _ -> "" + + -- handled by parent module calling back into here buildVersion + VersionRequest -> "" + +programName :: String +programName = unsafePerformIO getProgName + +{-| +Given a program configuration schema and the command-line arguments, +process them into key/value pairs in a Parameters object. + +This results in 'InvalidCommandLine' on the left side if one of the passed +in options is unrecognized or if there is some other problem handling +options or arguments (because at that point, we want to rabbit right back +to the top and bail out; there's no recovering). + +This isn't something you'll ever need to call directly; it's exposed for +testing convenience. This function is invoked when you call +'Core.Program.Context.configure' or 'Core.Program.Execute.execute' (which +calls 'configure' with a default @Config@ when initializing). +-} +parseCommandLine :: Config -> [String] -> Either InvalidCommandLine Parameters +parseCommandLine config argv = case config of + Blank -> return (Parameters Nothing emptyMap emptyMap) + + Simple options -> do + params <- extractor Nothing options argv + return (Parameters Nothing params emptyMap) + + Complex commands -> + let + globalOptions = extractGlobalOptions commands + modes = extractValidModes commands + in do + (possibles,first,remainingArgs) <- splitCommandLine argv + params1 <- extractor Nothing globalOptions possibles + (mode,localOptions) <- parseIndicatedCommand modes first + params2 <- extractor (Just mode) localOptions remainingArgs + return (Parameters (Just mode) ((<>) params1 params2) emptyMap) + where + + extractor :: Maybe LongName -> [Options] -> [String] -> Either InvalidCommandLine (Map LongName ParameterValue) + extractor mode options args = + let + (possibles,arguments) = List.partition isOption args + valids = extractValidNames options + shorts = extractShortNames options + needed = extractRequiredArguments options + in do + list1 <- parsePossibleOptions mode valids shorts possibles + list2 <- parseRequiredArguments needed arguments + return ((<>) (intoMap list1) (intoMap list2)) + +isOption :: String -> Bool +isOption arg = case arg of + ('-':_) -> True + _ -> False + +parsePossibleOptions + :: Maybe LongName + -> Set LongName + -> Map ShortName LongName + -> [String] + -> Either InvalidCommandLine [(LongName,ParameterValue)] +parsePossibleOptions mode valids shorts args = mapM f args + where + f arg = case arg of + "--help" -> Left (HelpRequest mode) + "-?" -> Left (HelpRequest mode) + "--version" -> Left VersionRequest + ('-':'-':name) -> considerLongOption name + ('-':c:[]) -> considerShortOption c + _ -> Left (InvalidOption arg) + + considerLongOption :: String -> Either InvalidCommandLine (LongName,ParameterValue) + considerLongOption arg = + let + (name,value) = List.span (/= '=') arg + candidate = LongName name + -- lose the '=' + value' = case List.uncons value of + Just (_,remainder) -> Value remainder + Nothing -> Empty + in + if containsElement candidate valids + then Right (candidate,value') + else Left (UnknownOption ("--" ++ name)) + + considerShortOption :: Char -> Either InvalidCommandLine (LongName,ParameterValue) + considerShortOption c = + case lookupKeyValue c shorts of + Just name -> Right (name,Empty) + Nothing -> Left (UnknownOption ['-',c]) + +parseRequiredArguments + :: [LongName] + -> [String] + -> Either InvalidCommandLine [(LongName,ParameterValue)] +parseRequiredArguments needed argv = iter needed argv + where + iter :: [LongName] -> [String] -> Either InvalidCommandLine [(LongName,ParameterValue)] + + iter [] [] = Right [] + -- more arguments supplied than expected + iter [] args = Left (UnexpectedArguments 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) + +parseIndicatedCommand + :: Map LongName [Options] + -> String + -> Either InvalidCommandLine (LongName,[Options]) +parseIndicatedCommand modes first = + let + candidate = LongName first + in + case lookupKeyValue candidate modes of + Just options -> Right (candidate,options) + Nothing -> Left (UnknownCommand first) + +-- +-- Ok, the f,g,h,... was silly. But hey :) +-- + +extractValidNames :: [Options] -> Set LongName +extractValidNames options = + foldr f emptySet options + where + f :: Options -> Set LongName -> Set LongName + f (Option longname _ _ _) valids = insertElement longname valids + f _ valids = valids + +extractShortNames :: [Options] -> Map ShortName LongName +extractShortNames options = + foldr g emptyMap options + where + g :: Options -> Map ShortName LongName -> Map ShortName LongName + g (Option longname shortname _ _) shorts = case shortname of + Just shortchar -> insertKeyValue shortchar longname shorts + Nothing -> shorts + g _ shorts = shorts + +extractRequiredArguments :: [Options] -> [LongName] +extractRequiredArguments arguments = + foldr h [] arguments + where + h :: Options -> [LongName] -> [LongName] + h (Argument longname _) needed = longname:needed + h _ needed = needed + +extractGlobalOptions :: [Commands] -> [Options] +extractGlobalOptions commands = + foldr j [] commands + where + j :: Commands -> [Options] -> [Options] + j (Global options) valids = options ++ valids + j _ valids = valids + +extractValidModes :: [Commands] -> Map LongName [Options] +extractValidModes commands = + foldr k emptyMap commands + where + k :: Commands -> Map LongName [Options] -> Map LongName [Options] + k (Command longname _ options) modes = insertKeyValue longname options modes + k _ modes = modes + +splitCommandLine :: [String] -> Either InvalidCommandLine ([String], String, [String]) +splitCommandLine args = + let + (possibles,remainder) = List.span isOption args + x = List.uncons remainder + in + case x of + Just (mode,remainingArgs) -> Right (possibles,mode,remainingArgs) + Nothing -> if (List.elem "--help" possibles) + then Left (HelpRequest Nothing) + else Left NoCommandFound + +-- +-- Environment variable handling +-- + +extractValidEnvironments :: Maybe LongName -> Config -> Set LongName +extractValidEnvironments mode config = case config of + Blank -> emptySet + + Simple options -> extractVariableNames options + + Complex commands -> + let + globals = extractGlobalOptions commands + variables1 = extractVariableNames globals + + locals = extractLocalVariables commands (fromMaybe "" mode) + variables2 = extractVariableNames locals + in + variables1 <> variables2 + +extractLocalVariables :: [Commands] -> LongName -> [Options] +extractLocalVariables commands mode = + foldr k [] commands + where + k :: Commands -> [Options] -> [Options] + k (Command name _ options) acc = if name == mode then options else acc + k _ acc = acc + + +extractVariableNames :: [Options] -> Set LongName +extractVariableNames options = + foldr f emptySet options + where + f :: Options -> Set LongName -> Set LongName + f (Variable longname _) valids = insertElement longname valids + f _ valids = valids + + + +-- +-- The code from here on is formatting code. It's fairly repetative +-- and crafted to achieve a specific aesthetic output. Rather messy. +-- I'm sure it could be done "better" but no matter; this is on the +-- path to an exit and return to user's command line. +-- + +buildUsage :: Config -> Maybe LongName -> Doc ann +buildUsage config mode = case config of + Blank -> emptyDoc + + Simple options -> + let + (o,a) = partitionParameters options + in + "Usage:" <> hardline <> hardline + <> indent 4 (nest 4 (fillCat + [ pretty programName + , optionsSummary o + , argumentsSummary a + ])) <> hardline + <> optionsHeading o + <> formatParameters o + <> argumentsHeading a + <> formatParameters a + + Complex commands -> + let + globalOptions = extractGlobalOptions commands + modes = extractValidModes commands + + (oG,_) = partitionParameters globalOptions + in + "Usage:" <> hardline <> hardline <> case mode of + Nothing -> + indent 2 (nest 4 (fillCat + [ pretty programName + , globalSummary oG + , commandSummary modes + ])) <> hardline + <> globalHeading oG + <> formatParameters oG + <> commandHeading modes + <> formatCommands commands + + Just longname -> + let + (oL,aL) = case lookupKeyValue longname modes of + Just localOptions -> partitionParameters localOptions + Nothing -> error "Illegal State" + in + indent 2 (nest 4 (fillCat + [ pretty programName + , globalSummary oG + , commandSummary modes + , localSummary oL + , argumentsSummary aL + ])) <> hardline + <> localHeading oL + <> formatParameters oL + <> argumentsHeading aL + <> formatParameters aL + + where + partitionParameters :: [Options] -> ([Options],[Options]) + partitionParameters options = foldr f ([],[]) options + + optionsSummary :: [Options] -> Doc ann + optionsSummary os = if length os > 0 then softline <> "[OPTIONS]" else emptyDoc + + optionsHeading os = if length os > 0 then hardline <> "Available options:" <> hardline else emptyDoc + + globalSummary os = if length os > 0 then softline <> "[GLOBAL OPTIONS]" else emptyDoc + globalHeading os = if length os > 0 + then hardline <> "Global options:" <> hardline + else emptyDoc + + localSummary os = if length os > 0 then softline <> "[LOCAL OPTIONS]" else emptyDoc + localHeading os = if length os > 0 + then hardline <> "Options to the '" <> commandName <> "' command:" <> hardline + else emptyDoc + + commandName :: Doc ann + commandName = case mode of + Just (LongName name) -> pretty name + Nothing -> "COMMAND..." + + argumentsSummary :: [Options] -> Doc ann + argumentsSummary as = " " <> fillSep (fmap pretty (extractRequiredArguments as)) + + argumentsHeading as = if length as > 0 then hardline <> "Required arguments:" <> hardline 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 + + f :: Options -> ([Options],[Options]) -> ([Options],[Options]) + f o@(Option _ _ _ _) (opts,args) = (o:opts,args) + f a@(Argument _ _) (opts,args) = (opts,a:args) + f (Variable _ _) (opts,args) = (opts,args) + + formatParameters :: [Options] -> Doc ann + formatParameters [] = emptyDoc + formatParameters options = hardline <> foldr g emptyDoc options + +-- +-- 16 characters width for short option, long option, and two spaces. If the +-- long option's name is wider than this the description will be moved to +-- the next line. +-- +-- Arguments are aligned to the character of the short option; looks +-- pretty good and better than waiting until column 8. +-- + + g :: Options -> Doc ann -> Doc ann + g (Option longname shortname valued description) acc = + let + s = case shortname of + Just shortchar -> " -" <> pretty shortchar <> ", --" + Nothing -> " --" + l = pretty longname + d = fromRope description + in case valued of + Empty -> + fillBreak 16 (s <> l <> " ") <+> align (reflow d) <> hardline <> acc + Value label -> + fillBreak 16 (s <> l <> "=" <> pretty label <> " ") <+> align (reflow d) <> hardline <> acc + + g (Argument longname description) acc = + let + l = pretty longname + d = fromRope description + in + fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc + g (Variable longname description) acc = + let + l = pretty longname + d = fromRope description + in + fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc + + formatCommands :: [Commands] -> Doc ann + formatCommands commands = hardline <> foldr h emptyDoc commands + + h :: Commands -> Doc ann -> Doc ann + h (Command longname description _) acc = + let + l = pretty longname + d = fromRope description + in + fillBreak 16 (" " <> l <> " ") <+> align (reflow d) <> hardline <> acc + h _ acc = acc + +buildVersion :: Version -> Doc ann +buildVersion version = + pretty (projectNameFrom version) + <+> "v" + <> pretty (versionNumberFrom version) + <> hardline + diff --git a/lib/Core/Program/Context.hs b/lib/Core/Program/Context.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Context.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK hide #-} + +-- This is an Internal module, hidden from Haddock +module Core.Program.Context + ( + Context(..) + , None(..) + , isNone + , configure + , Message(..) + , Verbosity(..) + , Program(..) + , unProgram + , getContext + , subProgram + , getConsoleWidth + ) where + +import Prelude hiding (log) +import Chrono.TimeStamp (TimeStamp, getCurrentTimeNanoseconds) +import Control.Concurrent.MVar (MVar, newMVar, newEmptyMVar) +import Control.Concurrent.STM.TQueue (TQueue, newTQueueIO) +import Control.Exception.Safe (displayException) +import qualified Control.Exception.Safe as Safe (throw, catch) +import Control.Monad.Catch (MonadThrow(throwM), MonadCatch(catch)) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Reader.Class (MonadReader(..)) +import Control.Monad.Trans.Reader (ReaderT(..)) +import Data.Foldable (foldrM) +import Data.Text.Prettyprint.Doc (layoutPretty, LayoutOptions(..), PageWidth(..)) +import Data.Text.Prettyprint.Doc.Render.Text (renderIO) +import qualified System.Console.Terminal.Size as Terminal (Window(..), size) +import System.Environment (getArgs, getProgName, lookupEnv) +import System.Exit (ExitCode(..), exitWith) + +import Core.Data.Structures +import Core.System.Base hiding (throw, catch) +import Core.Text.Rope +import Core.Program.Arguments +import Core.Program.Metadata + +{-| +Internal context for a running program. You access this via actions in the +'Program' monad. The principal item here is the user-supplied top-level +application data of type @τ@ which can be retrieved with +'Core.Program.Execute.getApplicationState' and updated with +'Core.Program.Execute.setApplicationState'. +-} +-- +-- The fieldNameFrom idiom is an experiment. Looks very strange, +-- certainly, here in the record type definition and when setting +-- fields, but for the common case of getting a value out of the +-- record, a call like +-- +-- fieldNameFrom context +-- +-- isn't bad at all, and no worse than the leading underscore +-- convention. +-- +-- _fieldName context +-- +-- (I would argue better, since _ is already so overloaded as the +-- wildcard symbol in Haskell). Either way, the point is to avoid a +-- bare fieldName because so often you have want to be able to use +-- that field name as a local variable name. +-- +data Context τ = Context { + programNameFrom :: MVar Rope + , versionFrom :: Version + , commandLineFrom :: Parameters + , exitSemaphoreFrom :: MVar ExitCode + , startTimeFrom :: TimeStamp + , terminalWidthFrom :: Int + , verbosityLevelFrom :: MVar Verbosity + , outputChannelFrom :: TQueue Rope + , loggerChannelFrom :: TQueue Message + , applicationDataFrom :: MVar τ +} + +{-| +A 'Program' with no user-supplied state to be threaded throughout the +computation. + +The "Core.Program.Execute" framework makes your top-level application state +available at the outer level of your process. While this is a feature that +most substantial programs rely on, it is /not/ needed for many simple +tasks or when first starting out what will become a larger project. + +This is effectively the unit type, but this alias is here to clearly signal +a user-data type is not a part of the program semantics. + +-} +-- Bids are open for a better name for this +data None = None + deriving (Show, Eq) + +isNone :: None -> Bool +isNone _ = True + + +data Message = Message TimeStamp Verbosity Rope (Maybe Rope) + +data Verbosity = Output | Event | Debug + deriving Show + +{-| +The type of a top-level program. + +You would use this by writing: + +@ +module Main where + +import "Core.Program" + +main :: 'IO' () +main = 'Core.Program.Execute.execute' program +@ + +and defining a program that is the top level of your application: + +@ +program :: 'Program' 'None' () +@ + +Such actions are combinable; you can sequence them (using bind in +do-notation) or run them in parallel, but basically you should need one +such object at the top of your application. + +/Type variables/ + +A 'Program' has a user-supplied application state and a return type. + +The first type variable, @τ@, is your application's state. This is an +object that will be threaded through the computation and made available to +your code in the 'Program' monad. While this is a common requirement of the +outer code layer in large programs, it is often /not/ necessary in small +programs or when starting new projects. You can mark that there is no +top-level application state required using 'None' and easily change it +later if your needs evolve. + +The return type, @α@, is usually unit as this effectively being called +directly from @main@ and Haskell programs have type @'IO' ()@. That is, +they don't return anything; I/O having already happened as side effects. + +/Programs in separate modules/ + +One of the quirks of Haskell is that it is difficult to refer to code in +the Main module when you've got a number of programs kicking around in a +project each with a @main@ function. So you're best off putting your +top-level 'Program' actions in a separate modules so you can refer to them +from test suites and example snippets. +-} +newtype Program τ α = Program (ReaderT (Context τ) IO α) + deriving (Functor, Applicative, Monad, MonadIO, MonadReader (Context τ)) + +unProgram :: Program τ α -> ReaderT (Context τ) IO α +unProgram (Program r) = r + +{-| +Get the internal @Context@ of the running @Program@. There is ordinarily no +reason to use this; to access your top-level application data @τ@ within +the @Context@ use 'Core.Program.Execute.getApplicationState'. +-} +getContext :: Program τ (Context τ) +getContext = do + context <- ask + return context + +{-| +Run a subprogram from within a lifted @IO@ block. +-} +subProgram :: Context τ -> Program τ α -> IO α +subProgram context (Program r) = do + runReaderT r context + +-- +-- This is complicated. The **safe-exceptions** library exports a +-- `throwM` which is not the `throwM` class method from MonadThrow. +-- See https://github.com/fpco/safe-exceptions/issues/31 for +-- discussion. In any event, the re-exports flow back to +-- Control.Monad.Catch from **exceptions** and Control.Exceptions in +-- **base**. In the execute actions, we need to catch everything (including +-- asynchronous exceptions); elsewhere we will use and wrap/export +-- **safe-exceptions**'s variants of the functions. +-- +instance MonadThrow (Program τ) where + throwM = liftIO . Safe.throw + +unHandler :: (ε -> Program τ α) -> (ε -> ReaderT (Context τ) IO α) +unHandler = fmap unProgram + +instance MonadCatch (Program τ) where + catch :: Exception ε => (Program τ) α -> (ε -> (Program τ) α) -> (Program τ) α + catch program handler = + let + r = unProgram program + h = unHandler handler + in do + context <- ask + liftIO $ do + Safe.catch + (runReaderT r context) + (\e -> runReaderT (h e) context) + +{-| +Initialize the programs's execution context. This takes care of various +administrative actions, including setting up output channels, parsing +command-line arguments (according to the supplied configuration), and +putting in place various semaphores for internal program communication. +See "Core.Program.Arguments" for details. + +This is also where you specify the initial {blank, empty, default) value +for the top-level user-defined application state, if you have one. Specify +'None' if you aren't using this feature. +-} +configure :: Version -> τ -> Config -> IO (Context τ) +configure version t config = do + start <- getCurrentTimeNanoseconds + + arg0 <- getProgName + n <- newMVar (intoRope arg0) + p <- handleCommandLine version config + q <- newEmptyMVar + columns <- getConsoleWidth + out <- newTQueueIO + log <- newTQueueIO + u <- newMVar t + + l <- handleVerbosityLevel p + + return $! Context { + programNameFrom = n + , versionFrom = version + , commandLineFrom = p + , exitSemaphoreFrom = q + , startTimeFrom = start + , terminalWidthFrom = columns + , verbosityLevelFrom = l + , outputChannelFrom = out + , loggerChannelFrom = log + , applicationDataFrom = u + } + +-- +-- | Probe the width of the terminal, in characters. If it fails to retrieve, +-- for whatever reason, return a default of 80 characters wide. +-- +getConsoleWidth :: IO (Int) +getConsoleWidth = do + window <- Terminal.size + let columns = case window of + Just (Terminal.Window _ w) -> w + Nothing -> 80 + return columns + +-- +-- | Process the command line options and arguments. If an invalid +-- option is encountered or a [mandatory] argument is missing, then +-- the program will terminate here. +-- +{- + We came back here with the error case so we can pass config in to + buildUsage (otherwise we could have done it all in displayException and + called that in Core.Program.Arguments). And, returning here lets us set + up the layout width to match (one off the) actual width of console. +-} +handleCommandLine :: Version -> Config -> IO Parameters +handleCommandLine version config = do + argv <- getArgs + let result = parseCommandLine config argv + case result of + Right parameters -> do + pairs <- lookupEnvironmentVariables config parameters + return parameters { environmentValuesFrom = pairs } + Left e -> case e of + HelpRequest mode -> do + render (buildUsage config mode) + exitWith (ExitFailure 1) + VersionRequest -> do + render (buildVersion version) + exitWith (ExitFailure 1) + _ -> do + putStr "error: " + putStrLn (displayException e) + hFlush stdout + exitWith (ExitFailure 1) + where + render message = do + columns <- getConsoleWidth + let options = LayoutOptions (AvailablePerLine (columns - 1) 1.0) + renderIO stdout (layoutPretty options message) + hFlush stdout + + +lookupEnvironmentVariables :: Config -> Parameters -> IO (Map LongName ParameterValue) +lookupEnvironmentVariables config params = do + let mode = commandNameFrom params + let valids = extractValidEnvironments mode config + + result <- foldrM f emptyMap valids + return result + where + f :: LongName -> (Map LongName ParameterValue) -> IO (Map LongName ParameterValue) + f name@(LongName var) acc = do + result <- lookupEnv var + return $ case result of + Just value -> insertKeyValue name (Value value) acc + Nothing -> acc + + +handleVerbosityLevel :: Parameters -> IO (MVar Verbosity) +handleVerbosityLevel params = do + let result = queryVerbosityLevel params + case result of + Right level -> do + newMVar level + Left exit -> do + putStrLn "error: To set logging level use --verbose or --debug; neither take values." + hFlush stdout + exitWith exit + +queryVerbosityLevel :: Parameters -> Either ExitCode Verbosity +queryVerbosityLevel params = + let + debug = lookupKeyValue "debug" (parameterValuesFrom params) + verbose = lookupKeyValue "verbose" (parameterValuesFrom params) + in + case debug of + Just value -> case value of + Empty -> Right Debug + Value _ -> Left (ExitFailure 2) + Nothing -> case verbose of + Just value -> case value of + Empty -> Right Event + Value _ -> Left (ExitFailure 2) + Nothing -> Right Output diff --git a/lib/Core/Program/Execute.hs b/lib/Core/Program/Execute.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Execute.hs @@ -0,0 +1,538 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK prune #-} + +{-| +Embelish a Haskell command-line program with useful behaviours. + +/Runtime/ + +Sets number of capabilities (heavy-weight operating system threads used by +the GHC runtime to run Haskell green threads) to the number of CPU cores +available (for some reason the default is 1 capability only, which is a bit +silly on a multicore system). + +Install signal handlers to properly terminate the program performing +cleanup as necessary. + +/Logging and output/ + +The 'Program' monad provides functions for both normal output and debug +logging. A common annoyance when building command line tools and daemons is +getting program output to @stdout@ and debug messages interleaved, made +even worse when error messages written to @stderr@ land in the same +console. To avoid this, when all output is sent through a single channel. +This includes both normal output and log messages. + +/Exceptions/ + +Ideally your code should handle (and not leak) exceptions, as is good +practice anywhere in the Haskell ecosystem. As a measure of last resort +however, if an exception is thrown (and not caught) by your program it will +be caught at the outer 'execute' entrypoint, logged for debugging, and then +your program will exit. + +/Customizing the execution context/ + +The 'execute' function will run your 'Program' in a basic 'Context' +initialized with appropriate defaults. Most settings can be changed at +runtime, but to specify the allowed command-line options and expected +arguments you can initialize your program using 'configure' and then run +with 'executeWith'. +-} +module Core.Program.Execute + ( Program () + {-* Running programs -} + , configure + , execute + , executeWith + {-* Exiting a program -} + , terminate + {-* Accessing program context -} + , getCommandLine + , lookupOptionFlag + , lookupOptionValue + , lookupArgument + , getProgramName + , setProgramName + , getVerbosityLevel + , setVerbosityLevel + , getApplicationState + , setApplicationState + , retrieve + , update + {-* Useful actions -} + , output + , input + {-* Concurrency -} + , Thread + , fork + , sleep + {-* Internals -} + , Context + , None(..) + , isNone + , unProgram + , unThread + , invalid + ) where + +import Prelude hiding (log) +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (Async, async, link, cancel + , ExceptionInLinkedThread(..), AsyncCancelled, race_) +import Control.Concurrent.MVar (readMVar, putMVar, modifyMVar_) +import Control.Concurrent.STM (atomically, check) +import Control.Concurrent.STM.TQueue (TQueue, readTQueue, isEmptyTQueue) +import qualified Control.Exception as Base (throwIO) +import Control.Exception.Safe (SomeException, Exception(displayException)) +import qualified Control.Exception.Safe as Safe (throw, catchesAsync) +import Control.Monad (when, forever) +import Control.Monad.Catch (Handler(..)) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Reader.Class (MonadReader(ask)) +import qualified Data.ByteString as B (hPut) +import qualified Data.ByteString.Char8 as C (singleton) +import GHC.Conc (numCapabilities, getNumProcessors, setNumCapabilities) +import GHC.IO.Encoding (setLocaleEncoding, utf8) +import System.Exit (ExitCode(..)) +import qualified System.Posix.Process as Posix (exitImmediately) + +import Core.Data.Structures +import Core.Text.Bytes +import Core.Text.Rope +import Core.System.Base +import Core.Program.Context +import Core.Program.Logging +import Core.Program.Signal +import Core.Program.Arguments + +-- execute actual "main" +executeAction :: Context τ -> Program τ α -> IO () +executeAction context program = + let + quit = exitSemaphoreFrom context + in do + _ <- subProgram context program + putMVar quit ExitSuccess + +-- +-- If an exception escapes, we'll catch it here. The displayException +-- value for some exceptions is really quit unhelpful, so we pattern +-- match the wrapping gumpf away for cases as we encounter them. The +-- final entry is the catch-all; the first is what we get from the +-- terminate action. +-- +escapeHandlers :: Context c -> [Handler IO ()] +escapeHandlers context = [ + Handler (\ (exit :: ExitCode) -> done exit) + , Handler (\ (_ :: AsyncCancelled) -> pass) + , Handler (\ (ExceptionInLinkedThread _ e) -> bail e) + , Handler (\ (e :: SomeException) -> bail e) + ] + where + quit = exitSemaphoreFrom context + + pass :: IO () + pass = return () + + done :: ExitCode -> IO () + done exit = do + putMVar quit exit + + bail :: Exception e => e -> IO () + bail e = + let + text = intoRope (displayException e) + in do + subProgram context $ do + setVerbosityLevel Debug + event text + putMVar quit (ExitFailure 127) + +-- +-- If an exception occurs in one of the output handlers, its failure causes +-- a subsequent race condition when the program tries to clean up and drain +-- the queues. So we use `exitImmediately` (which we normally avoid, as it +-- unhelpfully destroys the parent process if you're in ghci) because we +-- really need the process to go down and we're in an inconsistent state +-- where debug or console output is no longer possible. +-- +collapseHandlers :: [Handler IO ()] +collapseHandlers = + [ Handler (\ (e :: AsyncCancelled) -> do + Base.throwIO e) + , Handler (\ (e :: SomeException) -> do + putStrLn "error: Output handler collapsed" + print e + Posix.exitImmediately (ExitFailure 99)) + ] + +{-| +Embelish a program with useful behaviours. See module header +"Core.Program.Execute" for a detailed description. Internally this function +calls 'configure' with an appropriate default when initializing. +-} +execute :: Program None α -> IO () +execute program = do + context <- configure "" None (simple []) + executeWith context program + +{-| +Embelish a program with useful behaviours, supplying a configuration +for command-line options & argument parsing and an initial value for +the top-level application state, if appropriate. +-} +executeWith :: Context τ -> Program τ α -> IO () +executeWith context program = do + -- command line +RTS -Nn -RTS value + when (numCapabilities == 1) (getNumProcessors >>= setNumCapabilities) + + -- force UTF-8 working around bad VMs + setLocaleEncoding utf8 + + let quit = exitSemaphoreFrom context + level = verbosityLevelFrom context + out = outputChannelFrom context + log = loggerChannelFrom context + + -- set up standard output + o <- async $ do + Safe.catchesAsync + (processStandardOutput out) + (collapseHandlers) + + -- set up debug logger + l <- async $ do + Safe.catchesAsync + (processDebugMessages log) + (collapseHandlers) + + -- set up signal handlers + _ <- async $ do + setupSignalHandlers quit level + + -- run actual program, ensuring to trap uncaught exceptions + m <- async $ do + Safe.catchesAsync + (executeAction context program) + (escapeHandlers context) + + code <- readMVar quit + cancel m + + -- drain message queues. Allow 0.1 seconds, then timeout, in case + -- something has gone wrong and queues don't empty. + race_ + (do + atomically $ do + done2 <- isEmptyTQueue log + check done2 + + done1 <- isEmptyTQueue out + check done1) + (do + threadDelay 100000 + putStrLn "error: Timeout") + + threadDelay 100 -- instead of yield + hFlush stdout + + cancel l + cancel o + + -- exiting this way avoids "Exception: ExitSuccess" noise in GHCi + if code == ExitSuccess + then return () + else (Base.throwIO code) + + +processStandardOutput :: TQueue Rope -> IO () +processStandardOutput out = do + forever $ do + text <- atomically (readTQueue out) + + hWrite stdout text + B.hPut stdout (C.singleton '\n') + +processDebugMessages :: TQueue Message -> IO () +processDebugMessages log = do + forever $ do + -- TODO do sactually do something with log messages + -- Message now severity text potentialValue <- ... + _ <- atomically (readTQueue log) + + return () + +{-| +Safely exit the program with the supplied exit code. Current output and +debug queues will be flushed, and then the process will terminate. +-} +-- putting to the quit MVar initiates the cleanup and exit sequence, +-- but throwing the exception also aborts execution and starts unwinding +-- back up the stack. +terminate :: Int -> Program τ α +terminate code = + let + exit = case code of + 0 -> ExitSuccess + _ -> ExitFailure code + in do + context <- ask + let quit = exitSemaphoreFrom context + liftIO $ do + putMVar quit exit + Safe.throw exit + +-- undocumented +getVerbosityLevel :: Program τ Verbosity +getVerbosityLevel = do + context <- ask + liftIO $ do + level <- readMVar (verbosityLevelFrom context) + return level + +{-| +Change the verbosity level of the program's logging output. This changes +whether 'event' and the 'debug' family of functions emit to the logging +stream; they do /not/ affect 'write'ing to the terminal on the standard +output stream. +-} +setVerbosityLevel :: Verbosity -> Program τ () +setVerbosityLevel level = do + context <- ask + liftIO $ do + let v = verbosityLevelFrom context + modifyMVar_ v (\_ -> pure level) + + +{-| +Override the program name used for logging, etc. At least, that was the +idea. Nothing makes use of this at the moment. @:/@ +-} +setProgramName :: Rope -> Program τ () +setProgramName name = do + context <- ask + liftIO $ do + let v = programNameFrom context + modifyMVar_ v (\_ -> pure name) + +{-| +Get the program name as invoked from the command-line (or as overridden by +'setProgramName'). +-} +getProgramName :: Program τ Rope +getProgramName = do + context <- ask + liftIO $ do + let v = programNameFrom context + readMVar v + +{-| +Get the user supplied application state as originally supplied to +'configure' and modified subsequntly by replacement with +'setApplicationState'. + +@ + state <- getApplicationState +@ +-} +getApplicationState :: Program τ τ +getApplicationState = do + context <- ask + liftIO $ do + let v = applicationDataFrom context + readMVar v + +{-| +Update the user supplied top-level application state. + +@ + let state' = state { answer = 42 } + setApplicationState state' +@ +-} +setApplicationState :: τ -> Program τ () +setApplicationState user = do + context <- ask + liftIO $ do + let v = applicationDataFrom context + modifyMVar_ v (\_ -> pure user) + +{-| +Alias for 'getApplicationState'. +-} +retrieve :: Program τ τ +retrieve = getApplicationState + +{-| +Alias for 'setApplicationState'. +-} +update :: τ -> Program τ () +update = setApplicationState + +{-| +Write the supplied @Bytes@ to the given @Handle@. Note that in contrast to +'write' we don't output a trailing newline. + +@ + 'output' h b +@ + +Do /not/ use this to output to @stdout@ as that would bypass the mechanism +used by the 'write'*, 'event', and 'debug'* functions to sequence output +correctly. If you wish to write to the terminal use: + +@ + 'write' ('intoRope' b) +@ + +(which is not /unsafe/, but will lead to unexpected results if the binary +blob you pass in is other than UTF-8 text). +-} +output :: Handle -> Bytes -> Program τ () +output handle contents = liftIO (hOutput handle contents) + +{-| +Read the (entire) contents of the specified @Handle@. +-} +input :: Handle -> Program τ Bytes +input handle = liftIO (hInput handle) + +{-| +A thread for concurrent computation. Haskell uses green threads: small +lines of work that are scheduled down onto actual execution contexts, set +by default by this library to be one per core. They are incredibly +lightweight, and you are encouraged to use them freely. Haskell provides a +rich ecosystem of tools to do work concurrently and to communicate safely +between threads + +(this wraps __async__'s 'Async') +-} +newtype Thread α = Thread (Async α) + +unThread :: Thread α -> Async α +unThread (Thread a) = a + +{-| +Fork a thread. The child thread will run in the same @Context@ as the +calling @Program@, including sharing the user-defined application state +type. + +(this wraps __async__'s 'async' which in turn wraps __base__'s 'Control.Concurrent.forkIO') +-} +fork :: Program τ α -> Program τ (Thread α) +fork program = do + context <- ask + liftIO $ do + a <- async $ do + subProgram context program + link a + return (Thread a) + +{-| +Pause the current thread for the given number of seconds. For +example, to delay a second and a half, do: + +@ + 'sleep' 1.5 +@ + +(this wraps __base__'s 'threadDelay') +-} +-- +-- FIXME is this the right type, given we want to avoid type default warnings? +-- +sleep :: Rational -> Program τ () +sleep seconds = + let + us = floor (toRational (seconds * 1e6)) + in + liftIO $ threadDelay us + +{-| +Retrieve the values of parameters parsed from options and arguments +supplied by the user on the command-line. + +The command-line parameters are returned in a 'Map', mapping from from the +option or argument name to the supplied value. You can query this map +directly: + +@ +program = do + params <- 'getCommandLine' + let result = 'lookupKeyValue' \"silence\" (paramterValuesFrom params) + case result of + 'Nothing' -> 'return' () + 'Just' quiet = case quiet of + 'Value' _ -> 'throw' NotQuiteRight -- complain that flag doesn't take value + 'Empty' -> 'write' \"You should be quiet now\" -- much better + ... +@ + +which is pattern matching to answer "was this option specified by the +user?" or "what was the value of this [mandatory] argument?", and then "if +so, did the parameter have a value?" + +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). +-} +getCommandLine :: Program τ (Parameters) +getCommandLine = do + context <- ask + return (commandLineFrom context) + +{-| +Arguments are mandatory, so by the time your program is running a value +has already been identified. This returns the value for that parameter. +-} +-- 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 + Nothing -> Nothing + Just argument -> case argument of + Empty -> error "Invalid State" + Value value -> Just value + +{-| +Look to see if the user supplied a valued option and if so, what its value +was. +-} +-- Should this be more severe if it encounters Empty? +lookupOptionValue :: LongName -> Parameters -> Maybe String +lookupOptionValue name params = + case lookupKeyValue name (parameterValuesFrom params) of + Nothing -> Nothing + Just argument -> case argument of + Empty -> Nothing + Value value -> Just value + +{-| +Returns @Just True@ if the option is present, and @Nothing@ if it is not. +-} +-- 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 + + +{-| +Illegal internal state resulting from what should be unreachable code +or otherwise a programmer error. +-} +invalid :: Program τ α +invalid = error "Invalid State" diff --git a/lib/Core/Program/Logging.hs b/lib/Core/Program/Logging.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Logging.hs @@ -0,0 +1,358 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_HADDOCK prune #-} + +{-| +Output and Logging from your program. + +Broadly speaking, there are two kinds of program: console tools invoked for +a single purpose, and long-running daemons that effectively run forever. + +Tools tend to be run to either have an effect (in which case they tend not +to a say much of anything) or to report a result. This tends to be written +to \"standard output\"—traditionally abbreviated in code as @stdout@—which +is usually printed to your terminal. + +Daemons, on the other hand, don't write their output to file descriptor 1; +rather they tend to respond to requests by writing to files, replying over +network sockets, or sending up smoke signals (@ECPUTOOHOT@, in case you're +curious). What daemons /do/ output, however, is log messages. + +While there are many sophisticated logging services around that you can +interact with directly, from the point of view of an individual /program/ +these tend to have faded away and have become more an aspect of the +Infrastructure- or Platform-as-a-Service you're running on. Over the past +few years containerization mechanisms like __docker__, then more recently +container orchestration layers like __kubernetes__, have generally simply +captured programs' standard output /as if it were the program's log output/ +and then sent that down external logging channels to whatever log analysis +system is available. Even programs running locally under __systemd__ or +similar tend to follow the same pattern; services write to @stdout@ and +that output, as "logs", ends up being fed to the system journal. + +So with that in mind, in your program you will either be outputting results +to @stdout@ or not writing there at all, and you will either be describing +extensively what your application is up to, or not at all. + +There is also a \"standard error\" file descriptor available. We recommend +not using it. At best it is unclear what is written to @stderr@ and what +isn't; at worse it is lost as many environments in the wild discard +@stderr@ entirely. To avoid this most of the time people just combine them +in the invoking shell with @2>&1@, which inevitably results in @stderr@ +text appearing in the middle of normal @stdout@ lines corrupting them. + +The original idea of standard error was to provde a way to report adverse +conditions without interrupting normal text output, but as we have just +observed if it happens without context or out of order there isn't much +point. Instead this library offers a mechanism which caters for the +different /kinds/ of output in a unified, safe manner. + +== Three kinds of output/logging messages + +/Standard output/ + +Your program's normal output to the terminal. This library provides the +'write' (and 'writeS' and 'writeR') functions to send output to @stdout@. + +/Events/ + +When running a tool, you sometimes need to know /what it is doing/ as it is +carrying out its steps. The 'event' function allows you to emit descriptive +messages to the log channel tracing the activities of your program. + +Ideally you would never need to turn this on in a command-line tool, but +sometimes a user or operations engineer needs to see what an application is +up to. These should be human readable status messages to convey a sense of +progress. + +In the case of long-running daemons, 'event' can be used to describe +high-level lifecycle events, to document individual requests, or even +describing individual transitions in a request handler's state machine, all +depending on the nature of your program. + +/Debugging/ + +Programmers, on the other hand, often need to see the internal state of +the program when /debugging/. + +You almost always you want to know the value of some variable or parameter, +so the 'debug' (and 'debugS' and 'debugR') utility functions here send +messages to the log channel prefixed with a label that is, by convention, +the name of the value you are examining. + +The important distinction here is that such internal values are almost +never useful for someone other than the person or team who wrote the code +emitting it. Operations engineers might be asked by developers to turn on +@--debug@ing and report back the results; but a user of your program is not +going to do that in and of themselves to solve a problem. + +== Single output channel + +It is the easy to make the mistake of having multiple subsystems attempting +to write to @stdout@ and these outputs corrupting each other, especially in +a multithreaded language like Haskell. The output actions described here +send all output to terminal down a single thread-safe channel. Output will +be written in the order it was executed, and (so long as you don't use the +@stdout@ Handle directly yourself) your terminal output will be sound. + +Passing @--verbose@ on the command-line of your program will cause 'event' +to write its tracing messages to the terminal. This shares the same output +channel as the 'write'@*@ functions and will /not/ cause corruption of your +program's normal output. + +Passing @--debug@ on the command-line of your program will cause the +'debug'@*@ actions to write their debug-level messages to the terminal. +This shares the same output channel as above and again will not cause +corruption of your program's normal output. + +== Logging channel + +/Event and debug messages are internally also sent to a "logging channel",/ +/as distinct from the "output" one. This would allow us to send them/ +/directly to a file, syslog, or network logging service, but this is/ +/as-yet unimplemented./ +-} +module Core.Program.Logging + ( + putMessage + , Verbosity + {-* Normal output -} + , write + , writeS + , writeR + {-* Event tracing -} + , event + {-* Debugging -} + , debug + , debugS + , debugR + ) where + +import Chrono.TimeStamp (TimeStamp(..), getCurrentTimeNanoseconds) +import Control.Concurrent.MVar (readMVar) +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TQueue (writeTQueue) +import Control.Exception (evaluate) +import Control.Monad (when) +import Control.Monad.Reader.Class (MonadReader(ask)) +import Data.Fixed +import Data.Hourglass (timePrint, TimeFormatElem(..)) +import qualified Data.Text.Short as S (replicate) + +import Core.Text.Rope +import Core.Text.Utilities +import Core.System.Base +import Core.Program.Context + +{- +class Monad m => MonadLog a m where + logMessage :: Monoid a => Severity -> a -> m () +-} + +putMessage :: Context τ -> Message -> IO () +putMessage context message@(Message now _ text potentialValue) = do + let start = startTimeFrom context + let output = outputChannelFrom context + let logger = loggerChannelFrom context + + let display = case potentialValue of + Just value -> + if containsCharacter '\n' value + then text <> " =\n" <> value + else text <> " = " <> value + Nothing -> text + + let result = formatLogMessage start now display + + atomically $ do + writeTQueue output result + writeTQueue logger message + + +formatLogMessage :: TimeStamp -> TimeStamp -> Rope -> Rope +formatLogMessage start now message = + let + start' = unTimeStamp start + now' = unTimeStamp now + stampZ = timePrint + [ Format_Hour + , Format_Text ':' + , Format_Minute + , Format_Text ':' + , Format_Second + , Format_Text 'Z' + ] now + + -- I hate doing math in Haskell + elapsed = fromRational (toRational (now' - start') / 1e9) :: Fixed E3 + in + mconcat + [ intoRope stampZ + , " (" + , padWithZeros 9 (show elapsed) + , ") " + , message + ] + +-- +-- | Utility function to prepend \'0\' characters to a string representing a +-- number. +-- +{- + Cloned from **locators** package Data.Locators.Hashes, BSD3 licence +-} +padWithZeros :: Int -> String -> Rope +padWithZeros digits str = + intoRope pad <> intoRope str + where + pad = S.replicate len "0" + len = digits - length str + +{-| +Write the supplied text to @stdout@. + +This is for normal program output. + +@ + 'write' "Beginning now" +@ +-} +write :: Rope -> Program τ () +write text = do + context <- ask + liftIO $ do + let out = outputChannelFrom context + + !text' <- evaluate text + atomically (writeTQueue out text') + +{-| +Call 'show' on the supplied argument and write the resultant text to +@stdout@. + +(This is the equivalent of 'print' from __base__) +-} +writeS :: Show α => α -> Program τ () +writeS = write . intoRope . show + +{-| +Pretty print the supplied argument and write the resultant text to +@stdout@. This will pass the detected terminal width to the 'render' +function, resulting in appopriate line wrapping when rendering your value. +-} +writeR :: Render α => α -> Program τ () +writeR thing = do + context <- ask + liftIO $ do + let out = outputChannelFrom context + let columns = terminalWidthFrom context + + let text = render columns thing + !text' <- evaluate text + atomically (writeTQueue out text') + +{-| +Note a significant event, state transition, status, or debugging +message. This: + +@ + 'event' "Starting..." +@ + +will result in + +> 13:05:55Z (0000.001) Starting... + +appearing on stdout /and/ the message being sent down the logging +channel. The output string is current time in UTC, and time elapsed +since startup shown to the nearest millisecond (our timestamps are to +nanosecond precision, but you don't need that kind of resolution in +in ordinary debugging). + +Messages sent to syslog will be logged at @Info@ level severity. +-} +event :: Rope -> Program τ () +event text = do + context <- ask + liftIO $ do + level <- readMVar (verbosityLevelFrom context) + when (isEvent level) $ do + now <- getCurrentTimeNanoseconds + putMessage context (Message now Event text Nothing) + +isEvent :: Verbosity -> Bool +isEvent level = case level of + Output -> False + Event -> True + Debug -> True + +isDebug :: Verbosity -> Bool +isDebug level = case level of + Output -> False + Event -> False + Debug -> True + +{-| +Output a debugging message formed from a label and a value. This is like +'event' above but for the (rather common) case of needing to inspect or +record the value of a variable when debugging code. This: + +@ + 'setProgramName' \"hello\" + name <- 'getProgramName' + 'debug' \"programName\" name +@ + +will result in + +> 13:05:58Z (0003.141) programName = hello + +appearing on stdout /and/ the message being sent down the logging channel, +assuming these actions executed about three seconds after program start. + +Messages sent to syslog will be logged at @Debug@ level severity. +-} +debug :: Rope -> Rope -> Program τ () +debug label value = do + context <- ask + liftIO $ do + level <- readMVar (verbosityLevelFrom context) + when (isDebug level) $ do + now <- getCurrentTimeNanoseconds + !value' <- evaluate value + putMessage context (Message now Debug label (Just value')) + +{-| +Convenience for the common case of needing to inspect the value +of a general variable which has a 'Show' instance +-} +debugS :: Show α => Rope -> α -> Program τ () +debugS label value = debug label (intoRope (show value)) + +{-| +Convenience for the common case of needing to inspect the value of a +general variable for which there is a 'Render' instance and so can pretty +print the supplied argument to the log. This will pass the detected +terminal width to the 'render' function, resulting in appopriate line +wrapping when rendering your value (if logging to something other than +console the default width of @80@ will be applied). +-} +debugR :: Render α => Rope -> α -> Program τ () +debugR label thing = do + context <- ask + liftIO $ do + level <- readMVar (verbosityLevelFrom context) + when (isDebug level) $ do + now <- getCurrentTimeNanoseconds + + let columns = terminalWidthFrom context + + -- TODO take into account 22 width already consumed by timestamp + -- TODO move render to putMessage? putMessageR? + let value = render columns thing + !value' <- evaluate value + putMessage context (Message now Debug label (Just value')) + diff --git a/lib/Core/Program/Metadata.hs b/lib/Core/Program/Metadata.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Metadata.hs @@ -0,0 +1,171 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Dig metadata out of the description of your project. + +This uses the evil /Template Haskell/ to run code at compile time that +parses the /.cabal/ file for your Haskell project and extracts various +meaningful fields. +-} +module Core.Program.Metadata +( + Version + {-* Splice -} + , fromPackage + {-* Internals -} + , versionNumberFrom + , projectNameFrom + , projectSynopsisFrom +) +where + +import Core.Data +import Core.Text +import Core.System (withFile, IOMode(..)) +import Data.List (intersperse) +import qualified Data.List as List (isSuffixOf, find) +import Data.Maybe (fromMaybe) +import Data.String +import Language.Haskell.TH (Q, runIO) +import Language.Haskell.TH.Syntax (Lift, Exp(..)) +import System.Directory (listDirectory) + +{-| +Information about the version number of this piece of software and other +related metadata related to the project it was built from. This is supplied +to your program when you call 'Core.Program.Execute.configure'. This value +is used if the user requests it by specifying the @--version@ option on the +command-line. + +Simply providing an overloaded string literal such as version @\"1.0\"@ +will give you a 'Version' with that value: + +@ +\{\-\# LANGUAGE OverloadedStrings \#\-\} + +main :: 'IO' () +main = do + context <- 'Core.Program.Execute.configure' \"1.0\" 'Core.Program.Execute.None' ('Core.Program.Arguments.simple' ... +@ + + +For more complex usage you can populate a 'Version' object using the +'fromPackage' splice below. You can then call various accessors like +'versionNumberFrom' to access individual fields. +-} +data Version = Version { + projectNameFrom :: String + , projectSynopsisFrom :: String + , versionNumberFrom :: String +} deriving (Show, Lift) + +emptyVersion :: Version +emptyVersion = Version "" "" "0" + +instance IsString Version where + fromString x = emptyVersion { versionNumberFrom = x } + +{-| +This is a splice which includes key built-time metadata, including the +number from the version field from your project's /.cabal/ file (as written +by hand or generated from /package.yaml/). + +While we generally discourage the use of Template Haskell by beginners +(there are more important things to learn first) it is a way to execute +code at compile time and that is what what we need in order to have the +version number extracted from the /.cabal/ file rather than requiring the +user to specify (and synchronize) it in multiple places. + +To use this, enable the Template Haskell language extension in your +/Main.hs/ file. Then use the special @$( ... )@ \"insert splice here\" +syntax that extension provides to get a 'Version' object with the desired +metadata about your project: + +@ +\{\-\# LANGUAGE TemplateHaskell \#\-\} + +version :: 'Version' +version = $('fromPackage') + +main :: 'IO' () +main = do + context <- 'Core.Program.Execute.configure' version 'Core.Program.Execute.None' ('Core.Program.Arguments.simple' ... +@ + +(Using Template Haskell slows down compilation of this file, but the upside +of this technique is that it avoids linking the Haskell build machinery +into your executable, saving you about 10 MB in the size of the resultant +binary) +-} +fromPackage :: Q Exp +fromPackage = do + pairs <- readCabalFile + + let name = fromMaybe "" . lookupKeyValue "name" $ pairs + let synopsis = fromMaybe "" . lookupKeyValue "synopsis" $ pairs + let version = fromMaybe "" . lookupKeyValue "version" $ pairs + + let result = Version + { projectNameFrom = fromRope name + , projectSynopsisFrom = fromRope synopsis + , versionNumberFrom = fromRope version + } + +-- I would have preferred +-- +-- let e = AppE (VarE ... +-- return e +-- +-- but that's not happening. So more voodoo TH nonsense instead. + + [e|result|] + + +{- +Locate the .cabal file in the present working directory (assumed to be the +build root) and use the **Cabal** library to parse the few bits we need out +of it. +-} + +findCabalFile :: IO FilePath +findCabalFile = do + files <- listDirectory "." + let found = List.find (List.isSuffixOf ".cabal") files + case found of + Just file -> return file + Nothing -> error "No .cabal file found" + +readCabalFile :: Q (Map Rope Rope) +readCabalFile = runIO $ do + -- Find .cabal file + file <- findCabalFile + + -- Parse .cabal file + contents <- withFile file ReadMode hInput + let pairs = parseCabalFile contents + -- pass to calling program + return pairs + +parseCabalFile :: Bytes -> Map Rope Rope +parseCabalFile contents = + let + breakup = intoMap . fmap (breakRope (== ':')) . breakLines . fromBytes + in + breakup contents + +-- this should probably be a function in Core.Text.Rope +breakRope :: (Char -> Bool) -> Rope -> (Rope,Rope) +breakRope predicate text = + let + pieces = take 2 (breakPieces predicate text) + in + case pieces of + [] -> ("","") + [one] -> (one,"") + (one:two:_) -> (one, trimRope two) + +-- knock off the whitespace in "name: hello" +trimRope :: Rope -> Rope +trimRope = mconcat . intersperse " " . breakWords diff --git a/lib/Core/Program/Signal.hs b/lib/Core/Program/Signal.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Signal.hs @@ -0,0 +1,63 @@ +{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} + +module Core.Program.Signal +( + setupSignalHandlers +) +where + +import Control.Concurrent.MVar (MVar, putMVar, modifyMVar_) +import Foreign.C.Types (CInt) +import System.Exit (ExitCode(..)) +import System.IO (hPutStrLn, hFlush, stdout) +import System.Posix.Signals (Handler(Catch), installHandler, + sigINT, sigTERM, sigUSR1) + +import Core.Program.Context + +-- +-- | Make a non-zero exit code which is 0b1000000 + the number of the +-- signal. Probably never need this (especaially given our attempt to +-- write out a human readable name for the signal caught) but it's a +-- convention we're happy to observe. +-- +code :: CInt -> ExitCode +code signal = ExitFailure (128 + fromIntegral signal) + +{- + Technique to have a blocking MVar and signal handlers to set it + adapted from code in vaultaire-common package's Vaultaire.Program, + BSD3 licenced. +-} + +interruptHandler :: MVar ExitCode -> Handler +interruptHandler quit = Catch $ do + hPutStrLn stdout "\nInterrupt" + hFlush stdout + putMVar quit (code sigINT) + +terminateHandler :: MVar ExitCode -> Handler +terminateHandler quit = Catch $ do + hPutStrLn stdout "Terminating" + hFlush stdout + putMVar quit (code sigTERM) + +logLevelHandler :: MVar Verbosity -> Handler +logLevelHandler v = Catch $ do + hPutStrLn stdout "Signal" + hFlush stdout + modifyMVar_ v (\level -> case level of + Output -> pure Debug + Event -> pure Debug + Debug -> pure Output) + +-- +-- | Install signal handlers for SIGINT and SIGTERM that set the exit +-- semaphore so that a Program's [minimal] cleanup can occur. +-- +setupSignalHandlers :: MVar ExitCode -> MVar Verbosity -> IO () +setupSignalHandlers quit level = do + installHandler sigINT (interruptHandler quit) Nothing + installHandler sigTERM (terminateHandler quit) Nothing + installHandler sigUSR1 (logLevelHandler level) Nothing + return () diff --git a/lib/Core/Program/Unlift.hs b/lib/Core/Program/Unlift.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Program/Unlift.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_HADDOCK prune #-} + +{-| +The 'Program' monad is an instance of 'MonadIO', which makes sense; it's +just a wrapper around doing 'IO' and you call it using +'execute' from the top-level @main@ action that is the +entrypoint to any program. So when you need to actually do some I/O or +interact with other major libraries in the Haskell ecosystem, you need to +get back to 'IO' and you use 'liftIO' to do it: + +@ +main :: 'IO' () +main = 'execute' $ do + -- now in the Program monad + 'write' "Hello there" + + 'liftIO' $ do + -- now something in IO + source <- readFile "hello.c" + compileSourceCode source + + -- back in Program monad + 'write' \"Finished\" +@ + +and this is a perfectly reasonable pattern. + +Sometimes, however, you want to get to the 'Program' monad from /there/, +and that's tricky; you can't just 'execute' a new +program (and don't try: we've already initialized output and logging +channels, signal handlers, your application context, etc). + +@ +main :: 'IO' () +main = 'execute' $ do + -- now in the Program monad + 'write' "Hello there" + + 'liftIO' $ do + -- now something in IO + source <- readFile "hello.c" + -- log that we're starting compile ... FIXME how??? + result <- compileSourceCode source + case result of + Right object -> linkObjectCode object + Left err -> -- debug the error ... FIXME how??? + + -- back in Program monad + 'write' \"Finished\" +@ + +We have a problem, because we'd like to do is use, say, 'debug' to log the +compiler error, but we have no way to unlift back out of 'IO' to get to the +'Program' monad. + +To workaround this, we offer 'withContext'. It gives you a function that +you can then use within your lifted 'IO' to run a (sub)'Program' action: + +@ +main :: 'IO' () +main = 'execute' $ do + -- now in the Program monad + 'write' "Hello there" + + 'withContext' $ \\runProgram -> do + -- now lifted to IO + source <- readFile "hello.c" + + runProgram $ do + -- now \"unlifted\" back to Program monad! + 'event' \"Starting compile...\" + 'event' \"Nah. Changed our minds\" + 'event' \"Ok, fine, compile the thing\" + + -- more IO + result <- compileSourceCode source + case result of + 'Right' object -> linkObjectCode object + 'Left' err -> runProgram ('debugS' err) + + -- back in Program monad + 'write' \"Finished\" +@ + +Sometimes Haskell type inference can give you trouble because it tends to +assume you mean what you say with the last statement of do-notation block. +If you've got the type wrong you'll get an error, but in an odd place, +probably at the top where you have the lambda. This can be confusing. If +you're having trouble with the types try putting @return ()@ at the end of +your subprogram. +-} +module Core.Program.Unlift + ( + {-* Unlifting -} + withContext + {-* Internals -} + , getContext + , subProgram + ) where + +import Core.Program.Context +import Core.Program.Execute +import Core.Program.Logging +import Core.System.Base + +{-| +This gives you a function that you can use within your lifted 'IO' actions +to return to the 'Program' monad. + +The type signature of this function is a bit involved, but the example below +shows that the lambda gives you a /function/ as its argument (we recommend +you name it @__runProgram__@ for consistency) which gives you a way to run a +subprogram, be that a single action like writing to terminal or logging, or +a larger action in a do-notation block: + +@ +main :: IO () +main = 'execute' $ do + 'withContext' $ \\runProgram -> do + -- in IO monad, lifted + -- (just as if you had used liftIO) + + ... + + runProgram $ do + -- now unlifted, back to Program monad + + ... +@ + +Think of this as 'liftIO' with an escape hatch. + +This function is named 'withContext' because it is a convenience around the +following pattern: + +@ + context <- 'getContext' + liftIO $ do + ... + 'subProgram' context $ do + -- now in Program monad + ... +@ +-} +-- I think I just discovered the same pattern as **unliftio**? Certainly +-- the signature is similar. I'm not sure if there is any benefit to +-- restating this as a `withRunInIO` action; we're deliberately trying to +-- constrain the types. +withContext + :: ((forall β. Program τ β -> IO β) -> IO α) + -> Program τ α +withContext action = do + context <- getContext + let runThing = subProgram context + liftIO (action runThing) + diff --git a/lib/Core/System.hs b/lib/Core/System.hs new file mode 100644 --- /dev/null +++ b/lib/Core/System.hs @@ -0,0 +1,40 @@ +{-# OPTIONS_HADDOCK not-home #-} + +{-| +Common elements from the rest of the Haskell ecosystem. This is mostly +about re-exports. There are numerous types and functions that are more or +less assumed to be in scope when you're doing much of anything in Haskell; +this module is a convenience to pull in the ones we rely on for the rest of +this library. + +You can just import this directly: + +@ +import "Core.System" +@ + +as there's no particular benefit to cherry-picking the various sub-modules. + +-} +module Core.System + ( + {-* Base libraries -} +{-| +Re-exports from foundational libraries supplied by the compiler runtime, +or from re-implementations of those areas. +-} + module Core.System.Base + + {-* External dependencies -} +{-| +Dependencies from libraries outside the traditional ecosystem of Haskell. +These are typically special cases or custom re-implementations of things +which are maintained either by ourselves or people we are in regular +contact with. +-} + , module Core.System.External + ) where + +import Core.System.Base +import Core.System.External + diff --git a/lib/Core/System/Base.hs b/lib/Core/System/Base.hs new file mode 100644 --- /dev/null +++ b/lib/Core/System/Base.hs @@ -0,0 +1,39 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_HADDOCK not-home #-} + +-- +-- | Re-exports of Haskell base and GHC system libraries. +-- +module Core.System.Base + ( {-* Input/Output -} + {-** from Control.Monad.IO.Class -} + {-| Re-exported from "Control.Monad.IO.Class" in __base__: -} + liftIO + , MonadIO + {-** from System.IO -} + {-| Re-exported from "System.IO" in __base__: -} + , Handle + , IOMode(..) + , withFile + , stdin, stdout, stderr + , hFlush + , unsafePerformIO + {-* Exception handling -} + {-** from Control.Exception.Safe -} + {-| Re-exported from "Control.Exception.Safe" in the __safe-exceptions__ package: -} + , Exception(..) + , SomeException + , throw + , impureThrow + , bracket + , catch + , finally + ) where + +import Control.Exception.Safe (Exception(..), SomeException, throw + , bracket, catch, finally, impureThrow) +import Control.Monad.IO.Class (MonadIO, liftIO) +import System.IO (Handle, IOMode(..), withFile, stdin, stdout, stderr, hFlush) +import System.IO.Unsafe (unsafePerformIO) + diff --git a/lib/Core/System/External.hs b/lib/Core/System/External.hs new file mode 100644 --- /dev/null +++ b/lib/Core/System/External.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_HADDOCK not-home #-} + +-- +-- | Re-exports of dependencies from various external libraries. +-- +module Core.System.External + ( {-* Time -} + {-** from Chrono.TimeStamp -} + {-| Re-exported from "Chrono.TimeStamp" in __chronologique__: -} + TimeStamp(..) + , getCurrentTimeNanoseconds + ) where + +import Chrono.TimeStamp (TimeStamp(..), getCurrentTimeNanoseconds) +