Renamed tools to hub-* and added "roadmap" tool.

github-tools.cabal

@@ -45,8 +45,8 @@ library
   hs-source-dirs:      src
   default-language:    Haskell2010
 
-executable pull-status
-  main-is:             pull-status.hs
+executable hub-pulls
+  main-is:             hub-pulls.hs
   ghc-options:
       -Wall
   build-depends:
@@ -57,8 +57,21 @@ executable pull-status
   hs-source-dirs:      tools
   default-language:    Haskell2010
 
-executable changelog
-  main-is:             changelog.hs
+executable hub-changelog
+  main-is:             hub-changelog.hs
+  ghc-options:
+      -Wall
+  build-depends:
+      base >= 4 && < 5
+    , github-tools
+    , bytestring
+    , github            >= 0.15.0
+    , text
+  hs-source-dirs:      tools
+  default-language:    Haskell2010
+
+executable hub-roadmap
+  main-is:             hub-roadmap.hs
   ghc-options:
       -Wall
   build-depends:

src/Changelogs.hs

@@ -9,6 +9,7 @@ module Changelogs
 import           Control.Applicative     ((<$>), (<*>))
 import           Control.Arrow           (first, second, (&&&))
 import           Data.List               (foldl')
+import qualified Data.List               as List
 import qualified Data.Map                as Map
 import qualified Data.Maybe              as Maybe
 import           Data.Monoid             ((<>))
@@ -26,21 +27,25 @@ import           Requests
 newtype ChangeLog = ChangeLog { unChangeLog :: [(Text, [Text], [Text])] }
 
 
-formatChangeLog :: ChangeLog -> Text
-formatChangeLog = (<> "\n") . foldl' (<>) "" . map formatMilestone . unChangeLog
+formatChangeLog :: Bool -> ChangeLog -> Text
+formatChangeLog wantRoadmap =
+  (<> "\n") . foldl' (<>) "" . map formatMilestone . unChangeLog
   where
+    issuesWord = if wantRoadmap then "Planned tasks" else "Closed issues"
+    prsWord    = if wantRoadmap then "PRs to review" else "Merged PRs"
+
     formatMilestone (milestone, issues, pulls) =
       "\n\n## " <> milestone
       <> closedIssues issues
       <> mergedPrs pulls
 
     closedIssues [] = ""
     closedIssues issues =
-      foldl' (<>) "\n\n### Closed issues:\n" . itemise $ issues
+      foldl' (<>) ("\n\n### " <> issuesWord <> ":\n") . itemise $ issues
 
     mergedPrs [] = ""
     mergedPrs pulls =
-      foldl' (<>) "\n\n### Merged PRs:\n" . itemise $ pulls
+      foldl' (<>) ("\n\n### " <> prsWord <> ":\n") . itemise $ pulls
 
     itemise = map ("\n- " <>)
 
@@ -65,38 +70,54 @@ formatChangeLogItem ownerName repoName item =
     number = Text.pack . show . clNumber $ item
 
 
-makeChangeLog :: GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> [GitHub.SimplePullRequest] -> [GitHub.Issue] -> ChangeLog
-makeChangeLog ownerName repoName pulls issues =
+makeChangeLog :: Bool -> GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> [GitHub.SimplePullRequest] -> [GitHub.Issue] -> ChangeLog
+makeChangeLog wantRoadmap ownerName repoName pulls issues =
   ChangeLog
+  . sortChangelog
   . Map.foldlWithKey (\changes milestone (msIssues, msPulls) ->
-      ( milestone
-      , map (formatChangeLogItem ownerName repoName) msIssues
-      , map (formatChangeLogItem ownerName repoName) msPulls
-      ) : changes
+      if milestone == "meta"
+        then changes
+        else
+          ( milestone
+          , map (formatChangeLogItem ownerName repoName) msIssues
+          , map (formatChangeLogItem ownerName repoName) msPulls
+          ) : changes
     ) []
   . groupByMilestone (first  . (:)) changeLogIssues
   . groupByMilestone (second . (:)) changeLogPrs
   $ Map.empty
   where
-    mergedPrs = filter (\case
+    sortChangelog =
+      if wantRoadmap
+        then reverse
+        else id
+
+    (mergedPrs, openPrs) = List.partition (\case
         GitHub.SimplePullRequest
-          { GitHub.simplePullRequestMergedAt = Just _
-          } -> True
+          { GitHub.simplePullRequestMergedAt = Just _ } -> True
         _ -> False
       ) pulls
 
-    closedItems = filter (\case
+    selectedPrs =
+      if wantRoadmap
+        then openPrs
+        else mergedPrs
+
+    selectedItems = filter (\case
         GitHub.Issue
           { GitHub.issueMilestone = Just GitHub.Milestone
-            { GitHub.milestoneState = "closed" }
-          } -> True
+            { GitHub.milestoneState = state }
+          } ->
+            if wantRoadmap
+              then state == "open"
+              else state == "closed"
         _ -> False
       ) issues
 
     milestoneByIssueId =
       Map.fromList
       . map (GitHub.issueNumber &&& GitHub.milestoneTitle . Maybe.fromJust . GitHub.issueMilestone)
-      $ closedItems
+      $ selectedItems
 
     changeLogIssues :: [ChangeLogItem]
     changeLogIssues = Maybe.mapMaybe (\case
@@ -107,7 +128,7 @@ makeChangeLog ownerName repoName pulls issues =
           , clTitle     = GitHub.issueTitle issue
           , clNumber    = GitHub.issueNumber issue
           }
-      ) closedItems
+      ) selectedItems
 
     changeLogPrs :: [ChangeLogItem]
     changeLogPrs = Maybe.mapMaybe (\issue -> do
@@ -117,7 +138,7 @@ makeChangeLog ownerName repoName pulls issues =
           , clTitle     = GitHub.simplePullRequestTitle issue
           , clNumber    = GitHub.simplePullRequestNumber issue
           }
-      ) mergedPrs
+      ) selectedPrs
 
     groupByMilestone add = flip $ foldr (\item group ->
         Map.insert (clMilestone item) (
@@ -128,14 +149,16 @@ makeChangeLog ownerName repoName pulls issues =
       )
 
 
-fetchChangeLog :: GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> Maybe GitHub.Auth -> IO ChangeLog
-fetchChangeLog ownerName repoName auth = do
+fetchChangeLog :: Bool -> GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> Maybe GitHub.Auth -> IO ChangeLog
+fetchChangeLog wantRoadmap ownerName repoName auth = do
   -- Initialise HTTP manager so we can benefit from keep-alive connections.
   mgr <- newManager tlsManagerSettings
 
-  let pulls  = V.toList <$> request auth mgr (GitHub.pullRequestsForR ownerName repoName GitHub.stateClosed GitHub.FetchAll)
-  let issues = V.toList <$> request auth mgr (GitHub.issuesForRepoR   ownerName repoName (GitHub.stateClosed <> GitHub.optionsAnyMilestone) GitHub.FetchAll)
+  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.optionsAnyMilestone) GitHub.FetchAll)
 
   -- issues >>= putStrLn . groom
 
-  makeChangeLog ownerName repoName <$> pulls <*> issues
+  if wantRoadmap
+    then makeChangeLog wantRoadmap ownerName repoName <$> pulls GitHub.stateOpen   <*> issues GitHub.stateOpen
+    else makeChangeLog wantRoadmap ownerName repoName <$> pulls GitHub.stateClosed <*> issues GitHub.stateClosed

tools/changelog.hs → tools/hub-changelog.hs

@@ -18,7 +18,7 @@ main = do
   -- Get auth token from the $GITHUB_TOKEN environment variable.
   auth <- fmap (GitHub.OAuth . BS8.pack) <$> lookupEnv "GITHUB_TOKEN"
 
-  fetchChangeLog ownerName repoName auth >>= putStr . Text.unpack . formatChangeLog
+  fetchChangeLog False ownerName repoName auth >>= putStr . Text.unpack . formatChangeLog False
 
   where
     repoLocation [] =

tools/hub-roadmap.hs

@@ -0,0 +1,29 @@
+{-# 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
+import qualified GitHub
+import           System.Environment    (getArgs, lookupEnv)
+
+import           Changelogs
+
+
+main :: IO ()
+main = do
+  (ownerName, repoName) <- getArgs >>= repoLocation
+
+  -- Get auth token from the $GITHUB_TOKEN environment variable.
+  auth <- fmap (GitHub.OAuth . BS8.pack) <$> lookupEnv "GITHUB_TOKEN"
+
+  fetchChangeLog False ownerName repoName auth >>= putStr . Text.unpack . formatChangeLog False
+
+  where
+    repoLocation [] =
+      return ("TokTok", "c-toxcore")
+    repoLocation [ownerName, repoName] =
+      return (fromString ownerName, fromString repoName)
+    repoLocation _ =
+      fail "Usage: changelog <owner> <repo>"

web/TokTok/Hello.hs

@@ -6,7 +6,7 @@
 {-# LANGUAGE TypeOperators     #-}
 module TokTok.Hello (newApp) where
 
-import           Control.Applicative ((<$>))
+import           Control.Applicative ((<$>), (<*>))
 import           Control.Monad.Trans (lift)
 import           Data.Aeson          (FromJSON, ToJSON)
 import           Data.IORef          (IORef)
@@ -21,12 +21,14 @@ import qualified Changelogs
 
 data ApiContext = ApiContext
   { getChangelog :: IORef Changelogs.ChangeLog
+  , getRoadmap   :: IORef Changelogs.ChangeLog
   }
 
 
 newContext :: IO ApiContext
 newContext = ApiContext
-  <$> (IORef.newIORef =<< Changelogs.fetchChangeLog "TokTok" "c-toxcore" Nothing)
+  <$> (IORef.newIORef =<< Changelogs.fetchChangeLog False "TokTok" "c-toxcore" Nothing)
+  <*> (IORef.newIORef =<< Changelogs.fetchChangeLog True  "TokTok" "c-toxcore" Nothing)
 
 
 -- * Example
@@ -43,8 +45,8 @@ type TestApi =
        -- GET /hello/:name?capital={true, false}  returns a Greet as JSON
        "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet
 
-       -- GET /hello/:name?capital={true, false}  returns a Greet as JSON
   :<|> "changelog" :> Get '[PlainText] Text
+  :<|> "roadmap" :> Get '[PlainText] Text
 
        -- POST /greet with a Greet as JSON in the request body,
        --             returns a Greet as JSON
@@ -65,15 +67,17 @@ testApi = Proxy
 server :: ApiContext -> Server TestApi
 server ctx =
        helloH
-  :<|> changelogH
+  :<|> changelogH False
+  :<|> changelogH True
   :<|> postGreetH
   :<|> deleteGreetH
   where
     helloH name Nothing      = helloH name (Just False)
     helloH name (Just False) = return . Greet $ "Hello, " <> name
     helloH name (Just True)  = return . Greet . toUpper $ "Hello, " <> name
 
-    changelogH = lift $ Changelogs.formatChangeLog <$> IORef.readIORef (getChangelog ctx)
+    changelogH False = lift $ Changelogs.formatChangeLog False <$> IORef.readIORef (getChangelog ctx)
+    changelogH True  = lift $ Changelogs.formatChangeLog True  <$> IORef.readIORef (getRoadmap ctx)
 
     postGreetH greet = return greet