1 files changed, 93 insertions, 0 deletions
diff --git a/src/scm/webid-oidc/client/application.scm b/src/scm/webid-oidc/client/application.scm
index bbc39fb..dc0f3c4 100644
--- a/src/scm/webid-oidc/client/application.scm
+++ b/src/scm/webid-oidc/client/application.scm
@@ -378,6 +378,22 @@
 (define-class <page-with-uri> (<page>)
   (uri #:init-keyword #:uri #:getter uri))
 
+(define-method (initialize (page <page-with-uri>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((uri #f))
+   (let do-initialize ((uri uri))
+     (match uri
+       ((or (? string? (= string->uri (? uri? uri)))
+            (? uri? uri))
+        (slot-set! page 'uri uri))
+       (else
+        (scm-error 'wrong-type-arg "make <page-with-uri>"
+                   (G_ "the page URI (#:uri) should be a string encoding an URI or an URI")
+                   '()
+                   (list uri)))))))
+
 (define-method (equal? (x <page-with-uri>) (y <page-with-uri>))
   (and (equal? (uri x) (uri y))))
 
@@ -387,6 +403,24 @@
   (code #:init-keyword #:code #:getter code)
   (reason-phrase #:init-keyword #:reason-phrase #:getter reason-phrase))
 
+(define-method (initialize (page <error-page>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((code #f)
+    (reason-phrase #f))
+   (let do-initialize ((code code)
+                       (reason-phrase reason-phrase))
+     (match `(,code ,reason-phrase)
+       (((? integer? code) (? string? reason-phrase))
+        (slot-set! page 'code code)
+        (slot-set! page 'reason-phrase reason-phrase))
+       (else
+        (scm-error 'wrong-type-arg "make <error-page>"
+                   (G_ "the error code (#:code) should be an integer and the reason phrase (#:reason-phrase) should be a string")
+                   '()
+                   (list code reason-phrase)))))))
+
 (define-method (equal? (x <error-page>) (y <error-page>))
   (and (equal? (uri x) (uri y))
        (equal? (code x) (code y))
@@ -398,6 +432,41 @@
   (content-type #:init-keyword #:content-type #:getter content-type)
   (content #:init-keyword #:content #:getter content))
 
+(define (all-links? elements)
+  (match elements
+    (() #t)
+    (((? (cute is-a? <> <link>)) elements ...)
+     (all-links? elements))
+    (else #f)))
+
+(define-method (initialize (page <loaded-page>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((etag #f)
+    (links #f)
+    (content-type #f)
+    (content #f))
+   (let do-initialize ((etag etag)
+                       (links links)
+                       (content-type content-type)
+                       (content content))
+     (match `(,etag ,links ,content-type ,content)
+       (((? string? etag)
+         (? all-links? links)
+         (? symbol? content-type)
+         (or (? string? content)
+             (? bytevector? content)))
+        (slot-set! page 'etag etag)
+        (slot-set! page 'links links)
+        (slot-set! page 'content-type content-type)
+        (slot-set! page 'content content))
+       (else
+        (scm-error 'wrong-type-arg "make <error-page>"
+                   (G_ "the etag (#:etag) should be a string, the links (#:links) should be a list of links, the content-type (#:content-type) should be a symbol, and the content (#:content) should be a string or a bytevector")
+                   '()
+                   (list etag links content-type content)))))))
+
 (define-method (equal? (x <loaded-page>) (y <loaded-page>))
   (and (equal? (uri x) (uri y))
        (equal? (etag x) (etag y))
@@ -410,6 +479,30 @@
   (desired-content-type #:init-keyword #:desired-content-type #:getter desired-content-type)
   (desired-content #:init-keyword #:desired-content #:getter desired-content))
 
+(define-method (initialize (page <updated-page>) initargs)
+  (next-method)
+  (let-keywords
+   initargs #t
+   ((desired-links #f)
+    (desired-content-type #f)
+    (desired-content #f))
+   (let do-initialize ((desired-links desired-links)
+                       (desired-content-type desired-content-type)
+                       (desired-content desired-content))
+     (match `(,desired-links ,desired-content-type ,desired-content)
+       (((? list? desired-links)
+         (? symbol? desired-content-type)
+         (or (? string? desired-content)
+             (? bytevector? desired-content)))
+        (slot-set! page 'desired-links desired-links)
+        (slot-set! page 'desired-content-type desired-content-type)
+        (slot-set! page 'desired-content desired-content))
+       (else
+        (scm-error 'wrong-type-arg "make <updated-page>"
+                   (G_ "the desired links (#:desired-links) should be an alist from URI to alists, the desired content-type (#:desired-content-type) should be a symbol, and the desired content (#:desired-content) should be a string or a bytevector")
+                   '()
+                   (list desired-links desired-content-type desired-content)))))))
+
 (define-method (equal? (x <updated-page>) (y <updated-page>))
   (and (equal? (uri x) (uri y))
        (equal? (etag x) (etag y))