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

128 lines
3.9 KiB
Haskell
Raw Permalink 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-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
2021-01-02 06:58:08 +00:00
import Data.Char ( toLower )
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 )
2021-01-02 04:05:05 +00:00
import Text.Regex.Posix
2020-01-11 20:15:05 +00:00
import Validate
import qualified Data.ByteString as B
2020-08-09 15:39:02 +00:00
import qualified Data.Yaml as Y
2020-01-11 20:15:05 +00:00
data Options = Options
{ optCommand :: Command
}
2020-08-09 15:39:02 +00:00
data Command = ValidateYAML ValidateYAMLOpts
2021-01-02 04:53:11 +00:00
| ValidateTarballs ValidateYAMLOpts TarballFilter
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
2021-03-11 16:03:51 +00:00
<$> strOption
2020-01-11 20:15:05 +00:00
(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
2020-08-09 15:39:02 +00:00
data ValidateYAMLOpts = ValidateYAMLOpts
{ vInput :: Maybe Input
2020-01-11 20:15:05 +00:00
}
2020-08-09 15:39:02 +00:00
validateYAMLOpts :: Parser ValidateYAMLOpts
validateYAMLOpts = ValidateYAMLOpts <$> optional inputP
2020-01-11 20:15:05 +00:00
2021-01-02 04:53:11 +00:00
tarballFilterP :: Parser TarballFilter
tarballFilterP = option readm $
long "tarball-filter" <> short 'u' <> metavar "<tool>-<version>" <> value def
2021-01-02 06:58:08 +00:00
<> help "Only check certain tarballs (format: <tool>-<version>)"
2021-01-02 04:53:11 +00:00
where
def = TarballFilter (Right Nothing) (makeRegex ("" :: String))
2021-01-02 04:53:11 +00:00
readm = do
s <- str
2021-01-02 06:58:08 +00:00
case span (/= '-') s of
(_, []) -> fail "invalid format, missing '-' after the tool name"
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
pure (TarballFilter $ Right $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
(t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
pure (TarballFilter $ Left tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
2021-01-02 06:58:08 +00:00
_ -> fail "invalid tool"
low = fmap toLower
2020-01-11 20:15:05 +00:00
opts :: Parser Options
opts = Options <$> com
com :: Parser Command
com = subparser
2021-03-11 16:03:51 +00:00
( command
2020-01-11 20:15:05 +00:00
"check"
2020-08-09 15:39:02 +00:00
( ValidateYAML
2021-03-11 16:03:51 +00:00
<$> info (validateYAMLOpts <**> helper)
(progDesc "Validate the YAML")
2020-01-11 20:15:05 +00:00
)
2021-03-11 16:03:51 +00:00
<> command
2020-01-11 20:15:05 +00:00
"check-tarballs"
(info
2021-01-02 04:53:11 +00:00
((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
(progDesc "Validate all tarballs (download and checksum)")
2020-01-11 20:15:05 +00:00
)
)
main :: IO ()
main = do
2020-08-09 15:39:02 +00:00
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
2020-01-11 20:15:05 +00:00
>>= \Options {..} -> case optCommand of
ValidateYAML vopts -> withValidateYamlOpts vopts validate
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (validateTarballs tarballFilter)
2020-01-11 20:15:05 +00:00
pure ()
where
withValidateYamlOpts vopts f = case vopts of
ValidateYAMLOpts { vInput = Nothing } ->
B.getContents >>= valAndExit f
ValidateYAMLOpts { vInput = Just StdInput } ->
B.getContents >>= valAndExit f
ValidateYAMLOpts { vInput = Just (FileInput file) } ->
B.readFile file >>= valAndExit f
2020-01-11 20:15:05 +00:00
valAndExit f contents = do
2021-05-14 21:09:45 +00:00
(GHCupInfo _ av gt) <- case Y.decodeEither' contents of
2020-01-11 20:15:05 +00:00
Right r -> pure r
Left e -> die (color Red $ show e)
2021-05-14 21:09:45 +00:00
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av gt)
2020-01-11 20:15:05 +00:00
>>= exitWith