web: Implement GraphQL endpoint.

* mumi/web/graphql.scm: New file.
* Makefile.am (SOURCES): Register it.
* configure.ac: Test for guile-kolam.
* mumi/web/controller.scm: Import (mumi web graphql).
(controller): Pass on GraphQL requests to handle-graphql.

diff --git a/Makefile.am b/Makefile.am
index 82add7b7063f477902e4a0e2161d8725bb90f6d6..9f30a907a4277097c3ee8cb773ba2389745259f4 100644 (file)
--- 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 1d76be0d8625a35294b26ecbe05533a6c3bbcabc..22bfb71984a9318507260d08655ff4700882455d 100644 (file)
--- 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 bffc26cac389b89419f25cf54002a6bc104dc5fb..3b91021a372c02d4032bbd98a8d62fbb6de75a25 100644 (file)
--- 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 (file)
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))