diff --git a/BUILD.bazel b/BUILD.bazel index a00ddde..8923da6 100644 --- a/BUILD.bazel +++ b/BUILD.bazel @@ -28,6 +28,7 @@ haskell_library( hazel_library("http-client-tls"), hazel_library("monad-parallel"), hazel_library("quickcheck-text"), + hazel_library("split"), hazel_library("tabular"), hazel_library("text"), hazel_library("time"), diff --git a/README.md b/README.md index 7972d98..caf0ef1 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,5 @@ # Github tools for TokTok projects -See https://git-critique.herokuapp.com/hello/pulls.html. +c-toxcore pull requests: https://git-critique.herokuapp.com/hello/pulls.html. + +c-toxcore roadmap requests: https://git-critique.herokuapp.com/hello/roadmap.html. diff --git a/github-tools.cabal b/github-tools.cabal index 4009c7f..a0cc7e6 100644 --- a/github-tools.cabal +++ b/github-tools.cabal @@ -125,6 +125,7 @@ library , monad-parallel , QuickCheck , quickcheck-text + , split , tabular , text , time diff --git a/src/Changelogs.hs b/src/Changelogs.hs index 2f92d20..25aa352 100644 --- a/src/Changelogs.hs +++ b/src/Changelogs.hs @@ -8,16 +8,20 @@ module Changelogs ) where import Control.Arrow (first, second, (&&&)) +import qualified Control.Monad.Parallel as P import Data.List (foldl') import qualified Data.List as List +import qualified Data.List.Split as List import qualified Data.Map as Map import qualified Data.Maybe as Maybe import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Vector as V +import Debug.Trace (traceIO) import qualified GitHub import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) +import Text.Read (readMaybe) -- import Text.Groom (groom) import Requests @@ -26,6 +30,23 @@ import Requests newtype ChangeLog = ChangeLog { unChangeLog :: [(Text, [Text], [Text])] } +data VersionComponent + = Number Int + | Wildcard + deriving (Ord, Eq) + + +instance Read VersionComponent where + readsPrec _ ('x':s) = [(Wildcard, s)] + readsPrec p input = map (first Number) . readsPrec p $ input + + +data Version + = VersionNumber [VersionComponent] + | VersionString Text + deriving (Ord, Eq) + + formatChangeLog :: Bool -> ChangeLog -> Text formatChangeLog wantRoadmap = (<> "\n") . foldl' (<>) "" . map formatMilestone . unChangeLog @@ -72,8 +93,7 @@ groupByMilestone add = flip $ foldr (\item group -> case Map.lookup (clMilestone item) group of Just old -> add item old Nothing -> add item ([], []) - ) group - ) + ) group) formatChangeLogItem @@ -103,6 +123,7 @@ makeChangeLog -> ChangeLog makeChangeLog wantRoadmap ownerName repoName pulls issues = ChangeLog + . reverseIfChangelog . sortChangelog . Map.foldlWithKey (\changes milestone (msIssues, msPulls) -> if milestone == "meta" @@ -117,12 +138,25 @@ makeChangeLog wantRoadmap ownerName repoName pulls issues = . groupByMilestone (second . (:)) changeLogPrs $ Map.empty where - sortChangelog l = + reverseIfChangelog l = if wantRoadmap - then case reverse l of + then l + else case reverse l of [] -> [] x:xs -> xs ++ [x] -- Put "Backlog" last. - else l + + sortChangelog :: [(Text, [Text], [Text])] -> [(Text, [Text], [Text])] + sortChangelog = List.sortOn $ \(v, _, _) -> parseVersion v + + parseVersion :: Text -> Version + parseVersion v = + case Text.unpack v of + -- Milestones starting with "v" must be versions. + 'v':version -> + case map readMaybe $ List.splitOn "." version of + [Just major, Just minor, Just rev] -> VersionNumber [major, minor, rev] + _ -> error $ "invalid version: " <> version + _ -> VersionString v (mergedPrs, openPrs) = List.partition (\case GitHub.SimplePullRequest @@ -210,11 +244,23 @@ fetchChangeLog wantRoadmap ownerName repoName auth = do -- Initialise HTTP manager so we can benefit from keep-alive connections. mgr <- newManager tlsManagerSettings - let pulls state = V.toList <$> request auth mgr (GitHub.pullRequestsForR ownerName repoName state GitHub.FetchAll) - let issues state = V.toList <$> request auth mgr (GitHub.issuesForRepoR ownerName repoName state GitHub.FetchAll) + let fetchPulls state = do + traceIO $ "Fetching pull requests" + l <- V.toList <$> request auth mgr (GitHub.pullRequestsForR ownerName repoName state GitHub.FetchAll) + traceIO $ "Got " <> show (length l) <> " pull requests" + return l + let fetchIssues state = do + traceIO $ "Fetching issues" + l <- V.toList <$> request auth mgr (GitHub.issuesForRepoR ownerName repoName state GitHub.FetchAll) + traceIO $ "Got " <> show (length l) <> " issues" + return l -- issues >>= putStrLn . groom - if wantRoadmap - then makeChangeLog wantRoadmap ownerName repoName <$> pulls GitHub.stateOpen <*> issues GitHub.stateOpen - else makeChangeLog wantRoadmap ownerName repoName <$> pulls GitHub.stateClosed <*> issues GitHub.stateClosed + (pulls, issues) <- uncurry (P.bindM2 (\p i -> return (p, i))) $ + if wantRoadmap + then (fetchPulls GitHub.stateOpen , fetchIssues GitHub.stateOpen ) + else (fetchPulls GitHub.stateClosed, fetchIssues GitHub.stateClosed) + + traceIO "Formatting changelog/roadmap" + return $ makeChangeLog wantRoadmap ownerName repoName pulls issues diff --git a/tools/BUILD.bazel b/tools/BUILD.bazel new file mode 100644 index 0000000..7664937 --- /dev/null +++ b/tools/BUILD.bazel @@ -0,0 +1,28 @@ +load("@ai_formation_hazel//tools:mangling.bzl", "hazel_library") +load("@rules_haskell//haskell:defs.bzl", "haskell_binary") + +haskell_binary( + name = "hub-changelog", + srcs = ["hub-changelog.hs"], + visibility = ["//visibility:public"], + deps = [ + "//hs-github-tools", + hazel_library("base"), + hazel_library("bytestring"), + hazel_library("github"), + hazel_library("text"), + ], +) + +haskell_binary( + name = "hub-roadmap", + srcs = ["hub-roadmap.hs"], + visibility = ["//visibility:public"], + deps = [ + "//hs-github-tools", + hazel_library("base"), + hazel_library("bytestring"), + hazel_library("github"), + hazel_library("text"), + ], +) diff --git a/tools/hub-changelog.hs b/tools/hub-changelog.hs index 9aa9779..dfc29f8 100644 --- a/tools/hub-changelog.hs +++ b/tools/hub-changelog.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Applicative ((<$>)) import qualified Data.ByteString.Char8 as BS8 import Data.String (fromString) import qualified Data.Text as Text @@ -26,4 +25,4 @@ main = do repoLocation [ownerName, repoName] = return (fromString ownerName, fromString repoName) repoLocation _ = - fail "Usage: changelog " + fail "Usage: hub-changelog " diff --git a/tools/hub-roadmap.hs b/tools/hub-roadmap.hs index 62f960b..3af02f1 100644 --- a/tools/hub-roadmap.hs +++ b/tools/hub-roadmap.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import Control.Applicative ((<$>)) import qualified Data.ByteString.Char8 as BS8 import Data.String (fromString) import qualified Data.Text as Text @@ -26,4 +25,4 @@ main = do repoLocation [ownerName, repoName] = return (fromString ownerName, fromString repoName) repoLocation _ = - fail "Usage: changelog " + fail "Usage: hub-roadmap "