From 6b56dcce6f89396892091a06ad3082d3716bcf0d Mon Sep 17 00:00:00 2001 From: Wesley Kerfoot Date: Sun, 24 Mar 2019 16:18:32 -0400 Subject: [PATCH] Initial commit --- .gitignore | 4 ++ ChangeLog.md | 3 ++ LICENSE | 30 +++++++++++ README.md | 11 ++++ Setup.hs | 2 + app/Main.hs | 19 +++++++ package.yaml | 48 ++++++++++++++++++ src/PullWatch/Environment.hs | 15 ++++++ src/PullWatch/PullWatch.hs | 98 ++++++++++++++++++++++++++++++++++++ stack.yaml | 67 ++++++++++++++++++++++++ test/Spec.hs | 2 + 11 files changed, 299 insertions(+) create mode 100644 .gitignore create mode 100644 ChangeLog.md create mode 100644 LICENSE create mode 100644 README.md create mode 100644 Setup.hs create mode 100644 app/Main.hs create mode 100644 package.yaml create mode 100644 src/PullWatch/Environment.hs create mode 100644 src/PullWatch/PullWatch.hs create mode 100644 stack.yaml create mode 100644 test/Spec.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..2bf31db --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +.stack-work/ +pullwatch.cabal +*~ +.envrc diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..fab49bd --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for pullwatch + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..5bc13a5 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Wesley Kerfoot (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Wesley Kerfoot nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 index 0000000..98162b4 --- /dev/null +++ b/README.md @@ -0,0 +1,11 @@ +# Pullwatch +A Simple Haskell Daemon that monitors for new pull requests in a list of repos, and notifies you if there is a new one + +## How to Use +* Create a new Github application (see [here](https://github.com/settings/apps)) +* Create a .envrc (or .env if you don't have direnv) with your personal access + token, e.g. `export PERSONAL_ACCESS_TOKEN = "foobarbaz"` +* Source that file +* Modify `Main.hs` (at the moment there is no other entrypoint to this) and + build or run it with stack +* Make sure your desktop environment supports DBus notifications (e.g. [https://wiki.archlinux.org/index.php/Desktop_notifications](https://wiki.archlinux.org/index.php/Desktop_notifications) ) diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..957fe25 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import PullWatch.PullWatch (getLatestPRs, getLatest, toNote, prID) +import PullWatch.Environment (getPAT) + +import Control.Applicative + +main :: IO () +main = do + -- Set up authentication token from environment + pat <- getPAT + let ?pat = pat + + prIDs <- getLatestPRs [("racket", "racket")] + print prIDs + + return () diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..1ee17aa --- /dev/null +++ b/package.yaml @@ -0,0 +1,48 @@ +name: pullwatch +version: 0.1.0.0 +github: "weskerfoot/pullwatch" +license: BSD3 +author: "Wesley Kerfoot" +maintainer: "wes@wesk.tech" +copyright: "" + +extra-source-files: +- README.md +- ChangeLog.md + +# Metadata used when publishing your package +# synopsis: Short description of your package +# category: Web + +# To avoid duplicated efforts in documentation and dealing with the +# complications of embedding Haddock markup inside cabal files, it is +# common to point users to the README.md file. +description: Please see the README on GitHub at + +dependencies: +- base >= 4.7 && < 5 + +library: + source-dirs: src + +executables: + pullwatch-exe: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - pullwatch + +tests: + pullwatch-test: + main: Spec.hs + source-dirs: test + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - pullwatch diff --git a/src/PullWatch/Environment.hs b/src/PullWatch/Environment.hs new file mode 100644 index 0000000..ee8aabd --- /dev/null +++ b/src/PullWatch/Environment.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImplicitParams #-} + +module PullWatch.Environment + ( getPAT + ) where + +import System.Environment + +import qualified GitHub.Auth as Auth +import qualified Data.ByteString.Char8 as C + +getPAT = do + (Just pat) <- lookupEnv "PERSONAL_ACCESS_TOKEN" + return $ Just $ Auth.OAuth $ C.pack pat diff --git a/src/PullWatch/PullWatch.hs b/src/PullWatch/PullWatch.hs new file mode 100644 index 0000000..8bf77e0 --- /dev/null +++ b/src/PullWatch/PullWatch.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ImplicitParams #-} + +module PullWatch.PullWatch + ( getLatest + , getLatestAsync + , getLatestPRs + , prText + , prTitle + , prID + , toNote + ) where + +import GitHub.Data.PullRequests + ( simplePullRequestId + , simplePullRequestTitle + , simplePullRequestBody + ) + +import Prelude.Compat +import GitHub.Data.Id (untagId) +import GitHub.Data.Name (untagName) +import System.Environment (lookupEnv) +import Data.Vector ((!)) +import DBus.Notify +import Control.Concurrent.Async +import Control.Applicative +import Data.Maybe +import Data.Monoid + +import qualified GitHub.Endpoints.PullRequests as PR +import qualified GitHub.Auth as Auth +import qualified Data.Text as T + +data PullRequest = PR { + prText :: T.Text + , prTitle :: T.Text + , prRepo :: T.Text + , prOwner :: T.Text + , prID :: Integer } + + deriving (Show) + + +fiveMinutes = 300000000 + +getPRId = Just . fromIntegral . untagId . simplePullRequestId . (! 0) + +getPRTitle = Just . simplePullRequestTitle . (! 0) + +getPRBody = simplePullRequestBody . (! 0) + +-- Converts a pull request into a dbus notification +toNote :: Maybe PullWatch.PullWatch.PullRequest -> Maybe Note + +toNote Nothing = Nothing +toNote (Just pr) = + Just $ blankNote { + summary = T.unpack $ prRepo pr + , body = (Just $ Text $ T.unpack $ prTitle pr) + , appImage = (Just $ Icon "dialog-information") + } + +getLatest :: (?pat :: (Maybe Auth.Auth)) => + (PR.Name PR.Owner) -> + (PR.Name PR.Repo) -> + IO (Maybe PullRequest) + +getLatest owner repo = do + prs <- PR.pullRequestsFor' ?pat owner repo + let pr = case prs of + (Left _) -> Nothing + (Right pullreqs) -> do + id <- getPRId pullreqs + title <- getPRTitle pullreqs + body <- getPRBody pullreqs + let repoName = untagName repo + let repoOwner = untagName owner + return $ PR body title repoName repoOwner id + return pr + +getLatestAsync owner repo = do + client <- connectSession + + async $ poll client where + poll client = do + latest <- getLatest owner repo + notification <- maybe undefined (notify client) (toNote latest) + return $ prID <$> latest + +getLatestPRs :: (?pat :: (Maybe Auth.Auth)) => + [(PR.Name PR.Owner, PR.Name PR.Repo)] -> + IO [Maybe (T.Text, T.Text, Integer)] + +getLatestPRs repos = do + prs <- mapConcurrently (uncurry getLatest) repos + return $ map ((\pr -> (prRepo pr, prOwner pr, prID pr)) <$>) prs diff --git a/stack.yaml b/stack.yaml new file mode 100644 index 0000000..62fe1cb --- /dev/null +++ b/stack.yaml @@ -0,0 +1,67 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# resolver: ghcjs-0.1.0_ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-13.14 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# - location: +# git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver +# using the same syntax as the packages field. +# (e.g., acme-missiles-0.3) +extra-deps: + - fdo-notify-0.3.1 + - github-0.21 + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=1.7" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..cd4753f --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"