;;;; Copyright (C) 2019, 2020 Julien Lepiller ;;;; ;;;; 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 online) #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (test-modules download) #:use-module (test-modules result) #:use-module (test-modules testsuite) #:use-module (jsonld download) #:use-module (jsonld json) #:use-module (jsonld) #:use-module (jsonld options) #:use-module (jsonld iri) #:export (run-test-suite run-test-suites get-test-doc)) ;; The JsonLD specification comes with a test suite. It consists in on JsonLD ;; document per API function. The test suite is designed for the latest ;; version of the API, but can be used for older versions. Tests for newer ;; versions or specific to older versions are clearly marked, so we can ;; select them. ;; Each JsonLD document is a manifest listing a huge list of tests that require ;; us to download a few other JsonLD documents, run a function on them and compare ;; the result. This is what this file does. (define (execute-test test) "Execute one test described by a Json object @var{test}. Return a Json object as the output of the test, or throws an exception if something went wrong." (let* ((document (test-case-document test)) (input (assoc-ref document "input")) (context (assoc-ref document "context")) (type (array->list (assoc-ref document "@type"))) (options (assoc-ref document "option")) (spec-version (assoc-ref options "specVersion")) (document-loader (get-test-document-loader options))) (cond ((equal? spec-version "json-ld-1.0") (throw 'unsupported-spec 1.0)) ((member "jld:CompactTest" type) (compact (string-append jsonld-test-url input) (string-append jsonld-test-url context) #:options (apply new-jsonld-options #:ordered? #t #:document-loader document-loader `(,@(if (assoc-ref options "base") `(#:base ,(assoc-ref options "base")) '()) ,@(if (assoc-ref options "processingMode") `(#:processing-mode ,(assoc-ref options "processingMode")) '()) ,@(if (assoc-ref options "extractAllScripts") `(#:extract-all-scripts? ,(assoc-ref options "extractAllScripts")) '()) ,@(if (json-has-key? options "compactArrays") `(#:compact-arrays? ,(assoc-ref options "compactArrays")) '()))))) ((member "jld:ExpandTest" type) (expand (string-append jsonld-test-url input) #:options (apply new-jsonld-options #:ordered? #t #:document-loader document-loader `(,@(if (assoc-ref options "base") `(#:base ,(assoc-ref options "base")) '()) ,@(if (assoc-ref options "extractAllScripts") `(#:extract-all-scripts? ,(assoc-ref options "extractAllScripts")) '()) ,@(if (assoc-ref options "processingMode") `(#:processing-mode ,(assoc-ref options "processingMode")) '()) ,@(if (assoc-ref options "expandContext") `(#:expand-context ,(string-append jsonld-test-url (assoc-ref options "expandContext"))) '()))))) ((member "jld:FlattenTest" type) (flatten (string-append jsonld-test-url input) #:context (if context (string-append jsonld-test-url context) #f) #:options (apply new-jsonld-options #:ordered? #t #:document-loader document-loader `(,@(if (assoc-ref options "base") `(#:base ,(assoc-ref options "base")) '()) ,@(if (assoc-ref options "processingMode") `(#:processing-mode ,(assoc-ref options "processingMode")) '()) ,@(if (assoc-ref options "extractAllScripts") `(#:extract-all-scripts? ,(assoc-ref options "extractAllScripts")) '()) ,@(if (json-has-key? options "compactArrays") `(#:compact-arrays? ,(assoc-ref options "compactArrays")) '()))))) (else (throw 'unrecognized-test type))))) (define (run-test test) "Run one test described by the Json object @var{test}, whose @var{id} is an identifier. @var{id} is used as the test number for the test driver. Return is undefined. As a side-effect, outputs one line on the standard output to report the test status." (let* ((document (test-case-document test)) (description (or (assoc-ref document "purpose") (test-case-name test))) (description (string-append (test-case-id test) ": " description)) (expect (assoc-ref document "expect")) (expect-error (assoc-ref document "expectErrorCode")) (type (array->list (assoc-ref document "@type"))) (option (assoc-ref document "option")) (result (catch #t (lambda () (execute-test test)) (lambda (key . value) (cons key value))))) (if (member "jld:NegativeEvaluationTest" type) (match result (((? symbol? key) . value) (cond ((equal? key 'unrecognized-test) (update-test-case test #:result 'skip #:reason "unrecognized test type")) ((equal? key 'unsupported-spec) (update-test-case test #:result 'skip #:reason "unsupported specification version")) ((equal? key 'unsupported-version-test) (update-test-case test #:result 'skip #:reason "unsupported JsonLD version")) ((equal? (jsonld-error->string key) expect-error) (update-test-case test #:result 'pass)) (else (update-test-case test #:result 'fail #:reason (format #f "Expected ~a but got ~a: ~a" expect-error key value))))) (_ (begin (update-test-case test #:result 'fail #:reason (format #f "Expected ~a but got success" expect-error))))) (match result (((? symbol? key) . value) (cond ((equal? key 'unrecognized-test) (update-test-case test #:result 'skip #:reason "unrecognized test type")) ((equal? key 'unsupported-spec) (update-test-case test #:result 'skip #:reason "unsupported specification version")) ((equal? key 'unsupported-version-test) (update-test-case test #:result 'skip #:reason "unsupported JsonLD version")) (else (update-test-case test #:result 'fail #:reason (format #f "Expected success but got ~a: ~a" key value))))) (_ (let ((expected (json-document-document (download-json (string-append jsonld-test-url expect))))) (if (same-json? result expected) (update-test-case test #:result 'pass) (update-test-case test #:result 'fail #:reason (format #f "Expected ~a but got ~a" expected result))))))))) (define (run-tests tests expected-failures driver) "Run all the tests of the @var{tests} test suite, using identifiers starting from @var{id}. Return is undefined." (fold (lambda (test results) (let* ((result (run-test test)) (result (if (assoc-ref expected-failures (test-case-id test)) (update-test-case result #:result (cond ((equal? 'skip (test-case-result result)) 'skip) ((equal? 'fail (test-case-result result)) 'xfail) ((equal? 'pass (test-case-result result)) 'xpass)) #:reason (assoc-ref expected-failures (test-case-id test))) result))) ((test-driver-print driver) result) (cons result results))) '() tests)) (define (get-test-doc url) "Get a test suite object from the manifest at @var{url}." (assoc-ref (json-document-document (download-json url)) "sequence")) (define* (get-test-plan url #:key (num 1)) (define document (get-test-doc url)) (cdr (fold (lambda (test result) (let* ((num (car result)) (result (cdr result)) (name (assoc-ref test "name")) (@id (assoc-ref test "@id")) (name (string-append @id ": " name)) (description (or (assoc-ref test "purpose") name)) (description (string-append @id ": " description))) (cons (+ 1 num) (cons (make-test-case (string-append url @id) num name description test #f #f) result)))) `(,num . ()) (array->list document)))) (define (run-test-suite manifest expected-failures driver) "Run a test suite described by @var{manifest}." (let* ((plan (reverse (get-test-plan manifest)))) ((test-driver-init driver) plan) ((test-driver-finalize driver) (run-tests plan expected-failures driver)))) (define (run-test-suites manifests expected-failures driver) "Run multiple test suites described by @var{manifests}." (let* ((plan (fold (lambda (manifest plan) (append plan (reverse (get-test-plan manifest #:num (+ (length plan) 1))))) '() manifests))) ((test-driver-init driver) plan) ((test-driver-finalize driver) (run-tests plan expected-failures driver))))