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

158 lines
5.4 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-10 15:36:27 +00:00
import GHCup.Types
2021-08-30 20:41:58 +00:00
import GHCup.Errors
import GHCup.Platform
import GHCup.Utils.Dirs
2021-09-23 10:53:01 +00:00
import GHCup.Utils.Logger
2020-01-11 20:15:05 +00:00
import GHCup.Types.JSON ( )
2021-08-30 20:41:58 +00:00
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.IO.Class
2021-01-02 06:58:08 +00:00
import Data.Char ( toLower )
import Data.Maybe
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 )
2021-08-30 20:41:58 +00:00
import Haskus.Utils.Variant.Excepts
2020-01-11 20:15:05 +00:00
import System.Console.Pretty
import System.Environment
2020-01-11 20:15:05 +00:00
import System.Exit
2021-08-30 20:41:58 +00:00
import System.IO ( stderr )
2021-01-02 04:05:05 +00:00
import Text.Regex.Posix
2020-01-11 20:15:05 +00:00
import Validate
2021-08-30 20:41:58 +00:00
import Text.PrettyPrint.HughesPJClass ( prettyShow )
2020-01-11 20:15:05 +00:00
2021-08-30 20:41:58 +00:00
import qualified Data.Text.IO as T
import qualified Data.Text as T
2020-01-11 20:15:05 +00:00
import qualified Data.ByteString as B
2021-08-30 21:04:28 +00:00
import qualified Data.YAML.Aeson 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
no_color <- isJust <$> lookupEnv "NO_COLOR"
let loggerConfig = LoggerConfig { lcPrintDebug = True
, consoleOutter = T.hPutStr stderr
, fileOutter = \_ -> pure ()
, fancyColors = not no_color
2021-08-30 20:41:58 +00:00
}
dirs <- liftIO getAllDirs
let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings loggerConfig
2021-08-30 20:41:58 +00:00
pfreq <- (
flip runReaderT leanAppstate . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
2021-08-30 20:41:58 +00:00
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
2021-08-30 20:41:58 +00:00
ValidateYAML vopts -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validate dl m)
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validateTarballs tarballFilter dl m)
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-08-30 21:04:28 +00:00
(GHCupInfo _ av gt) <- case Y.decode1Strict contents of
2020-01-11 20:15:05 +00:00
Right r -> pure r
2021-08-30 21:04:28 +00:00
Left (_, e) -> die (color Red $ show e)
2021-08-30 20:41:58 +00:00
f av gt
2020-01-11 20:15:05 +00:00
>>= exitWith