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:
parent
ce4acc08a5
commit
1fd59f5158
12 changed files with 122 additions and 335 deletions
|
@ -4,7 +4,9 @@ packages:
|
|||
./arglib/arglib-netencode.cabal
|
||||
./execline/exec-helpers.cabal
|
||||
./htmx-experiment/htmx-experiment.cabal
|
||||
./mailbox-org/mailbox-org.cabal
|
||||
./cas-serve/cas-serve.cabal
|
||||
./jbovlaste-sqlite/jbovlaste-sqlite.cabal
|
||||
./whatcd-resolver/whatcd-resolver.cabal
|
||||
./ircmail/ircmail.cabal
|
||||
./httzip/httzip.cabal
|
||||
|
|
|
@ -10,15 +10,19 @@ cradle:
|
|||
component: "lib:exec-helpers"
|
||||
- path: "./htmx-experiment/src"
|
||||
component: "lib:htmx-experiment"
|
||||
- path: "./htmx-experiment/src"
|
||||
component: "lib:htmx-experiment"
|
||||
- path: "./htmx-experiment/Main.hs"
|
||||
component: "htmx-experiment:exe:htmx-experiment"
|
||||
- path: "./mailbox-org/src"
|
||||
component: "lib:mailbox-org"
|
||||
- path: "./mailbox-org/MailboxOrg.hs"
|
||||
component: "mailbox-org:exe:mailbox-org"
|
||||
- path: "./cas-serve/CasServe.hs"
|
||||
component: "cas-serve:exe:cas-serve"
|
||||
- path: "./jbovlaste-sqlite/JbovlasteSqlite.hs"
|
||||
component: "jbovlaste-sqlite:exe:jbovlaste-sqlite"
|
||||
- path: "./whatcd-resolver/src"
|
||||
component: "lib:whatcd-resolver"
|
||||
- path: "./ircmail/src"
|
||||
component: "lib:ircmail"
|
||||
- path: "./httzip/Httzip.hs"
|
||||
component: "httzip:exe:httzip"
|
||||
|
|
|
@ -20,8 +20,6 @@ let
|
|||
pkgs.haskellPackages.foldl
|
||||
pkgs.haskellPackages.sqlite-simple
|
||||
pkgs.haskellPackages.xml-conduit
|
||||
depot.users.Profpatsch.arglib.netencode.haskell
|
||||
depot.users.Profpatsch.netencode.netencode-hs
|
||||
|
||||
];
|
||||
|
||||
|
|
|
@ -62,7 +62,6 @@ executable jbovlaste-sqlite
|
|||
pa-label,
|
||||
pa-error-tree,
|
||||
pa-field-parser,
|
||||
my-prelude,
|
||||
containers,
|
||||
selective,
|
||||
semigroupoids,
|
||||
|
@ -71,8 +70,6 @@ executable jbovlaste-sqlite
|
|||
foldl,
|
||||
conduit,
|
||||
bytestring,
|
||||
arglib-netencode,
|
||||
netencode,
|
||||
text,
|
||||
sqlite-simple,
|
||||
xml-conduit,
|
||||
|
|
|
@ -1,6 +1,5 @@
|
|||
{-# LANGUAGE ApplicativeDo #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DerivingStrategies #-}
|
||||
{-# LANGUAGE DerivingVia #-}
|
||||
{-# LANGUAGE GHC2021 #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
|
@ -31,7 +30,6 @@ import Data.List qualified as List
|
|||
import Data.Map.Strict qualified as Map
|
||||
import Data.Text qualified as Text
|
||||
import ExecHelpers
|
||||
import GHC.Records (HasField (..))
|
||||
import Label
|
||||
import Netencode qualified
|
||||
import Netencode.Parse qualified as NetParse
|
||||
|
@ -117,9 +115,7 @@ listFilterConfig session = do
|
|||
>>= printPretty
|
||||
|
||||
applyFilterRule ::
|
||||
( HasField "folderId" dat Text,
|
||||
HasField "rulename" dat Text
|
||||
) =>
|
||||
(HasField "folderId" dat Text) =>
|
||||
dat ->
|
||||
Session ->
|
||||
IO ()
|
||||
|
@ -209,48 +205,47 @@ applyFilters session = do
|
|||
<&> mapFromListOn (\dat -> getLabel @"rulename" dat.parsed)
|
||||
)
|
||||
([] :: [()])
|
||||
let goal = Map.fromList [(label @"rulename" "another", 32), (label @"rulename" "xyz", 23)]
|
||||
let goal = Map.fromList [(label @"rulename" "another", 32 :: Integer), (label @"rulename" "xyz", 23)]
|
||||
let actions = declarativeUpdate goal filters
|
||||
log [fmt|To * create: {actions.toCreate & Map.keys & show}, * update: {actions.toUpdate & Map.keys & show}, * delete: {actions.toDelete & Map.keys & show}|]
|
||||
where
|
||||
-- filters
|
||||
-- & Map.elems
|
||||
-- & traverse_
|
||||
-- ( updateIfDifferent
|
||||
-- session
|
||||
-- ( \el ->
|
||||
-- pure $
|
||||
-- el.original.mailfilter
|
||||
-- & KeyMap.insert "active" (Json.Bool False)
|
||||
-- )
|
||||
-- (pure ())
|
||||
-- )
|
||||
|
||||
mapFromListOn :: Ord k => (a -> k) -> [a] -> Map k a
|
||||
mapFromListOn on xs = xs <&> (\x -> (on x, x)) & Map.fromList
|
||||
updateIfDifferent ::
|
||||
forall label parsed.
|
||||
( HasField "id_" parsed Json.Value,
|
||||
HasField "rulename" parsed Text
|
||||
) =>
|
||||
Session ->
|
||||
(Dat label Json.Object parsed -> IO Json.Object) ->
|
||||
Json.Parse Error () ->
|
||||
Dat label Json.Object parsed ->
|
||||
IO ()
|
||||
updateIfDifferent session switcheroo parser dat = do
|
||||
new <- switcheroo dat
|
||||
if new /= getField @label dat.original
|
||||
then do
|
||||
log [fmt|Updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value})|]
|
||||
mailfilter
|
||||
session
|
||||
"update"
|
||||
mempty
|
||||
parser
|
||||
new
|
||||
else do
|
||||
log [fmt|Skipping updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value}) because nothing changed.|]
|
||||
-- where
|
||||
-- filters
|
||||
-- & Map.elems
|
||||
-- & traverse_
|
||||
-- ( updateIfDifferent
|
||||
-- session
|
||||
-- ( \el ->
|
||||
-- pure $
|
||||
-- el.original.mailfilter
|
||||
-- & KeyMap.insert "active" (Json.Bool False)
|
||||
-- )
|
||||
-- (pure ())
|
||||
-- )
|
||||
|
||||
-- updateIfDifferent ::
|
||||
-- forall label parsed.
|
||||
-- ( HasField "id_" parsed Json.Value,
|
||||
-- HasField "rulename" parsed Text
|
||||
-- ) =>
|
||||
-- Session ->
|
||||
-- (Dat label Json.Object parsed -> IO Json.Object) ->
|
||||
-- Json.Parse Error () ->
|
||||
-- Dat label Json.Object parsed ->
|
||||
-- IO ()
|
||||
-- updateIfDifferent session switcheroo parser dat = do
|
||||
-- new <- switcheroo dat
|
||||
-- if new /= getField @label dat.original
|
||||
-- then do
|
||||
-- log [fmt|Updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value})|]
|
||||
-- mailfilter
|
||||
-- session
|
||||
-- "update"
|
||||
-- mempty
|
||||
-- parser
|
||||
-- new
|
||||
-- else do
|
||||
-- log [fmt|Skipping updating filter "{dat.parsed.rulename}" (id {dat.parsed.id_ & show @Json.Value}) because nothing changed.|]
|
||||
|
||||
-- | https://oxpedia.org/wiki/index.php?title=HTTP_API_MailFilter
|
||||
mailfilter ::
|
||||
|
|
|
@ -7,7 +7,7 @@ let
|
|||
|
||||
src = depot.users.Profpatsch.exactSource ./. [
|
||||
./mailbox-org.cabal
|
||||
./AesonQQ.hs
|
||||
./src/AesonQQ.hs
|
||||
./MailboxOrg.hs
|
||||
];
|
||||
|
||||
|
|
|
@ -4,38 +4,93 @@ version: 0.1.0.0
|
|||
author: Profpatsch
|
||||
maintainer: mail@profpatsch.de
|
||||
|
||||
|
||||
common common-options
|
||||
ghc-options:
|
||||
-Wall
|
||||
-Wno-type-defaults
|
||||
-Wunused-packages
|
||||
-Wredundant-constraints
|
||||
-fwarn-missing-deriving-strategies
|
||||
|
||||
-- See https://downloads.haskell.org/ghc/latest/docs/users_guide/exts.html
|
||||
-- for a description of all these extensions
|
||||
default-extensions:
|
||||
-- Infer Applicative instead of Monad where possible
|
||||
ApplicativeDo
|
||||
|
||||
-- Allow literal strings to be Text
|
||||
OverloadedStrings
|
||||
|
||||
-- Syntactic sugar improvements
|
||||
LambdaCase
|
||||
MultiWayIf
|
||||
|
||||
-- Makes the (deprecated) usage of * instead of Data.Kind.Type an error
|
||||
NoStarIsType
|
||||
|
||||
-- Convenient and crucial to deal with ambiguous field names, commonly
|
||||
-- known as RecordDotSyntax
|
||||
OverloadedRecordDot
|
||||
|
||||
-- does not export record fields as functions, use OverloadedRecordDot to access instead
|
||||
NoFieldSelectors
|
||||
|
||||
-- Record punning
|
||||
RecordWildCards
|
||||
|
||||
-- Improved Deriving
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
|
||||
-- Type-level strings
|
||||
DataKinds
|
||||
|
||||
-- to enable the `type` keyword in import lists (ormolu uses this automatically)
|
||||
ExplicitNamespaces
|
||||
|
||||
default-language: GHC2021
|
||||
|
||||
|
||||
library
|
||||
import: common-options
|
||||
|
||||
hs-source-dirs: src
|
||||
|
||||
exposed-modules:
|
||||
AesonQQ
|
||||
|
||||
build-depends:
|
||||
base >=4.15 && <5,
|
||||
pa-prelude,
|
||||
aeson,
|
||||
PyF,
|
||||
template-haskell
|
||||
|
||||
|
||||
|
||||
executable mailbox-org
|
||||
import: common-options
|
||||
main-is: MailboxOrg.hs
|
||||
|
||||
build-depends:
|
||||
base >=4.15 && <5,
|
||||
mailbox-org,
|
||||
my-prelude,
|
||||
pa-prelude,
|
||||
pa-label,
|
||||
pa-pretty,
|
||||
pa-error-tree,
|
||||
exec-helpers,
|
||||
netencode,
|
||||
text,
|
||||
semigroupoids,
|
||||
nonempty-containers,
|
||||
data-fix,
|
||||
selective,
|
||||
directory,
|
||||
mtl,
|
||||
filepath,
|
||||
arglib-netencode,
|
||||
random,
|
||||
http-conduit,
|
||||
http-client,
|
||||
aeson,
|
||||
aeson-better-errors,
|
||||
bytestring,
|
||||
PyF,
|
||||
typed-process,
|
||||
process,
|
||||
containers,
|
||||
|
||||
default-language: Haskell2010
|
||||
|
||||
default-extensions:
|
||||
GHC2021
|
||||
|
|
|
@ -3,20 +3,21 @@
|
|||
module AesonQQ where
|
||||
|
||||
import Data.Aeson qualified as Json
|
||||
import Data.Either qualified as Either
|
||||
import Language.Haskell.TH.Quote (QuasiQuoter)
|
||||
import PossehlAnalyticsPrelude
|
||||
import PyF qualified
|
||||
import PyF.Internal.QQ qualified as PyFConf
|
||||
|
||||
aesonQQ :: QuasiQuoter
|
||||
aesonQQ =
|
||||
PyF.mkFormatter
|
||||
"aesonQQ"
|
||||
PyF.defaultConfig
|
||||
{ PyFConf.delimiters = Just ('|', '|'),
|
||||
PyFConf.postProcess = \exp -> do
|
||||
PyFConf.postProcess = \exp_ -> do
|
||||
-- TODO: this does not throw an error at compilation time if the json does not parse
|
||||
[|
|
||||
case Json.eitherDecodeStrict' @Json.Value $ textToBytesUtf8 $ stringToText $(exp) of
|
||||
case Json.eitherDecodeStrict' @Json.Value $ textToBytesUtf8 $ stringToText $(exp_) of
|
||||
Left err -> error err
|
||||
Right a -> a
|
||||
|]
|
|
@ -8,8 +8,6 @@ pkgs.haskellPackages.mkDerivation {
|
|||
./my-prelude.cabal
|
||||
./src/Aeson.hs
|
||||
./src/MyPrelude.hs
|
||||
./src/Pretty.hs
|
||||
./src/RunCommand.hs
|
||||
./src/Test.hs
|
||||
./src/Tool.hs
|
||||
./src/ValidationParseT.hs
|
||||
|
@ -24,25 +22,20 @@ pkgs.haskellPackages.mkDerivation {
|
|||
pkgs.haskellPackages.pa-label
|
||||
pkgs.haskellPackages.pa-error-tree
|
||||
pkgs.haskellPackages.pa-json
|
||||
pkgs.haskellPackages.pa-pretty
|
||||
pkgs.haskellPackages.aeson-better-errors
|
||||
pkgs.haskellPackages.ansi-terminal
|
||||
pkgs.haskellPackages.error
|
||||
pkgs.haskellPackages.hscolour
|
||||
pkgs.haskellPackages.hspec
|
||||
pkgs.haskellPackages.hspec-expectations-pretty-diff
|
||||
pkgs.haskellPackages.monad-logger
|
||||
pkgs.haskellPackages.nicify-lib
|
||||
pkgs.haskellPackages.postgresql-simple
|
||||
pkgs.haskellPackages.profunctors
|
||||
pkgs.haskellPackages.PyF
|
||||
pkgs.haskellPackages.semigroupoids
|
||||
pkgs.haskellPackages.these
|
||||
pkgs.haskellPackages.typed-process
|
||||
pkgs.haskellPackages.unliftio
|
||||
pkgs.haskellPackages.validation-selective
|
||||
pkgs.haskellPackages.vector
|
||||
|
||||
|
||||
];
|
||||
|
||||
license = lib.licenses.mit;
|
||||
|
|
|
@ -56,9 +56,7 @@ library
|
|||
hs-source-dirs: src
|
||||
exposed-modules:
|
||||
MyPrelude
|
||||
Pretty
|
||||
Aeson
|
||||
RunCommand
|
||||
Test
|
||||
Postgres.Decoder
|
||||
Postgres.MonadPostgres
|
||||
|
@ -76,20 +74,18 @@ library
|
|||
, pa-label
|
||||
, pa-error-tree
|
||||
, pa-json
|
||||
, pa-pretty
|
||||
, aeson
|
||||
, aeson-better-errors
|
||||
, ansi-terminal
|
||||
, bytestring
|
||||
, containers
|
||||
, error
|
||||
, exceptions
|
||||
, filepath
|
||||
, hscolour
|
||||
, hspec
|
||||
, hspec-expectations-pretty-diff
|
||||
, monad-logger
|
||||
, mtl
|
||||
, nicify-lib
|
||||
, postgresql-simple
|
||||
, profunctors
|
||||
, PyF
|
||||
|
@ -97,7 +93,6 @@ library
|
|||
, selective
|
||||
, text
|
||||
, these
|
||||
, typed-process
|
||||
, unix
|
||||
, unliftio
|
||||
, validation-selective
|
||||
|
|
|
@ -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…
Reference in a new issue