;;;; Copyright (C) 2019, 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 (jsonld context-processing)

  #:use-module (jsonld context)

  #:use-module (jsonld create-term-definition)

  #:use-module (jsonld download)

  #:use-module (jsonld iri)

  #:use-module (jsonld iri-expansion)

  #:use-module (jsonld json)

  #:use-module (jsonld options)

  #:use-module (json)

  #:use-module (web uri)

  #:use-module (rnrs bytevectors)

  #:use-module (ice-9 match)

  #:use-module (srfi srfi-9)

  #:export (context-processing))

(define* (context-processing

           active-context local-context base-url

           #:key (remote-contexts '()) (override-protected? #f) (propagate? #t)

           (validate-scoped-context? #t)

           (options (new-jsonld-options)))

  "Process a context.  This is an implementation of the context processing

algorithm defined in the JsonLD API specification.

See @url{https://www.w3.org/TR/2014/REC-json-ld-api-20140116}."

  ;; 1

  (define result active-context)

  ;; 2

  (when (json-has-key? local-context "@propagate")

    (set! propagate? (assoc-ref local-context "@propagate")))

  ;; 3

  (unless (or propagate? (active-context-previous active-context))

    (set! result (update-active-context result #:previous active-context)))

  ;; 4

  (if (json-array? local-context)

      (set! local-context (array->list local-context))

      (set! local-context (list local-context)))

  ;; 5

  (for-each

    (lambda (context)

      (match context

        ;; 5.1

        (#nil

         (unless (or override-protected?

                     (null? (filter

                              term-definition-protected?

                              (map cdr (active-context-definitions result)))))

           (throw 'invalid-context-nullification))

         (let ((original-base (active-context-original-base active-context)))

           (if propagate?

             (set! result (new-active-context #:previous result

                                              #:base original-base

                                              #:original-base original-base))

             (set! result (new-active-context #:base original-base

                                              #:original-base original-base)))))

        ;; 5.2

        ((? string? context)

         ;; 5.2.1

         (set! context (resolve-iri base-url context))

         (unless (absolute-iri? context)

           (throw 'loading-document-failed context))

         ;; 5.2.2

         ;; A processor-defined limit, here we choose 10

         (when (> (length remote-contexts) 10)

           (throw 'context-overflow-error))

         (set! remote-contexts (cons context remote-contexts))

         ;; 5.2.3

         (when validate-scoped-context?

           ;; 5.2.4

           (let ((context-document #f))

             (catch #t

               (lambda ()

                 (set! context-document

                   ((jsonld-options-document-loader options)

                      context

                      #:profile "http://www.w3.org/ns/json-ld#context"

                      #:request-profile "http://www.w3.org/ns/json-ld#context"))

                 (set! context (json-document-document context-document)))

               (lambda (key . value)

                 (apply throw 'loading-remote-context-failed key value)))

             ;; 5.2.5

             (if (json-has-key? context "@context")

               (set! context (assoc-ref context "@context"))

               (throw 'invalid-remote-context))

             ;; 5.2.6

             (set! result (context-processing

                            result context

                            (json-document-document-url context-document)

                            #:remote-contexts remote-contexts

                            #:validate-scoped-context? validate-scoped-context?

                            #:options options)))))

        ;; 5.4: if it's a Json object (also see below, if it's not, for 5.3)

        ((? json-object? context)

         ;; 5.5: If it has an @version key...

         (when (json-has-key? context "@version")

           ;; 5.5.1

           (unless (equal? (assoc-ref context "@version") 1.1)

             (throw 'invalid-@version-value (assoc-ref context "@version")))

           ;; 5.5.2

           (when (processing-mode-1.0? (jsonld-options-processing-mode options))

             (throw 'processing-mode-conflict)))

         ;; 5.6: If it has an @import key...

         (when (json-has-key? context "@import")

           ;; 5.6.1

           (when (processing-mode-1.0? (jsonld-options-processing-mode options))

             (throw 'invalid-context-entry))

           ;; 5.6.2

           (unless (string? (assoc-ref context "@import"))

             (throw 'invalid-@import-value))

           ;; 5.6.3

           (let ((import (resolve-iri

                           base-url

                           (assoc-ref context "@import"))))

             ;; 5.6.4

             (catch #t

               (lambda ()

                 (set! import ((jsonld-options-document-loader options)

                                 import

                                 #:profile "http://www.w3.org/ns/json-ld#context"

                                 #:request-profile "http://www.w3.org/ns/json-ld#context"))

                 (set! import (json-document-document import)))

               (lambda (key . value)

                 (apply throw 'loading-remote-context-failed key value)))

             ;; 5.6.6

             (unless (and (json-has-key? import "@context")

                          (json-object? (assoc-ref import "@context")))

               (throw 'invalid-remote-context import))

             (let ((import-context (assoc-ref import "@context")))

               ;; 5.6.7

               (when (json-has-key? import-context "@import")

                 (throw 'invalid-context-entry))

               ;; 5.6.8

               (set! context (merge-json context import-context)))))

         ;; 5.7: If it has an @base key...

         (when (and (json-has-key? context "@base") (null? remote-contexts))

           ;; 5.7.1

           (let ((value (assoc-ref context "@base")))

             (cond

               ;; 5.7.2

               ((equal? value #nil)

                (set! result (update-active-context result #:base #nil)))

               ;; 5.7.3

               ((absolute-iri? value)

                (set! result (update-active-context result #:base value)))

               (else

                 (let ((iri (resolve-iri (active-context-base result) value)))

                   (if (and (absolute-iri? iri)

                            (active-context-base result))

                     ;; 5.7.4

                     (set! result (update-active-context result #:base iri))

                     ;; 5.7.5

                     (throw 'invalid-base-iri iri (active-context-base result))))))))

         ;; 5.8: If it has an @vocab key...

         (when (json-has-key? context "@vocab")

           ;; 5.8.1

           (let ((value (assoc-ref context "@vocab")))

             (if (equal? value #nil)

               ;; 5.8.2

               (set! result (update-active-context result #:vocab #f))

               ;; 5.8.3

               (let ((value

                       (assoc-ref

                         (iri-expansion result value

                                        #:vocab? #t

                                        #:document-relative? #t)

                         "iri")))

                 (if (or (absolute-iri? value) (blank-node? value))

                   (set! result (update-active-context result #:vocab value))

                   (throw 'invalid-vocab-mapping value))))))

         ;; 5.9: If it has an @language key...

         (when (json-has-key? context "@language")

           ;; 5.9.1

           (let ((value (assoc-ref context "@language")))

             (if (equal? value #nil)

               ;; 5.9.2

               (set! result (update-active-context result #:language #f))

               ;; 5.9.3

               (if (string? value)

                 (set! result (update-active-context result #:language value))

                 (throw 'invalid-default-language)))))

         ;; 5.10: If it has an @direction key...

         (when (json-has-key? context "@direction")

           ;; 5.10.1

           (when (processing-mode-1.0? (jsonld-options-processing-mode options))

             (throw 'invalid-context-entry))

           (let ((value (assoc-ref context "@direction")))

             (if (equal? value #nil)

               ;; 5.10.2

               (set! result (update-active-context result #:direction #f))

               ;; 5.10.3

               (if (member value '("ltr" "rtl"))

                 (set! result (update-active-context result #:direction value))

                 (throw 'invalid-base-direction value)))))

         ;; 5.11: If it has an @propagate key...

         (when (json-has-key? context "@propagate")

           ;; 5.11.1

           (when (processing-mode-1.0? (jsonld-options-processing-mode options))

             (throw 'invalid-context-entry))

           ;; 5.11.2

           (unless (member (assoc-ref context "@propagate") '(#t #f))

             (throw 'invalid-@propagate-value)))

         ;; and now loop over key-value pair that are not @base, @vocab nor @language

         ;; 5.12

         (let ((defined '()))

           ;; 5.13

           (for-each-pair

             (lambda (key value)

               (unless (member key '("@base" "@direction" "@import" "@language"

                                     "@propagate" "@protected" "@version"

                                     "@vocab"))

                 (let* ((term-res (create-term-definition

                                    result context key defined

                                    #:base-url base-url

                                    #:protected? (assoc-ref context "@protected")

                                    #:override-protected? override-protected?

                                    #:remote-contexts remote-contexts

                                    #:validate-scoped-context? validate-scoped-context?

                                    #:options options)))

                   (set! defined (assoc-ref term-res "defined"))

                   (set! result (assoc-ref term-res "active-context")))))

             context)))

        ;; 5.3: if it's not a Json object

        (_ (throw 'invalid-local-context context))))

    local-context)

  result)