165 lines
4.5 KiB
Haskell
165 lines
4.5 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
|
|
|
|
module Main where
|
|
|
|
import GHCup.Types.JSON ( )
|
|
import GHCup.Utils.Logger
|
|
import GHCupDownloads
|
|
|
|
import Data.Aeson ( eitherDecode )
|
|
import Data.Aeson.Encode.Pretty
|
|
import Data.Semigroup ( (<>) )
|
|
import Options.Applicative hiding ( style )
|
|
import System.Console.Pretty
|
|
import System.Exit
|
|
import System.IO ( stdout )
|
|
import Validate
|
|
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
|
|
data Options = Options
|
|
{ optCommand :: Command
|
|
}
|
|
|
|
data Command = GenJSON GenJSONOpts
|
|
| ValidateJSON ValidateJSONOpts
|
|
| ValidateTarballs ValidateJSONOpts
|
|
|
|
data Output
|
|
= FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
|
|
| StdOutput
|
|
|
|
fileOutput :: Parser Output
|
|
fileOutput =
|
|
FileOutput
|
|
<$> (strOption
|
|
(long "file" <> short 'f' <> metavar "FILENAME" <> help
|
|
"Output to a file"
|
|
)
|
|
)
|
|
|
|
stdOutput :: Parser Output
|
|
stdOutput = flag'
|
|
StdOutput
|
|
(short 'o' <> long "stdout" <> help "Print to stdout (default)")
|
|
|
|
outputP :: Parser Output
|
|
outputP = fileOutput <|> stdOutput
|
|
|
|
|
|
data GenJSONOpts = GenJSONOpts
|
|
{ output :: Maybe Output
|
|
}
|
|
|
|
genJSONOpts :: Parser GenJSONOpts
|
|
genJSONOpts = GenJSONOpts <$> optional outputP
|
|
|
|
|
|
data Input
|
|
= FileInput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
|
|
| StdInput
|
|
|
|
fileInput :: Parser Input
|
|
fileInput =
|
|
FileInput
|
|
<$> (strOption
|
|
(long "file" <> short 'f' <> metavar "FILENAME" <> help
|
|
"Input file to validate"
|
|
)
|
|
)
|
|
|
|
stdInput :: Parser Input
|
|
stdInput = flag'
|
|
StdInput
|
|
(short 'i' <> long "stdin" <> help "Validate from stdin (default)")
|
|
|
|
inputP :: Parser Input
|
|
inputP = fileInput <|> stdInput
|
|
|
|
data ValidateJSONOpts = ValidateJSONOpts
|
|
{ input :: Maybe Input
|
|
}
|
|
|
|
validateJSONOpts :: Parser ValidateJSONOpts
|
|
validateJSONOpts = ValidateJSONOpts <$> optional inputP
|
|
|
|
opts :: Parser Options
|
|
opts = Options <$> com
|
|
|
|
com :: Parser Command
|
|
com = subparser
|
|
( (command
|
|
"gen"
|
|
( GenJSON
|
|
<$> (info (genJSONOpts <**> helper)
|
|
(progDesc "Generate the json downloads file")
|
|
)
|
|
)
|
|
)
|
|
<> (command
|
|
"check"
|
|
( ValidateJSON
|
|
<$> (info (validateJSONOpts <**> helper)
|
|
(progDesc "Validate the JSON")
|
|
)
|
|
)
|
|
)
|
|
<> (command
|
|
"check-tarballs"
|
|
( ValidateTarballs
|
|
<$> (info
|
|
(validateJSONOpts <**> helper)
|
|
(progDesc "Validate all tarballs (download and checksum)")
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
|
|
|
|
main :: IO ()
|
|
main = do
|
|
customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
|
>>= \Options {..} -> case optCommand of
|
|
GenJSON gopts -> do
|
|
let
|
|
bs = encodePretty' (defConfig { confIndent = Spaces 2 })
|
|
ghcupDownloads
|
|
case gopts of
|
|
GenJSONOpts { output = Nothing } -> L.hPutStr stdout bs
|
|
GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs
|
|
GenJSONOpts { output = Just (FileOutput file) } ->
|
|
L.writeFile file bs
|
|
ValidateJSON vopts -> case vopts of
|
|
ValidateJSONOpts { input = Nothing } ->
|
|
L.getContents >>= valAndExit validate
|
|
ValidateJSONOpts { input = Just StdInput } ->
|
|
L.getContents >>= valAndExit validate
|
|
ValidateJSONOpts { input = Just (FileInput file) } ->
|
|
L.readFile file >>= valAndExit validate
|
|
ValidateTarballs vopts -> case vopts of
|
|
ValidateJSONOpts { input = Nothing } ->
|
|
L.getContents >>= valAndExit validateTarballs
|
|
ValidateJSONOpts { input = Just StdInput } ->
|
|
L.getContents >>= valAndExit validateTarballs
|
|
ValidateJSONOpts { input = Just (FileInput file) } ->
|
|
L.readFile file >>= valAndExit validateTarballs
|
|
pure ()
|
|
|
|
where
|
|
valAndExit f contents = do
|
|
av <- case eitherDecode contents of
|
|
Right r -> pure r
|
|
Left e -> die (color Red $ show e)
|
|
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
|
|
>>= exitWith
|
|
|