;; disfluid, implementation of the Solid specification
;; Copyright (C) 2021  Vivien Kraus

;; This program 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.

;; This program 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 this program.  If not, see <https://www.gnu.org/licenses/>.

(define-module (webid-oidc serializable)
  #:use-module (oop goops)
  #:use-module (ice-9 optargs)
  #:use-module (ice-9 match)
  #:use-module (ice-9 receive)
  #:use-module (webid-oidc web-i18n)
  #:use-module (webid-oidc errors)
  #:use-module (sxml ssax)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (web uri)
  #:declarative? #t
  #:export
  (
   <plugin-class> module-name direct-name
   read/xml
   ->sxml
   ))

(define-class <plugin-class> (<class>)
  (module-name #:init-keyword #:module-name #:getter module-name)
  (direct-name #:getter direct-name))

(define (check-class-name name)
  (let ((chars (string->list (symbol->string name))))
    (match chars
      ((#\< next-chars ...)
       (let ((rev (reverse next-chars)))
         (match rev
           ((#\> middle-chars ...)
            (string->symbol (list->string (reverse middle-chars))))
           (else #f))))
      (else #f))))

(define-method (initialize (class <plugin-class>) initargs)
  (next-method)
  (let-keywords
   initargs #t
   ((module-name #f)
    (name #f))
   (unless (and name module-name)
     (fail (G_ "a plugin class should have an explicit #:name and #:module-name")))
   (unless (symbol? name)
     (scm-error 'wrong-type-arg "make"
                (G_ "#:name should be a symbol")
                '()
                (list name)))
   (let check-module-name ((module-name module-name))
     (match module-name
       (() #t)
       (((? symbol? hd) tl ...)
        (check-module-name tl))
       (else
        (scm-error 'wrong-type-arg "make"
                   (G_ "#:module-name should be a list of symbols")
                   '()
                   (list module-name)))))
   (let ((direct-name (check-class-name name)))
     (unless direct-name
       (fail (G_ "plugin class names should be surrounded by <angle brackets>")))
     (slot-set! class 'direct-name direct-name))
   (slot-set! class 'module-name module-name)))

(define-class <parser-state> ())

(define-class <parser-reading-value> (<parser-state>))

(define-class <parser-reading-element> (<parser-reading-value>)
  (namespace #:init-keyword #:namespace #:accessor namespace)
  (init-class #:init-keyword #:init-class #:accessor init-class)
  (init-args-reverse #:init-keyword #:init-args-reverse #:accessor init-args-reverse))

(define-class <parser-reading-list> (<parser-reading-value>)
  (items-reverse #:init-keyword #:items-reversed #:accessor items-reversed #:init-value '()))

(define-class <parser-reading-extended-attribute> (<parser-state>)
  (attribute-name #:init-keyword #:attribute-name #:accessor attribute-name)
  (attribute-value #:init-keyword #:attribute-value #:accessor attribute-value #:init-value #f))

(define-class <parser-root> (<parser-reading-extended-attribute>))

(define-method (get-value (list <parser-reading-list>))
  (reverse (items-reverse list)))

(define-method (get-value (element <parser-reading-element>))
  (let* ((class (init-class element))
         (with-slots
          (filter-map
           (match-lambda
             ((name . value)
              (let ((slot (class-slot-definition class name)))
                (and slot `(,slot . ,value)))))
           (reverse (init-args-reverse element))))
         (initializable/non-initializable
          (receive (initializable non-initializable)
              (partition (match-lambda
                           ((slot . value)
                            (slot-definition-init-keyword slot)))
                         with-slots)
            (let collect-initializable ((initializable initializable)
                                        (collected '()))
              (match initializable
                (()
                 `(,(reverse collected)
                   . ,(map (match-lambda
                             ((slot . value)
                              (lambda (x)
                                (slot-set! x (slot-definition-name slot) value))))
                           non-initializable)))
                (((slot . value) initializable ...)
                 (collect-initializable
                  initializable
                  `(,value ,(slot-definition-init-keyword slot) ,@collected)))))))
         (initializable (car initializable/non-initializable))
         (non-initializable (cdr initializable/non-initializable)))
    (let ((object (apply make class initializable)))
      (for-each (lambda (finish!) (finish! object)) non-initializable)
      object)))

(define-method (new-level-seed elem-gi attributes namespaces expected-content (state <parser-reading-extended-attribute>))
  (match elem-gi
    (('guile . 'list)
     (make <parser-reading-list>))
    ((namespace . local-name)
     (let ((namespace-parsed
            (map string->symbol
                 (split-and-decode-uri-path (symbol->string namespace))))
           (local-name
            (string->symbol
             (string-append "<" (symbol->string local-name) ">"))))
       (let ((class
               (module-ref (resolve-interface namespace-parsed) local-name))
             (initargs (reverse attributes)))
         (make <parser-reading-element>
           #:namespace namespace
           #:init-class class
           #:init-args-reverse initargs))))
    (else state)))

(define-method (new-level-seed elem-gi attributes namespaces expected-content (state <parser-reading-element>))
  (match elem-gi
    (((? (cute eq? <> (namespace state))) . local-name)
     (make <parser-reading-extended-attribute>
       #:attribute-name local-name))
    (else state)))

(define-method (new-level-seed elem-gi attributes namespaces expected-content (state <parser-reading-list>))
  (new-level-seed elem-gi attributes namespaces expected-content
                  (make <parser-reading-extended-attribute>
                    #:namespace '(guile)
                    #:init-class <list>
                    #:init-args-reverse '())))

(define-method (finish-element elem-gi attributes namespaces (parent-seed <parser-reading-element>) (seed <parser-reading-extended-attribute>))
  (let ((ret (shallow-clone parent-seed)))
    (set! (init-args-reverse ret)
          `((,(attribute-name seed) . ,(attribute-value seed))
            ,@(init-args-reverse ret)))
    ret))

(define-method (finish-element elem-gi attributes namespaces (parent-seed <parser-reading-extended-attribute>) (seed <parser-reading-value>))
  (let ((object (get-value seed)))
    (let ((ret (shallow-clone parent-seed)))
      (set! (attribute-value ret) object)
      ret)))

(define-method (finish-element elem-gi attributes namespaces (parent-seed <parser-reading-list>) (seed <parser-reading-value>))
  (let ((object (get-value seed)))
    (let ((ret (shallow-clone parent-seed)))
      (set! (items-reversed ret)
            `(,object ,@(items-reversed ret)))
      ret)))

(define-method (char-data-handler string1 string2 (seed <parser-reading-extended-attribute>))
  (match (attribute-value seed)
    ((or (? not (= (const "") existing))
         (? string? existing))
     (let ((ret (shallow-clone seed)))
       (set! (attribute-value ret)
             (string-append
              existing
              string1
              string2))
       ret))
    (else seed)))

(define-method (char-data-handler string1 string2 (seed <parser-reading-element>))
  seed)

(define read/xml
  (let ((parser
         (ssax:make-parser
          NEW-LEVEL-SEED new-level-seed
          FINISH-ELEMENT finish-element
          CHAR-DATA-HANDLER char-data-handler)))
    (lambda (port)
      (attribute-value (parser port (make <parser-root>))))))

(define (->sxml object)
  (let ((class (class-of object)))
    (cond
     ((is-a? class <plugin-class>)
      (let ((namespace
             (encode-and-join-uri-path
              (map symbol->string (module-name class)))))
        (let ((all-slots (class-slots class)))
          (define (get-slot-value slot)
            (let ((name (slot-definition-name slot)))
              (let-keywords
               (slot-definition-options slot) #t
               ((->sxml ->sxml))
               (if (eq? ->sxml 'ignore)
                   '()
                   (catch 'slot-unbound
                     (lambda ()
                       (let ((value (slot-ref object name)))
                         `((,name ,(->sxml value)))))
                     (lambda _
                       '()))))))
          `(,(direct-name class) (@ (xmlns ,namespace))
            ,@(apply append (map get-slot-value all-slots))))))
     ((list? object)
      `(list (@ (xmlns "guile"))
             ,@(map ->sxml object)))
     (else
      (call-with-output-string (lambda (port) (display object port)))))))