├── .gitignore ├── .travis.yml ├── CONTRIBUTING.md ├── LICENSE ├── README.md ├── executables ├── pull-request-mailer-server │ └── Main.hs └── pull-request-mailer │ └── Main.hs ├── pull-request-mailer.cabal └── src └── Github └── PullRequests ├── Mailer.hs └── Mailer ├── MsgId.hs └── Opts.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | .virtualenv 8 | .hsenv 9 | .cabal-sandbox/ 10 | cabal.sandbox.config 11 | cabal.config 12 | 13 | # vim 14 | *.sw[op] 15 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: haskell 2 | 3 | ghc: 4 | - 7.6 5 | - 7.8 6 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to [pull-request-mailer][home] 2 | 3 | We'd love you to contribute to our source code and to make 4 | _pull-request-mailer_ a better tool. 5 | Before contributing (sending a pull request), you must sign Google's Contributor 6 | License Agreement (CLA). Without this we cannot accept your code. 7 | Fortunately it's a quick process. 8 | 9 | * For individuals we have a [simple click-through form][individual-cla]. 10 | * For corporations we'll need you to 11 | [print, sign and one of scan+email, fax or mail the form][corporate-cla]. 12 | 13 | [corporate-cla]: https://developers.google.com/open-source/cla/corporate 14 | [individual-cla]: https://developers.google.com/open-source/cla/individual 15 | [home]: https://github.com/google/pull-request-mailer 16 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2014, Google Inc. All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | * Redistributions in binary form must reproduce the above 10 | copyright notice, this list of conditions and the following disclaimer 11 | in the documentation and/or other materials provided with the 12 | distribution. 13 | 14 | * Neither the name of Google Inc. nor the names of its 15 | contributors may be used to endorse or promote products derived from 16 | this software without specific prior written permission. 17 | 18 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 19 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 20 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 21 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 22 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 23 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 24 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 25 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 26 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 27 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # pull-request-mailer 2 | 3 | Sends a GitHub pull request as a patch series via email 4 | 5 | **Disclaimer:** This is not an official Google product. 6 | 7 | --- 8 | 9 | Many open-source projects (such as the Linux kernel or the [Ganeti project](http://www.ganeti.org/)) accept patches only via their mailing lists. 10 | 11 | This tool makes it easy to integrate contributors who prefer Github pull requests into mailing list review workflows. 12 | 13 | ## Features 14 | 15 | * Sending a pull request to a mailing list takes **no more than 1 command**. 16 | * Optional **notification** as a pull request comment that discussion shall be continued on the mailing list (instead of in the pull request). 17 | * **Support for force-pushes and thread tracking.** After addressing review feedback, the improved patches can be force-pushed into the pull request, and the next invocation of this tool will send the next patch series as a reply to the previous email thread. 18 | * Optionally it's possible to run the tool in daemon mode, let it **receive GitHub 19 | webhooks** and automatically process them. 20 | 21 | ## Usage 22 | 23 | ### Procesing a single pull request 24 | 25 | ``` 26 | Usage: pull-request-mailer USER REPO N --to EMAIL [--post-checkout-hook PROGRAM] 27 | [--no-thread-tracking] [--discussion-location STRING] 28 | Sends a GitHub pull request as a patch series via email 29 | 30 | Available options: 31 | -h,--help Show this help text 32 | USER GitHub user who owns the repo containing the pull 33 | request 34 | REPO Repo containing the pull request 35 | N Number of the pull request 36 | --to EMAIL Email recipient 37 | --post-checkout-hook PROGRAM 38 | A program in the cloned direcotry just after checkout 39 | --no-thread-tracking Disable posting thread message ID and patch iteration 40 | count into the pull request. When active, future 41 | versions of the PR can not be sent as reply to the 42 | created email thread 43 | --discussion-location STRING 44 | The place where the contents of the PR are discussed 45 | (as opposed to the discussion being in PR comments. 46 | Example: 'the mailing list project@example.com'. 47 | 48 | Available environment variables: 49 | PULL_REQUEST_MAILER_OAUTH_TOKEN 50 | Auth token needed to write information into the pull 51 | request. You can generate one at 52 | https://github.com/settings/applications. 53 | PULL_REQUEST_MAILER_SECRET_TOKEN 54 | Secret token to verify that requests really come from 55 | Github. See 56 | https://developer.github.com/webhooks/securing. 57 | ``` 58 | 59 | ### Automated server mode 60 | 61 | ``` 62 | Usage: pull-request-mailer-server --to EMAIL [--post-checkout-hook PROGRAM] 63 | [--no-thread-tracking] 64 | [--discussion-location STRING] 65 | Receive GitHub pull request webbooks and send the patch series via email 66 | 67 | Available options: 68 | -h,--help Show this help text 69 | --to EMAIL Email recipient 70 | --post-checkout-hook PROGRAM 71 | A program in the cloned direcotry just after checkout 72 | --no-thread-tracking Disable posting thread message ID and patch iteration 73 | count into the pull request. When active, future 74 | versions of the PR can not be sent as reply to the 75 | created email thread 76 | --discussion-location STRING 77 | The place where the contents of the PR are discussed 78 | (as opposed to the discussion being in PR comments. 79 | Example: 'the mailing list project@example.com'. 80 | 81 | Available environment variables: 82 | PULL_REQUEST_MAILER_OAUTH_TOKEN 83 | Auth token needed to write information into the pull 84 | request. You can generate one at 85 | https://github.com/settings/applications. 86 | PULL_REQUEST_MAILER_SECRET_TOKEN 87 | Secret token to verify that requests really come from 88 | Github. See 89 | https://developer.github.com/webhooks/securing. 90 | ``` 91 | 92 | ## Contact 93 | 94 | The tool has been created and is maintained by the 95 | [Ganeti](http://www.ganeti.org/) team. Please send any questions to 96 | the ganeti-devel@googlegroups.com mailing list (also available 97 | [online](https://groups.google.com/forum/#!forum/ganeti-devel)). 98 | -------------------------------------------------------------------------------- /executables/pull-request-mailer-server/Main.hs: -------------------------------------------------------------------------------- 1 | {- 2 | 3 | Copyright 2014 Google Inc. All rights reserved. 4 | 5 | Use of this source code is governed by a BSD-style 6 | license that can be found in the LICENSE file or at 7 | https://developers.google.com/open-source/licenses/bsd 8 | 9 | -} 10 | 11 | {-# LANGUAGE OverloadedStrings #-} 12 | 13 | import Control.Monad 14 | import Control.Monad.IO.Class 15 | import qualified Data.Aeson as A 16 | import qualified Data.ByteString.Lazy as BL 17 | import Data.Foldable (for_) 18 | import Data.Monoid 19 | import Data.Text.Lazy as TL 20 | import Data.Text.Lazy.Encoding as TL 21 | import qualified Data.Text.Lazy.IO as TL 22 | import Github.Auth 23 | import Github.PullRequests 24 | import Github.Repos.Webhooks.Validate (isValidPayload) 25 | import Network.HTTP.Types.Status (forbidden403) 26 | import Options.Applicative hiding (header) 27 | import System.IO (stderr) 28 | import System.Posix.Process (forkProcess, getProcessStatus) 29 | import Web.Scotty 30 | 31 | import Github.PullRequests.Mailer 32 | import Github.PullRequests.Mailer.Opts 33 | 34 | 35 | -- | A helper function that parses given data to a JSON object. 36 | parse :: (A.FromJSON a) => BL.ByteString -> ActionM a 37 | parse payload = 38 | maybe (raise $ "jsonData - no parse: " <> TL.decodeUtf8 payload) return 39 | . A.decode $ payload 40 | 41 | 42 | main :: IO () 43 | main = do 44 | opts <- parseOptsAndEnv id 45 | -- TODO udate description for the server 46 | ( progDesc "Receive GitHub pull request webbooks and send\ 47 | \ the patch series via email" 48 | ) 49 | 50 | case opts of 51 | Opts { optsSecret = Nothing } -> 52 | die $ "The server needs to have " ++ secretEnvVar ++ " set to verify\ 53 | \ GitHub's webhooks." 54 | 55 | Opts { optsNoThreadTracking = False 56 | , optsAuth = Nothing 57 | } -> 58 | die $ "Thread tracking requires " ++ tokenEnvVar ++ " to be set." 59 | 60 | Opts { optsNoThreadTracking = False 61 | , optsDiscussionLocation = Nothing 62 | } -> 63 | die $ "Thread tracking requires --discussion-location." 64 | 65 | -- Passive mode (no thread tracking). 66 | Opts { optsNoThreadTracking = True 67 | , optsAuth = m'auth 68 | , optsSecret = Just secret 69 | , optsRecipient = recipient 70 | , optsReplyTo = replyTo 71 | , optsPostCheckoutHook = checkoutHookCmd 72 | } -> 73 | pullRequestToThreadServer m'auth secret recipient replyTo 74 | checkoutHookCmd Nothing 75 | 76 | -- Normal mode (thread tracking). 77 | Opts { optsNoThreadTracking = False 78 | , optsAuth = m'auth@(Just _) 79 | , optsSecret = Just secret 80 | , optsDiscussionLocation = m'loc@(Just _) 81 | , optsRecipient = recipient 82 | , optsReplyTo = replyTo 83 | , optsPostCheckoutHook = checkoutHookCmd 84 | } -> 85 | pullRequestToThreadServer m'auth secret recipient replyTo 86 | checkoutHookCmd m'loc 87 | 88 | 89 | -- | Runs an action in a separate unix process. Blocks until finished. 90 | forkWait :: IO () -> IO () 91 | forkWait f = forkProcess f >>= void . getProcessStatus True False 92 | 93 | 94 | pullRequestToThreadServer :: Maybe GithubAuth -- ^ Github authentication 95 | -> String -- ^ Hook verification secret 96 | -> String -- ^ recipient email address 97 | -> Maybe String -- ^ reply-to email address 98 | -> Maybe String -- ^ post-checkout hook program 99 | -> Maybe String -- ^ discussion location; Nothing 100 | -- disables posting/tracking 101 | -> IO () 102 | pullRequestToThreadServer m'auth 103 | secret 104 | recipient 105 | replyTo 106 | checkoutHookCmd 107 | m'discussionLocation = 108 | 109 | scotty 8014 $ do 110 | -- The exception-catching `defaultHandler` must come before the other 111 | -- routes to catch its exceptions, see http://stackoverflow.com/q/26747855 112 | defaultHandler $ \errText -> do 113 | -- We do not want to disclose the text of IO exceptions to the client; 114 | -- we log them to stderr instead. 115 | liftIO $ TL.hPutStrLn stderr errText 116 | text "Internal server error\r\n" 117 | 118 | post "/" $ do 119 | digest <- fmap TL.unpack <$> header "X-Hub-Signature" 120 | payload <- body 121 | 122 | if isValidPayload secret digest (BL.toStrict payload) 123 | then do 124 | run payload 125 | text "" 126 | else do 127 | status forbidden403 128 | text "Invalid or missing hook verification digest" 129 | where 130 | run payload = do 131 | 132 | pre <- parse payload :: ActionM PullRequestEvent 133 | 134 | when (pullRequestEventAction pre `elem` 135 | [ PullRequestOpened, PullRequestSynchronized ]) . liftIO $ do 136 | -- TODO: Logging 137 | let pr = pullRequestEventPullRequest pre 138 | prid = detailedPullRequestToPRID pr 139 | 140 | -- Fork process so that cd'ing into temporary directories doesn't 141 | -- change the cwd of the server. 142 | forkWait $ do 143 | -- Pull code, send the mail. 144 | tInfo <- pullRequestToThread m'auth prid recipient replyTo 145 | checkoutHookCmd 146 | 147 | -- Post comment into PR if enabled and we have auth. 148 | for_ m'auth $ \auth -> 149 | for_ m'discussionLocation $ \discussionLocation -> 150 | postMailerInfoComment auth prid discussionLocation tInfo 151 | -------------------------------------------------------------------------------- /executables/pull-request-mailer/Main.hs: -------------------------------------------------------------------------------- 1 | {- 2 | 3 | Copyright 2014 Google Inc. All rights reserved. 4 | 5 | Use of this source code is governed by a BSD-style 6 | license that can be found in the LICENSE file or at 7 | https://developers.google.com/open-source/licenses/bsd 8 | 9 | -} 10 | 11 | module Main where 12 | 13 | import Control.Monad 14 | import Options.Applicative 15 | 16 | import Github.PullRequests.Mailer 17 | import Github.PullRequests.Mailer.Opts 18 | 19 | 20 | main :: IO () 21 | main = do 22 | ( prid, 23 | opts@Opts 24 | { optsRecipient = recipient 25 | , optsReplyTo = replyTo 26 | , optsPostCheckoutHook = checkoutHookCmd 27 | , optsAuth = m'auth 28 | } 29 | ) <- parseOptsAndEnv 30 | (\optsParse -> (,) <$> pridParser <*> optsParse) 31 | (progDesc "Sends a GitHub pull request as a patch series via email") 32 | 33 | -- When checking command line arguments for consistency, make sure to handle 34 | -- any conflicts before doing any IO. 35 | 36 | case opts of 37 | Opts { optsNoThreadTracking = True } -> 38 | void $ pullRequestToThread m'auth prid recipient replyTo checkoutHookCmd 39 | 40 | Opts{ optsNoThreadTracking = False, optsAuth = Nothing } -> 41 | die "No authentication token was given, so we cannot track\ 42 | \the email thread on Github and future versions of the pull\ 43 | \request cannot be sent in reply to this one.\n\ 44 | \Pass --no-thread-tracking if you want this." 45 | 46 | Opts{ optsNoThreadTracking = False, optsDiscussionLocation = Nothing } -> 47 | die "No --discussion-location was given. It is needed for thread\ 48 | \ tracking. Pass --no-thread-tracking if you don't need it." 49 | 50 | Opts { optsAuth = Just auth 51 | , optsDiscussionLocation = Just loc 52 | , optsNoThreadTracking = False 53 | } -> do 54 | pullRequestToThread m'auth prid recipient replyTo checkoutHookCmd 55 | >>= postMailerInfoComment auth prid loc 56 | -------------------------------------------------------------------------------- /pull-request-mailer.cabal: -------------------------------------------------------------------------------- 1 | -- Copyright 2014 Google Inc. All rights reserved. 2 | -- 3 | -- Use of this source code is governed by a BSD-style 4 | -- license that can be found in the LICENSE file or at 5 | -- https://developers.google.com/open-source/licenses/bsd 6 | 7 | name: pull-request-mailer 8 | version: 0.1.0.0 9 | license: BSD3 10 | license-file: LICENSE 11 | copyright: Copyright (C) 2014 Google Inc. 12 | maintainer: Ganeti Development Team 13 | build-type: Simple 14 | cabal-version: >=1.10 15 | synopsis: Sends a GitHub pull request as a patch series via email 16 | description: 17 | Many open-source projects (such as the Linux kernel or the Ganeti project) 18 | accept patches only via their mailing lists. 19 | . 20 | This tool makes it easy to integrate contributors who prefer Github pull 21 | requests into mailing list review workflows. 22 | category: Development, Git, Email 23 | 24 | library 25 | hs-source-dirs: 26 | src 27 | exposed-modules: 28 | Github.PullRequests.Mailer 29 | Github.PullRequests.Mailer.MsgId 30 | Github.PullRequests.Mailer.Opts 31 | default-language: 32 | Haskell2010 33 | build-depends: 34 | base >= 4.5 && < 4.8 35 | , aeson >= 0.7.0.6 && < 0.9 36 | , attoparsec >= 0.12.1.1 && < 0.13 37 | , bytestring >= 0.10.0.2 && < 0.11 38 | , command >= 0.1.1 && < 0.2 39 | , directory >= 1.2.1.0 && < 1.3 40 | , filepath >= 1.3.0.2 && < 1.4 41 | , github >= 0.12 && < 0.13 42 | , hsemail >= 1.7.7 && < 1.8 43 | , mtl >= 2 && < 3 44 | , optparse-applicative >= 0.10.0 && < 0.11 45 | , parsec >= 3.1.5 && < 3.2 46 | , temporary >= 1.2.0.3 && < 1.3 47 | , text >= 1.1.1.3 && < 1.3 48 | ghc-options: 49 | -Wall 50 | 51 | executable pull-request-mailer 52 | hs-source-dirs: 53 | executables/pull-request-mailer 54 | main-is: 55 | Main.hs 56 | default-language: 57 | Haskell2010 58 | build-depends: 59 | -- Same dependencies as the library (no need for versions): 60 | base 61 | , pull-request-mailer 62 | , optparse-applicative 63 | 64 | -- Own dependencies (with versions): 65 | ghc-options: 66 | -Wall 67 | 68 | executable pull-request-mailer-server 69 | hs-source-dirs: 70 | executables/pull-request-mailer-server 71 | main-is: 72 | Main.hs 73 | default-language: 74 | Haskell2010 75 | build-depends: 76 | -- Same dependencies as the library (no need for versions): 77 | base 78 | , pull-request-mailer 79 | , aeson 80 | , bytestring 81 | , github 82 | , text 83 | 84 | -- Own dependencies (with versions): 85 | , http-types >= 0.8.2 && < 0.9 86 | , optparse-applicative >= 0.10.0 && < 0.11 87 | , scotty >= 0.9 && < 0.10 88 | , transformers >= 0.3 && < 5 89 | , unix >= 2.5.0.0 && < 2.8 90 | ghc-options: 91 | -Wall 92 | -------------------------------------------------------------------------------- /src/Github/PullRequests/Mailer.hs: -------------------------------------------------------------------------------- 1 | {- 2 | 3 | Copyright 2014 Google Inc. All rights reserved. 4 | 5 | Use of this source code is governed by a BSD-style 6 | license that can be found in the LICENSE file or at 7 | https://developers.google.com/open-source/licenses/bsd 8 | 9 | -} 10 | 11 | {-# LANGUAGE NamedFieldPuns, DeriveGeneric, DeriveDataTypeable #-} 12 | 13 | module Github.PullRequests.Mailer where 14 | 15 | import Control.Applicative 16 | import Control.Exception 17 | import Control.Monad 18 | import Control.Monad.Error 19 | import Data.Aeson (FromJSON(..), ToJSON(..), genericParseJSON, genericToJSON, 20 | fromJSON, json') 21 | import qualified Data.Aeson as JSON 22 | import qualified Data.Aeson.Types as JSON 23 | import qualified Data.Attoparsec.ByteString as A 24 | import qualified Data.ByteString as BS 25 | import qualified Data.ByteString.Char8 as BS8 26 | import qualified Data.ByteString.Lazy.Char8 as BSL8 27 | import Data.Char (toLower) 28 | import Data.Foldable (for_) 29 | import Data.List (stripPrefix) 30 | import Data.Maybe 31 | import Data.Text (Text) 32 | import qualified Data.Text as T 33 | import qualified Data.Text.IO as T 34 | import Data.Typeable 35 | import GHC.Generics 36 | import Github.Auth 37 | import qualified Github.Issues.Comments as GH 38 | import Github.PullRequests hiding (Error) 39 | import qualified Github.PullRequests as GH 40 | import System.Command (cmd, Stdout(..), Exit(..)) 41 | import System.Directory (setCurrentDirectory) 42 | import System.Exit (ExitCode(..)) 43 | import System.FilePath (()) 44 | import System.IO (hPutStrLn, stderr) 45 | import System.IO.Temp (withSystemTempDirectory) 46 | 47 | import Github.PullRequests.Mailer.MsgId 48 | 49 | 50 | -- | Terminates the program with exit code 1 and the given error message. 51 | die :: (MonadError e m, Error e) => String -> m a 52 | die = throwError . strMsg 53 | 54 | 55 | -- | Logs a given message. 56 | logInfo :: String -> IO () 57 | logInfo = hPutStrLn stderr 58 | 59 | 60 | -- | Newtype around Github `Error`s so that we can throw them as exceptions. 61 | data GithubError = GithubError String GH.Error 62 | deriving (Show, Typeable) 63 | 64 | instance Exception GithubError 65 | 66 | -- | Throws a Github Error as an Exception, adding a description of what 67 | -- what action failed. 68 | throwGithub :: String -> GH.Error -> IO a 69 | throwGithub msg e = throwIO $ GithubError msg e 70 | 71 | 72 | -- | If the value is 'Left', throw an error using `throwGithub` using the 73 | -- supplied error message. Otherwise return the 'Right' part. 74 | rightOrThrowGithub :: String -> Either GH.Error a -> IO a 75 | rightOrThrowGithub msg = either (throwGithub msg) return 76 | 77 | 78 | -- | Read-replace-write the contents of a file. 79 | replaceTextInFile :: FilePath -> (Text -> Text) -> IO () 80 | replaceTextInFile path f = T.readFile path >>= T.writeFile path . f 81 | 82 | 83 | -- | Remove leading and trailing white space from a string. 84 | strip :: String -> String 85 | strip = T.unpack . T.strip . T.pack 86 | 87 | 88 | -- | Identifies a pull request. 89 | data PRID = PRID 90 | { pridUser :: String 91 | , pridName :: String 92 | , pridNumber :: Int 93 | } deriving (Eq, Ord, Show) 94 | 95 | 96 | -- | Downloads a pull request from Github. Dies on error. 97 | downloadPullRequest :: Maybe GithubAuth -> PRID -> IO DetailedPullRequest 98 | downloadPullRequest auth PRID{ pridUser, pridName, pridNumber } = do 99 | GH.pullRequest' auth pridUser pridName pridNumber >>= 100 | rightOrThrowGithub "Error getting pull request" 101 | 102 | 103 | -- | Information about an email thread. 104 | data ThreadInfo = ThreadInfo 105 | { tiMsgId :: MsgId -- ^ the email message ID 106 | , tiIteration :: Int -- ^ patch iteration (`reroll-count` in Git), 107 | -- starting at 1 108 | } deriving (Eq, Ord, Show, Generic) 109 | 110 | threadInfoJsonOptions :: JSON.Options 111 | threadInfoJsonOptions = JSON.defaultOptions 112 | { JSON.fieldLabelModifier = \s -> case stripPrefix "ti" s of 113 | Just (x:xs) -> toLower x : xs 114 | Just xs -> xs 115 | Nothing -> error "threadInfoJsonOptions: bad prefix" 116 | } 117 | 118 | instance FromJSON ThreadInfo where 119 | parseJSON = genericParseJSON threadInfoJsonOptions 120 | instance ToJSON ThreadInfo where 121 | toJSON = genericToJSON threadInfoJsonOptions 122 | 123 | 124 | -- | The string in a pull request comment that directly precedes a JSON 125 | -- representation of `ThreadInfo`. 126 | _THREAD_INFO_JSON_HEADER :: String 127 | _THREAD_INFO_JSON_HEADER = "pull-request-mailer-data " 128 | 129 | 130 | 131 | -- | Parses a Github issue comment body into a `ThreadInfo`, if it contains 132 | -- one. 133 | parseThreadInfo :: String -> Maybe ThreadInfo 134 | parseThreadInfo body = do 135 | let bodyBs = BS8.pack body 136 | dataHeader = BS8.pack _THREAD_INFO_JSON_HEADER 137 | -- Find where the data starts. 138 | rest = BS.drop (BS8.length dataHeader) 139 | . snd . BS.breakSubstring dataHeader $ bodyBs 140 | 141 | -- Parse what follows as `ThreadInfo`, drop everything behind. 142 | case fromJSON <$> A.parseOnly json' rest of 143 | Right (JSON.Success threadInfo) -> Just threadInfo 144 | _ -> Nothing 145 | 146 | 147 | -- | Get the most recent `ThreadInfo` contained in a pull request's comments. 148 | getMostRecentThreadInfo :: Maybe GithubAuth -- ^ Github authentication 149 | -> PRID -- ^ from wich PR to get the info 150 | -> IO (Maybe ThreadInfo) 151 | getMostRecentThreadInfo auth PRID{ pridUser, pridName, pridNumber } = 152 | liftM (last . (Nothing :) . map (parseThreadInfo . issueCommentBody)) . 153 | rightOrThrowGithub "Failed to get pull request comments" =<< 154 | GH.comments' auth pridUser pridName pridNumber 155 | 156 | 157 | -- | Converts a pull request to a patch series using `git format-patch`. 158 | sendPatchSeries :: String -- ^ recipient email address 159 | -> Maybe String -- ^ reply-to address 160 | -> Maybe ThreadInfo -- ^ thread to reply to 161 | -- (previous iteration of the PR) 162 | -> Maybe String -- ^ post-checkout hook program 163 | -> DetailedPullRequest -- ^ the pull request to convert 164 | -> IO ThreadInfo 165 | sendPatchSeries recipient replyTo prevThreadInfo checkoutHookCmd 166 | DetailedPullRequest 167 | { detailedPullRequestHtmlUrl = url 168 | , detailedPullRequestUser = prOwner 169 | , detailedPullRequestTitle = title 170 | , detailedPullRequestBody = body 171 | , detailedPullRequestHead = PullRequestCommit 172 | { pullRequestCommitRef = tipBranch 173 | , pullRequestCommitRepo = Repo 174 | { repoName = tipRepoName 175 | , repoOwner = tipRepoOwner 176 | } 177 | } 178 | , detailedPullRequestBase = PullRequestCommit 179 | { pullRequestCommitRef = baseBranch 180 | , pullRequestCommitRepo = Repo 181 | { repoName = baseRepoName 182 | , repoOwner = baseRepoOwner 183 | } 184 | } 185 | } = do 186 | 187 | withSystemTempDirectory "pull-request-mailer" $ \tmpDir -> do 188 | 189 | -- Clone the base. 190 | let uri = githubOwnerLogin baseRepoOwner ++ "/" ++ baseRepoName 191 | logInfo $ "Cloning " ++ uri 192 | () <- cmd ("git clone git://github.com/" ++ uri) "-b" baseBranch tmpDir 193 | -- ^ We don't use --depth 1 here because git will send the whole history 194 | -- as patches if it cannot see a common base between our two commits. 195 | 196 | setCurrentDirectory tmpDir 197 | 198 | -- Add the pull request tipBranch as a remote. 199 | let uriR = githubOwnerLogin tipRepoOwner ++ "/" ++ tipRepoName 200 | logInfo $ "Adding remote " ++ uriR 201 | () <- cmd ("git remote add pullrequest git://github.com/" ++ uriR) 202 | logInfo $ "Fetching from the remote: " ++ tipBranch 203 | -- We would prefer to do `git fetch pullrequest tipBranch` here, but 204 | -- in git < 1.8.4 this doesn't make pullrequest/tipBranch available, 205 | -- so we have to fetch the whole remote in order to support this version. 206 | () <- cmd "git fetch pullrequest" 207 | 208 | () <- cmd "git branch -rv" 209 | () <- cmd "git remote -v" 210 | 211 | -- Run the post-checkout hook command if given. 212 | for_ checkoutHookCmd $ \hookCmd -> do 213 | logInfo $ "Running " ++ hookCmd 214 | Exit code <- cmd hookCmd 215 | when (code /= ExitSuccess) $ die "Post checkout hook failed. Aborting." 216 | 217 | let _PATCH_DIR_NAME = "patch-dir" 218 | patchVersionPrefix = case prevThreadInfo of 219 | Just (ThreadInfo _ lastN) -> "v" ++ show (lastN + 1) ++ "-" 220 | Nothing -> "" 221 | coverLetterPath = _PATCH_DIR_NAME 222 | patchVersionPrefix ++ "0000-cover-letter.patch" 223 | 224 | -- Create the patch series. 225 | () <- cmd "git format-patch" 226 | "--cover-letter" 227 | (["--subject-prefix=PR PATCH " ++ baseBranch] 228 | ++ case prevThreadInfo of 229 | Nothing -> [] 230 | Just (ThreadInfo msgId lastN) -> 231 | -- `--in-reply-to` allows email header injection. 232 | -- `msgId` being of type MsgId makes it safe to use here 233 | -- as it carries the invariant of being a valid msg-id 234 | -- /only/. 235 | [ "--in-reply-to=" ++ fromMsgId msgId 236 | , "--reroll-count=" ++ show (lastN + 1) 237 | ] 238 | ) 239 | [ "--add-header=Reply-To: " ++ addr | Just addr <- [replyTo] ] 240 | "--output-directory" _PATCH_DIR_NAME 241 | "--thread=shallow" 242 | ("origin/" ++ baseBranch ++ "..pullrequest/" ++ tipBranch) 243 | 244 | -- Get the Message-Id git format-patch assgined. 245 | msgId <- mkMsgId =<< 246 | fromMaybe (error "format-patch failed to create Message-Id") 247 | . fmap T.unpack 248 | . listToMaybe 249 | . mapMaybe (T.stripPrefix $ T.pack "Message-Id: ") 250 | . T.lines 251 | <$> T.readFile coverLetterPath 252 | 253 | -- Fill out the cover letter. 254 | Stdout gitUserEmailOutput <- cmd "git config --get user.email" 255 | let seriesSubmitter = strip gitUserEmailOutput 256 | let prUser = githubOwnerLogin prOwner 257 | let note = "******** NOTE: pull-request-mailer ********\n\ 258 | \* User '" ++ prUser ++ "' has submitted a pull request on\n\ 259 | \* " ++ url ++ "\n\ 260 | \* \n\ 261 | \* It has been converted to a patch series by \n\ 262 | \* " ++ seriesSubmitter ++ "\n\ 263 | \***************************************************\n\ 264 | \\n" 265 | replaceTextInFile coverLetterPath 266 | $ T.replace (T.pack "*** SUBJECT HERE ***") (T.pack title) 267 | . T.replace (T.pack "*** BLURB HERE ***") (T.pack $ note ++ body) 268 | 269 | -- Send the email. 270 | () <- cmd "git send-email" 271 | "--no-thread" -- we do threading with `format-patch` above 272 | "--confirm=never" -- be non-interactive 273 | ["--to=" ++ recipient, "--from=" ++ seriesSubmitter] 274 | _PATCH_DIR_NAME 275 | 276 | return $ ThreadInfo msgId (maybe 1 (succ . tiIteration) prevThreadInfo) 277 | 278 | 279 | -- | Creates a comment in the pull request stating that the PR was converted 280 | -- to an email thread using this program and that users shall not reply to the 281 | -- PR, but continue the discussion at the given location instead. 282 | -- It states the used message ID of the first email in a parsable format so 283 | -- that subsequent invocations can be sent as replies to the previous threads. 284 | -- 285 | -- This way we can achieve threading as given in the example in 286 | -- `man git send-email`. 287 | -- 288 | -- [PATCH branch 0/2] Here is what I did... 289 | -- [PATCH branch 1/2] Clean up and tests 290 | -- [PATCH branch 2/2] Implementation 291 | -- [PATCH branch v2 0/3] Here is a reroll 292 | -- [PATCH branch v2 1/3] Clean up 293 | -- [PATCH branch v2 2/3] New tests 294 | -- [PATCH branch v2 3/3] Implementation 295 | -- 296 | -- It also includes the number of times the pull request was turned into 297 | -- a thread so that force-pushed improvements to the PR can be sent with 298 | -- the correct `--reroll-count` option to `git format-patch`. 299 | -- The first iteration (original patch) should be passed as reroll-count=1. 300 | postMailerInfoComment :: GithubAuth -- ^ Github authentication 301 | -> PRID -- ^ on which PR to comment 302 | -> String -- ^ discussion location 303 | -> ThreadInfo -- ^ information to post for subsequent 304 | -- invocations 305 | -> IO () 306 | postMailerInfoComment auth prid discussionLocation threadInfo = do 307 | let PRID{ pridUser, pridName, pridNumber } = prid 308 | -- Note: The message ID in `threadInfo` contains "<" and ">". 309 | -- aeson's `encode` turns them into not-so-nice "\u003c" and "\u003e" 310 | -- for silly reasons, see: 311 | -- https://github.com/bos/aeson/issues/180#issuecomment-54386449 312 | let dat = BSL8.unpack . JSON.encode $ threadInfo 313 | let msg = 314 | "`AUTOGENERATED MESSAGE by pull-request-mailer`\n\ 315 | \This pull request has been converted to an email thread on\ 316 | \ " ++ discussionLocation ++ ". Discussion continues there.\n\ 317 | \\n\ 318 | \**Please do not post comments to this pull request.**\ 319 | \ The email thread will not get notified.\n\ 320 | \\n\ 321 | \" 322 | 323 | GH.createComment auth pridUser pridName pridNumber msg >>= 324 | rightOrThrowGithub "Failed to create comment" >> 325 | return () 326 | 327 | 328 | -- | Converts a detailed pull request into a 'PRID'. 329 | detailedPullRequestToPRID :: DetailedPullRequest -> PRID 330 | detailedPullRequestToPRID dpr = 331 | PRID (githubOwnerLogin . repoOwner $ repo) 332 | (repoName repo) 333 | (detailedPullRequestNumber dpr) 334 | where 335 | repo = pullRequestCommitRepo . detailedPullRequestBase $ dpr 336 | 337 | 338 | -- | Converts a GitHub pull request to a mail thread and sends it. 339 | pullRequestToThread :: Maybe GithubAuth -- ^ Github authentication 340 | -> PRID -- ^ wich PR to convert to an email 341 | -- thread 342 | -> String -- ^ recipient email address 343 | -> Maybe String -- ^ reply-to address 344 | -> Maybe String -- ^ post-checkout hook program 345 | -> IO ThreadInfo 346 | pullRequestToThread m'auth prid recipient replyTo checkoutHookCmd = do 347 | pr <- downloadPullRequest m'auth prid 348 | prevThreadInfo <- getMostRecentThreadInfo m'auth prid 349 | sendPatchSeries recipient replyTo prevThreadInfo checkoutHookCmd pr 350 | -------------------------------------------------------------------------------- /src/Github/PullRequests/Mailer/MsgId.hs: -------------------------------------------------------------------------------- 1 | {- 2 | 3 | Copyright 2014 Google Inc. All rights reserved. 4 | 5 | Use of this source code is governed by a BSD-style 6 | license that can be found in the LICENSE file or at 7 | https://developers.google.com/open-source/licenses/bsd 8 | 9 | -} 10 | 11 | {-# LANGUAGE DeriveGeneric #-} 12 | 13 | module Github.PullRequests.Mailer.MsgId 14 | ( MsgId(fromMsgId) -- do not export constructor, see `MsgId` 15 | , mkMsgId 16 | ) where 17 | 18 | import Data.Aeson 19 | import qualified Data.Text as T 20 | import GHC.Generics 21 | import qualified Text.Parsec as P 22 | import qualified Text.ParserCombinators.Parsec.Rfc2822 as Rfc2822 23 | 24 | 25 | -- | A string that is known to be a valid "msg-id" according to RFC 2822. 26 | -- 27 | -- We call this @MsgId@ instead of @MessageId@ because in RFC 2822, 28 | -- @message-id@ means something of form "Message-Id: msg-id", and this 29 | -- data type shall only represent the inner msg-id part. 30 | -- 31 | -- We care a lot about the constructor not being exported because we pass 32 | -- this to `git format-patch --in-reply-to=` which allows inserting arbitrary 33 | -- strings into the generated emails (email header injection), so we need 34 | -- to ensure that any `MsgId` has been validated. 35 | -- 36 | -- See also: 37 | -- 38 | -- 39 | newtype MsgId = MsgId 40 | { fromMsgId :: String 41 | } deriving (Eq, Ord, Show, Generic) 42 | 43 | 44 | -- | Checks whether a string is a valid @msg-id@ according to RFC 2822. 45 | mkMsgId :: (Monad m) => String -> m MsgId 46 | mkMsgId s = case P.runParser Rfc2822.msg_id () "" s of 47 | Left _ -> fail $ "Invalid msg-id: " ++ show s 48 | Right msgId -> return $ MsgId msgId 49 | 50 | 51 | instance FromJSON MsgId where 52 | parseJSON (String s) = mkMsgId (T.unpack s) 53 | parseJSON _ = fail "msg-id must be a string in JSON" 54 | instance ToJSON MsgId where 55 | toJSON = toJSON . fromMsgId 56 | -------------------------------------------------------------------------------- /src/Github/PullRequests/Mailer/Opts.hs: -------------------------------------------------------------------------------- 1 | {- 2 | 3 | Copyright 2014 Google Inc. All rights reserved. 4 | 5 | Use of this source code is governed by a BSD-style 6 | license that can be found in the LICENSE file or at 7 | https://developers.google.com/open-source/licenses/bsd 8 | 9 | -} 10 | 11 | module Github.PullRequests.Mailer.Opts 12 | ( Opts(..) 13 | , tokenEnvVar 14 | , secretEnvVar 15 | , optsParser 16 | , pridParser 17 | , parseOptsAndEnv 18 | ) where 19 | 20 | import Github.Auth 21 | import Options.Applicative 22 | import qualified Options.Applicative.Help as H 23 | import System.Environment (lookupEnv) 24 | 25 | import Github.PullRequests.Mailer 26 | 27 | 28 | -- | Command line arguments to this program. 29 | data Opts = Opts 30 | { optsRecipient :: String 31 | , optsReplyTo :: Maybe String 32 | , optsPostCheckoutHook :: Maybe String 33 | , optsAuth :: Maybe GithubAuth 34 | , optsNoThreadTracking :: Bool 35 | , optsDiscussionLocation :: Maybe String 36 | , optsSecret :: Maybe String 37 | } deriving (Eq, Ord, Show) 38 | 39 | 40 | -- | Env variable that can set the auth token. 41 | tokenEnvVar :: String 42 | tokenEnvVar = "PULL_REQUEST_MAILER_OAUTH_TOKEN" 43 | 44 | 45 | -- | Env variable that can set the secret webhook validation token. 46 | secretEnvVar :: String 47 | secretEnvVar = "PULL_REQUEST_MAILER_SECRET_TOKEN" 48 | 49 | 50 | -- | Command line argument parser. 51 | optsParser :: Parser Opts 52 | optsParser = Opts 53 | <$> strOption 54 | ( long "to" 55 | <> metavar "EMAIL" 56 | <> help "Email recipient" 57 | ) 58 | <*> optional (strOption 59 | ( long "reply-to" 60 | <> metavar "EMAIL" 61 | <> help "Address to which responses shall be sent. Useful if\ 62 | \ the sending email address shall not receive replies." 63 | ) 64 | ) 65 | <*> optional (strOption 66 | ( long "post-checkout-hook" 67 | <> metavar "PROGRAM" 68 | <> help "A program in the cloned direcotry just after checkout" 69 | ) 70 | ) 71 | <*> pure Nothing -- set by env variable 72 | <*> switch 73 | ( long "no-thread-tracking" 74 | <> help "Disable posting thread message ID and patch iteration\ 75 | \ count into the pull request. When active, future versions\ 76 | \ of the PR can not be sent as reply to the created email\ 77 | \ thread" 78 | ) 79 | <*> optional (strOption 80 | ( long "discussion-location" 81 | <> metavar "STRING" 82 | <> help "The place where the contents of the PR are discussed (as\ 83 | \ opposed to the discussion being in PR comments. Example:\ 84 | \ 'the mailing list project@example.com'." 85 | ) 86 | ) 87 | <*> pure Nothing -- set by env variable 88 | 89 | 90 | -- | Command line argument parser for pull request identifiers. 91 | pridParser :: Parser PRID 92 | pridParser = 93 | PRID 94 | <$> argument str 95 | ( metavar "USER" 96 | <> help "GitHub user who owns the repo containing the pull request" 97 | ) 98 | <*> argument str 99 | ( metavar "REPO" 100 | <> help "Repo containing the pull request" 101 | ) 102 | <*> argument auto 103 | ( metavar "N" 104 | <> help "Number of the pull request" 105 | ) 106 | 107 | 108 | -- | Like `execParser`, but sets those fields of `Opts` that can be set via 109 | -- environment variables. 110 | -- 111 | -- It allows extending the `Parser` as well as updating the help text 112 | -- (`InfoMod`); a help text with the full program description is the default. 113 | -- 114 | -- Common usage: 115 | -- 116 | -- >opts <- parseOptsAndEnv id (progDesc "This program does...") 117 | parseOptsAndEnv :: (Parser Opts -> Parser a) -> InfoMod a -> IO a 118 | parseOptsAndEnv f infoMod = do 119 | envToken <- lookupEnv tokenEnvVar 120 | envSecret <- lookupEnv secretEnvVar 121 | let setEnvOpts opts = opts{ optsAuth = GithubOAuth <$> envToken 122 | , optsSecret = envSecret 123 | } 124 | execParser $ 125 | info 126 | (helper <*> f (setEnvOpts <$> optsParser)) 127 | ( fullDesc 128 | <> footerDoc 129 | (H.unChunk $ H.vcatChunks 130 | [ H.stringChunk "Available environment variables:" 131 | , H.tabulate 132 | [ ( H.text tokenEnvVar 133 | , H.align . H.extractChunk $ H.paragraph 134 | "Auth token needed to write information\ 135 | \ into the pull request.\ 136 | \ You can generate one at\ 137 | \ https://github.com/settings/applications." 138 | ) 139 | , ( H.text secretEnvVar 140 | , H.align . H.extractChunk $ H.paragraph 141 | "Secret token to verify that requests really come\ 142 | \ from Github. See\ 143 | \ https://developer.github.com/webhooks/securing." 144 | ) 145 | ] 146 | ] 147 | ) 148 | <> infoMod 149 | ) 150 | --------------------------------------------------------------------------------