Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
G
ghcup-hs
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Iterations
Wiki
Requirements
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Locked files
Build
Pipelines
Jobs
Pipeline schedules
Test cases
Artifacts
Deploy
Releases
Package Registry
Container Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Code review analytics
Issue analytics
Insights
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Haskell
ghcup-hs
Commits
28b47377
Verified
Commit
28b47377
authored
4 years ago
by
Julian Ospald
Browse files
Options
Downloads
Plain Diff
Merge remote-tracking branch 'origin/merge-requests/56'
parents
9e628e34
5c43ff4c
No related branches found
No related tags found
1 merge request
!56
allow to filter tarball validation by a URL substring
Pipeline
#29369
canceled
4 years ago
Stage: test
Changes
4
Pipelines
1
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
app/ghcup-gen/Main.hs
+26
-10
26 additions, 10 deletions
app/ghcup-gen/Main.hs
app/ghcup-gen/Validate.hs
+22
-17
22 additions, 17 deletions
app/ghcup-gen/Validate.hs
ghcup.cabal
+1
-0
1 addition, 0 deletions
ghcup.cabal
lib/GHCup/Types.hs
+3
-3
3 additions, 3 deletions
lib/GHCup/Types.hs
with
52 additions
and
30 deletions
app/ghcup-gen/Main.hs
+
26
−
10
View file @
28b47377
...
...
@@ -14,6 +14,7 @@ import GHCup.Types
import
GHCup.Types.JSON
(
)
import
GHCup.Utils.Logger
import
Data.Char
(
toLower
)
#
if
!
MIN_VERSION_base
(
4
,
13
,
0
)
import
Data.Semigroup
(
(
<>
)
)
#
endif
...
...
@@ -21,6 +22,7 @@ import Options.Applicative hiding ( style )
import
System.Console.Pretty
import
System.Exit
import
System.IO
(
stdout
)
import
Text.Regex.Posix
import
Validate
import
qualified
Data.ByteString
as
B
...
...
@@ -32,7 +34,7 @@ data Options = Options
}
data
Command
=
ValidateYAML
ValidateYAMLOpts
|
ValidateTarballs
ValidateYAMLOpts
|
ValidateTarballs
ValidateYAMLOpts
TarballFilter
data
Input
...
...
@@ -63,6 +65,22 @@ data ValidateYAMLOpts = ValidateYAMLOpts
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
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
]
->
TarballFilter
<$>
pure
(
Just
tool
)
<*>
makeRegexOptsM
compIgnoreCase
execBlank
(
drop
1
v
)
_
->
fail
"invalid tool"
low
=
fmap
toLower
opts
::
Parser
Options
opts
=
Options
<$>
com
...
...
@@ -78,11 +96,9 @@ com = subparser
)
<>
(
command
"check-tarballs"
(
ValidateTarballs
<$>
(
info
(
validateYAMLOpts
<**>
helper
)
(
progDesc
"Validate all tarballs (download and checksum)"
)
)
(
info
((
ValidateTarballs
<$>
validateYAMLOpts
<*>
tarballFilterP
)
<**>
helper
)
(
progDesc
"Validate all tarballs (download and checksum)"
)
)
)
)
...
...
@@ -100,13 +116,13 @@ main = do
B
.
getContents
>>=
valAndExit
validate
ValidateYAMLOpts
{
vInput
=
Just
(
FileInput
file
)
}
->
B
.
readFile
file
>>=
valAndExit
validate
ValidateTarballs
vopts
->
case
vopts
of
ValidateTarballs
vopts
tarballFilter
->
case
vopts
of
ValidateYAMLOpts
{
vInput
=
Nothing
}
->
B
.
getContents
>>=
valAndExit
validateTarballs
B
.
getContents
>>=
valAndExit
(
validateTarballs
tarballFilter
)
ValidateYAMLOpts
{
vInput
=
Just
StdInput
}
->
B
.
getContents
>>=
valAndExit
validateTarballs
B
.
getContents
>>=
valAndExit
(
validateTarballs
tarballFilter
)
ValidateYAMLOpts
{
vInput
=
Just
(
FileInput
file
)
}
->
B
.
readFile
file
>>=
valAndExit
validateTarballs
B
.
readFile
file
>>=
valAndExit
(
validateTarballs
tarballFilter
)
pure
()
where
...
...
This diff is collapsed.
Click to expand it.
app/ghcup-gen/Validate.hs
+
22
−
17
View file @
28b47377
...
...
@@ -7,6 +7,7 @@ module Validate where
import
GHCup
import
GHCup.Download
import
GHCup.Types
import
GHCup.Types.Optics
import
GHCup.Utils.Dirs
import
GHCup.Utils.Logger
import
GHCup.Utils.Version.QQ
...
...
@@ -21,6 +22,7 @@ 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.String.Interpolate
...
...
@@ -30,6 +32,7 @@ import Optics
import
System.Exit
import
System.IO
import
Text.ParserCombinators.ReadP
import
Text.Regex.Posix
import
qualified
Data.ByteString
as
B
import
qualified
Data.Map.Strict
as
M
...
...
@@ -157,6 +160,11 @@ validate dls = do
isBase
(
Base
_
)
=
True
isBase
_
=
False
data
TarballFilter
=
TarballFilter
{
tfTool
::
Maybe
Tool
,
tfVersion
::
Regex
}
validateTarballs
::
(
Monad
m
,
MonadLogger
m
,
MonadThrow
m
...
...
@@ -164,23 +172,20 @@ validateTarballs :: ( Monad m
,
MonadUnliftIO
m
,
MonadMask
m
)
=>
GHCupDownloads
=>
TarballFilter
->
GHCupDownloads
->
m
ExitCode
validateTarballs
dls
=
do
validateTarballs
(
TarballFilter
tool
versionRegex
)
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
-- download/verify all tarballs
let
dlis
=
nubOrd
$
dls
^..
each
%&
indices
(
maybe
(
const
True
)
(
==
)
tool
)
%>
each
%&
indices
(
matchTest
versionRegex
.
T
.
unpack
.
prettyVer
)
%
(
viSourceDL
%
_Just
`
summing
`
viArch
%
each
%
each
%
each
)
when
(
null
dlis
)
$
$
(
logError
)
[
i
|
no tarballs selected by filter
|]
*>
addError
forM_
dlis
$
downloadAll
-- exit
e
<-
liftIO
$
readIORef
ref
...
...
@@ -191,13 +196,13 @@ validateTarballs dls = do
pure
ExitSuccess
where
runLogger
=
myLoggerT
LoggerConfig
{
lcPrintDebug
=
True
,
colorOutter
=
B
.
hPut
stderr
,
rawOutter
=
(
\
_
->
pure
()
)
}
downloadAll
dli
=
do
dirs
<-
liftIO
getDirs
let
settings
=
AppState
(
Settings
True
False
Never
Curl
False
GHCupURL
)
dirs
defaultKeyBindings
let
runLogger
=
myLoggerT
LoggerConfig
{
lcPrintDebug
=
True
,
colorOutter
=
B
.
hPut
stderr
,
rawOutter
=
(
\
_
->
pure
()
)
}
r
<-
runLogger
...
...
This diff is collapsed.
Click to expand it.
ghcup.cabal
+
1
−
0
View file @
28b47377
...
...
@@ -431,6 +431,7 @@ executable ghcup-gen
, optics
, optparse-applicative
, pretty-terminal
, regex-posix
, resourcet
, safe-exceptions
, string-interpolate
...
...
This diff is collapsed.
Click to expand it.
lib/GHCup/Types.hs
+
3
−
3
View file @
28b47377
...
...
@@ -79,7 +79,7 @@ data Tool = GHC
|
Cabal
|
GHCup
|
HLS
deriving
(
Eq
,
GHC
.
Generic
,
Ord
,
Show
)
deriving
(
Eq
,
GHC
.
Generic
,
Ord
,
Show
,
Enum
,
Bounded
)
-- | All necessary information of a tool version, including
...
...
@@ -172,7 +172,7 @@ data DownloadInfo = DownloadInfo
,
_dlSubdir
::
Maybe
TarDir
,
_dlHash
::
Text
}
deriving
(
Eq
,
GHC
.
Generic
,
Show
)
deriving
(
Eq
,
Ord
,
GHC
.
Generic
,
Show
)
...
...
@@ -185,7 +185,7 @@ data DownloadInfo = DownloadInfo
-- | How to descend into a tar archive.
data
TarDir
=
RealDir
(
Path
Rel
)
|
RegexDir
String
-- ^ will be compiled to regex, the first match will "win"
deriving
(
Eq
,
GHC
.
Generic
,
Show
)
deriving
(
Eq
,
Ord
,
GHC
.
Generic
,
Show
)
-- | Where to fetch GHCupDownloads from.
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment