;;; mumi -- Mediocre, uh, mail interface
;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero General Public License
#:use-module (mumi messages)
#:use-module (mumi web render)
#:use-module (mumi web download)
+ #:use-module (mumi web graphql)
#:use-module (mumi web util)
#:use-module (mumi web view html)
#:export (controller))
(render-html
(list-of-matching-bugs "severity:wishlist is:open"
(bugs-by-severity "wishlist" "open"))))
+ (((or 'GET 'POST) "graphql")
+ (handle-graphql request body))
(('GET "search")
(let ((query (-> request
request-uri
--- /dev/null
+;;; mumi -- Mediocre, uh, mail interface
+;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This program is free software: you can redistribute it and/or
+;;; modify it under the terms of the GNU Affero General Public License
+;;; as published by the Free Software Foundation, either version 3 of
+;;; the License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Affero General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Affero General Public
+;;; License along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (mumi web graphql)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:use-module (kolam graphql)
+ #:use-module (kolam http)
+ #:use-module (email email)
+ #:use-module (mumi debbugs)
+ #:use-module (mumi messages)
+ #:export (handle-graphql))
+
+(define-enum-type <severity>
+ "critical" "grave" "serious" "important"
+ "normal" "minor" "wishlist")
+
+(define-enum-type <tag>
+ "patch" "wontfix" "moreinfo" "unreproducible"
+ "fixed" "notabug" "pending" "help" "security"
+ "confirmed" "easy")
+
+(define (accessor->resolver accessor)
+ (lambda (parent . _)
+ (accessor parent)))
+
+(define-object-type <issue>
+ (number (non-nullable-type <integer>)
+ (accessor->resolver bug-num))
+ (title (non-nullable-type <string>)
+ (accessor->resolver bug-subject))
+ (date (non-nullable-type <datetime>)
+ (accessor->resolver bug-date))
+ (open (non-nullable-type <boolean>)
+ (lambda (parent . _)
+ (not (bug-done parent))))
+ (submitter (non-nullable-type <person>)
+ (accessor->resolver bug-originator))
+ (closer <person>
+ (lambda (parent . _)
+ (or (bug-done parent)
+ 'null)))
+ (severity (non-nullable-type <severity>)
+ (accessor->resolver bug-severity))
+ (tags (non-nullable-type (list-type <tag>))
+ (lambda (parent . _)
+ (if (bug-tags parent)
+ (string-split (bug-tags parent) #\space)
+ (list))))
+ (messages (non-nullable-type (list-type <email>))
+ (lambda (parent . _)
+ (issue-messages (bug-num parent)))))
+
+(define-object-type <person>
+ (name <string> (lambda (parent . _)
+ (or (assq-ref (parse-email-address parent)
+ 'name)
+ 'null)))
+ (address (non-nullable-type <string>)
+ (lambda (parent . _)
+ (assq-ref (parse-email-address parent)
+ 'address)))
+ (submitted_issues (non-nullable-type (list-type <issue>))
+ (lambda (parent . _)
+ (search-bugs (string-append "submitter:" parent))))
+ (participated_in_issues (non-nullable-type (list-type <issue>))
+ (lambda (parent . _)
+ (search-bugs (string-append "author:" parent)))))
+
+(define-object-type <email>
+ (message-id (non-nullable-type <id>)
+ (lambda (parent . _)
+ (assq-ref (email-headers parent)
+ 'message-id)))
+ (from (non-nullable-type <person>)
+ (lambda (parent . _)
+ (match (assq-ref (email-headers parent)
+ 'from)
+ ((from _ ...) (interpret-address from)))))
+ (date (non-nullable-type <datetime>)
+ (lambda (parent . _)
+ (assq-ref (email-headers parent)
+ 'date))))
+
+(define-object-type <query>
+ (issue (non-nullable-type <issue>)
+ (lambda* (parent context info #:key number)
+ (bug-status number)))
+ (issues (non-nullable-type (list-type <issue>))
+ (lambda* (parent context info #:key search)
+ (search-bugs search)))
+ (person (non-nullable-type <person>)
+ (lambda* (parent context info #:key email)
+ email)))
+
+(define schema
+ (graphql-schema #:query <query>))
+
+(define handler
+ (graphql-handler schema))
+
+(define (handle-graphql request body)
+ (call-with-values (cut handler request body) list))