;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu>

;;;; 

;;;; This library is free software; you can redistribute it and/or

;;;; modify it under the terms of the GNU Lesser General Public

;;;; License as published by the Free Software Foundation; either

;;;; version 3 of the License, or (at your option) any later version.

;;;; 

;;;; This library 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

;;;; Lesser General Public License for more details.

;;;; 

;;;; You should have received a copy of the GNU Lesser General Public

;;;; License along with this library; if not, write to the Free Software

;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA

;;;; 

(define-module (test-modules download)

  #:use-module (jsonld download)

  #:use-module (jsonld iri)

  #:use-module (jsonld json)

  #:use-module (jsonld memoization)

  #:use-module (jsonld options)

  #:use-module (test-modules testsuite)

  #:use-module (web client)

  #:use-module (web response)

  #:use-module (web uri)

  #:export (test-http-get get-test-document-loader))

(define* (update-response response

                          #:key

                          (version           (response-version response))

                          (code              (response-code response))

                          (reason-phrase     (response-reason-phrase response))

                          (headers           (response-headers response))

                          (port              (response-port response))

                          (validate-headers? #t))

  (build-response

    #:version version

    #:code code

    #:reason-phrase reason-phrase

    #:headers headers

    #:port port

    #:validate-headers? validate-headers?))

(define (test-http-get options)

  "Return a procedure that downloads a file, and modifies the response according

to @var{options}, an alist of parameters, as described in the test suite

specification."

  (lambda* (uri #:key (headers '()))

    (call-with-values

      (lambda ()

        (http-get uri #:headers headers))

      (lambda (hdr body)

        (when (json-has-key? options "contentType")

          (let ((type (assoc-ref options "contentType")))

            (set! type (list (string->symbol type)))

            (set! hdr

              (update-response hdr #:headers (alist-set (response-headers hdr)

                                                      'content-type type)))))

        (when (json-has-key? options "httpLink")

          ;; first remove http link headers

          (let loop ((headers (response-headers hdr)))

            (if (assoc-ref headers 'link)

                (loop (alist-remove headers 'link))

                (set! hdr (update-response hdr #:headers headers))))

          ;; then add our own

          (let* ((links (assoc-ref options "httpLink"))

                 (links (if (json-array? links)

                            (array->list links)

                            (list links))))

            (let loop ((headers (response-headers hdr))

                       (links links))

              (if (null? links)

                  (set! hdr (update-response hdr #:headers headers))

                  (loop (cons (cons 'link (car links)) headers)

                        (cdr links))))))

        (when (json-has-key? options "redirectTo")

          (let* ((location (assoc-ref options "redirectTo"))

                 (location (resolve-iri jsonld-test-url location)))

            (set! hdr

              (update-response hdr #:headers (alist-set (response-headers hdr)

                                               'location (string->uri location))))))

        (when (json-has-key? options "httpStatus")

          (set! hdr

            (update-response hdr #:code (assoc-ref options "httpStatus"))))

        (values hdr body)))))

(define (get-test-document-loader options)

  "Return a procedure that cane be used as the document loader in the

jsonld-options structure."

  (memoize

    (lambda args

      (apply download-json

             (append args `(#:http-get ,(test-http-get options)))))))