noprs

  1#!/usr/bin/env hy
  2
  3(import os sys argparse json hmac
  4  [http.server [*]]
  5  [github [Github]])
  6(require [hy.contrib.walk [let]])
  7
  8(setv GITHUB-TOKEN  "GITHUB_ACCESS_TOKEN")   ;; ENV for API access token
  9(setv GITHUB-SECRET "GITHUB_WEBHOOK_SECRET") ;; ENV for webhook secret
 10
 11(defclass WebhookException [Exception]
 12  (defn --init-- [self msg &optional [code 500]]
 13    (setv self.code code)
 14    (.--init-- (super WebhookException self) msg))
 15
 16  (defn get-status-code [self]
 17    (. self code)))
 18
 19(defclass GithubWebhookHandler [BaseHTTPRequestHandler]
 20  (defn handle-pr [self dict]
 21    (let [action (get dict "action")]
 22      (if (or (= action "opened")
 23              (and handle-reopened? (= action "reopened")))
 24        (let [name (get (get dict "repository") "full_name")
 25              repo (.get-repo github-api name)
 26              pr   (.get-issue repo :number (get dict "number"))]
 27          (.create-comment pr comment-text)
 28          (when close-issue?
 29            (.edit pr :state "closed"))))))
 30
 31  (defn dispatch-event [self body]
 32    (try
 33      (let [body-json (json.loads body)
 34            event     (.get self.headers "X-GitHub-Event")]
 35        (cond
 36          [(= event "pull_request")
 37            (.handle-pr self body-json)]
 38          [(not (= event "ping"))
 39            (raise (WebhookException "Unsupported webhook event" 500))])
 40        (.send-response self 200)
 41        (.end-headers self))
 42      (except [e WebhookException]
 43        (.send-error self (.get-status-code e) (str e)))
 44      (except [[json.decoder.JSONDecodeError KeyError]]
 45        (.send-error self 400 "Received invalid JSON document"))))
 46
 47  (defn from-github? [self header data]
 48    (let [hmac-obj (hmac.new github-secret :msg data :digestmod "sha1")
 49          digest   (.hex (.digest hmac-obj))]
 50      (= (.format "sha1={}" digest) header)))
 51
 52  (defn do-POST [self]
 53    (if (not (= "application/json" (.get self.headers "Content-Type")))
 54      (.send-error self 400 "Expected Content-Type application/json")
 55      (let [con-len (int (.get self.headers "Content-Length" :failobj "0"))]
 56        (let [body (.read self.rfile con-len)]
 57          (if (.from-github? self (.get self.headers "X-Hub-Signature") body)
 58            (.dispatch-event self body)
 59            (.send-error self 403 "HMAC digest validation failed"))))))
 60
 61  (defn handle [self]
 62    (try
 63      (.handle (super GithubWebhookHandler self))
 64
 65      ;; Flush stderr, containing log messages created by http.server
 66      (finally (sys.stderr.flush)))))
 67
 68(defmacro setg [name value]
 69  `(do
 70    (global ~name)
 71    (setv ~name ~value)))
 72
 73(defn get-env [name]
 74  (let [value (os.getenv name)]
 75    (when (is None value)
 76      (print :file sys.stderr
 77        (.format "Environment variable '{}' is not set but required" name))
 78      (sys.exit 1))
 79    value))
 80
 81(defmain [&rest args]
 82  (let [parser (argparse.ArgumentParser)
 83        token  (get-env GITHUB-TOKEN)
 84        secret (get-env GITHUB-SECRET)]
 85    (parser.add-argument "PATH" :type string
 86      :help "Path to markdown file containing comment text")
 87    (parser.add-argument "-p" :type int :metavar "PORT"
 88      :default 80 :help "TCP port used by the webhook HTTP server")
 89    (parser.add-argument "-c" :action "store_true"
 90      :help "Apart from adding a comment, also close the PR")
 91    (parser.add-argument "-r" :action "store_true"
 92      :help "Also handle reopened pull requests")
 93    (parser.add-argument "-a" :type string :metavar "ADDR"
 94      :default "localhost" :help "Address the webhook HTTP server binds to")
 95
 96    (let [args (parser.parse-args)]
 97      (setg close-issue? args.c)
 98      (setg handle-reopened? args.r)
 99      (setg github-api (Github token))
100      (setg github-secret (.encode secret))
101
102      (with [f (open args.PATH)]
103        (setg comment-text (.rstrip (.read f))))
104
105      (.serve-forever
106        (HTTPServer (, args.a args.p) GithubWebhookHandler)))))