Add simple hello world webservice.

Procfile

@@ -0,0 +1 @@
+web: ./webservice $PORT

github-tools.cabal

@@ -17,17 +17,19 @@ 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:
       -Wall
   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

src/changelog.hs → 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 <owner> <repo>"

src/pull-status.hs → 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,22 +16,22 @@ 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
     $ simplePr
 
 
 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

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

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 <owner> <repo>"

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

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