;;; kolam --- GraphQL implementation
;;; Copyright © 2021, 2022 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 (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (web client)
  #:use-module (web request)
  #:use-module (web response)
  #:use-module (web uri)
  #:use-module (json)
  #:use-module (kolam graphql)
  #:use-module (kolam parse)
  #:use-module (kolam utils)
  #:export (graphql-handler
            graphql-http-get
            graphql-http-post))

(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/graphql+json))
              (scm->json-string
               (match (graphql-string->scm
                       (assoc-ref (graphql-request-alist request body)
                                  "query"))
                 (('document operations ...)
                  `(("data" . ,(map evaluator operations))))))))))

(define (variables->alist variables)
  "Convert VARIABLES into an association list to be embedded into the
GraphQL request."
  (map (match-lambda
         ((key . value)
          (cons (keyword->symbol key)
                value)))
       (pairify variables)))

(define (graphql-http-get uri document . variables)
  "Send GraphQL query as specified in GraphQL DOCUMENT to graphql
endpoint URI. The GET HTTP method is used. VARIABLES must be a list of
variables to send with the query. It must be of the form (name value
...) where NAME must be a keyword. For example, (#:spam 1 #:ham
\"bacon\" #:eggs 2)."
  (call-with-values
      (cut http-get
           (string-append uri
                          "?query="
                          (uri-encode (scm->graphql-string document))
                          "&"
                          "variables="
                          (uri-encode (scm->json-string
                                       (variables->alist variables))))
           #:streaming? #t)
    graphql-http-response))

(define (graphql-http-post uri document . variables)
  "Send GraphQL query as specified in GraphQL DOCUMENT to graphql
endpoint URI. The POST HTTP method is used. VARIABLES must be a list
of variables to send with the query. It must be of the form (name
value ...) where NAME must be a keyword. For example, (#:spam 1 #:ham
\"bacon\" #:eggs 2)."
  (call-with-values
      (cut http-post
           uri
           #:body (scm->json-string
                   (cons (cons 'query (scm->graphql-string document))
                         (match variables
                           (() '())
                           (_ (cons 'variables (variables->alist variables))))))
           #:streaming? #t)
    graphql-http-response))

(define (graphql-http-response response port)
  "Return GraphQL response data from HTTP RESPONSE and response body
read from PORT. Raise errors, if any."
  (unless (and (>= (response-code response) 200)
               (< (response-code response) 300))
    (error "GraphQL query failed with non-2xx status code:"
           response (get-string-all port)))
  (set-port-encoding! port "utf-8")
  (let ((response-alist (json->scm port)))
    (cond
     ((assoc-ref response-alist "errors")
      => (cut error "GraphQL query failed with errors:" <>))
     (else (assoc-ref response-alist "data")))))