Initial commit
This commit is contained in:
1693
app/ghcup-gen/GHCupDownloads.hs
Normal file
1693
app/ghcup-gen/GHCupDownloads.hs
Normal file
File diff suppressed because it is too large
Load Diff
164
app/ghcup-gen/Main.hs
Normal file
164
app/ghcup-gen/Main.hs
Normal file
@@ -0,0 +1,164 @@
|
||||
{-# 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
|
||||
|
||||
181
app/ghcup-gen/Validate.hs
Normal file
181
app/ghcup-gen/Validate.hs
Normal file
@@ -0,0 +1,181 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Validate where
|
||||
|
||||
import GHCup
|
||||
import GHCup.Download
|
||||
import GHCup.Types
|
||||
import GHCup.Utils.Logger
|
||||
|
||||
import Control.Exception.Safe
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Monad.Logger
|
||||
import Control.Monad.Reader.Class
|
||||
import Control.Monad.Trans.Class ( lift )
|
||||
import Control.Monad.Trans.Reader ( runReaderT )
|
||||
import Control.Monad.Trans.Resource ( runResourceT
|
||||
, MonadUnliftIO
|
||||
)
|
||||
import Data.IORef
|
||||
import Data.List
|
||||
import Data.String.Interpolate
|
||||
import Data.Versions
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Optics
|
||||
import System.Exit
|
||||
import System.IO
|
||||
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Map.Strict as M
|
||||
|
||||
|
||||
data ValidationError = InternalError String
|
||||
deriving Show
|
||||
|
||||
instance Exception ValidationError
|
||||
|
||||
|
||||
addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
|
||||
addError = do
|
||||
ref <- ask
|
||||
liftIO $ modifyIORef ref (+ 1)
|
||||
|
||||
|
||||
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
|
||||
=> GHCupDownloads
|
||||
-> m ExitCode
|
||||
validate dls = do
|
||||
ref <- liftIO $ newIORef 0
|
||||
|
||||
-- * verify binary downloads * --
|
||||
flip runReaderT ref $ do
|
||||
-- unique tags
|
||||
forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
|
||||
|
||||
-- required platforms
|
||||
forM_ (M.toList dls) $ \(t, versions) ->
|
||||
forM_ (M.toList versions) $ \(v, vi) ->
|
||||
forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
|
||||
checkHasRequiredPlatforms t v arch (M.keys pspecs)
|
||||
|
||||
checkGHCisSemver
|
||||
forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
|
||||
|
||||
-- exit
|
||||
e <- liftIO $ readIORef ref
|
||||
if e > 0
|
||||
then pure $ ExitFailure e
|
||||
else do
|
||||
lift $ $(logInfo) [i|All good|]
|
||||
pure ExitSuccess
|
||||
where
|
||||
checkHasRequiredPlatforms t v arch pspecs = do
|
||||
let v' = prettyVer v
|
||||
when (not $ any (== Linux UnknownLinux) pspecs) $ do
|
||||
lift $ $(logError)
|
||||
[i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
|
||||
addError
|
||||
when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do
|
||||
lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
|
||||
addError
|
||||
when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
|
||||
[i|FreeBSD missing for #{t} #{v'} #{arch}|]
|
||||
|
||||
checkUniqueTags tool = do
|
||||
let allTags = join $ fmap snd $ availableToolVersions dls tool
|
||||
let nonUnique =
|
||||
fmap fst
|
||||
. filter (\(_, b) -> not b)
|
||||
<$> ( mapM
|
||||
(\case
|
||||
[] -> throwM $ InternalError "empty inner list"
|
||||
(t : ts) ->
|
||||
pure $ (t, ) $ if isUniqueTag t then ts == [] else True
|
||||
)
|
||||
. group
|
||||
. sort
|
||||
$ allTags
|
||||
)
|
||||
case join nonUnique of
|
||||
[] -> pure ()
|
||||
xs -> do
|
||||
lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|]
|
||||
addError
|
||||
where
|
||||
isUniqueTag Latest = True
|
||||
isUniqueTag Recommended = True
|
||||
|
||||
checkGHCisSemver = do
|
||||
let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
|
||||
forM_ ghcVers $ \v -> case semver (prettyVer v) of
|
||||
Left _ -> do
|
||||
lift $ $(logError) [i|GHC version #{v} is not valid semver|]
|
||||
addError
|
||||
Right _ -> pure ()
|
||||
|
||||
-- a tool must have at least one of each mandatory tags
|
||||
checkMandatoryTags tool = do
|
||||
let allTags = join $ fmap snd $ availableToolVersions dls tool
|
||||
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
|
||||
False -> do
|
||||
lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
|
||||
addError
|
||||
True -> pure ()
|
||||
|
||||
|
||||
validateTarballs :: ( Monad m
|
||||
, MonadLogger m
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadUnliftIO m
|
||||
, MonadMask m
|
||||
)
|
||||
=> GHCupDownloads
|
||||
-> m ExitCode
|
||||
validateTarballs dls = do
|
||||
ref <- liftIO $ newIORef 0
|
||||
|
||||
flip runReaderT ref $ do
|
||||
-- download/verify all binary tarballs
|
||||
let
|
||||
dlbis = nub $ join $ (M.elems dls) <&> \versions ->
|
||||
join $ (M.elems versions) <&> \vi ->
|
||||
join $ (M.elems $ _viArch vi) <&> \pspecs ->
|
||||
join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs)
|
||||
forM_ dlbis $ downloadAll
|
||||
|
||||
let dlsrc = nub $ join $ (M.elems dls) <&> \versions ->
|
||||
join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL
|
||||
forM_ dlsrc $ downloadAll
|
||||
|
||||
-- exit
|
||||
e <- liftIO $ readIORef ref
|
||||
if e > 0
|
||||
then pure $ ExitFailure e
|
||||
else do
|
||||
lift $ $(logInfo) [i|All good|]
|
||||
pure ExitSuccess
|
||||
|
||||
where
|
||||
downloadAll dli = do
|
||||
let settings = Settings True GHCupURL False
|
||||
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
|
||||
, colorOutter = B.hPut stderr
|
||||
, rawOutter = (\_ -> pure ())
|
||||
}
|
||||
|
||||
r <-
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runResourceT
|
||||
. runE
|
||||
$ downloadCached dli Nothing
|
||||
case r of
|
||||
VRight _ -> pure ()
|
||||
VLeft e -> do
|
||||
lift $ $(logError)
|
||||
[i|Could not download (or verify hash) of #{dli}, Error was: #{e}|]
|
||||
addError
|
||||
Reference in New Issue
Block a user