;;;; 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 (tests webfinger)

  #:use-module (ice-9 format)

  #:use-module (ice-9 match)

  #:use-module (json)

  #:use-module (rnrs bytevectors)

  #:use-module (srfi srfi-1)

  #:use-module (srfi srfi-64)

  #:use-module (webfinger webfinger))

(test-begin "webfinger")

(define (json-has-key? json key)

  (match json

    (((k . v) json ...)

     (or (equal? key k) (json-has-key? json key)))

    (_ #f)))

(define (alist-include? j1 j2)

  (fold

    (lambda (elem acc)

      (if acc

          (match elem

            ((key . value)

             (and

               (json-has-key? j2 key)

               (json-equal? value (assoc-ref j2 key))))

            (_ #f))

          #f))

    #t

    j1))

(define (json-equal? j1 j2)

  (cond

    ((list? j1)

     (and (list? j2)

          (alist-include? j1 j2)

          (alist-include? j2 j1)))

    ((string? j1)

     (equal? j1 j2))

    ((array? j1)

     (let loop ((j1 j1) (j2 j2))

       (match (cons j1 j2)

         ((#() . #())

          #t)

         ((#(v1 j1 ...) . #(v2 j2 ...))

          (and (json-equal? v1 v2)

               (loop `#(,@j1) `#(,@j2))))

         (_ #f))))

    (else (equal? j1 j2))))

(define simple-record-scm

  '(("subject" . "acct:carol@example.com")

    ("links" . #((("rel" . "http://openid.net/specs/connect/1.0/issuer")

                  ("href" . "https://openid.example.com"))))))

(define simple-record

  (make-jrd-record

    "acct:carol@example.com"

    '()

    *unspecified*

    (list

      (make-link-record

        "http://openid.net/specs/connect/1.0/issuer"

        *unspecified*

        "https://openid.example.com"

        *unspecified*

        *unspecified*))))

(test-assert "json-equality"

  (and (json-equal? #t #t)

       (json-equal? #f #f)

       (json-equal? "abc" "abc")

       (not (json-equal? "abc" "cba"))

       (json-equal? #() #())

       (json-equal? #(1 2) #(1 2))

       (not (json-equal? #(1 2) #(2 1)))

       (json-equal? '(("a" . 1) ("b" . 2))

                    '(("a" . 1) ("b" . 2)))

       (json-equal? '(("a" . 1) ("b" . 2))

                    '(("b" . 2) ("a" . 1)))))

(test-assert "simple example decode"

  (let ((converted-simple-record (json->jrd-record simple-record-scm)))

    (if (equal? converted-simple-record simple-record)

        #t

        (pk 'fail converted-simple-record #f))))

(test-assert "simple example encode"

  (let ((converted-simple-record-scm (jrd-record->json simple-record)))

    (if (json-equal? simple-record-scm

                     (json-string->scm converted-simple-record-scm))

        #t

        (pk 'fail converted-simple-record-scm

            (scm->json-string simple-record-scm) #f))))

(test-end "webfinger")