Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Ben Gamari
trac-to-remarkup
Commits
4104086b
Commit
4104086b
authored
Mar 16, 2019
by
Ben Gamari
Browse files
Introduce label fixup
parent
964a1b19
Changes
2
Hide whitespace changes
Inline
Side-by-side
Main.hs
View file @
4104086b
...
...
@@ -57,6 +57,7 @@ data Mode = Import { skipMilestones :: Bool
,
keepWikiGit
::
Bool
,
ticketNumbers
::
S
.
Set
TicketNumber
}
|
FixLabels
|
TestParser
|
TestScraper
[
String
]
|
TestParserOnly
...
...
@@ -67,6 +68,7 @@ mode = hsubparser $
<>
command
"test-parser"
(
info
(
helper
<*>
pure
TestParser
)
(
progDesc
"test ticket parser and Markdown writer"
))
<>
command
"test-parser-only"
(
info
(
helper
<*>
pure
TestParserOnly
)
(
progDesc
"test ticket parser"
))
<>
command
"test-scraper"
(
info
(
helper
<*>
testScraperMode
)
(
progDesc
"test wiki parser"
))
<>
command
"fix-ticket-labels"
(
info
(
helper
<*>
pure
FixLabels
)
(
progDesc
"import missing ticket labels"
))
importMode
::
Parser
Mode
importMode
=
...
...
@@ -184,6 +186,12 @@ main = do
$
Logging
.
withContext
logger
"ticket fixup"
$
printErrors
logger
$
fixupLastUpdated
logger
FixLabels
->
do
conn
<-
connectPostgreSQL
tracDsn
env
<-
makeGitLabEnv
tickets
<-
getTickets
conn
runClientM
(
mapM_
fixLabels
tickets
)
env
>>=
throwLeft
where
throwLeft
::
(
Exception
e
,
Monad
m
,
MonadThrow
m
)
=>
Either
e
a
->
m
a
throwLeft
=
either
throwM
return
...
...
TicketImport.hs
View file @
4104086b
...
...
@@ -6,12 +6,15 @@
module
TicketImport
(
createTicket
,
createTicketChanges
,
fixLabels
)
where
import
Control.Applicative
import
Control.Concurrent
import
Control.Monad
import
Data.Bifunctor
import
Data.Char
import
Data.Either
import
Data.Maybe
import
Data.String
import
Control.Monad.IO.Class
...
...
@@ -66,40 +69,94 @@ toAddRemove f (Update old new) =
-- | Maps Trac keywords to labels
keywordLabels
::
Text
->
Labels
keywordLabels
=
fromMaybe
mempty
.
flip
M
.
lookup
labelMapping
fromMaybe
mempty
.
flip
M
.
lookup
labelMapping
.
T
.
toCaseFold
where
labelMapping
::
M
.
Map
Text
Labels
labelMapping
=
M
.
fromList
$
map
(
first
T
.
toCaseFold
)
$
[
passthru
"newcomer"
,
(
"newcomers"
,
"newcomer"
)
,
(
"beginner"
,
"newcomer"
)
,
(
"easy"
,
"newcomer"
)
,
(
"CI"
,
"infrastructure"
)
,
(
"windows"
,
"Windows"
)
,
(
"Msys2"
,
"Windows"
)
,
(
"Win32"
,
"Windows"
)
,
(
"PowerPC"
,
"PowerPC"
)
,
(
"macOS"
,
"macOS"
)
,
(
"osx"
,
"macOS"
)
,
(
"darwin"
,
"macOS"
)
,
(
"mac"
,
"macOS"
)
,
(
"ios"
,
"macOS"
)
,
(
"cross-compiling"
,
"cross-compilation"
)
,
(
"cross-compile"
,
"cross-compilation"
)
,
(
"crosscompile"
,
"cross-compilation"
)
,
(
"cross"
,
"cross-compilation"
)
,
passthru
"unregisterised"
,
(
"unregisterize"
,
"unregisterised"
)
,
passthru
"ConstraintKinds"
,
passthru
"ImplicitParams"
,
(
"polykinds"
,
"PolyKinds"
)
,
passthru
"TypeInType"
,
(
"LevityPolymorphism"
,
"levity polymorphism"
)
,
passthru
"type families"
,
(
"TypeFamilies"
,
"type families"
)
,
passthru
"RankNTypes"
,
passthru
"hadrian"
,
(
"PEi386"
,
"Windows"
<>
"linking"
)
,
(
"sparc64"
,
"SPARC"
)
,
(
"raspberry"
,
"ARM"
)
,
(
"raspberrypi"
,
"ARM"
)
,
(
"arm"
,
"ARM"
)
,
(
"armv7"
,
"ARM"
)
,
(
"concurrency"
,
"concurrency"
)
,
(
"SMP"
,
"concurrency"
)
,
(
"threads"
,
"concurrency"
)
,
(
"threaded"
,
"concurrency"
)
,
(
"GC"
,
"RTS"
)
,
(
"AmbiguityCheck"
,
"ambiguity check"
)
,
(
"ImpredicativeTypes"
,
"ImpredicativeTypes"
)
,
(
"impredicativity"
,
"ImpredicativeTypes"
)
,
(
"link"
,
"linking"
)
,
passthru
"pattern synonyms"
,
passthru
"deriving"
,
passthru
"DerivingVia"
,
passthru
"RebindableSyntax"
,
(
"Deriving"
,
"deriving"
)
,
(
"GeneralizedNewtypeDeriving"
,
"deriving"
)
,
(
"GeneralisedNewtypeDeriving"
,
"deriving"
)
,
passthru
"generics"
,
(
"DeriveGeneric"
,
"generics"
)
,
(
"Generics"
,
"generics"
)
,
(
"Generic1"
,
"generics"
)
,
passthru
"pattern match warnings"
,
passthru
"inli
ning
"
,
(
"PatternMatchWarnings"
,
"pattern match war
ning
s"
)
,
passthru
"quantified constraints"
,
passthru
"TypeApplications"
,
passthru
"levity polymorphism"
,
passthru
"code-gen"
,
(
"codegen"
,
"code-gen"
)
,
passthru
"GADTs"
,
(
"GADT"
,
"GADTs"
)
,
(
"rts"
,
"RTS"
)
,
"JoinPoints"
.=
"join points"
,
passthru
"Typeable"
,
(
"Typeable"
,
"Typeable"
)
,
(
"ORF"
,
"OverloadedRecordFields"
)
,
(
"ORF"
,
"OverloadedRecordFields"
<>
"records"
)
,
(
"orf"
,
"OverloadedRecordFields"
<>
"records"
)
,
(
"hs-boot"
,
"hs-boot"
)
,
passthru
"spec constr"
,
passthru
"ApplicativeDo"
,
passthru
"demand analysis"
,
(
"FunDeps"
,
"functional dependencies"
)
,
(
"FunctionalDependencies"
,
"functional dependencies"
)
,
passthru
"MultiParamTypeClasses"
,
"TypedHoles"
.=
"typed holes"
,
"typed-holes"
.=
"typed holes"
,
"holes"
.=
"typed holes"
,
passthru
"CSE"
,
(
"DemandAnalysis"
,
"demand analysis"
)
,
(
"plugin"
,
"plugins"
)
,
(
"plugins"
,
"plugins"
)
,
(
"TypeCheckerPlugins"
,
"plugins"
)
,
(
"deriving-perf"
,
"deriving"
<>
"compiler perf"
)
,
passthru
"CUSKs"
...
...
@@ -107,29 +164,80 @@ keywordLabels =
,
(
"performance"
,
"runtime perf"
)
,
(
"ci-breakage"
,
"CI breakage"
)
,
(
"DWARF"
,
"debug information"
)
,
(
"STM"
,
"STM"
)
,
(
"TChan"
,
"STM"
)
,
(
"throwSTM"
,
"STM"
)
,
passthru
"InstanceSigs"
,
passthru
"DefaultSignatures"
,
passthru
"SafeHaskell"
,
passthru
"custom type errors"
,
(
"CustomTypeErrors"
,
"custom type errors"
)
,
passthru
"StaticPointers"
,
passthru
"UndecideableInstances"
,
(
"UndecidableInstances"
,
"UndecideableInstances"
)
,
passthru
"IncoherentInstances"
,
passthru
"ScopedTypeVariables"
,
passthru
"ViewPatterns"
,
passthru
"VisibleDependentQuantification"
,
passthru
"utf"
,
passthru
"utf-8"
,
passthru
"utf8"
,
passthru
"Unicode"
,
(
"UnicodeSyntax"
,
"Unicode"
)
,
(
"unicode"
,
"Unicode"
)
,
(
"documentation"
,
"documentation"
)
,
(
"manpage"
,
"documentation"
)
,
(
"manpages"
,
"documentation"
)
,
(
"split-objs"
,
"split-objs"
)
,
(
"SplitObjs"
,
"split-objs"
)
,
(
"TypeErrors"
,
"error messages"
)
,
(
"TypeErrorMessages"
,
"error messages"
)
,
(
"error messages"
,
"error messages"
)
,
(
"ErrorMessages"
,
"error messages"
)
,
(
"warnings"
,
"error messages"
)
,
(
"warning"
,
"error messages"
)
,
(
"profiling"
,
"profiling"
)
,
passthru
"Arrows"
,
(
"arrows"
,
"Arrows"
)
,
passthru
"SIMD"
,
passthru
"sse2"
,
passthru
"TemplateHaskell"
,
(
"template-haskell"
,
"TemplateHaskell"
)
,
(
"template"
,
"TemplateHaskell"
)
,
(
"TH"
,
"TemplateHaskell"
)
,
passthru
"backpack"
,
passthru
"ImpredicativeTypes"
,
(
"Roles"
,
"roles"
)
,
(
"existentialquantification"
,
"ExistentialQuantification"
)
,
(
"XOverlappingInstances"
,
"OverlappingInstances"
)
,
(
"OverlappingInstances"
,
"OverlappingInstances"
)
,
(
"NamedWildCards"
,
"holes"
)
,
(
"RecordWildCards"
,
"RecordWildCards"
<>
"records"
)
,
(
"Records"
,
"records"
)
,
(
"duplicaterecordfields"
,
"records"
)
,
(
"FFI"
,
"FFI"
)
,
(
"GHCi"
,
"GHCi"
)
,
(
"roles"
,
"roles"
)
,
(
"admin"
,
"infrastructure"
)
,
(
"git"
,
"infrastructure"
)
,
(
"UnboxedSums"
,
"UnboxedSums"
)
,
(
"UnboxedSum"
,
"UnboxedSums"
)
,
(
"UnboxedTuples"
,
"UnboxedTuples"
)
,
(
"Safe"
,
"Safe Haskell"
)
,
passthru
"DataKinds"
,
passthru
"exceptions"
,
passthru
"debugger"
,
(
"synonyms"
,
"pattern synonyms"
)
-- generally arises from typos
,
(
"PatternSynonyms"
,
"pattern synonyms"
)
-- generally arises from typos
,
passthru
"cpp"
,
(
"TypedTemplateHaskell"
,
"typed TemplateHaskell"
<>
"TemplateHaskell"
)
,
passthru
"strings"
,
passthru
"clang"
,
(
"FloatOut"
,
"float-out"
)
,
passthru
"LLVM"
,
(
"FloatOut"
,
"simplifier"
<>
"float-out"
)
,
passthru
"SpecConstr"
,
passthru
"QuantifiedContexts"
,
(
"QuantifiedConstraints"
,
"QuantifiedContexts"
)
,
(
"APIAnnotations"
,
"API Annotations"
)
,
passthru
"InjectiveFamilies"
,
passthru
"performance"
,
(
"CPRAnalysis"
,
"CPR analysis"
)
...
...
@@ -137,14 +245,45 @@ keywordLabels =
,
(
"PartialTypeSignatures"
,
"partial type sigs"
)
,
passthru
"SafeHaskell"
,
(
"RemoteGHCi"
,
"remote GHCi"
)
,
(
"injective"
,
"injective type families"
)
,
(
"specialisation"
,
"specialisation"
)
,
(
"stream-fusion"
,
"stream fusion"
)
,
(
"fusion"
,
"stream fusion"
)
,
(
"gmp"
,
"integer-gmp"
)
,
passthru
"integer-gmp"
,
passthru
"integer-simple"
,
(
"recompilation"
,
"recompilation checking"
)
,
(
"RecompilationCheck"
,
"recompilation checking"
)
,
(
"recompilation"
,
"recompilation checking"
)
,
(
"LateLamLift"
,
"late lambda lifting"
)
,
(
"Simplifier"
,
"simplifier"
)
,
(
"Inlining"
,
"simplifier"
<>
"inlining"
)
,
passthru
"DeferredTypeErrors"
,
passthru
"UndecidableSuperClasses"
,
passthru
"CAFs"
,
passthru
"rules"
,
passthru
"haddock"
,
passthru
"linking"
,
(
"rounding"
,
"numerics"
)
,
(
"ieee754"
,
"numerics"
)
,
(
"Number"
,
"numerics"
)
,
(
"Numeric"
,
"numerics"
)
,
(
"Numerics"
,
"numerics"
)
,
(
"linker"
,
"linking"
)
,
(
"base"
,
"core libraries"
)
,
(
"AMP"
,
"core libraries"
)
,
(
"ghc-prim"
,
"core libraries"
)
,
(
"CodeGen"
,
"code generation"
)
,
(
"hpc"
,
"HPC"
)
,
(
"nofib"
,
"nofib"
)
,
(
"numa"
,
"NUMA"
<>
"RTS"
)
,
(
"interpreter"
,
"GHCi"
)
,
(
"TypeableReflection"
,
"Typeable"
)
,
(
"Typeable"
,
"Typeable"
)
,
(
"DPH"
,
"Data Parallel Haskell"
)
,
(
"segfault"
,
"runtime crash"
)
,
(
"segv"
,
"runtime crash"
)
,
(
"segmentation"
,
"runtime crash"
)
]
where
passthru
x
=
(
x
,
mkLabel
x
)
...
...
@@ -224,6 +363,11 @@ ticketTypeLabel Task = "task"
ticketTypeLabel
FeatureRequest
=
"feature request"
ticketTypeLabel
MergeReq
=
"backport request"
statusLabel
::
Trac
.
Status
->
Labels
statusLabel
Merge
=
"backport"
statusLabel
Upstream
=
"upstream"
statusLabel
_
=
mempty
fieldLabels
::
Fields
Update
->
AddRemove
Labels
fieldLabels
fields
=
add
"Trac import"
...
...
@@ -236,12 +380,9 @@ fieldLabels fields =
keywordLbls
=
toAddRemove
id
$
fmap
(
foldMap
keywordLabels
)
(
ticketKeywords
fields
)
typeLbls
=
toAddRemove
ticketTypeLabel
(
ticketType
fields
)
failureLbls
=
toAddRemove
typeOfFailureLabels
(
ticketTypeOfFailure
fields
)
statusLbls
=
toAddRemove
toS
tatusLabel
(
ticketStatus
fields
)
statusLbls
=
toAddRemove
s
tatusLabel
(
ticketStatus
fields
)
componentLbls
=
toAddRemove
componentLabels
(
ticketComponent
fields
)
toStatusLabel
Merge
=
"backport"
toStatusLabel
Upstream
=
"upstream"
toStatusLabel
_
=
mempty
createTicket
::
Logger
->
MilestoneMap
...
...
@@ -732,3 +873,55 @@ nthMay n = listToMaybe . drop n
dummyLookupAnchor
::
String
->
Maybe
String
dummyLookupAnchor
=
Just
fixLabels
::
Ticket
->
ClientM
()
fixLabels
ticket
=
do
liftIO
$
mapM_
(
\
kw
->
putStrLn
$
"Dropping keyword "
++
show
kw
)
droppedKeywords
unless
(
nullLabels
keywordLbls
)
$
do
let
iid
=
ticketNumberToIssueIid
$
ticketNumber
ticket
issue
<-
getIssue
gitlabToken
project
iid
liftIO
$
putStrLn
$
"Adding labels "
++
show
(
labels
`
diffLabels
`
irLabels
issue
)
let
edit
=
EditIssue
{
eiTitle
=
Nothing
,
eiDescription
=
Nothing
,
eiMilestoneId
=
Nothing
,
eiLabels
=
Just
$
labels
<>
irLabels
issue
,
eiStatus
=
Nothing
,
eiUpdateTime
=
Nothing
,
eiWeight
=
Nothing
,
eiAssignees
=
Nothing
,
eiKeywords
=
Nothing
}
liftIO
$
print
edit
--void $ editIssue gitlabToken Nothing project iid edit
where
keywordToLabels
::
Text
->
Either
Text
Labels
keywordToLabels
keyword
=
case
keywordLabels
keyword
of
xs
|
nullLabels
xs
->
Left
keyword
|
otherwise
->
Right
xs
(
droppedKeywords
,
keywordLbls
)
=
second
fold
$
partitionEithers
$
map
keywordToLabels
$
toList
$
runIdentity
$
ticketKeywords
fields
hasKeyword
kw
=
kw
`
S
.
member
`
runIdentity
(
ticketKeywords
fields
)
typeFamilies
|
hasKeyword
"type"
&&
(
hasKeyword
"family"
||
hasKeyword
"families"
)
=
"type families"
|
otherwise
=
mempty
dataFamilies
|
hasKeyword
"data"
&&
(
hasKeyword
"family"
||
hasKeyword
"families"
)
=
"data families"
|
otherwise
=
mempty
fields
=
ticketFields
ticket
typeLbls
=
ticketTypeLabel
$
runIdentity
$
ticketType
fields
failureLbls
=
typeOfFailureLabels
$
runIdentity
$
ticketTypeOfFailure
fields
statusLbls
=
statusLabel
$
runIdentity
$
ticketStatus
fields
componentLbls
=
componentLabels
$
runIdentity
$
ticketComponent
fields
labels
=
"Trac import"
<>
typeFamilies
<>
keywordLbls
<>
failureLbls
<>
typeLbls
<>
statusLbls
<>
componentLbls
Ben Gamari
🐢
@bgamari
mentioned in issue
gitlab-migration#36 (closed)
·
Mar 16, 2019
mentioned in issue
gitlab-migration#36 (closed)
mentioned in issue gitlab-migration#36
Toggle commit list
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment