Feat: collect reviews

.stylish-haskell.yaml

@@ -40,6 +40,7 @@ language_extensions:
 - PolyKinds
 - RankNTypes
 - StandaloneDeriving
+- TupleSections
 - TypeFamilies
 - TypeOperators
 - TypeSynonymInstances

app/Main.hs

@@ -12,19 +12,21 @@ import           GetOpt                 (withGetOpt')
 import           Mix
 import qualified Mix.Plugin.GitHub      as MixGitHub
 import           Mix.Plugin.Logger      as MixLogger
-import           OctGraph.Cmd
+import           OctGraph.Cmd           as OctGraph
 import           OctGraph.Config
 import           System.Environment     (getEnv)
 import qualified Version
 
 main :: IO ()
-main = withGetOpt' "[options] [input-file]" opts $ \r args usage -> do
+main = withGetOpt' "[options] (pulls|reviews)" opts $ \r args usage -> do
   homeDir <- getHomeDirectory
   _ <- loadEnvFileIfExist defaultConfig
   _ <- loadEnvFileIfExist $ defaultConfig { configPath = [homeDir <> "/.env"] }
-  if | r ^. #help    -> hPutBuilder stdout (fromString usage)
-     | r ^. #version -> hPutBuilder stdout (Version.build version <> "\n")
-     | otherwise     -> runCmd r (listToMaybe args)
+  if | r ^. #help          -> hPutBuilder stdout (fromString usage)
+     | r ^. #version       -> hPutBuilder stdout (Version.build version <> "\n")
+     | args == ["pulls"]   -> runCmd r PullRequestFreqency
+     | args == ["reviews"] -> runCmd r ReviewFrequency
+     | otherwise           -> hPutBuilder stdout (fromString usage)
   where
     loadEnvFileIfExist conf =
       whenM (and <$> mapM doesFileExist (configPath conf)) (void $ loadFile conf)
@@ -33,6 +35,7 @@ main = withGetOpt' "[options] [input-file]" opts $ \r args usage -> do
         <: #verbose @= verboseOpt
         <: #work    @= workOpt
         <: #output  @= outputOpt
+        <: #config  @= configOpt
         <: nil
 
 type Options = Record
@@ -41,6 +44,7 @@ type Options = Record
    , "verbose" >: Bool
    , "work"    >: FilePath
    , "output"  >: Maybe FilePath
+   , "config"  >: FilePath
    ]
 
 helpOpt :: OptDescr' Bool
@@ -58,16 +62,19 @@ workOpt = fromMaybe ".octgraph" <$> optLastArg ['w'] ["work"] "PATH" "Work direc
 outputOpt :: OptDescr' (Maybe FilePath)
 outputOpt = optLastArg ['o'] ["out"] "PATH" "Output png file PATH"
 
-runCmd :: Options -> Maybe FilePath -> IO ()
-runCmd opts path = do
+configOpt :: OptDescr' FilePath
+configOpt = fromMaybe "./octgraph.yaml" <$> optLastArg ['c'] ["config"] "PATH" "Configuration PATH (default: ./octgraph.yaml"
+
+runCmd :: Options -> Cmd -> IO ()
+runCmd opts subcmd = do
   gToken <- liftIO $ fromString <$> getEnv "GH_TOKEN"
   let plugin = hsequence
              $ #logger <@=> MixLogger.buildPlugin logOpts
             <: #github <@=> MixGitHub.buildPlugin gToken
-            <: #config <@=> readConfig (fromMaybe "./octgraph.yaml" path)
+            <: #config <@=> readConfig (opts ^. #config)
             <: #cache  <@=> pure (opts ^. #work </> "cache")
             <: #output <@=> pure (opts ^. #output)
             <: nil
-  Mix.run plugin cmd
+  Mix.run plugin $ OctGraph.run subcmd
   where
     logOpts = #handle @= stdout <: #verbose @= (opts ^. #verbose) <: nil

package.yaml

@@ -37,6 +37,7 @@ default-extensions:
 - PolyKinds
 - RankNTypes
 - StandaloneDeriving
+- TupleSections
 - TypeFamilies
 - TypeOperators
 - TypeSynonymInstances

src/OctGraph/Cache.hs

@@ -0,0 +1,20 @@
+module OctGraph.Cache where
+
+import           RIO
+import           RIO.Directory (createDirectoryIfMissing, doesFileExist)
+import           RIO.FilePath  (dropFileName)
+
+import qualified Data.Aeson    as J
+
+writeCache :: (MonadIO m, J.ToJSON a) => FilePath -> a -> m ()
+writeCache path target = do
+  createDirectoryIfMissing True (dropFileName path)
+  liftIO $ J.encodeFile path target
+
+readCache :: (MonadIO m, J.FromJSON a, Monoid a) => FilePath  -> m a
+readCache path = do
+  isExist <- doesFileExist path
+  if isExist then
+    fromMaybe mempty <$> liftIO (J.decodeFileStrict path)
+  else
+    pure mempty

src/OctGraph/Cmd.hs

@@ -1,37 +1,93 @@
 module OctGraph.Cmd where
 
 import           RIO
+import qualified RIO.List              as L
+import qualified RIO.Map               as Map
 
 import           Data.Fallible
-import qualified Mix.Plugin.Logger  as MixLogger
+import qualified Mix.Plugin.Logger     as MixLogger
+import           OctGraph.Cache        (readCache, writeCache)
 import           OctGraph.Cmd.Chart
 import           OctGraph.Config
 import           OctGraph.Env
-import           OctGraph.Pulls     as Pulls
+import           OctGraph.Pulls        as Pulls
+import           OctGraph.Pulls.Review as Review
 
-cmd :: RIO Env ()
-cmd = do
-  repos <- asks (view #repositories . view #config)
-  ps <- forM repos $ \repo -> do
+data Cmd
+    = PullRequestFreqency
+    | ReviewFrequency
+    deriving (Show, Eq)
+
+run :: Cmd -> RIO Env ()
+run cmd = do
+  ps <- fetchPulls =<< asks (view #repositories . view #config)
+  case cmd of
+    PullRequestFreqency ->
+      createChartFile (concat $ Map.elems ps)
+    ReviewFrequency -> do
+      _ <- fetchReviews ps
+      pure ()
+
+showNotImpl :: MonadIO m => m ()
+showNotImpl = hPutBuilder stdout "not yet implement command.\n"
+
+fetchPulls :: [RepositoryPath] -> RIO Env PullRequests
+fetchPulls repos = fmap Map.fromList . forM repos $ \repo -> do
     pulls <- fetchPullsWithCache repo
     MixLogger.logInfo (display repo)
     MixLogger.logInfo (display $ "     all pulls: " <> tshow (length pulls))
     MixLogger.logInfo (display $ "  closed pulls: " <> tshow (length $ filter isClosed pulls))
-    pure pulls
-  createChartFile (concat ps)
-
-showNotImpl :: MonadIO m => m ()
-showNotImpl = hPutBuilder stdout "not yet implement command.\n"
+    pure (repo, pulls)
 
 fetchPullsWithCache :: RepositoryPath -> RIO Env [PullRequest]
 fetchPullsWithCache repo = evalContT $ do
-  cachedPulls <- lift $ Pulls.readCache repo
+  path <- lift $ Pulls.cachePath repo
+  MixLogger.logDebug (fromString $ "read cache: " <> path)
+  cachedPulls <- lift $ readCache path
   pulls <- lift (fetchPullsWith cachedPulls) !?= err
-  when (length pulls /= length cachedPulls) $
-    lift (Pulls.writeCache repo pulls)
+  when (length pulls /= length cachedPulls) $ do
+    MixLogger.logDebug (fromString $ "write cache: " <> path)
+    lift (writeCache path pulls)
   pure pulls
   where
     err txt = exit $ MixLogger.logError (display $ repo <> txt) >> pure []
 
     fetchPullsWith []     = fetchAllPulls repo
     fetchPullsWith cached = fmap (`mergePulls` cached) <$> fetchLatestPulls repo
+
+fetchReviews :: PullRequests -> RIO Env (Map RepositoryPath  Reviews)
+fetchReviews ps = fmap Map.fromList . forM (Map.toList ps) $ \(repo, pulls) ->do
+  reviews <- fetchReviewsWithCache repo pulls
+  MixLogger.logInfo (display repo)
+  MixLogger.logInfo (display $ "  all reviews: " <> tshow (sum $ fmap length reviews))
+  pure (repo, reviews)
+
+fetchReviewsWithCache :: RepositoryPath -> [PullRequest] -> RIO Env Reviews
+fetchReviewsWithCache repo pulls = evalContT $ do
+  path <- lift $ Review.cachePath repo
+  MixLogger.logDebug (fromString $ "read cache: " <> path)
+  cachedReviews <- lift $ readCache path
+  rs <- fmap Map.fromList $ forM (take 100 $ reverse pulls) $ \pull -> do
+    threadDelay 1_000_000
+    lift (fetchReviewsWith cachedReviews pull) !?= err
+  MixLogger.logDebug (fromString $ "write cache: " <> path)
+  lift (writeCache path rs)
+  pure rs
+  where
+    err txt = exit $ MixLogger.logError (display $ repo <> txt) >> pure mempty
+
+    fetchReviewsWith :: Map Int [Review] -> PullRequest -> RIO Env (Either Text (Int, [Review]))
+    fetchReviewsWith cache pull = fmap (pull ^. #id,) <$>
+      case Map.lookup (pull ^. #id) cache of
+        Nothing     -> Review.fetchAllReviews repo pull
+        Just cached -> do
+          if Pulls.isClosed pull then
+            pure $ Right cached
+          else
+            case L.maximumByMaybe (compare `on` view #created_at) cached of
+              Nothing     -> Review.fetchAllReviews repo pull
+              Just latest ->
+                if pull ^. #updated_at > latest ^. #created_at then
+                  fmap (`mergeReviews` cached) <$> Review.fetchLatestReviews repo pull
+                else
+                  pure $ Right cached

src/OctGraph/Pulls.hs

@@ -1,23 +1,23 @@
 module OctGraph.Pulls where
 
 import           RIO
-import           RIO.Directory     (createDirectoryIfMissing, doesFileExist)
-import           RIO.FilePath      (dropFileName, (<.>), (</>))
+import           RIO.FilePath      ((<.>), (</>))
 import qualified RIO.List          as L
 import qualified RIO.Text          as T
 import           RIO.Time
 import qualified RIO.Vector        as V
 
-import qualified Data.Aeson        as J
 import           Data.Extensible
 import qualified GitHub
 import qualified Mix.Plugin.GitHub as MixGitHub
+import qualified Mix.Plugin.Logger as MixLogger
 import           OctGraph.Config   (RepositoryPath, splitRepoName)
 import           OctGraph.Env
 
 type PullRequest = Record
   '[ "id"         >: Int
    , "created_at" >: UTCTime
+   , "updated_at" >: UTCTime
    , "closed_at"  >: Maybe UTCTime
    ]
 
@@ -32,6 +32,7 @@ fetchAllPulls = fetchPulls' GitHub.FetchAll
 fetchPulls' ::
   GitHub.FetchCount -> RepositoryPath -> RIO Env (Either Text [PullRequest])
 fetchPulls' count repo = do
+  MixLogger.logDebug (display $ "fetch pulls: " <> repo <> " (" <> tshow count <> ")")
   resp <- MixGitHub.fetch $ GitHub.pullRequestsForR
     (GitHub.mkName Proxy org)
     (GitHub.mkName Proxy name)
@@ -47,33 +48,18 @@ toPullRequest :: GitHub.SimplePullRequest -> PullRequest
 toPullRequest pull
     = #id         @= GitHub.unIssueNumber (GitHub.simplePullRequestNumber pull)
    <: #created_at @= GitHub.simplePullRequestCreatedAt pull
+   <: #updated_at @= GitHub.simplePullRequestUpdatedAt pull
    <: #closed_at  @= GitHub.simplePullRequestClosedAt pull
    <: nil
 
 isClosed :: PullRequest -> Bool
 isClosed = isJust . view #closed_at
 
-
 mergePulls :: [PullRequest] -> [PullRequest] -> [PullRequest]
 mergePulls pulls =
   L.sortBy (\x y -> (x ^. #id) `compare` (y ^. #id))
     . L.nubBy (\x y -> x ^. #id == y ^. #id)
     . (pulls ++)
 
-writeCache :: RepositoryPath -> [PullRequest] -> RIO Env ()
-writeCache repo pulls = do
-  path <- cachePath repo
-  createDirectoryIfMissing True (dropFileName path)
-  liftIO $ J.encodeFile path pulls
-
-readCache :: RepositoryPath -> RIO Env [PullRequest]
-readCache repo = do
-  path    <- cachePath repo
-  isExist <- doesFileExist path
-  if isExist then
-    fromMaybe [] <$> liftIO (J.decodeFileStrict path)
-  else
-    pure []
-
 cachePath :: RepositoryPath -> RIO Env FilePath
 cachePath repo = (</> "pulls" </> T.unpack repo <.> "json") <$> asks (view #cache)

src/OctGraph/Pulls/Review.hs

@@ -0,0 +1,64 @@
+module OctGraph.Pulls.Review where
+
+import           RIO
+import           RIO.FilePath                          ((<.>), (</>))
+import qualified RIO.List                              as L
+import qualified RIO.Text                              as T
+import           RIO.Time
+import qualified RIO.Vector                            as V
+
+import           Data.Extensible
+import qualified GitHub.Data.Definitions               as GitHub
+import qualified GitHub.Data.Name                      as GitHub
+import qualified GitHub.Data.Reviews                   as GitHub
+import qualified GitHub.Endpoints.PullRequests.Reviews as GitHub
+import qualified Mix.Plugin.GitHub                     as MixGitHub
+import qualified Mix.Plugin.Logger                     as MixLogger
+import           OctGraph.Config                       (RepositoryPath,
+                                                        splitRepoName)
+import           OctGraph.Env
+import           OctGraph.Pulls                        (PullRequest)
+
+type Review = Record
+   '[ "id" >: Int
+    , "pull" >: Int
+    , "user" >: Text
+    , "created_at" >: UTCTime
+    ]
+
+type Reviews = Map Int [Review]
+
+fetchLatestReviews, fetchAllReviews :: RepositoryPath -> PullRequest -> RIO Env (Either Text [Review])
+fetchLatestReviews = fetchReviews' (GitHub.FetchAtLeast 100)
+fetchAllReviews = fetchReviews' GitHub.FetchAll
+
+fetchReviews' :: GitHub.FetchCount -> RepositoryPath -> PullRequest -> RIO Env (Either Text [Review])
+fetchReviews' count repo pr = do
+  MixLogger.logDebug (display $ "fetch reviews: " <> repo <> "#" <> tshow (pr ^. #id) <> " (" <> tshow count <> ")")
+  resp <- MixGitHub.fetch $ GitHub.pullRequestReviewsR
+    (GitHub.mkName Proxy org)
+    (GitHub.mkName Proxy name)
+    (GitHub.IssueNumber $ pr ^. #id)
+    count
+  pure $ case resp of
+    Left _        -> Left "cannot fetch reviews"
+    Right reviews -> Right (toReview pr <$> V.toList reviews)
+  where
+    (org, name) = splitRepoName repo
+
+toReview :: PullRequest -> GitHub.Review -> Review
+toReview pr review
+    = #id         @= GitHub.untagId (GitHub.reviewId review)
+   <: #pull       @= (pr ^. #id)
+   <: #user       @= GitHub.untagName (GitHub.simpleUserLogin $ GitHub.reviewUser review)
+   <: #created_at @= GitHub.reviewSubmittedAt review
+   <: nil
+
+mergeReviews :: [Review] -> [Review] -> [Review]
+mergeReviews reviews =
+  L.sortBy (\x y -> (x ^. #id) `compare` (y ^. #id))
+    . L.nubBy (\x y -> x ^. #id == y ^. #id)
+    . (reviews ++)
+
+cachePath :: RepositoryPath -> RIO Env FilePath
+cachePath repo = (</> "reviews" </> T.unpack repo <.> "json") <$> asks (view #cache)