chore(users/Profpatsch): clean up haskell libs a little
Change-Id: Ia9a6c5a754ca8f2912308feb5a26f5276a08d24c Reviewed-on: https://cl.tvl.fyi/c/depot/+/9011 Reviewed-by: Profpatsch <mail@profpatsch.de> Autosubmit: Profpatsch <mail@profpatsch.de> Tested-by: BuildkiteCI
This commit is contained in:
Profpatsch
clbot
parent
ce4acc08a5
commit
1fd59f5158
12 changed files with 122 additions and 335 deletions
|
|
@ -1,91 +0,0 @@
|
|||
{-# LANGUAGE ImportQualifiedPost #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
||||
module Pretty
|
||||
( -- * Pretty printing for error messages
|
||||
Err,
|
||||
printPretty,
|
||||
showPretty,
|
||||
-- constructors hidden
|
||||
prettyErrs,
|
||||
message,
|
||||
messageString,
|
||||
pretty,
|
||||
prettyString,
|
||||
hscolour',
|
||||
)
|
||||
where
|
||||
|
||||
import Data.List qualified as List
|
||||
import Data.Text qualified as Text
|
||||
import Language.Haskell.HsColour
|
||||
( Output (TTYg),
|
||||
hscolour,
|
||||
)
|
||||
import Language.Haskell.HsColour.ANSI (TerminalType (..))
|
||||
import Language.Haskell.HsColour.Colourise
|
||||
( defaultColourPrefs,
|
||||
)
|
||||
import MyPrelude
|
||||
import System.Console.ANSI (setSGRCode)
|
||||
import System.Console.ANSI.Types
|
||||
( Color (Red),
|
||||
ColorIntensity (Dull),
|
||||
ConsoleLayer (Foreground),
|
||||
SGR (Reset, SetColor),
|
||||
)
|
||||
import Text.Nicify (nicify)
|
||||
|
||||
-- | Print any 'Show'able type to stderr, formatted nicely and in color. Very helpful for debugging.
|
||||
printPretty :: Show a => a -> IO ()
|
||||
printPretty a =
|
||||
a & pretty & (: []) & prettyErrs & stringToText & putStderrLn
|
||||
|
||||
showPretty :: Show a => a -> Text
|
||||
showPretty a = a & pretty & (: []) & prettyErrs & stringToText
|
||||
|
||||
-- | Display a list of 'Err's as a colored error message
|
||||
-- and abort the test.
|
||||
prettyErrs :: [Err] -> String
|
||||
prettyErrs errs = res
|
||||
where
|
||||
res = List.intercalate "\n" $ map one errs
|
||||
one = \case
|
||||
ErrMsg s -> color Red s
|
||||
ErrPrettyString s -> prettyShowString s
|
||||
-- Pretty print a String that was produced by 'show'
|
||||
prettyShowString :: String -> String
|
||||
prettyShowString = hscolour' . nicify
|
||||
|
||||
-- | Small DSL for pretty-printing errors
|
||||
data Err
|
||||
= -- | Message to display in the error
|
||||
ErrMsg String
|
||||
| -- | Pretty print a String that was produced by 'show'
|
||||
ErrPrettyString String
|
||||
|
||||
-- | Plain message to display, as 'Text'
|
||||
message :: Text -> Err
|
||||
message = ErrMsg . Text.unpack
|
||||
|
||||
-- | Plain message to display, as 'String'
|
||||
messageString :: String -> Err
|
||||
messageString = ErrMsg
|
||||
|
||||
-- | Any 'Show'able to pretty print
|
||||
pretty :: Show a => a -> Err
|
||||
pretty x = ErrPrettyString $ show x
|
||||
|
||||
-- | Pretty print a String that was produced by 'show'
|
||||
prettyString :: String -> Err
|
||||
prettyString s = ErrPrettyString s
|
||||
|
||||
-- Prettifying Helpers, mostly stolen from
|
||||
-- https://hackage.haskell.org/package/hspec-expectations-pretty-diff-0.7.2.5/docs/src/Test.Hspec.Expectations.Pretty.html#prettyColor
|
||||
|
||||
hscolour' :: String -> String
|
||||
hscolour' =
|
||||
hscolour (TTYg Ansi16Colour) defaultColourPrefs False False "" False
|
||||
|
||||
color :: Color -> String -> String
|
||||
color c s = setSGRCode [SetColor Foreground Dull c] ++ s ++ setSGRCode [Reset]
|
||||
|
|
@ -1,162 +0,0 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module RunCommand where
|
||||
|
||||
import Data.ByteString qualified as ByteString
|
||||
import Data.ByteString.Lazy qualified as Bytes.Lazy
|
||||
import Data.Char qualified as Char
|
||||
import Data.List qualified as List
|
||||
import Data.Text qualified as Text
|
||||
import MyPrelude
|
||||
import System.Exit qualified as Exit
|
||||
import System.IO (Handle)
|
||||
import System.Process.Typed qualified as Process
|
||||
import Prelude hiding (log)
|
||||
|
||||
-- | Given a a command, the executable and arguments,
|
||||
-- spawn the tool as subprocess and collect its stdout (stderr will go to our stderr).
|
||||
|
||||
-- Will strip the stdout of trailing newlines.
|
||||
--
|
||||
-- If the executable is not a path, it will be resolved via the @PATH@ environment variable.
|
||||
runCommand :: MonadIO m => FilePath -> [Text] -> m (Exit.ExitCode, ByteString)
|
||||
runCommand executable args = do
|
||||
let bashArgs = prettyArgsForBash ((executable & stringToText) : args)
|
||||
log [fmt|Running: $ {bashArgs}|]
|
||||
Process.proc
|
||||
executable
|
||||
(args <&> textToString)
|
||||
& Process.readProcessStdout
|
||||
<&> second toStrictBytes
|
||||
<&> second stripWhitespaceFromEnd
|
||||
|
||||
-- | Given a a command, the executable and arguments,
|
||||
-- spawn the tool as subprocess and run it to conclusion.
|
||||
--
|
||||
-- If the executable is not a path, it will be resolved via the @PATH@ environment variable.
|
||||
runCommandNoStdout :: MonadIO m => FilePath -> [Text] -> m Exit.ExitCode
|
||||
runCommandNoStdout executable args = do
|
||||
let bashArgs = prettyArgsForBash ((executable & stringToText) : args)
|
||||
log [fmt|Running: $ {bashArgs}|]
|
||||
Process.proc
|
||||
executable
|
||||
(args <&> textToString)
|
||||
& Process.runProcess
|
||||
|
||||
-- TODO: This is reversing the whole string *twice*. Can we strip from end without doing that?
|
||||
stripWhitespaceFromEnd :: ByteString -> ByteString
|
||||
stripWhitespaceFromEnd = ByteString.reverse . ByteString.dropWhile (\w -> w == charToWordUnsafe '\n') . ByteString.reverse
|
||||
|
||||
-- | Like `runCommand`, but takes a Bytestring that provides the command with streamed input on stdin.
|
||||
runCommandWithStdin :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m (Exit.ExitCode, ByteString)
|
||||
runCommandWithStdin executable args stdin = do
|
||||
let bashArgs = prettyArgsForBash ((executable & stringToText) : args)
|
||||
log [fmt|Running: $ {bashArgs}|]
|
||||
Process.proc
|
||||
executable
|
||||
(args <&> textToString)
|
||||
& Process.setStdin (Process.byteStringInput stdin)
|
||||
& Process.readProcessStdout
|
||||
<&> second toStrictBytes
|
||||
<&> second stripWhitespaceFromEnd
|
||||
|
||||
-- | Like `runCommand`, but takes a Bytestring that provides the command with streamed input on stdin.
|
||||
runCommandWithStdinNoStdout :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m Exit.ExitCode
|
||||
runCommandWithStdinNoStdout executable args stdin = do
|
||||
let bashArgs = prettyArgsForBash ((executable & stringToText) : args)
|
||||
log [fmt|Running: $ {bashArgs}|]
|
||||
Process.proc
|
||||
executable
|
||||
(args <&> textToString)
|
||||
& Process.setStdin (Process.byteStringInput stdin)
|
||||
& Process.runProcess
|
||||
|
||||
-- | Like 'runCommandWithStdin' but exit if the command returns a non-0 status.
|
||||
runCommandWithStdinExpect0 :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m ByteString
|
||||
runCommandWithStdinExpect0 executable args stdin =
|
||||
runCommandWithStdin executable args stdin >>= \case
|
||||
(ex, stdout) -> do
|
||||
checkStatus0 executable ex
|
||||
pure stdout
|
||||
|
||||
-- | Like 'runCommandWithStdinNoStdout' but exit if the command returns a non-0 status.
|
||||
runCommandWithStdinNoStdoutExpect0 :: MonadIO m => FilePath -> [Text] -> Bytes.Lazy.ByteString -> m ()
|
||||
runCommandWithStdinNoStdoutExpect0 executable args stdin =
|
||||
runCommandWithStdinNoStdout executable args stdin
|
||||
>>= checkStatus0 executable
|
||||
|
||||
-- | Like 'runCommandExpect0', but don’t capture stdout,
|
||||
-- connect stdin and stdout to the command until it returns.
|
||||
--
|
||||
-- This is for interactive subcommands.
|
||||
runCommandInteractiveExpect0 :: MonadIO m => FilePath -> [Text] -> m ()
|
||||
runCommandInteractiveExpect0 executable args = do
|
||||
let bashArgs = prettyArgsForBash ((executable & stringToText) : args)
|
||||
log [fmt|Running interactively: $ {bashArgs}|]
|
||||
( liftIO $
|
||||
Process.runProcess $
|
||||
Process.proc
|
||||
executable
|
||||
(args <&> textToString)
|
||||
)
|
||||
>>= checkStatus0 executable
|
||||
|
||||
-- | Given a name of a command, the executable and arguments,
|
||||
-- spawn the tool as subprocess and pipe its stdout to the given 'Handle'.
|
||||
--
|
||||
-- If the executable is not a path, it will be resolved via the @PATH@ environment variable.
|
||||
runCommandPipeToHandle :: MonadIO m => FilePath -> [Text] -> Handle -> m Exit.ExitCode
|
||||
runCommandPipeToHandle executable args handle = do
|
||||
-- TODO log the output file?
|
||||
let bashArgs = prettyArgsForBash ((executable & stringToText) : args)
|
||||
log [fmt|Running: $ {bashArgs}|]
|
||||
liftIO $
|
||||
Process.runProcess
|
||||
( Process.proc
|
||||
executable
|
||||
(args <&> textToString)
|
||||
& Process.setStdout (Process.useHandleClose handle)
|
||||
)
|
||||
|
||||
-- | Check whether a command exited 0 or crash.
|
||||
checkStatus0 :: MonadIO m => FilePath -> Exit.ExitCode -> m ()
|
||||
checkStatus0 executable = \case
|
||||
Exit.ExitSuccess -> pure ()
|
||||
Exit.ExitFailure status -> do
|
||||
logCritical [fmt|Command `{executable}` did not exit with status 0 (success), but status {status}|]
|
||||
|
||||
log :: MonadIO m => Text -> m ()
|
||||
log = liftIO . putStderrLn
|
||||
|
||||
-- | Log the message on the normal logging level & exit the program
|
||||
logCritical :: MonadIO m => Text -> m b
|
||||
logCritical msg = do
|
||||
liftIO $ putStderrLn msg
|
||||
liftIO $ Exit.exitWith (Exit.ExitFailure 1)
|
||||
|
||||
-- | Pretty print a command line in a way that can be copied to bash.
|
||||
prettyArgsForBash :: [Text] -> Text
|
||||
prettyArgsForBash = Text.intercalate " " . map simpleBashEscape
|
||||
|
||||
-- | Simple escaping for bash words. If they contain anything that’s not ascii chars
|
||||
-- and a bunch of often-used special characters, put the word in single quotes.
|
||||
simpleBashEscape :: Text -> Text
|
||||
simpleBashEscape t = do
|
||||
case Text.find (not . isSimple) t of
|
||||
Just _ -> escapeSingleQuote t
|
||||
Nothing -> t
|
||||
where
|
||||
-- any word that is just ascii characters is simple (no spaces or control characters)
|
||||
-- or contains a few often-used characters like - or .
|
||||
isSimple c =
|
||||
Char.isAsciiLower c
|
||||
|| Char.isAsciiUpper c
|
||||
|| Char.isDigit c
|
||||
-- These are benign, bash will not interpret them as special characters.
|
||||
|| List.elem c ['-', '.', ':', '/']
|
||||
-- Put the word in single quotes
|
||||
-- If there is a single quote in the word,
|
||||
-- close the single quoted word, add a single quote, open the word again
|
||||
escapeSingleQuote t' = "'" <> Text.replace "'" "'\\''" t' <> "'"
|
||||
Loading…
Add table
Add a link
Reference in a new issue