Add ghcup-gen
This commit is contained in:
parent
aa77fec353
commit
f16faca114
24
.github/workflows/test.yaml
vendored
24
.github/workflows/test.yaml
vendored
@ -14,6 +14,10 @@ jobs:
|
|||||||
YAML_VER: 0.0.6
|
YAML_VER: 0.0.6
|
||||||
strategy:
|
strategy:
|
||||||
matrix:
|
matrix:
|
||||||
|
ghc:
|
||||||
|
- '8.10.7'
|
||||||
|
cabal:
|
||||||
|
- '3.6.2.0'
|
||||||
os:
|
os:
|
||||||
- ubuntu-latest
|
- ubuntu-latest
|
||||||
steps:
|
steps:
|
||||||
@ -22,8 +26,22 @@ jobs:
|
|||||||
|
|
||||||
- uses: haskell/actions/setup@v1.2
|
- uses: haskell/actions/setup@v1.2
|
||||||
with:
|
with:
|
||||||
ghc-version: 8.10.7
|
ghc-version: ${{ matrix.ghc }}
|
||||||
cabal-version: 3.6.2.0
|
cabal-version: ${{ matrix.cabal }}
|
||||||
|
|
||||||
|
- name: Cache Cabal
|
||||||
|
uses: actions/cache@v2
|
||||||
|
env:
|
||||||
|
cache-name: cache-cabal
|
||||||
|
with:
|
||||||
|
path: |
|
||||||
|
~/.cabal/store
|
||||||
|
~/.cabal/packages
|
||||||
|
key: v2-${{ runner.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}-build-${{ hashFiles('cabal.project') }}
|
||||||
|
restore-keys: |
|
||||||
|
v2-${{ runner.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}-build-${{ hashFiles('cabal.project') }}
|
||||||
|
v2-${{ runner.os }}-${{ matrix.ghc }}-${{ matrix.cabal }}-build-
|
||||||
|
v2-${{ runner.os }}-${{ matrix.ghc }}
|
||||||
|
|
||||||
- name: create ~/.local/bin
|
- name: create ~/.local/bin
|
||||||
run: mkdir -p "$HOME/.local/bin"
|
run: mkdir -p "$HOME/.local/bin"
|
||||||
@ -39,7 +57,7 @@ jobs:
|
|||||||
|
|
||||||
- name: Install ghcup-gen
|
- name: Install ghcup-gen
|
||||||
run: |
|
run: |
|
||||||
cabal install --installdir="$HOME/.local/bin" --overwrite-policy=always --install-method=copy ghcup
|
cabal install --installdir="$HOME/.local/bin" --overwrite-policy=always --install-method=copy ghcup-gen
|
||||||
shell: bash
|
shell: bash
|
||||||
|
|
||||||
- name: Check
|
- name: Check
|
||||||
|
17
.gitignore
vendored
Normal file
17
.gitignore
vendored
Normal file
@ -0,0 +1,17 @@
|
|||||||
|
.ghci
|
||||||
|
.vim
|
||||||
|
codex.tags
|
||||||
|
dist-newstyle/
|
||||||
|
cabal.project.local
|
||||||
|
.stack-work/
|
||||||
|
bin/
|
||||||
|
/*.prof
|
||||||
|
/*.ps
|
||||||
|
/*.hp
|
||||||
|
tags
|
||||||
|
TAGS
|
||||||
|
/tmp/
|
||||||
|
.entangled
|
||||||
|
release/
|
||||||
|
releases/
|
||||||
|
site/
|
@ -7,7 +7,6 @@
|
|||||||
3. copy-paste it
|
3. copy-paste it
|
||||||
4. adjust the version, tags, changelog, source url
|
4. adjust the version, tags, changelog, source url
|
||||||
5. adjust the various bindist urls (make sure to also change the yaml anchors)
|
5. adjust the various bindist urls (make sure to also change the yaml anchors)
|
||||||
6. build the `ghcup-gen` binary from the [ghcup repo](https://gitlab.haskell.org/haskell/ghcup-hs)
|
6. run `cabal run ghcup-gen -- check -f ghcup-<yaml-ver>.yaml`
|
||||||
7. run `ghcup-gen -- check -f ghcup-<yaml-ver>.yaml`
|
7. run `cabal run ghcup-gen -- check-tarballs -f ghcup-<yaml-ver>.yaml -u 'ghc-8\.10\.8'`
|
||||||
8. run `ghcup-gen -- check-tarballs -f ghcup-<yaml-ver>.yaml -u 'ghc-8\.10\.8'`
|
|
||||||
|
|
||||||
|
29
cabal.project
Normal file
29
cabal.project
Normal file
@ -0,0 +1,29 @@
|
|||||||
|
packages: ./ghcup-gen/ghcup-gen.cabal
|
||||||
|
|
||||||
|
package ghcup
|
||||||
|
tests: False
|
||||||
|
flags: -tui +no-exe
|
||||||
|
|
||||||
|
source-repository-package
|
||||||
|
type: git
|
||||||
|
location: https://gitlab.haskell.org/haskell/ghcup-hs.git
|
||||||
|
tag: v0.1.17.3
|
||||||
|
|
||||||
|
constraints: http-io-streams -brotli,
|
||||||
|
any.Cabal ==3.6.2.0,
|
||||||
|
any.aeson >= 2.0.1.0
|
||||||
|
|
||||||
|
package libarchive
|
||||||
|
flags: -system-libarchive
|
||||||
|
|
||||||
|
package aeson-pretty
|
||||||
|
flags: +lib-only
|
||||||
|
|
||||||
|
package cabal-plan
|
||||||
|
flags: -exe
|
||||||
|
|
||||||
|
package aeson
|
||||||
|
flags: +ordered-keymap
|
||||||
|
|
||||||
|
allow-newer: base, ghc-prim, template-haskell, language-c
|
||||||
|
|
6
ghcup-gen/CHANGELOG.md
Normal file
6
ghcup-gen/CHANGELOG.md
Normal file
@ -0,0 +1,6 @@
|
|||||||
|
# Revision history for ghcup-gen
|
||||||
|
|
||||||
|
## 0.1.17.3 -- 2021-10-27
|
||||||
|
|
||||||
|
* First release (split from ghcup)
|
||||||
|
|
165
ghcup-gen/LICENSE
Normal file
165
ghcup-gen/LICENSE
Normal file
@ -0,0 +1,165 @@
|
|||||||
|
GNU LESSER GENERAL PUBLIC LICENSE
|
||||||
|
Version 3, 29 June 2007
|
||||||
|
|
||||||
|
Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>
|
||||||
|
Everyone is permitted to copy and distribute verbatim copies
|
||||||
|
of this license document, but changing it is not allowed.
|
||||||
|
|
||||||
|
|
||||||
|
This version of the GNU Lesser General Public License incorporates
|
||||||
|
the terms and conditions of version 3 of the GNU General Public
|
||||||
|
License, supplemented by the additional permissions listed below.
|
||||||
|
|
||||||
|
0. Additional Definitions.
|
||||||
|
|
||||||
|
As used herein, "this License" refers to version 3 of the GNU Lesser
|
||||||
|
General Public License, and the "GNU GPL" refers to version 3 of the GNU
|
||||||
|
General Public License.
|
||||||
|
|
||||||
|
"The Library" refers to a covered work governed by this License,
|
||||||
|
other than an Application or a Combined Work as defined below.
|
||||||
|
|
||||||
|
An "Application" is any work that makes use of an interface provided
|
||||||
|
by the Library, but which is not otherwise based on the Library.
|
||||||
|
Defining a subclass of a class defined by the Library is deemed a mode
|
||||||
|
of using an interface provided by the Library.
|
||||||
|
|
||||||
|
A "Combined Work" is a work produced by combining or linking an
|
||||||
|
Application with the Library. The particular version of the Library
|
||||||
|
with which the Combined Work was made is also called the "Linked
|
||||||
|
Version".
|
||||||
|
|
||||||
|
The "Minimal Corresponding Source" for a Combined Work means the
|
||||||
|
Corresponding Source for the Combined Work, excluding any source code
|
||||||
|
for portions of the Combined Work that, considered in isolation, are
|
||||||
|
based on the Application, and not on the Linked Version.
|
||||||
|
|
||||||
|
The "Corresponding Application Code" for a Combined Work means the
|
||||||
|
object code and/or source code for the Application, including any data
|
||||||
|
and utility programs needed for reproducing the Combined Work from the
|
||||||
|
Application, but excluding the System Libraries of the Combined Work.
|
||||||
|
|
||||||
|
1. Exception to Section 3 of the GNU GPL.
|
||||||
|
|
||||||
|
You may convey a covered work under sections 3 and 4 of this License
|
||||||
|
without being bound by section 3 of the GNU GPL.
|
||||||
|
|
||||||
|
2. Conveying Modified Versions.
|
||||||
|
|
||||||
|
If you modify a copy of the Library, and, in your modifications, a
|
||||||
|
facility refers to a function or data to be supplied by an Application
|
||||||
|
that uses the facility (other than as an argument passed when the
|
||||||
|
facility is invoked), then you may convey a copy of the modified
|
||||||
|
version:
|
||||||
|
|
||||||
|
a) under this License, provided that you make a good faith effort to
|
||||||
|
ensure that, in the event an Application does not supply the
|
||||||
|
function or data, the facility still operates, and performs
|
||||||
|
whatever part of its purpose remains meaningful, or
|
||||||
|
|
||||||
|
b) under the GNU GPL, with none of the additional permissions of
|
||||||
|
this License applicable to that copy.
|
||||||
|
|
||||||
|
3. Object Code Incorporating Material from Library Header Files.
|
||||||
|
|
||||||
|
The object code form of an Application may incorporate material from
|
||||||
|
a header file that is part of the Library. You may convey such object
|
||||||
|
code under terms of your choice, provided that, if the incorporated
|
||||||
|
material is not limited to numerical parameters, data structure
|
||||||
|
layouts and accessors, or small macros, inline functions and templates
|
||||||
|
(ten or fewer lines in length), you do both of the following:
|
||||||
|
|
||||||
|
a) Give prominent notice with each copy of the object code that the
|
||||||
|
Library is used in it and that the Library and its use are
|
||||||
|
covered by this License.
|
||||||
|
|
||||||
|
b) Accompany the object code with a copy of the GNU GPL and this license
|
||||||
|
document.
|
||||||
|
|
||||||
|
4. Combined Works.
|
||||||
|
|
||||||
|
You may convey a Combined Work under terms of your choice that,
|
||||||
|
taken together, effectively do not restrict modification of the
|
||||||
|
portions of the Library contained in the Combined Work and reverse
|
||||||
|
engineering for debugging such modifications, if you also do each of
|
||||||
|
the following:
|
||||||
|
|
||||||
|
a) Give prominent notice with each copy of the Combined Work that
|
||||||
|
the Library is used in it and that the Library and its use are
|
||||||
|
covered by this License.
|
||||||
|
|
||||||
|
b) Accompany the Combined Work with a copy of the GNU GPL and this license
|
||||||
|
document.
|
||||||
|
|
||||||
|
c) For a Combined Work that displays copyright notices during
|
||||||
|
execution, include the copyright notice for the Library among
|
||||||
|
these notices, as well as a reference directing the user to the
|
||||||
|
copies of the GNU GPL and this license document.
|
||||||
|
|
||||||
|
d) Do one of the following:
|
||||||
|
|
||||||
|
0) Convey the Minimal Corresponding Source under the terms of this
|
||||||
|
License, and the Corresponding Application Code in a form
|
||||||
|
suitable for, and under terms that permit, the user to
|
||||||
|
recombine or relink the Application with a modified version of
|
||||||
|
the Linked Version to produce a modified Combined Work, in the
|
||||||
|
manner specified by section 6 of the GNU GPL for conveying
|
||||||
|
Corresponding Source.
|
||||||
|
|
||||||
|
1) Use a suitable shared library mechanism for linking with the
|
||||||
|
Library. A suitable mechanism is one that (a) uses at run time
|
||||||
|
a copy of the Library already present on the user's computer
|
||||||
|
system, and (b) will operate properly with a modified version
|
||||||
|
of the Library that is interface-compatible with the Linked
|
||||||
|
Version.
|
||||||
|
|
||||||
|
e) Provide Installation Information, but only if you would otherwise
|
||||||
|
be required to provide such information under section 6 of the
|
||||||
|
GNU GPL, and only to the extent that such information is
|
||||||
|
necessary to install and execute a modified version of the
|
||||||
|
Combined Work produced by recombining or relinking the
|
||||||
|
Application with a modified version of the Linked Version. (If
|
||||||
|
you use option 4d0, the Installation Information must accompany
|
||||||
|
the Minimal Corresponding Source and Corresponding Application
|
||||||
|
Code. If you use option 4d1, you must provide the Installation
|
||||||
|
Information in the manner specified by section 6 of the GNU GPL
|
||||||
|
for conveying Corresponding Source.)
|
||||||
|
|
||||||
|
5. Combined Libraries.
|
||||||
|
|
||||||
|
You may place library facilities that are a work based on the
|
||||||
|
Library side by side in a single library together with other library
|
||||||
|
facilities that are not Applications and are not covered by this
|
||||||
|
License, and convey such a combined library under terms of your
|
||||||
|
choice, if you do both of the following:
|
||||||
|
|
||||||
|
a) Accompany the combined library with a copy of the same work based
|
||||||
|
on the Library, uncombined with any other library facilities,
|
||||||
|
conveyed under the terms of this License.
|
||||||
|
|
||||||
|
b) Give prominent notice with the combined library that part of it
|
||||||
|
is a work based on the Library, and explaining where to find the
|
||||||
|
accompanying uncombined form of the same work.
|
||||||
|
|
||||||
|
6. Revised Versions of the GNU Lesser General Public License.
|
||||||
|
|
||||||
|
The Free Software Foundation may publish revised and/or new versions
|
||||||
|
of the GNU Lesser General Public License from time to time. Such new
|
||||||
|
versions will be similar in spirit to the present version, but may
|
||||||
|
differ in detail to address new problems or concerns.
|
||||||
|
|
||||||
|
Each version is given a distinguishing version number. If the
|
||||||
|
Library as you received it specifies that a certain numbered version
|
||||||
|
of the GNU Lesser General Public License "or any later version"
|
||||||
|
applies to it, you have the option of following the terms and
|
||||||
|
conditions either of that published version or of any later version
|
||||||
|
published by the Free Software Foundation. If the Library as you
|
||||||
|
received it does not specify a version number of the GNU Lesser
|
||||||
|
General Public License, you may choose any version of the GNU Lesser
|
||||||
|
General Public License ever published by the Free Software Foundation.
|
||||||
|
|
||||||
|
If the Library as you received it specifies that a proxy can decide
|
||||||
|
whether future versions of the GNU Lesser General Public License shall
|
||||||
|
apply, that proxy's public statement of acceptance of any version is
|
||||||
|
permanent authorization for you to choose that version for the
|
||||||
|
Library.
|
155
ghcup-gen/Main.hs
Normal file
155
ghcup-gen/Main.hs
Normal file
@ -0,0 +1,155 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
|
|
||||||
|
module Main where
|
||||||
|
|
||||||
|
import GHCup.Types
|
||||||
|
import GHCup.Errors
|
||||||
|
import GHCup.Platform
|
||||||
|
import GHCup.Utils.Dirs
|
||||||
|
import GHCup.Utils.Logger
|
||||||
|
import GHCup.Types.JSON ( )
|
||||||
|
|
||||||
|
import Control.Exception ( displayException )
|
||||||
|
import Control.Monad.Trans.Reader ( runReaderT )
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
import Data.Char ( toLower )
|
||||||
|
import Data.Maybe
|
||||||
|
#if !MIN_VERSION_base(4,13,0)
|
||||||
|
import Data.Semigroup ( (<>) )
|
||||||
|
#endif
|
||||||
|
import Options.Applicative hiding ( style )
|
||||||
|
import Haskus.Utils.Variant.Excepts
|
||||||
|
import System.Console.Pretty
|
||||||
|
import System.Environment
|
||||||
|
import System.Exit
|
||||||
|
import System.IO ( stderr )
|
||||||
|
import Text.Regex.Posix
|
||||||
|
import Validate
|
||||||
|
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||||
|
|
||||||
|
import qualified Data.Text.IO as T
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.ByteString as B
|
||||||
|
import qualified Data.Yaml.Aeson as Y
|
||||||
|
|
||||||
|
|
||||||
|
data Options = Options
|
||||||
|
{ optCommand :: Command
|
||||||
|
}
|
||||||
|
|
||||||
|
data Command = ValidateYAML ValidateYAMLOpts
|
||||||
|
| ValidateTarballs ValidateYAMLOpts TarballFilter
|
||||||
|
|
||||||
|
|
||||||
|
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 ValidateYAMLOpts = ValidateYAMLOpts
|
||||||
|
{ vInput :: Maybe Input
|
||||||
|
}
|
||||||
|
|
||||||
|
validateYAMLOpts :: Parser ValidateYAMLOpts
|
||||||
|
validateYAMLOpts = ValidateYAMLOpts <$> optional inputP
|
||||||
|
|
||||||
|
tarballFilterP :: Parser TarballFilter
|
||||||
|
tarballFilterP = option readm $
|
||||||
|
long "tarball-filter" <> short 'u' <> metavar "<tool>-<version>" <> value def
|
||||||
|
<> help "Only check certain tarballs (format: <tool>-<version>)"
|
||||||
|
where
|
||||||
|
def = TarballFilter (Right Nothing) (makeRegex ("" :: String))
|
||||||
|
readm = do
|
||||||
|
s <- str
|
||||||
|
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)
|
||||||
|
_ -> fail "invalid tool"
|
||||||
|
low = fmap toLower
|
||||||
|
|
||||||
|
|
||||||
|
opts :: Parser Options
|
||||||
|
opts = Options <$> com
|
||||||
|
|
||||||
|
com :: Parser Command
|
||||||
|
com = subparser
|
||||||
|
( command
|
||||||
|
"check"
|
||||||
|
( ValidateYAML
|
||||||
|
<$> info (validateYAMLOpts <**> helper)
|
||||||
|
(progDesc "Validate the YAML")
|
||||||
|
)
|
||||||
|
<> command
|
||||||
|
"check-tarballs"
|
||||||
|
(info
|
||||||
|
((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
|
||||||
|
(progDesc "Validate all tarballs (download and checksum)")
|
||||||
|
)
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
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
|
||||||
|
}
|
||||||
|
dirs <- liftIO getAllDirs
|
||||||
|
let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings loggerConfig
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
|
||||||
|
>>= \Options {..} -> case optCommand of
|
||||||
|
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)
|
||||||
|
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
|
||||||
|
valAndExit f contents = do
|
||||||
|
(GHCupInfo _ av gt) <- case Y.decodeEither' contents of
|
||||||
|
Right r -> pure r
|
||||||
|
Left e -> die (color Red $ displayException e)
|
||||||
|
f av gt
|
||||||
|
>>= exitWith
|
280
ghcup-gen/Validate.hs
Normal file
280
ghcup-gen/Validate.hs
Normal file
@ -0,0 +1,280 @@
|
|||||||
|
{-# LANGUAGE CPP #-}
|
||||||
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE FlexibleContexts #-}
|
||||||
|
{-# LANGUAGE QuasiQuotes #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
|
||||||
|
module Validate where
|
||||||
|
|
||||||
|
import GHCup
|
||||||
|
import GHCup.Download
|
||||||
|
import GHCup.Errors
|
||||||
|
import GHCup.Types
|
||||||
|
import GHCup.Types.Optics
|
||||||
|
import GHCup.Utils
|
||||||
|
import GHCup.Utils.Logger
|
||||||
|
import GHCup.Utils.Version.QQ
|
||||||
|
|
||||||
|
import Codec.Archive
|
||||||
|
import Control.Applicative
|
||||||
|
import Control.Exception.Safe
|
||||||
|
import Control.Monad
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
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.Containers.ListUtils ( nubOrd )
|
||||||
|
import Data.IORef
|
||||||
|
import Data.List
|
||||||
|
import Data.Versions
|
||||||
|
import Haskus.Utils.Variant.Excepts
|
||||||
|
import Optics
|
||||||
|
import System.FilePath
|
||||||
|
import System.Exit
|
||||||
|
import Text.ParserCombinators.ReadP
|
||||||
|
import Text.PrettyPrint.HughesPJClass ( prettyShow )
|
||||||
|
import Text.Regex.Posix
|
||||||
|
|
||||||
|
import qualified Data.Map.Strict as M
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import qualified Data.Version as V
|
||||||
|
|
||||||
|
|
||||||
|
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, MonadReader env m, HasLog env, MonadThrow m, MonadIO m, MonadUnliftIO m)
|
||||||
|
=> GHCupDownloads
|
||||||
|
-> M.Map GlobalTool DownloadInfo
|
||||||
|
-> 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 (_viTags vi) arch (M.keys pspecs)
|
||||||
|
|
||||||
|
checkGHCVerIsValid
|
||||||
|
forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
|
||||||
|
_ <- checkGHCHasBaseVersion
|
||||||
|
|
||||||
|
-- exit
|
||||||
|
e <- liftIO $ readIORef ref
|
||||||
|
if e > 0
|
||||||
|
then pure $ ExitFailure e
|
||||||
|
else do
|
||||||
|
lift $ logInfo "All good"
|
||||||
|
pure ExitSuccess
|
||||||
|
where
|
||||||
|
checkHasRequiredPlatforms t v tags arch pspecs = do
|
||||||
|
let v' = prettyVer v
|
||||||
|
arch' = prettyShow arch
|
||||||
|
when (Linux UnknownLinux `notElem` pspecs) $ do
|
||||||
|
lift $ logError $
|
||||||
|
"Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
|
||||||
|
addError
|
||||||
|
when ((Darwin `notElem` pspecs) && arch == A_64) $ do
|
||||||
|
lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
|
||||||
|
addError
|
||||||
|
when ((FreeBSD `notElem` pspecs) && arch == A_64) $ lift $ logWarn $
|
||||||
|
"FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
|
||||||
|
when (Windows `notElem` pspecs && arch == A_64) $ do
|
||||||
|
lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
|
||||||
|
addError
|
||||||
|
|
||||||
|
-- alpine needs to be set explicitly, because
|
||||||
|
-- we cannot assume that "Linux UnknownLinux" runs on Alpine
|
||||||
|
-- (although it could be static)
|
||||||
|
when (Linux Alpine `notElem` pspecs) $
|
||||||
|
case t of
|
||||||
|
GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
|
||||||
|
Cabal | v > [vver|2.4.1.0|]
|
||||||
|
, arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
|
||||||
|
GHC | Latest `elem` tags || Recommended `elem` tags
|
||||||
|
, arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))
|
||||||
|
_ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
|
||||||
|
|
||||||
|
checkUniqueTags tool = do
|
||||||
|
let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
|
||||||
|
let nonUnique =
|
||||||
|
fmap fst
|
||||||
|
. filter (\(_, b) -> not b)
|
||||||
|
<$> ( mapM
|
||||||
|
(\case
|
||||||
|
[] -> throwM $ InternalError "empty inner list"
|
||||||
|
(t : ts) ->
|
||||||
|
pure $ (t, ) (not (isUniqueTag t) || null ts)
|
||||||
|
)
|
||||||
|
. group
|
||||||
|
. sort
|
||||||
|
$ allTags
|
||||||
|
)
|
||||||
|
case join nonUnique of
|
||||||
|
[] -> pure ()
|
||||||
|
xs -> do
|
||||||
|
lift $ logError $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
|
||||||
|
addError
|
||||||
|
where
|
||||||
|
isUniqueTag Latest = True
|
||||||
|
isUniqueTag Recommended = True
|
||||||
|
isUniqueTag Old = False
|
||||||
|
isUniqueTag Prerelease = False
|
||||||
|
isUniqueTag (Base _) = False
|
||||||
|
isUniqueTag (UnknownTag _) = False
|
||||||
|
|
||||||
|
checkGHCVerIsValid = do
|
||||||
|
let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
|
||||||
|
forM_ ghcVers $ \v ->
|
||||||
|
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
|
||||||
|
[_] -> pure ()
|
||||||
|
_ -> do
|
||||||
|
lift $ logError $ "GHC version " <> prettyVer v <> " is not valid"
|
||||||
|
addError
|
||||||
|
|
||||||
|
-- a tool must have at least one of each mandatory tags
|
||||||
|
checkMandatoryTags tool = do
|
||||||
|
let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
|
||||||
|
forM_ [Latest, Recommended] $ \t -> case t `elem` allTags of
|
||||||
|
False -> do
|
||||||
|
lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
|
||||||
|
addError
|
||||||
|
True -> pure ()
|
||||||
|
|
||||||
|
-- all GHC versions must have a base tag
|
||||||
|
checkGHCHasBaseVersion = do
|
||||||
|
let allTags = M.toList $ availableToolVersions dls GHC
|
||||||
|
forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
|
||||||
|
False -> do
|
||||||
|
lift $ logError $ "Base tag missing from GHC ver " <> prettyVer ver
|
||||||
|
addError
|
||||||
|
True -> pure ()
|
||||||
|
|
||||||
|
isBase (Base _) = True
|
||||||
|
isBase _ = False
|
||||||
|
|
||||||
|
data TarballFilter = TarballFilter
|
||||||
|
{ tfTool :: Either GlobalTool (Maybe Tool)
|
||||||
|
, tfVersion :: Regex
|
||||||
|
}
|
||||||
|
|
||||||
|
validateTarballs :: ( Monad m
|
||||||
|
, MonadReader env m
|
||||||
|
, HasLog env
|
||||||
|
, HasDirs env
|
||||||
|
, HasSettings env
|
||||||
|
, MonadThrow m
|
||||||
|
, MonadIO m
|
||||||
|
, MonadUnliftIO m
|
||||||
|
, MonadMask m
|
||||||
|
, Alternative m
|
||||||
|
, MonadFail m
|
||||||
|
)
|
||||||
|
=> TarballFilter
|
||||||
|
-> GHCupDownloads
|
||||||
|
-> M.Map GlobalTool DownloadInfo
|
||||||
|
-> m ExitCode
|
||||||
|
validateTarballs (TarballFilter etool versionRegex) dls gt = do
|
||||||
|
ref <- liftIO $ newIORef 0
|
||||||
|
|
||||||
|
-- download/verify all tarballs
|
||||||
|
let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
|
||||||
|
let gdlis = nubOrd $ gt ^.. each
|
||||||
|
let allDls = either (const gdlis) (const dlis) etool
|
||||||
|
when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref
|
||||||
|
forM_ allDls (downloadAll ref)
|
||||||
|
|
||||||
|
-- exit
|
||||||
|
e <- liftIO $ readIORef ref
|
||||||
|
if e > 0
|
||||||
|
then pure $ ExitFailure e
|
||||||
|
else do
|
||||||
|
logInfo "All good"
|
||||||
|
pure ExitSuccess
|
||||||
|
|
||||||
|
where
|
||||||
|
downloadAll :: ( MonadUnliftIO m
|
||||||
|
, MonadIO m
|
||||||
|
, MonadReader env m
|
||||||
|
, HasLog env
|
||||||
|
, HasDirs env
|
||||||
|
, HasSettings env
|
||||||
|
, MonadCatch m
|
||||||
|
, MonadMask m
|
||||||
|
, MonadThrow m
|
||||||
|
)
|
||||||
|
=> IORef Int
|
||||||
|
-> DownloadInfo
|
||||||
|
-> m ()
|
||||||
|
downloadAll ref dli = do
|
||||||
|
r <- runResourceT
|
||||||
|
. runE @'[DigestError
|
||||||
|
, GPGError
|
||||||
|
, DownloadFailed
|
||||||
|
, UnknownArchive
|
||||||
|
, ArchiveResult
|
||||||
|
]
|
||||||
|
$ do
|
||||||
|
case etool of
|
||||||
|
Right (Just GHCup) -> do
|
||||||
|
tmpUnpack <- lift mkGhcupTmpDir
|
||||||
|
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False
|
||||||
|
pure Nothing
|
||||||
|
Right _ -> do
|
||||||
|
p <- liftE $ downloadCached dli Nothing
|
||||||
|
fmap (Just . head . splitDirectories . head)
|
||||||
|
. liftE
|
||||||
|
. getArchiveFiles
|
||||||
|
$ p
|
||||||
|
Left ShimGen -> do
|
||||||
|
tmpUnpack <- lift mkGhcupTmpDir
|
||||||
|
_ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False
|
||||||
|
pure Nothing
|
||||||
|
case r of
|
||||||
|
VRight (Just basePath) -> do
|
||||||
|
case _dlSubdir dli of
|
||||||
|
Just (RealDir prel) -> do
|
||||||
|
logInfo
|
||||||
|
$ " verifying subdir: " <> T.pack prel
|
||||||
|
when (basePath /= prel) $ do
|
||||||
|
logError $
|
||||||
|
"Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
|
||||||
|
runReaderT addError ref
|
||||||
|
Just (RegexDir regexString) -> do
|
||||||
|
logInfo $
|
||||||
|
"verifying subdir (regex): " <> T.pack regexString
|
||||||
|
let regex = makeRegexOpts
|
||||||
|
compIgnoreCase
|
||||||
|
execBlank
|
||||||
|
regexString
|
||||||
|
unless (match regex basePath) $ do
|
||||||
|
logError $
|
||||||
|
"Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
|
||||||
|
runReaderT addError ref
|
||||||
|
Nothing -> pure ()
|
||||||
|
VRight Nothing -> pure ()
|
||||||
|
VLeft e -> do
|
||||||
|
logError $
|
||||||
|
"Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
|
||||||
|
runReaderT addError ref
|
65
ghcup-gen/ghcup-gen.cabal
Normal file
65
ghcup-gen/ghcup-gen.cabal
Normal file
@ -0,0 +1,65 @@
|
|||||||
|
cabal-version: 3.0
|
||||||
|
name: ghcup-gen
|
||||||
|
version: 0.1.17.3
|
||||||
|
license: LGPL-3.0-only
|
||||||
|
license-file: LICENSE
|
||||||
|
copyright: Julian Ospald 2020
|
||||||
|
maintainer: hasufell@posteo.de
|
||||||
|
author: Julian Ospald
|
||||||
|
homepage: https://github.com/haskell/ghcup-metadata
|
||||||
|
bug-reports: https://github.com/haskell/ghcup-metadata/issues
|
||||||
|
synopsis: ghcup-gen dev tool
|
||||||
|
description: Dev tool for handling ghcup metadata
|
||||||
|
|
||||||
|
category: System
|
||||||
|
build-type: Simple
|
||||||
|
extra-doc-files:
|
||||||
|
CHANGELOG.md
|
||||||
|
|
||||||
|
source-repository head
|
||||||
|
type: git
|
||||||
|
location: https://github.com/haskell/ghcup-metadata.git
|
||||||
|
|
||||||
|
executable ghcup-gen
|
||||||
|
main-is: Main.hs
|
||||||
|
other-modules: Validate
|
||||||
|
default-language: Haskell2010
|
||||||
|
default-extensions:
|
||||||
|
DeriveGeneric
|
||||||
|
LambdaCase
|
||||||
|
MultiWayIf
|
||||||
|
NamedFieldPuns
|
||||||
|
PackageImports
|
||||||
|
QuasiQuotes
|
||||||
|
RecordWildCards
|
||||||
|
ScopedTypeVariables
|
||||||
|
StrictData
|
||||||
|
TupleSections
|
||||||
|
TypeApplications
|
||||||
|
TypeFamilies
|
||||||
|
ViewPatterns
|
||||||
|
|
||||||
|
ghc-options:
|
||||||
|
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
|
||||||
|
-fwarn-incomplete-record-updates -threaded
|
||||||
|
|
||||||
|
build-depends:
|
||||||
|
, base >=4.13 && <5
|
||||||
|
, bytestring ^>=0.10
|
||||||
|
, containers ^>=0.6
|
||||||
|
, filepath ^>=1.4.2.1
|
||||||
|
, ghcup ^>=0.1.17.3
|
||||||
|
, haskus-utils-variant >=3.0 && <3.2
|
||||||
|
, libarchive ^>=3.0.3.0
|
||||||
|
, mtl ^>=2.2
|
||||||
|
, optics ^>=0.4
|
||||||
|
, optparse-applicative >=0.15.1.0 && <0.17
|
||||||
|
, pretty ^>=1.1.3.1
|
||||||
|
, pretty-terminal ^>=0.1.0.0
|
||||||
|
, regex-posix ^>=0.96
|
||||||
|
, resourcet ^>=1.2.2
|
||||||
|
, safe-exceptions ^>=0.1
|
||||||
|
, text ^>=1.2.4.0
|
||||||
|
, transformers ^>=0.5
|
||||||
|
, versions >=4.0.1 && <5.1
|
||||||
|
, yaml-streamly ^>=0.12.0
|
Loading…
Reference in New Issue
Block a user