From: Nathaniel Wesley Filardo Date: Mon, 4 Jan 2016 03:44:55 +0000 (-0500) Subject: New csvRedmine.hs script X-Git-Url: https://hydra-www.ietfng.org/gitweb/?a=commitdiff_plain;h=3f0d845b6cb38d7b669231e21a14be64f766d41b;p=hs-redmine-automation New csvRedmine.hs script --- diff --git a/NOTES b/NOTES new file mode 100644 index 0000000..f66ec20 --- /dev/null +++ b/NOTES @@ -0,0 +1,20 @@ +Using csvRedmine.hs +=================== + +One-time Setup +-------------- + +sudo apt-get install ghc cabal-install happy alex libz-dev +cabal update +cabal install wreq conduit cassava-conduit + +Running +------- + +runghc csvRedmine.hs \ + -h https://clsp-redmine.cs.jhu.edu \ + -a $your_auth_token \ + -p $project_name \ + upsert -x < foo.csv + +The -x indicates that we should clobber existing entries. diff --git a/csvRedmine.hs b/csvRedmine.hs new file mode 100644 index 0000000..fb5e0de --- /dev/null +++ b/csvRedmine.hs @@ -0,0 +1,613 @@ +-- Headers ------------------------------------------------------------- {{{ + +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, + GeneralizedNewtypeDeriving, MultiParamTypeClasses, + OverloadedStrings, ScopedTypeVariables, TemplateHaskell #-} +{-# OPTIONS_GHC -Wall #-} + +import Control.Monad.Trans(MonadIO, liftIO) +import Data.Monoid((<>)) +import Data.String(fromString) +import Data.Text(Text) +-- import Data.Vector(Vector) + +import Control.Applicative +import qualified Control.Lens as L +import Control.Lens.Operators +import qualified Control.Monad.Reader as MR +import qualified Data.Aeson as A +import qualified Data.Aeson.Lens as A +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.Conduit as C +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import qualified Data.Csv as CSV +import qualified Data.Csv.Conduit as CSV +import qualified Data.Data as D +import qualified Data.HashMap.Strict as DHS +import qualified Data.Maybe as M +import qualified Data.Text as T +-- import qualified Data.Vector as V +import qualified Network.Connection as N +import qualified Network.HTTP.Client as N +import qualified Network.HTTP.Client.Internal as N +import qualified Network.HTTP.Client.TLS as N +import qualified Network.Wreq as W +import qualified Network.Wreq.Session as WS +import qualified System.Console.CmdLib as Cm +import qualified System.IO as IO +import qualified Text.Regex.Posix as Re + + +-- import Data.Map(Map) +-- import qualified Data.Map as M +-- import qualified Debug.Trace as DT + +------------------------------------------------------------------------ }}} +-- Early Type Definitions----------------------------------------------- {{{ +-- These are fronted due to TemplateHaskell ordering requirements. + +-- | See `withRedmine` +data RedmineInfo = RI + { _ri_projId :: Integer + , _ri_trackId :: Integer + , _ri_cf_areas :: Integer + , _ri_cf_citizen :: Integer + , _ri_cf_faculty :: Integer + , _ri_cf_gre :: Integer + , _ri_cf_insts :: Integer + , _ri_cf_jhuAppId :: Integer + , _ri_cf_pdfURL :: Integer + , _ri_cf_toefl :: Integer + , _ri_cf_triageA :: Integer + , _ri_cf_triageB :: Integer + } +$(L.makeLenses ''RedmineInfo) + +------------------------------------------------------------------------ }}} +-- CSV Data ------------------------------------------------------------ {{{ + +{- We are at present ignoring these fields: + - IELTS_BAND_SCORE, IELTS_LISTENING, IELTS_SPEAKING, IELTS_READING, IELTS_WRITING + -} + +--- CSV Applicant Data Definition -------------------------------------- {{{ + +-- These records approximate what we get out of the CSV file. If its schema +-- changes over time, this is the right place to start changing this script. + +data GREText = GREText + { gre_quant :: (Text,Text) + , gre_verbal :: (Text,Text) + , gre_awa :: (Text,Text) + } + deriving (Eq,Ord,Show) + +defGREText :: GREText +defGREText = GREText ("","") ("","") ("","") + +data TOEFLText = TOEFLText + { toefl_cbt_pbt :: Text + , toefl_total :: Text + , toefl_listen :: Text + , toefl_read :: Text + , toefl_speak :: Text + , toefl_swrite :: Text + } + deriving (Eq,Ord,Show) + +defTOEFLText :: TOEFLText +defTOEFLText = TOEFLText "" "" "" "" "" "" + +data CSVApplicant = CSVApplicant + { _ca_jhuAppId :: Text + , _ca_pdfURL :: Text + , _ca_name_first :: Text + , _ca_name_last :: Text + , _ca_gender :: Text + , _ca_email :: Text + , _ca_citizen :: Text + , _ca_area1 :: Text + , _ca_area2 :: Text + , _ca_faculty :: Text + , _ca_insts :: [(Text,Text,Text)] + , _ca_gre :: [GREText] + , _ca_toefl :: TOEFLText + , _ca_reviewer1 :: Text -- Email, not name + , _ca_reviewer2 :: Text + } + deriving (Eq,Ord,Show) +$(L.makeLenses ''CSVApplicant) + +defCSVApplicant :: CSVApplicant +defCSVApplicant = CSVApplicant "" "" "" "" "" "" "" "" "" "" [] [] + defTOEFLText "" "" + +------------------------------------------------------------------------ }}} +--- CSV Applicant Data Parser ------------------------------------------ {{{ + +-- The way this works is that we start off with the default applicant +-- structure, namely 'defCSVApplicant' and fill in pieces of it as we go. +-- Each piece is feched by a Lens (but don't worry about it too much), +-- which names the field and an action which actually gets the thing we +-- want. 'grab' here is an alias for the named field projection which +-- uses the column headings from the CSV file. The actual data from which +-- we are projecting ('m') is closed over in 'grab'; don't be alarmed that +-- it's not overtly present in each line. +instance CSV.FromNamedRecord CSVApplicant where + parseNamedRecord m = pure defCSVApplicant + >>= (ca_jhuAppId $ grab "Applicant Client ID") + >>= (ca_pdfURL $ grabDef "" "Box URL") + >>= (ca_name_first $ grab "First Name") + >>= (ca_name_last $ grab "Last Name") + >>= (ca_gender $ grab "Gender") + >>= (ca_email $ grab "Email") + >>= (ca_area1 $ grab "Area of Interest") + >>= (ca_area2 $ grab "Secondary Area of Interest") + >>= (ca_faculty $ {- fmap (T.split (== ',')) . -} grab "Faculty of Interest") + >>= (ca_citizen $ grab "Citizenship") + >>= (ca_reviewer1 $ grabDef "" "Reviewer A Email") + >>= (ca_reviewer2 $ grabDef "" "Reviewer B Email") + >>= (ca_insts $ \_ -> + (filter (/= ("","",""))) + <$> sequence + [ (,,) <$> grab' "Inst 1" <*> grab' "Deg 1" <*> grab' "GPA1" + , (,,) <$> grab' "Inst 2" <*> grab' "Deg 2" <*> grab' "GPA2" + , (,,) <$> grab' "Institution Name3" <*> grab' "Degree Awarded3" <*> grab' "GPA3" + ]) + >>= (ca_gre $ \_ -> + (filter (/= GREText ("","") ("","") ("",""))) + <$> sequence + [ GREText <$> ((,) <$> grab' "QUANTITATIVE_SCORE" <*> grab' "Quantitative Percent") + <*> ((,) <$> grab' "VERBAL_SCORE" <*> grab' "GRE Verbal Percent") + <*> ((,) <$> grab' "AWA_SCORE" <*> grab' "Analytical Writing Percent") + , GREText <$> ((,) <$> grab' "QUANTITATIVE_SCORE 2" <*> grab' "Quantitative Percent 2") + <*> ((,) <$> grab' "VERBAL_SCORE 2" <*> grab' "GRE Verbal Percent 2") + <*> ((,) <$> grab' "AWA_SCORE 2" <*> grab' "Analytical Writing Percent 2") + ]) + >>= (ca_toefl $ \_ -> + TOEFLText <$> grab' "TOEFL_CBT_PBT" + <*> grab' "TOEFL_TOTAL_SCORE" + <*> grab' "TOEFL_LISTENING_SCORE" + <*> grab' "TOEFL_READING_SCORE" + <*> grab' "TOEFL_SPEAKING_SCORE" + <*> grab' "TOEFL_STRUCTURE_WRTG_SCORE") + + where + grab' f = m CSV..: f + grabOpt' f = optional (grab' f) + + grab f _ = grab' f + -- grabOpt f _ = grabOpt' f + + grabDef d f _ = fmap (maybe d id) (grabOpt' f) + +showCSVError :: CSV.CsvParseError -> String +showCSVError (CSV.IncrementalError e) = "Incremental CSV parse error: " ++ e +showCSVError (CSV.CsvParseError bs e) = "CSV Parse error: " ++ (show bs) ++ ":" ++ e + +------------------------------------------------------------------------ }}} +------------------------------------------------------------------------ }}} +-- Redmine Applicant Data ---------------------------------------------- {{{ + +-- This approximates the Redmine schema. If that changes over time, this is +-- the right place to start changing this file. Note that these are +-- parameterized on the type of reviewers (and, perhaps, should be +-- parameterized on other things too); reason being that we need to go to +-- Redmine and ask it for the identifiers of users. So we move from email +-- text to numerics at some point (see 'lookupReviewers') + +data RedmineApplicant uid = RedmineApplicant + { _ra_jhuAppId :: Text + , _ra_pdfURL :: Text + , _ra_subject :: Text -- formed from name fields + , _ra_citizen_us :: Bool + , _ra_areas :: [Text] -- formed from area fields + , _ra_faculty :: Text + , _ra_insts :: Text -- formed from inst field + , _ra_gre :: Text -- formed from GRE data + , _ra_toefl :: Text -- formed from TOEFL data + , _ra_reviewer1 :: uid + , _ra_reviewer2 :: uid + } + deriving (Eq,Ord,Show) +$(L.makeLenses ''RedmineApplicant) + +--- Redmine Applicant From CSV ----------------------------------------- {{{ + +-- Here's our schema conversion, mostly. + +csvToRedmine :: CSVApplicant -> RedmineApplicant Text +csvToRedmine ca = RedmineApplicant + { _ra_jhuAppId = _ca_jhuAppId ca + , _ra_pdfURL = _ca_pdfURL ca + , _ra_faculty = _ca_faculty ca + , _ra_reviewer1 = _ca_reviewer1 ca -- copy across emails + , _ra_reviewer2 = _ca_reviewer2 ca + + , _ra_citizen_us = _ca_citizen ca == "U.S. Citizen" + + , _ra_subject = T.concat [ _ca_name_last ca, ", ", _ca_name_first ca ] + , _ra_areas = [ _ca_area1 ca, _ca_area2 ca ] + + , _ra_insts = T.intercalate "; " + $ flip map (_ca_insts ca) + $ \(i,d,g) -> T.concat [mkQ i, " (", mkQ d, ": ", mkQ g, ")"] + + , _ra_gre = T.intercalate "; " + $ flip map (_ca_gre ca) + $ \(GREText (qs,qp) (vs,vp) (ws,wp)) -> + T.concat [mkQ qs, "M " , mkQ vs, "V " , mkQ ws, "AW (" + ,mkQ qp, "%, ", mkQ vp, "%," , mkQ wp, "%)"] + + , _ra_toefl = ($ _ca_toefl ca) $ \(TOEFLText cbt t l r s w) -> + T.concat [t, ": ", mkQ l, "(Listening), ", mkQ r, "(Reading), " + , mkQ s, "(Speaking), " , mkQ w, "(Writing) " + , toeflty cbt] + } + where + mkQ x = if x == "" then "??" else x + + toeflty :: Text -> Text + toeflty t = case (T.unpack t) Re.=~ ("^[^(]*(\\([^)]+\\))$" :: String) of + (_ :: String, _ :: String, _ :: String, [t']) -> T.pack t' + _ -> t + + +-- XXX +--- testCSV = IO.withFile "test.csv" IO.ReadMode $ \f -> do +--- fc <- BL.hGetContents f +--- let Right (_, d) = decodeCSV fc +--- print (V.map csvToRedmine d) + +------------------------------------------------------------------------ }}} +------------------------------------------------------------------------ }}} +-- Redmine API Details ------------------------------------------------- {{{ + +data RestTD = RTD + { _rtd_sess :: WS.Session + , _rtd_opts :: W.Options + , _rtd_base :: String + , _rtd_show_resps :: W.Response BL.ByteString -> IO () + } +$(L.makeLenses ''RestTD) + +-- | Package up most things we need to make ReSTful queries +newtype RestT m a = RestT { runRestT :: MR.ReaderT RestTD m a } + deriving (Applicative,Functor,Monad,MonadIO,MR.MonadReader RestTD) + +--- Redmine API Query Core --------------------------------------------- {{{ + +-- Return the entire response body as well as a descended piece of it +redmineQuery :: MonadIO m + => IO (W.Response BL.ByteString) + -> Text + -> m (A.Value, A.Value) +redmineQuery q d = do + resp :: W.Response A.Value <- liftIO (W.asJSON =<< q) + let rb = resp ^. W.responseBody + case rb ^? A.key d of + Nothing -> error $ "Invalid Redmine response? " ++ (show resp) + Just value -> pure (rb, value) + +-- Sometimes we need to make Redmine queries for lists of things. Sometimes +-- those things have paged interfaces because there are lots of them; the +-- 'redmineListCursor' version here manages the offset transparently. +-- Hooray. +redmineList, redmineListCursor + :: MonadIO m + => String -- ^ URL suffix + -> Text -- ^ Field to look for in Redmine response + -> C.ConduitM i A.Value (RestT m) () +redmineList u d = do + RTD s o b vp <- MR.ask + (_, value) <- redmineQuery (WS.getWith o s (b ++ u) >>= \resp -> vp resp >> pure resp) d + CL.sourceList $ value ^.. L.traverseOf A.values +redmineListCursor u d = do + RTD s o b vp <- MR.ask + let fetch n = WS.getWith (o & W.param "offset" .~ [T.pack $ show n]) s (b ++ u) + >>= \resp -> vp resp >> pure resp + go fetch 0 + where + go fetch off = do + (rb, value) <- redmineQuery (fetch off) d + CL.sourceList $ value ^.. L.traverseOf A.values + maybe (error $ "JSON response missing position information: " ++ show rb) + (\(tc,ooff,olim) -> if ooff + olim < tc then go fetch (ooff+olim) else return ()) + $ do + total_count <- rb L.^? A.key "total_count" . A._Integer + offset <- rb L.^? A.key "offset" . A._Integer + limit <- rb L.^? A.key "limit" . A._Integer + pure (total_count, offset, limit) + + +------------------------------------------------------------------------ }}} +--- Redmine API Post-Query Filters ------------------------------------- {{{ + +-- Redmine likes to give us things with identifiers and fields whose +-- value we care about and then expects us to use the identifiers rather +-- than values we care about later. That stinks. This is a convenience +-- wrapper that maps us from the values we care about to the identifiers. +withRedmineIdThing :: (MonadIO m, A.AsValue s) + => Text -- ^ Field carrying the name + -> ([Integer] -> m a) -- ^ Error callback + -> C.Conduit () m s -- ^ Source conduit + -> Text -- ^ Name of thing to look for + -> (Integer -> m a) + -> m a +withRedmineIdThing k err cond name f = do + ids <- C.sourceToList + $ cond + C.=$= CL.filter (\p -> Just name == p ^? A.key k . A._String) + C.=$= CL.mapMaybe (\p -> p ^? A.key "id" . A._Integer) + case ids of + [i] -> f i + _ -> err ids + +-- A lot of Redmine things use "name" as the value we care about *and* +-- we don't necessarily care about all the fancy error handling that +-- the generic `withRedmineIdThing` would give us. This is a simplified +-- interface. +redmineIdNamed :: (MonadIO m, A.AsValue s) + => ([Integer] -> m Integer) -- ^ Error callback + -> C.Conduit () m s -- ^ Source conduit + -> Text -- ^ Name of thing to look for + -> m Integer +redmineIdNamed err cond name = withRedmineIdThing "name" err cond name pure + + +------------------------------------------------------------------------ }}} +--- Redmine API Queries ------------------------------------------------ {{{ + +-- Using the above functions, make some convenience enumerators ("source +-- conduits") for things in Redmine we care about. + +redmineProjects, redmineUsers, redmineTrackers, redmineCustomFields, redmineIssues + :: MonadIO m => C.ConduitM i A.Value (RestT m) () +redmineProjects = redmineListCursor "/projects.json" "projects" +redmineUsers = redmineListCursor "/users.json" "users" +redmineIssues = redmineListCursor "/issues.json" "issues" +redmineTrackers = redmineList "/trackers.json" "trackers" +redmineCustomFields = redmineList "/custom_fields.json" "custom_fields" + +------------------------------------------------------------------------ }}} +--- Redmine Applicant To JSON ------------------------------------------ {{{ + +-- Map reviewer emails to possible identifiers +lookupReviewers :: RedmineApplicant Text -> RestT IO (RedmineApplicant (Maybe Integer)) +lookupReviewers ra = do + let findUserMaybe un = if un == "" + then pure Nothing + else withRedmineIdThing "mail" (pure . M.listToMaybe) redmineUsers un (pure . Just) + r1id <- findUserMaybe (_ra_reviewer1 ra) + r2id <- findUserMaybe (_ra_reviewer2 ra) + pure $ ra { _ra_reviewer1 = r1id, _ra_reviewer2 = r2id } + +-- Convert a RemineApplicant, whose reviewers have already been mapped using +-- Redmine, to a JSON representation using the RedmineInfo to get +-- identifiers for custom fields +jsonifyRedmineApp :: RedmineInfo -> RedmineApplicant (Maybe Integer) -> A.Value +jsonifyRedmineApp ri ra = do + A.object [ "custom_fields" A..= (A.toJSON + $ addcfm ri_cf_triageA ra_reviewer1 + $ addcfm ri_cf_triageB ra_reviewer2 + $ [ mkcf ri_cf_jhuAppId ra_jhuAppId + , mkcf ri_cf_pdfURL ra_pdfURL + , mkcf ri_cf_citizen ra_citizen_us + , mkcf ri_cf_areas ra_areas + , mkcf ri_cf_faculty ra_faculty + , mkcf ri_cf_insts ra_insts + , mkcf ri_cf_gre ra_gre + , mkcf ri_cf_toefl ra_toefl + ]) + , "subject" A..= (ra ^. ra_subject) + ] + where + addcfm f v = maybe id (\vv -> ((A.object [ "id" A..= show (ri ^. f), "value" A..= vv ]) :)) (ra ^. v) + mkcf f v = A.object [ "id" A..= show (ri ^. f), "value" A..= (ra ^. v) ] + +------------------------------------------------------------------------ }}} +--- Redmine API Updates ------------------------------------------------ {{{ + +-- Construct a new applicant +redmineNewIssue :: RedmineInfo -> RedmineApplicant (Maybe Integer) -> RestT IO (W.Response BL.ByteString) +redmineNewIssue ri ra = do + RTD s o u vp <- MR.ask + let (A.Object fs) = jsonifyRedmineApp ri ra + let fs' = (DHS.fromList [ "project_id" A..= (_ri_projId ri), "tracker_id" A..= (_ri_trackId ri) ]) <> fs + liftIO $ WS.postWith o s (u ++ "/issues.json") (A.object ["issue" A..= fs']) + >>= \resp -> vp resp >> pure resp + +-- Update an existing applicant; sends all fields and Redmine sorts it out +redmineUpdateIssue :: RedmineInfo -> Integer -> RedmineApplicant (Maybe Integer) -> RestT IO (W.Response BL.ByteString) +redmineUpdateIssue ri n ra = do + RTD s o u vp <- MR.ask + liftIO $ WS.putWith o s (u ++ "/issues/" ++ show n ++ ".json") (A.object ["issue" A..= jsonifyRedmineApp ri ra]) + >>= \resp -> vp resp >> pure resp +------------------------------------------------------------------------ }}} +------------------------------------------------------------------------ }}} +-- withRedmine --------------------------------------------------------- {{{ + +-- | A wrapper which sets us up to make ReSTful queries against a Redmine +-- instance given the common arguments. +-- +-- Makes a boatload of requests itself to figure out common parameters +-- of the Redmine setup used by CLSP. Hooray. +withRedmine :: ArgCommon -> (RedmineInfo -> RestT IO ()) -> IO () +withRedmine ac cb = do + let rurl = ac_redmineURL ac + let tlss0 = if ac_cert_check ac + then N.tlsManagerSettings + else N.mkManagerSettings (N.TLSSettingsSimple True False False) Nothing + let tlss = if ac_debug ac < 2 + then tlss0 + else tlss0 { N.managerTlsConnection = pure $ \ha h p -> do + mkTLSC <- N.managerTlsConnection tlss0 + c <- mkTLSC ha h p + pure c { N.connectionWrite = \bs -> do + mapM_ (\bsl -> do + IO.hPutStr IO.stderr "> " + BS8.hPutStrLn IO.stderr bsl) + (BS8.lines bs) + N.connectionWrite c bs + } + } + let vp = if ac_debug ac < 2 + then \_ -> pure () + else print + let wreqOpts = W.defaults & W.auth .~ Just (W.basicAuth (fromString $ ac_redmineAuth ac) "") + WS.withSessionControl Nothing tlss $ \sess -> flip MR.runReaderT (RTD sess wreqOpts rurl vp) $ runRestT $ do + + -- We need to look up a whole lot of custom fields; since there aren't + -- that many of them, grab them all into RAM now and scan locally rather + -- than making repeated queries of the server. + customFields <- C.sourceToList redmineCustomFields + + -- Build redmine configuration information to pass to callback + ri <- RI + -- project + <$> redmineIdNamed rerr (redmineProjects) (fromString $ ac_redmineProjName ac) + -- tracker + <*> redmineIdNamed rerr (redmineTrackers) "Applicant" + -- custom fields + <*> redmineIdNamed rerr (CL.sourceList customFields) "Research Areas" + <*> redmineIdNamed rerr (CL.sourceList customFields) "US Citizen" + <*> redmineIdNamed rerr (CL.sourceList customFields) "Faculty of Interest" + <*> redmineIdNamed rerr (CL.sourceList customFields) "GRE Scores" + <*> redmineIdNamed rerr (CL.sourceList customFields) "Prior Institutions" + <*> redmineIdNamed rerr (CL.sourceList customFields) "JHU Applicant ID" + <*> redmineIdNamed rerr (CL.sourceList customFields) "PDF Application" + <*> redmineIdNamed rerr (CL.sourceList customFields) "TOEFL Score" + <*> redmineIdNamed rerr (CL.sourceList customFields) "Triage A" + <*> redmineIdNamed rerr (CL.sourceList customFields) "Triage B" + + cb ri + where + rerr [] = error "Could not find redmine project by name." + rerr _ = error "Redmine project name is not unique." + +------------------------------------------------------------------------ }}} +-- CSV Upsert ---------------------------------------------------------- {{{ + +-- Insert or Update an applicant based on CSV data + +data ArgUpsert = ArgUpsert { upsert_clobber :: Bool } + deriving (D.Data,Eq) + +instance Cm.Attributes ArgUpsert where + attributes _ = Cm.group "Upsert Options" + [ upsert_clobber + Cm.%> [ Cm.Short "x" , Cm.Long ["clobber"] + , Cm.Help "Overwrite existing records" ] + ] + +data RedmineUpsert = RedmineUpsert ArgCommon + deriving (D.Data,Eq) + +instance Cm.Command RedmineUpsert (Cm.Record ArgUpsert) where + cmdname _ = "upsert" + run (RedmineUpsert ac) au _ = withRedmine ac $ \ri -> do + -- A little ahead of the game, but... once we've got an applicant + -- 'what', we should... + let process what = do + let appid = _ra_jhuAppId what + -- ... see if they already exist in Redmine ... + raids <- MR.local (rtd_opts %~ ( (W.param "project_id" .~ [T.pack $ show $ _ri_projId ri]) + . (W.param "tracker_id" .~ [T.pack $ show $ _ri_trackId ri]) + . (W.param (fromString ("cf_" ++ show (_ri_cf_jhuAppId ri))) + .~ [appid]))) + $ C.sourceToList + $ redmineIssues + C.=$= CL.mapMaybe (^? A.key "id" . A._Integer) + + -- ... and respond appropriately by... + case (raids, upsert_clobber au) of + -- complaining if there's a problem + (_:_:_, _) -> liftIO $ IO.hPutStrLn IO.stdout + ("Multiple applicants with the same ID? " ++ show appid) + -- ... creating a new issue if they + -- don't already exist + ([], _) -> redmineNewIssue ri what >> pure () + -- ... clobbering the existing record + -- if they already do and we've been told + -- to clobber ... + ([applicant], True) -> redmineUpdateIssue ri applicant what >> pure () + -- ... or complaining otherwise. + ([_], False) -> liftIO $ IO.hPutStrLn IO.stdout + ("Not clobbering existing applicant" ++ show appid) + + -- Alright, here's our pipeline; the heart of the upsert command. We + -- start by... + C.runConduit $ + -- ... reading stdin as chunks of bytes ... + CB.sourceHandle IO.stdin + + -- ... converting those chunks of bytes to CSVApplicants ... + C.=$= CSV.fromNamedCsvStreamError CSV.defaultDecodeOptions + + -- ... filtering out any CSV errors and showing them ... + C.=$= CL.mapMaybeM (either ((*> pure Nothing) . printErr) (pure . Just)) + + -- ... purely mapping schemas ... + C.=$= CL.map csvToRedmine + + -- ... using Redmine to convert reviewers ... + C.=$= CL.mapM lookupReviewers + + -- ... and lastly using the above "process" function + C.=$= CL.mapM_ process + where + printErr = liftIO . IO.hPutStrLn IO.stdout . showCSVError + +------------------------------------------------------------------------ }}} +-- Argument Parsing and main function ---------------------------------- {{{ + +-- Common argument parsing. Nothing terribly fancy. + +redmine_commands :: ArgCommon -> [Cm.CommandWrap] +redmine_commands f = Cm.commandGroup "Redmine Command" (RedmineUpsert f) + +data ArgCommon = ArgCommon + { ac_redmineURL :: String + , ac_redmineAuth :: String + , ac_redmineProjName :: String + , ac_cert_check :: Bool + , ac_debug :: Int + } + deriving (D.Data,Eq,Show) + +instance Cm.Attributes ArgCommon where + attributes _ = Cm.group "Common Options" + [ ac_redmineURL + Cm.%> [ Cm.Short "h" , Cm.Long ["url", "host"] + , Cm.Help "Base to redmine server", Cm.ArgHelp "URL" ] + , ac_redmineAuth + Cm.%> [ Cm.Short "au", Cm.Long ["auth", "user"] + , Cm.Help "Authentication token" , Cm.ArgHelp "STRING" ] + , ac_redmineProjName + Cm.%> [ Cm.Short "p" , Cm.Long ["project"] + , Cm.Help "Project Name" , Cm.ArgHelp "STRING" ] + , ac_cert_check + Cm.%> [ Cm.Short "C" , Cm.Long ["cert"], Cm.Default False + , Cm.Help "certificate checking" ] + , ac_debug + Cm.%> [ Cm.Short "v" , Cm.Long ["debug"], Cm.Default (0 :: Int) + , Cm.Help "verbosity" , Cm.ArgHelp "LEVEL" ] + ] + +data RedmineCommand = RedmineCommand deriving (D.Typeable,Eq) + +instance Cm.Command RedmineCommand (Cm.Record ArgCommon) where + summary _ = "Interact with Redmine" + help _ = Cm.helpCommands (redmine_commands undefined) + cmdname _ = "redmine" + supercommand _ = True + synopsis _ = "redmine [COMMON OPTIONS] [REDMINE COMMAND] ..." + run _ f opts = Cm.dispatch [] (redmine_commands f) opts + +main :: IO () +main = Cm.getArgs >>= Cm.execute (Cm.cmd :: RedmineCommand) + +------------------------------------------------------------------------ }}} +-- vim: foldmethod=marker:ts=2