Define an XML-loadable meta-class

1 files changed, 207 insertions, 0 deletions

diff --git a/src/scm/webid-oidc/serializable.scm b/src/scm/webid-oidc/serializable.scm
new file mode 100644
index 0000000..f05206c
--- /dev/null
+++ b/src/scm/webid-oidc/serializable.scm
@@ -0,0 +1,207 @@
+;; 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-element> (<parser-state>)
+  (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-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 (new-level-seed elem-gi attributes namespaces expected-content (state <parser-reading-extended-attribute>))
+  (match elem-gi
+    ((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 (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-element>))
+  (let* ((class (init-class seed))
+         (with-slots
+          (filter-map
+           (match-lambda
+             ((name . value)
+              (let ((slot (class-slot-definition class name)))
+                (and slot `(,slot . ,value)))))
+           (reverse (init-args-reverse seed))))
+         (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)
+      (let ((ret (shallow-clone parent-seed)))
+        (set! (attribute-value ret) object)
+        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)))
+    (if (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))
+                 (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)))))
+        (call-with-output-string (lambda (port) (display object port))))))