ghcup-hs/app/ghcup-gen/Main.hs

174 lines
4.9 KiB
Haskell
Raw Normal View History

2020-04-09 17:53:22 +00:00
{-# LANGUAGE CPP #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE NamedFieldPuns #-}
2020-01-11 20:15:05 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
2020-01-11 20:15:05 +00:00
module Main where
2020-04-22 17:32:48 +00:00
import GHCup.Data.GHCupInfo
2020-04-10 15:36:27 +00:00
import GHCup.Types
2020-01-11 20:15:05 +00:00
import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import Data.Aeson ( eitherDecode, encode )
2020-01-11 20:15:05 +00:00
import Data.Aeson.Encode.Pretty
2020-04-09 17:53:22 +00:00
#if !MIN_VERSION_base(4,13,0)
2020-01-11 20:15:05 +00:00
import Data.Semigroup ( (<>) )
2020-04-09 17:53:22 +00:00
#endif
2020-01-11 20:15:05 +00:00
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
, pretty :: Bool
2020-01-11 20:15:05 +00:00
}
genJSONOpts :: Parser GenJSONOpts
genJSONOpts = GenJSONOpts <$> optional outputP <*> switch
(short 'p' <> long "pretty" <> help "Make JSON output pretty (human readable)"
)
2020-01-11 20:15:05 +00:00
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 True =
encodePretty' (defConfig { confIndent = Spaces 2 }) ghcupInfo
bs False = encode ghcupInfo
2020-01-11 20:15:05 +00:00
case gopts of
GenJSONOpts { output = Nothing, pretty } ->
L.hPutStr stdout (bs pretty)
GenJSONOpts { output = Just StdOutput, pretty } ->
L.hPutStr stdout (bs pretty)
GenJSONOpts { output = Just (FileOutput file), pretty } ->
L.writeFile file (bs pretty)
2020-01-11 20:15:05 +00:00
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
2020-04-10 15:36:27 +00:00
(GHCupInfo _ av) <- case eitherDecode contents of
2020-01-11 20:15:05 +00:00
Right r -> pure r
Left e -> die (color Red $ show e)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
>>= exitWith