kolam: Implement HTTP server.

* kolam/http.scm: New file.

1 files changed, 64 insertions, 0 deletions

diff --git a/kolam/http.scm b/kolam/http.scm
new file mode 100644
index 0000000..b4d4beb
--- /dev/null
+++ b/kolam/http.scm
@@ -0,0 +1,64 @@
+;;; kolam --- GraphQL implementation
+;;; Copyright © 2021 Arun Isaac <arunisaac@systemreboot.net>
+;;;
+;;; This file is part of kolam.
+;;;
+;;; kolam 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.
+;;;
+;;; kolam 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 kolam.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (kolam http)
+  #:use-module (rnrs io ports)
+  #:use-module (ice-9 match)
+  #:use-module (web request)
+  #:use-module (web uri)
+  #:use-module (json)
+  #:use-module (kolam graphql)
+  #:use-module (kolam parse)
+  #:export (graphql-handler))
+
+(define transcoder
+  (make-transcoder (utf-8-codec) 'none 'raise))
+
+(define (graphql-request-alist request body)
+  "Return an association list containing graphql request parameters
+corresponding to REQUEST and request BODY."
+  (case (request-method request)
+    ((GET)
+     (map (lambda (arg)
+            (match (string-split arg #\=)
+              ((name value)
+               (cons (uri-decode name)
+                     (uri-decode value)))))
+          (string-split (uri-query (request-uri request))
+                        #\&)))
+    ((POST)
+     (json-string->scm
+      (bytevector->string body transcoder)))
+    (else (error "Unsupported GraphQL request method"
+                 (request-method request)))))
+
+(define (graphql-handler schema)
+  "Return a graphql handler for graphql SCHEMA. The handler accepts
+two arguments---a REQUEST and a BODY---and returns two values---a
+response and a response body. This function is suitable for use with
+run-server from guile's (web server)."
+  (let ((evaluator (graphql-evaluator schema)))
+    (lambda (request body)
+      (values '((content-type application-json))
+              (scm->json-string
+               (match (graphql-string->scm
+                       (assoc-ref (graphql-request-alist request body)
+                                  "query"))
+                 (('document operations ...)
+                  `(("data" . ,(map evaluator operations))))))))))