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 2023-08-06 12:46:50 +02:00 committed by clbot
parent ce4acc08a5
commit 1fd59f5158
12 changed files with 122 additions and 335 deletions

View file

@ -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

View file

@ -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"

View file

@ -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
];

View file

@ -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,

View file

@ -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 ::

View file

@ -7,7 +7,7 @@ let
src = depot.users.Profpatsch.exactSource ./. [
./mailbox-org.cabal
./AesonQQ.hs
./src/AesonQQ.hs
./MailboxOrg.hs
];

View file

@ -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

View file

@ -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
|]

View file

@ -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;

View file

@ -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

View file

@ -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]

View file

@ -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 dont 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 thats 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' <> "'"