From 9110064fe62f98dd3ecc5fb4c3915a843492b8fb Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 23 Oct 2023 23:18:34 +0200
Subject: a year went by

This does many meta-things, but changes no functionality:
 - get rid of stack, and use just cabal with a stackage snapshot instead
   (why did I ever think stack was a good idea?)
 - update the stackage snapshot to something halfway recent
 - thus making builds work on nixpkgs-23.05 (current stable)
 - separating out packages into their own cabal files
 - use the GHC2021 set of extensions as default
 - very slight code changes to make things build again
 - update readme accordingly
 - stylish-haskell run
---
 walint-cli/Main.hs | 108 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 108 insertions(+)
 create mode 100644 walint-cli/Main.hs

(limited to 'walint-cli/Main.hs')

diff --git a/walint-cli/Main.hs b/walint-cli/Main.hs
new file mode 100644
index 0000000..4bbc670
--- /dev/null
+++ b/walint-cli/Main.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveAnyClass    #-}
+{-# LANGUAGE LambdaCase        #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+module Main where
+
+import           Universum
+
+import           Data.Aeson               (eitherDecodeFileStrict', encode)
+import           Data.Aeson.Encode.Pretty (encodePretty)
+import           Data.Aeson.KeyMap        (coercionToHashMap)
+import           WithCli                  (HasArguments, withCli)
+
+import           CheckDir                 (recursiveCheckDir, resultIsFatal)
+import           LintConfig               (ConfigKind (..), LintConfig (..),
+                                           patchConfig)
+import           System.Exit              (ExitCode (ExitFailure))
+import           Types                    (Level (..))
+import           Util                     (printPretty)
+import qualified Version                  as V (version)
+import           WriteRepo                (writeAdjustedRepository)
+
+-- | the options this cli tool can take
+data Options = Options
+  { repository :: Maybe String
+  -- ^ path to the repository containing maps to lint
+  , entrypoint :: Maybe String
+  -- ^ entrypoint in that repository
+  , json       :: Bool
+  -- ^ emit json if --json was given
+  , lintlevel  :: Maybe Level
+  -- ^ maximum lint level to print
+  , pretty     :: Bool
+  -- ^ pretty-print the json to make it human-readable
+  , out        :: Maybe String
+  -- ^ path to write the (possibly adjusted) maps to after linting
+  , configFile :: Maybe FilePath
+  -- ^ path to a config file. Currently required.
+  , config     :: Maybe (LintConfig Patch)
+  -- ^ a "patch" for the configuration file
+  , version    :: Bool
+  , dot        :: Bool
+  } deriving (Show, Generic, HasArguments)
+
+
+main :: IO ()
+main = withCli run
+
+run :: Options -> IO ()
+run Options { .. } = do
+  aesonWarning
+
+  if version then
+    putStrLn V.version
+  else do
+    let repo = fromMaybe "." repository
+    let entry = fromMaybe "main.json" entrypoint
+    let level = fromMaybe Suggestion lintlevel
+    configFile' <- case configFile of
+      Nothing -> do
+        hPutStrLn stderr ("option --config-file=FILEPATH required" :: Text)
+        exitFailure
+      Just path -> pure path
+
+    lintconfig <- eitherDecodeFileStrict' configFile' >>= \case
+      Left  err  -> error $ "config file invalid: " <> toText err
+      Right file -> pure (patchConfig file config)
+
+    lints <- recursiveCheckDir lintconfig repo entry
+
+    if json
+      then putText
+      $ decodeUtf8 (if pretty then encodePretty lints else encode lints)
+      else printPretty (level, lints)
+
+    case out of
+      Nothing
+        | resultIsFatal lintconfig lints -> exitWith (ExitFailure 1)
+        | otherwise -> exitSuccess
+      Just outpath -> do
+        c <- writeAdjustedRepository lintconfig repo outpath lints
+        unless json $
+          case c of
+            ExitFailure 1 ->
+              putTextLn "\nMap failed linting!"
+            ExitFailure 2 ->
+              putTextLn "\nOutpath already exists, not writing anything."
+            _ -> pass
+        exitWith c
+
+
+-- if Aesons's internal map and HashMap are the same type, then coercionToHashMap
+-- will contain a proof of that, and we can print a warning. Otherwise we're not
+-- using HashMaps in Aeson and everything is fine.
+--
+-- cf. https://frasertweedale.github.io/blog-fp/posts/2021-10-12-aeson-hash-flooding-protection.html
+aesonWarning :: IO ()
+aesonWarning = case coercionToHashMap of
+  Just _ -> hPutStrLn stderr
+    ("Warning: this program was compiled using an older version of the Aeson Library\n\
+    \used for parsing JSON, which is susceptible to hash flooding attacks.\n\
+    \n\
+    \Recompiling with a newer version is recommended when handling untrusted inputs.\n\
+    \n\
+    \See https://cs-syd.eu/posts/2021-09-11-json-vulnerability for details." :: Text)
+  _ -> pass
-- 
cgit v1.2.3