diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | configure.ac | 5 | ||||
| -rw-r--r-- | mumi/web/controller.scm | 4 | ||||
| -rw-r--r-- | mumi/web/graphql.scm | 117 |
4 files changed, 127 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am index 82add7b..9f30a90 100644 --- a/Makefile.am +++ b/Makefile.am @@ -42,6 +42,7 @@ SOURCES = \ mumi/web/controller.scm \ mumi/web/sxml.scm \ mumi/web/util.scm \ + mumi/web/graphql.scm \ mumi/web/view/html.scm \ mumi/web/view/utils.scm \ mumi/cache.scm \ diff --git a/configure.ac b/configure.ac index 1d76be0..22bfb71 100644 --- a/configure.ac +++ b/configure.ac @@ -51,6 +51,11 @@ if test "x$have_fibers" != "xyes"; then AC_MSG_ERROR([Guile fibers is missing; please install it.]) fi +GUILE_MODULE_AVAILABLE([have_kolam], [(kolam graphql)]) +if test "x$have_kolam" != "xyes"; then + AC_MSG_ERROR([Guile kolam is missing; please install it.]) +fi + guilemoduledir="${datarootdir}/guile/site/${GUILE_EFFECTIVE_VERSION}" AC_SUBST([guilemoduledir]) AC_SUBST([GUILE_EFFECTIVE_VERSION]) diff --git a/mumi/web/controller.scm b/mumi/web/controller.scm index bffc26c..3b91021 100644 --- a/mumi/web/controller.scm +++ b/mumi/web/controller.scm @@ -1,5 +1,6 @@ ;;; 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 @@ -32,6 +33,7 @@ #: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)) @@ -67,6 +69,8 @@ (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 diff --git a/mumi/web/graphql.scm b/mumi/web/graphql.scm new file mode 100644 index 0000000..662c5ba --- /dev/null +++ b/mumi/web/graphql.scm @@ -0,0 +1,117 @@ +;;; 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)) |