diff --git a/Procfile b/Procfile new file mode 100644 index 0000000..bd49364 --- /dev/null +++ b/Procfile @@ -0,0 +1 @@ +web: ./webservice $PORT diff --git a/github-tools.cabal b/github-tools.cabal index 96f2a88..e61173a 100644 --- a/github-tools.cabal +++ b/github-tools.cabal @@ -17,10 +17,11 @@ source-repository head type: git location: https://github.com/TokTok/github-tools.git -executable pull-status - main-is: pull-status.hs - other-modules: +library + exposed-modules: + Changelogs PullRequestInfo + PullStatus Requests Review ghc-options: @@ -28,6 +29,7 @@ executable pull-status build-depends: base >= 4 && < 5 , bytestring + , containers , exceptions , github >= 0.15.0 , groom @@ -43,22 +45,44 @@ executable pull-status hs-source-dirs: src default-language: Haskell2010 +executable pull-status + main-is: pull-status.hs + ghc-options: + -Wall + build-depends: + base >= 4 && < 5 + , github-tools + , bytestring + , github >= 0.15.0 + hs-source-dirs: tools + default-language: Haskell2010 + executable changelog main-is: changelog.hs - other-modules: - Requests ghc-options: -Wall build-depends: base >= 4 && < 5 + , github-tools , bytestring - , containers - , exceptions , github >= 0.15.0 - , groom - , http-client - , http-client-tls , text - , vector - hs-source-dirs: src + hs-source-dirs: tools + default-language: Haskell2010 + +executable webservice + main-is: webservice.hs + ghc-options: + -Wall + build-depends: + base >= 4 && < 5 + , github-tools + , aeson + , github >= 0.15.0 + , servant + , servant-server + , text + , wai + , warp + hs-source-dirs: tools default-language: Haskell2010 diff --git a/src/changelog.hs b/src/Changelogs.hs similarity index 79% rename from src/changelog.hs rename to src/Changelogs.hs index 4bd7118..c95d7d5 100644 --- a/src/changelog.hs +++ b/src/Changelogs.hs @@ -1,32 +1,33 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -module Main (main) where +module Changelogs + ( fetchChangeLog + , formatChangeLog + , ChangeLog + ) where import Control.Applicative ((<$>), (<*>)) import Control.Arrow (first, second, (&&&)) -import qualified Data.ByteString.Char8 as BS8 import Data.List (foldl') import qualified Data.Map as Map import qualified Data.Maybe as Maybe import Data.Monoid ((<>)) -import Data.String (fromString) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Vector as V import qualified GitHub import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) -import System.Environment (getArgs, lookupEnv) -- import Text.Groom (groom) import Requests -type ChangeLog = [(Text, [Text], [Text])] +newtype ChangeLog = ChangeLog { unChangeLog :: [(Text, [Text], [Text])] } -formatChangeLog :: Text -> ChangeLog -> Text -formatChangeLog name = (<> "\n") . foldl' (<>) ("# Changelog for " <> name) . map formatMilestone +formatChangeLog :: ChangeLog -> Text +formatChangeLog = (<> "\n") . foldl' (<>) "" . map formatMilestone . unChangeLog where formatMilestone (milestone, issues, pulls) = "\n\n## " <> milestone @@ -66,7 +67,8 @@ formatChangeLogItem ownerName repoName item = makeChangeLog :: GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> [GitHub.SimplePullRequest] -> [GitHub.Issue] -> ChangeLog makeChangeLog ownerName repoName pulls issues = - Map.foldlWithKey (\changes milestone (msIssues, msPulls) -> + ChangeLog + . Map.foldlWithKey (\changes milestone (msIssues, msPulls) -> ( milestone , map (formatChangeLogItem ownerName repoName) msIssues , map (formatChangeLogItem ownerName repoName) msPulls @@ -126,11 +128,8 @@ makeChangeLog ownerName repoName pulls issues = ) -fetchChangeLog :: GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> IO ChangeLog -fetchChangeLog ownerName repoName = do - -- Get auth token from the $GITHUB_TOKEN environment variable. - auth <- fmap (GitHub.OAuth . BS8.pack) <$> lookupEnv "GITHUB_TOKEN" - +fetchChangeLog :: GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> Maybe GitHub.Auth -> IO ChangeLog +fetchChangeLog ownerName repoName auth = do -- Initialise HTTP manager so we can benefit from keep-alive connections. mgr <- newManager tlsManagerSettings @@ -140,19 +139,3 @@ fetchChangeLog ownerName repoName = do -- issues >>= putStrLn . groom makeChangeLog ownerName repoName <$> pulls <*> issues - - -main :: IO () -main = do - (ownerName, repoName) <- getArgs >>= repoLocation - let name = (GitHub.untagName ownerName) <> "/" <> (GitHub.untagName repoName) - - fetchChangeLog ownerName repoName >>= putStr . Text.unpack . formatChangeLog name - - where - repoLocation [] = - return ("TokTok", "c-toxcore") - repoLocation [ownerName, repoName] = - return (fromString ownerName, fromString repoName) - repoLocation _ = - fail "Usage: changelog " diff --git a/src/pull-status.hs b/src/PullStatus.hs similarity index 71% rename from src/pull-status.hs rename to src/PullStatus.hs index fb23ce6..00ce06f 100644 --- a/src/pull-status.hs +++ b/src/PullStatus.hs @@ -1,16 +1,13 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where +module PullStatus (getPullStatus) where import Control.Applicative ((<$>)) import qualified Control.Monad.Parallel as Parallel -import qualified Data.ByteString.Char8 as BS8 import Data.Time.Clock (getCurrentTime) import qualified Data.Vector as V import qualified GitHub import qualified GitHub.Data.Id as GitHub import Network.HTTP.Client (Manager, newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) -import System.Environment (getEnv, lookupEnv) import PullRequestInfo (PullRequestInfo (PullRequestInfo)) import qualified PullRequestInfo @@ -19,14 +16,14 @@ import qualified Review getFullPr - :: GitHub.Auth + :: Maybe GitHub.Auth -> Manager -> GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> GitHub.SimplePullRequest -> IO GitHub.PullRequest getFullPr auth mgr owner repo simplePr = do - request (Just auth) mgr + request auth mgr . GitHub.pullRequestR owner repo . GitHub.Id . GitHub.simplePullRequestNumber @@ -34,7 +31,7 @@ getFullPr auth mgr owner repo simplePr = do getPrInfo - :: GitHub.Auth + :: Maybe GitHub.Auth -> Manager -> GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo @@ -52,41 +49,36 @@ getPrInfo auth mgr ownerName repoName pr = do getPrsForRepo - :: GitHub.Auth + :: Maybe GitHub.Auth -> Manager -> GitHub.Name GitHub.Owner -> GitHub.Name GitHub.Repo -> IO [PullRequestInfo] getPrsForRepo auth mgr ownerName repoName = do -- Get PR list. - simplePRs <- V.toList <$> request (Just auth) mgr (GitHub.pullRequestsForR ownerName repoName GitHub.stateOpen GitHub.FetchAll) + simplePRs <- V.toList <$> request auth mgr (GitHub.pullRequestsForR ownerName repoName GitHub.stateOpen GitHub.FetchAll) prInfos <- Parallel.mapM (getPrInfo auth mgr ownerName repoName) simplePRs return $ map (uncurry $ PullRequestInfo repoName) prInfos -main :: IO () -main = do - let orgName = "TokTok" - let ownerName = "TokTok" - - -- Get auth token from the $GITHUB_TOKEN environment variable. - token <- BS8.pack <$> getEnv "GITHUB_TOKEN" - let auth = GitHub.OAuth token - - -- Check if we need to produce HTML or ASCII art. - wantHtml <- (/= Nothing) <$> lookupEnv "GITHUB_WANT_HTML" - +getPullStatus + :: GitHub.Name GitHub.Organization + -> GitHub.Name GitHub.Owner + -> Bool + -> Maybe GitHub.Auth + -> IO String +getPullStatus orgName ownerName wantHtml auth = do -- Initialise HTTP manager so we can benefit from keep-alive connections. mgr <- newManager tlsManagerSettings -- Get repo list. - repos <- V.toList <$> request (Just auth) mgr (GitHub.organizationReposR orgName GitHub.RepoPublicityAll GitHub.FetchAll) + repos <- V.toList <$> request auth mgr (GitHub.organizationReposR orgName GitHub.RepoPublicityAll GitHub.FetchAll) let repoNames = map GitHub.repoName repos infos <- Parallel.mapM (getPrsForRepo auth mgr ownerName) repoNames -- Pretty-print table with information. now <- getCurrentTime - putStrLn $ PullRequestInfo.formatPR wantHtml now infos + return $ PullRequestInfo.formatPR wantHtml now infos diff --git a/src/Requests.hs b/src/Requests.hs index 76be671..923996c 100644 --- a/src/Requests.hs +++ b/src/Requests.hs @@ -9,7 +9,7 @@ import Network.HTTP.Client (Manager) request :: Maybe GitHub.Auth -> Manager - -> GitHub.Request GitHub.RO a + -> GitHub.Request 'GitHub.RO a -> IO a request auth mgr req = do response <- executeRequest diff --git a/tools/changelog.hs b/tools/changelog.hs new file mode 100644 index 0000000..9e601c3 --- /dev/null +++ b/tools/changelog.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 ownerName repoName auth >>= putStr . Text.unpack . formatChangeLog + + where + repoLocation [] = + return ("TokTok", "c-toxcore") + repoLocation [ownerName, repoName] = + return (fromString ownerName, fromString repoName) + repoLocation _ = + fail "Usage: changelog " diff --git a/tools/pull-status.hs b/tools/pull-status.hs new file mode 100644 index 0000000..dc5e020 --- /dev/null +++ b/tools/pull-status.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Control.Applicative ((<$>)) +import qualified Data.ByteString.Char8 as BS8 +import qualified GitHub +import System.Environment (getEnv, lookupEnv) + +import PullStatus + + +main :: IO () +main = do + -- Get auth token from the $GITHUB_TOKEN environment variable. + auth <- Just . GitHub.OAuth . BS8.pack <$> getEnv "GITHUB_TOKEN" + + -- Check if we need to produce HTML or ASCII art. + wantHtml <- (/= Nothing) <$> lookupEnv "GITHUB_WANT_HTML" + + putStrLn =<< getPullStatus "TokTok" "TokTok" wantHtml auth diff --git a/tools/webservice.hs b/tools/webservice.hs new file mode 100644 index 0000000..ab10e57 --- /dev/null +++ b/tools/webservice.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +import Data.Aeson (FromJSON, ToJSON) +import Data.Monoid ((<>)) +import Data.Text (Text, toUpper) +import GHC.Generics (Generic) +import Network.Wai.Handler.Warp (Port, run) +import System.Environment (getArgs) + +import Servant + +-- * Example + +-- | A greet message data type +newtype Greet = Greet { _msg :: Text } + deriving (Generic, Show) + +instance FromJSON Greet +instance ToJSON Greet + +-- API specification +type TestApi = + -- GET /hello/:name?capital={true, false} returns a Greet as JSON + "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get '[JSON] Greet + + -- POST /greet with a Greet as JSON in the request body, + -- returns a Greet as JSON + :<|> "greet" :> ReqBody '[JSON] Greet :> Post '[JSON] Greet + + -- DELETE /greet/:greetid + :<|> "greet" :> Capture "greetid" Text :> Delete '[JSON] NoContent + +testApi :: Proxy TestApi +testApi = Proxy + +-- Server-side handlers. +-- +-- There's one handler per endpoint, which, just like in the type +-- that represents the API, are glued together using :<|>. +-- +-- Each handler runs in the 'Handler' monad. +server :: Server TestApi +server = helloH :<|> 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 + + postGreetH greet = return greet + + deleteGreetH _ = return NoContent + +-- Turn the server into a WAI app. 'serve' is provided by servant, +-- more precisely by the Servant.Server module. +test :: Application +test = serve testApi server + +-- Run the server. +-- +-- 'run' comes from Network.Wai.Handler.Warp +runTestServer :: Port -> IO () +runTestServer port = run port test + +-- Put this all to work! +main :: IO () +main = do + args <- getArgs + case args of + [port] -> runTestServer $ read port + _ -> runTestServer 8001