1 files changed, 108 insertions, 0 deletions
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