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
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiWayIf #-}
module Main where
import Control.Monad (unless, when)
import Control.Monad.Identity (Identity)
import Data.Aeson (eitherDecode, encode)
import Data.Aeson.Encode.Pretty (encodePretty)
import Data.Aeson.KeyMap (coercionToHashMap)
import qualified Data.ByteString.Lazy as LB
import Data.Maybe (fromMaybe)
import qualified Data.Text.Encoding as T
import qualified Data.Text.IO as T
import System.Exit (ExitCode (..), exitWith)
import System.IO (hPutStrLn, stderr)
import WithCli (Generic, HasArguments, withCli)
import CheckDir (recursiveCheckDir, resultIsFatal, DirResult (dirresultGraph))
import Control.Monad (when)
import LintConfig (LintConfig (..), patchConfig)
import Types (Level (..))
import Util (printPretty)
import WriteRepo (writeAdjustedRepository)
import Text.Dot (showDot)
import qualified Version as V (version)
-- | 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 Maybe)
-- ^ 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
when (version options) $ do
putStrLn V.version
exitWith ExitSuccess
let repo = fromMaybe "." (repository options)
let entry = fromMaybe "main.json" (entrypoint options)
let level = fromMaybe Suggestion (lintlevel options)
lintconfig <- case configFile options of
Nothing -> error "Need a config file!"
Just path -> LB.readFile path >>= \res ->
case eitherDecode res :: Either String (LintConfig Identity) of
Left err -> error $ "config file invalid: " <> err
Right file -> pure (patchConfig file (config options))
lints <- recursiveCheckDir lintconfig repo entry
if | dot options ->
putStrLn (showDot $ dirresultGraph lints)
| json options ->
printLB
$ if pretty options then encodePretty lints else encode lints
| otherwise -> printPretty (level, lints)
case out options of
Nothing -> exitWith $ case resultIsFatal lintconfig lints of
False -> ExitSuccess
True -> ExitFailure 1
Just outpath -> do
c <- writeAdjustedRepository lintconfig repo outpath lints
unless (json options) $
case c of
ExitFailure 1 -> putStrLn "\nMap failed linting!"
ExitFailure 2 -> putStrLn "\nOutpath already exists, not writing anything."
_ -> pure ()
exitWith c
-- | haskell's many string types are FUN …
printLB :: LB.ByteString -> IO ()
printLB a = T.putStrLn $ T.decodeUtf8 $ LB.toStrict a
-- 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."
_ -> pure ()
|
