1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
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
|
