FlexibleInstances, GADTs,
GeneralizedNewtypeDeriving, MultiParamTypeClasses,
RankNTypes, OverloadedStrings, ScopedTypeVariables,
- StandaloneDeriving,
- TemplateHaskell, TypeFamilies, UndecidableInstances #-}
+ StandaloneDeriving, TemplateHaskell, TypeFamilies,
+ TupleSections, UndecidableInstances #-}
{-# OPTIONS_GHC -Wall #-}
module Main(main) where
import qualified Data.HashMap.Strict as DHS
import qualified Data.Maybe as M
import qualified Data.Text as T
+import qualified Data.Text.Lazy.Builder as TLB
+import qualified Data.Text.Lazy.IO as TL
import qualified Data.Word as DW
import Lens.Micro as L
import qualified Lens.Micro.TH as L
lookupReviewers ra = do
r1id <- findUserMaybe (_ra_reviewer1 ra)
r2id <- findUserMaybe (_ra_reviewer2 ra)
- -- XXX debug -- liftIO $ IO.print (_ra_reviewer1 ra, r1id, _ra_reviewer2 ra, r2id)
let assignee = r2id <|> r1id
pure $ ra { _ra_reviewer1 = r1id, _ra_reviewer2 = r2id, _ra_assignee = assignee }
where
-- Redmine Applicant From Redmine JSON --------------------------------- {{{
-- Parse a Redmine JSON response into a RedmineApplicant structure
-jsonToRedmineApplicant :: RedmineInfo -> A.Value -> Maybe (RedmineApplicant (Maybe Integer))
+jsonToRedmineApplicant :: RedmineInfo -> A.Value -> Maybe (Integer, RedmineApplicant (Maybe Integer))
jsonToRedmineApplicant ri va = do
+ iid <- va ^? A.key "id" . A._Integer
subj <- va ^? A.key "subject" . A._String
cfs <- va ^? A.key "custom_fields"
let
let tB = lcf ri_cf_triageB >>= (^? A._String) >>= (readMaybe . T.unpack)
let tBs = lcf ri_cf_scoreB >>= (^? A._String) >>= (readMaybe . T.unpack)
let ae = va ^? A.key "assigned_to" . A.key "id" . A._Integer
- return $ RedmineApplicant
+ return $ (iid,) $ RedmineApplicant
{ _ra_subject = subj
, _ra_email = email
, _ra_pdfURL = pdf
}
where trace pfx bsl = IO.hPutStr stderr pfx >> BS8.hPutStrLn stderr bsl
let reqOpts = WR.basicAuth (fromString $ ac_redmineAuth ac) ""
-
+
N.newManager tlss >>= \manager ->
flip MR.runReaderT (RTD rurl (Def.def { WR.httpConfigAltManager = Just manager }) reqOpts ecb)
$ ME.runExceptT
tfi :: Integer -> T.Text
- tfi = T.pack . show
+ tfi = T.pack . show
new :: RedmineApplicant (Maybe Integer) -> RestT scheme e IO ()
new what = if pDryRun
<*> OA.option argWord8AsChar (OA.long "sep" <> OA.short 's' <> OA.value (fromIntegral $ DC.ord ',')
<> OA.help "Set the separator value (defaults to ',')")
------------------------------------------------------------------------- }}}
--- Command: Test Redmine Applicant Parser ------------------------------ {{{
-
-doTestParse :: ArgCommon -> IO ()
-doTestParse ac = wrap =<< withRedmine ac show go
- where
- wrap :: Either String () -> IO ()
- wrap = either IO.putStrLn return
-
- go :: RedmineInfo -> RestT scheme e IO ()
- go ri = do
- x <- liftIO $ BL.hGetContents IO.stdin
- case A.decode x of
- Just (v :: A.Value) -> liftIO $ print (jsonToRedmineApplicant ri v)
- Nothing -> liftIO $ putStrLn "JSON decode failure"
-
------------------------------------------------------------------------ }}}
-- Command: Applicants in Triage --------------------------------------- {{{
--- XXX Not quite yet done.
-
data TriageParams = TP
{ _triageDryRun :: Bool
}
go :: RedmineInfo -> RestT scheme e IO ()
go ri = do
isstats <- C.sourceToList redmineIssueStats
-
+
insid <- redmineIdNamed rerr (CL.sourceList isstats) "In Triage"
outsid <- redmineIdNamed rerr (CL.sourceList isstats) "Passed Triage"
))
redmineIssues
- let process ra = do
- liftIO $ IO.putStr ((T.unpack $ _ra_subject ra) ++ ": ")
- liftIO $ IO.putStrLn $
- case (_ra_score1 ra, _ra_score2 ra) of
- (Nothing, Nothing) -> "No scores"
- (Just x, Nothing) | x >= 5 -> "No second score, but first good enough"
- (Nothing, Just x) | x >= 5 -> "No first score, but second good enough"
- (Just x1, Just x2) | let xs = [x1,x2] in all (>= 4) xs || any (>= 5) xs -> ("Passed; move to " ++ (show outsid))
- (_,_) -> "No go"
+ let process (raid, ra) = do
+ let debugpfx = TLB.fromText (_ra_subject ra)
+ <> TLB.fromText " (jhuid="
+ <> TLB.fromText (_ra_jhuAppId ra)
+ <> TLB.fromText " redmineid="
+ <> TLB.fromText (T.pack $ show raid)
+ <> TLB.fromText "):"
+ let scores = M.catMaybes [_ra_score1 ra, _ra_score2 ra]
+ let promote = case scores of
+ [] -> False
+ xs | all (>= 4) xs || any (>= 5) xs -> True
+ _ -> False
+ rtx <- if promote
+ then if pDryRun
+ then return "Would promote"
+ else do
+ _ <- redmineUpdateIssueStatus raid outsid
+ return "Promoted"
+ else return "Not promoting"
+ liftIO $ TL.putStrLn $ TLB.toLazyText
+ $ TLB.fromText rtx
+ <> TLB.singleton ' '
+ <> debugpfx
+ <> TLB.fromText " scores="
+ <> TLB.fromText (T.pack $ show scores)
C.runConduit
$ applicants
C.=$= CL.mapM_ process
where
tfi :: Integer -> T.Text
- tfi = T.pack . show
+ tfi = T.pack . show
rerr n [] = error ("Could not find redmine object by name: " ++ (T.unpack n))
rerr n _ = error ("Redmine object name is not unique: " ++ (T.unpack n))
+------------------------------------------------------------------------ }}}
+-- Command: Test Redmine Applicant Parser ------------------------------ {{{
+
+doTestParse :: ArgCommon -> IO ()
+doTestParse ac = wrap =<< withRedmine ac show go
+ where
+ wrap :: Either String () -> IO ()
+ wrap = either IO.putStrLn return
+
+ go :: RedmineInfo -> RestT scheme e IO ()
+ go ri = do
+ x <- liftIO $ BL.hGetContents IO.stdin
+ case A.decode x of
+ Just (v :: A.Value) -> liftIO $ print (jsonToRedmineApplicant ri v)
+ Nothing -> liftIO $ putStrLn "JSON decode failure"
+
------------------------------------------------------------------------ }}}
-- Command: Expected Yield --------------------------------------------- {{{
, ac_debug :: Int
}
+oat :: OA.ReadM a -> [String] -> [Char] -> String -> String -> OA.Mod OA.OptionFields a -> OA.Parser a
+oat t ls ss m h x = OA.option t (OA.help h <> OA.metavar m <> mconcat (map OA.long ls) <> mconcat (map OA.short ss) <> x)
+
+parseArgCommon :: OA.Parser ArgCommon
+parseArgCommon = ArgCommon
+ <$> oat host ["host"] ['h'] "HOST" "Redmine server host"
+ (OA.value $ WR.https "clsp-redmine.cs.jhu.edu")
+ <*> oat OA.str ["auth","user"] ['a','u'] "STRING" "Authentication token" mempty
+ <*> oat OA.str ["project"] ['p'] "ProjName" "Project name" mempty
+ <*> OA.flag False True (OA.long "cert" <> OA.short 'C')
+ <*> oat OA.auto ["debug"] ['v'] "LEVEL" "Verbosity" (OA.value 0)
+ where
+ host = (WR.https . T.pack) <$> OA.str
+
redmine_commands :: OA.Parser (ArgCommon -> IO ())
redmine_commands = OA.subparser
$ pingCommand
<> upsertCommand
-- <> expectedYieldCommand
- <> testParseCommand
<> inTriageCommand
+ <> testParseCommand
where
pingCommand :: OA.Mod OA.CommandFields (ArgCommon -> IO ())
pingCommand = OA.command "ping"
(OA.progDesc "Upsert from CSV on stdin"
<> OA.footer "Note that input *must* be UTF-8. Try 'iconv --from latin1 --to utf8'")
- testParseCommand :: OA.Mod OA.CommandFields (ArgCommon -> IO ())
- testParseCommand = OA.command "test-parse"
- $ infoh (pure doTestParse)
- (OA.progDesc "Test parse")
-
inTriageCommand :: OA.Mod OA.CommandFields (ArgCommon -> IO ())
inTriageCommand = OA.command "in-triage"
$ infoh (doApplicantsInTriage <$> parseTriage)
(OA.progDesc "In Triage (in progress)")
-oat :: OA.ReadM a -> [String] -> [Char] -> String -> String -> OA.Mod OA.OptionFields a -> OA.Parser a
-oat t ls ss m h x = OA.option t (OA.help h <> OA.metavar m <> mconcat (map OA.long ls) <> mconcat (map OA.short ss) <> x)
-
-parseArgCommon :: OA.Parser ArgCommon
-parseArgCommon = ArgCommon
- <$> oat host ["host"] ['h'] "HOST" "Redmine server host"
- (OA.value $ WR.https "clsp-redmine.cs.jhu.edu")
- <*> oat OA.str ["auth","user"] ['a','u'] "STRING" "Authentication token" mempty
- <*> oat OA.str ["project"] ['p'] "ProjName" "Project name" mempty
- <*> OA.flag False True (OA.long "cert" <> OA.short 'C')
- <*> oat OA.auto ["debug"] ['v'] "LEVEL" "Verbosity" (OA.value 0)
- where
- host = (WR.https . T.pack) <$> OA.str
+ testParseCommand :: OA.Mod OA.CommandFields (ArgCommon -> IO ())
+ testParseCommand = OA.command "test-parse"
+ $ infoh (pure doTestParse)
+ (OA.progDesc "Test parse")
main :: IO ()
main = do
(OA.progDesc "Interact with clsp-redmine.cs.jhu.edu")
------------------------------------------------------------------------ }}}
--- vim: set foldmethod=marker ts=2
+-- vim: set foldmethod=marker ts=2 nu
projects / hs-redmine-automation / commitdiff