diff options
Diffstat (limited to 'src/scm/webid-oidc/server/resource/content.scm')
| -rw-r--r-- | src/scm/webid-oidc/server/resource/content.scm | 209 |
1 files changed, 148 insertions, 61 deletions
diff --git a/src/scm/webid-oidc/server/resource/content.scm b/src/scm/webid-oidc/server/resource/content.scm index 57c51dd..f0d12a5 100644 --- a/src/scm/webid-oidc/server/resource/content.scm +++ b/src/scm/webid-oidc/server/resource/content.scm @@ -1,4 +1,4 @@ -;; webid-oidc, implementation of the Solid specification +;; disfluid, implementation of the Solid specification ;; Copyright (C) 2020, 2021 Vivien Kraus ;; This program is free software: you can redistribute it and/or modify @@ -16,6 +16,7 @@ (define-module (webid-oidc server resource content) #:use-module (webid-oidc errors) + #:use-module (webid-oidc web-i18n) #:use-module ((webid-oidc stubs) #:prefix stubs:) #:use-module (webid-oidc rdf-index) #:use-module ((webid-oidc refresh-token) #:prefix refresh:) @@ -28,79 +29,165 @@ #:use-module (ice-9 iconv) #:use-module (ice-9 textual-ports) #:use-module (ice-9 binary-ports) - #:use-module (rnrs bytevectors) + #:use-module (ice-9 match) + #:use-module (srfi srfi-26) #:use-module (oop goops) + #:declarative? #t #:export ( - with-session + <content> + etag + content-type + contained + static-content + + <content-cache> + cache + delete-content + + current-content-cache )) (define-class <content> () + (etag #:init-keyword #:etag #:getter etag) (content-type #:init-keyword #:content-type #:getter content-type) (contained #:init-keyword #:contained #:getter contained) (static-content #:init-keyword #:static-content #:getter static-content)) -(define (load-content session etag) - (let ((first-char (substring etag 0 1)) - (rest (substring etag 1))) - (call-with-input-file (format #f "~a/server/content/~a/~a" - (p:data-home) - first-char - rest) - (lambda (port) - (let ((properties (read port))) - (set-port-encoding! port "ISO-8859-1") - (let ((ret - (make <content> - #:content-type (assq-ref properties 'content-type) - #:contained (assq-ref properties 'contained) - #:static-content - (string->bytevector (get-string-all port) "ISO-8859-1")))) - (hash-set! session etag ret) - ret)))))) - -(define (new-content session content-type contained static-content) - (when (string? static-content) - (set! static-content (string->utf8 static-content))) - (let ((etag (stubs:random 12))) - (let ((first-char (substring etag 0 1)) - (rest (substring etag 1))) - (stubs:mkdir-p (format #f "~a/server/content/~a" (p:data-home) first-char)) - (let ((port (open (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest) - (logior O_WRONLY O_CREAT O_EXCL)))) - (write `((content-type . ,content-type) - (contained . ,contained)) port) - (set-port-encoding! port "ISO-8859-1") - (display (bytevector->string static-content "ISO-8859-1") port) - (close-port port) - (hash-set! session - etag - (make <content> - #:content-type content-type - #:contained contained - #:static-content static-content)) - etag)))) - -(define (delete-content etag) +(define-class <content-cache> () + (cache #:init-thunk make-hash-table #:getter cache)) + +(define current-content-cache + (make-parameter #f)) + +(define (filter-keyword check arguments) + (let scan ((arguments arguments) + (kept '())) + (match arguments + (() + (let reverse ((reversed kept) + (final '())) + (match reversed + (() final) + ((key value reversed ...) + (reverse reversed `(,key ,value ,@final)))))) + (((? check key) value arguments ...) + (scan arguments `(,key ,value ,@kept))) + ((_ _ arguments ...) + (scan arguments kept))))) + +(define-method (initialize (content <content>) initargs) + (let-keywords + initargs #t + ((etag #f) + (content-type #f) + (contained #f) + (static-content #f) + (cache (current-content-cache)) + (save-to-cache (current-content-cache))) + (cond + ((and (not (eq? content-type 'text/turtle)) + (list? contained)) + ;; Error: containers must be RDF + (fail (G_ "content with contained resources must be RDF"))) + ((and etag content-type static-content) + ;; Construct it the normal way + (unless (string? etag) + (scm-error 'wrong-type-arg "make" + (G_ "#:etag should be a string") + '() + (list etag))) + (unless (symbol? content-type) + (scm-error 'wrong-type-arg "make" + (G_ "#:content-type should be a symbol") + '() + (list content-type))) + (unless (or (not contained) + (list? contained)) + (scm-error 'wrong-type-arg "make" + (G_ "#:contained should be a list if not #f") + '() + (list contained))) + (when (string? static-content) + (set! static-content (string->utf8 static-content))) + (unless (bytevector? static-content) + (scm-error 'wrong-type-arg "make" + (G_ "#:static-content should be a bytevector") + '() + (list static-content))) + (slot-set! content 'etag etag) + (slot-set! content 'content-type content-type) + (slot-set! content 'contained contained) + (slot-set! content 'static-content static-content) + (when save-to-cache + (hash-set! (slot-ref save-to-cache 'cache) etag content))) + ((and cache etag) + ;; Load the content from disk or from the session + (let ((cached (hash-ref (slot-ref save-to-cache 'cache) etag))) + (if cached + (initialize content `(#:etag ,etag + #:content-type ,(slot-ref cached 'content-type) + #:contained ,(slot-ref cached 'contained) + #:static-content ,(slot-ref cached 'static-content) + ,@initargs)) + ;; The cache is useless, try again without it + (parameterize ((current-content-cache #f)) + (initialize + content + `(#:save-to-cache ,cache + ,@(filter-keyword (lambda (key) (not (equal? key #:cache))) + initargs))))))) + (etag + (let ((first-char (substring etag 0 1)) + (rest (substring etag 1))) + (call-with-input-file (format #f "~a/server/content/~a/~a" + (p:data-home) + first-char + rest) + (lambda (port) + (let ((properties (read port))) + (set-port-encoding! port "ISO-8859-1") + (initialize + content + `(#:etag ,etag + #:content-type ,(assq-ref properties 'content-type) + #:contained ,(assq-ref properties 'contained) + #:static-content + ,(string->bytevector (get-string-all port) "ISO-8859-1") + ,@initargs))))))) + ((and content-type static-content) + ;; Save it to disk and generate an ETag + (let ((etag (stubs:random 12))) + ;; Recursive call before touching the file system, so if + ;; there’s an error we won’t create garbage + (initialize content `(#:etag ,etag ,@initargs)) + ;; static-content may be a string converted to bytevector by + ;; the recursive call + (set! static-content (slot-ref content 'static-content)) + (let ((first-char (substring etag 0 1)) + (rest (substring etag 1))) + (stubs:mkdir-p (format #f "~a/server/content/~a" (p:data-home) first-char)) + (let ((port (open (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest) + (logior O_WRONLY O_CREAT O_EXCL)))) + (write `((content-type . ,content-type) + (contained . ,contained)) port) + (set-port-encoding! port "ISO-8859-1") + (display (bytevector->string static-content "ISO-8859-1") port) + (close-port port) + (when save-to-cache + (hash-set! (slot-ref save-to-cache 'cache) etag content)))))) + (else + (fail (G_ "not enough arguments to create or load a <content>")))))) + +(define (delete-etag etag) (let ((first-char (substring etag 0 1)) (rest (substring etag 1))) (delete-file (format #f "~a/server/content/~a/~a" (p:data-home) first-char rest)))) -(define (with-session f) - (let ((session (make-hash-table))) - (define (do-load etag) - (or (hash-ref session etag) - (load-content session etag))) - (define (get-content-type etag) - (content-type (do-load etag))) - (define (get-contained etag) - (contained (do-load etag))) - (define (get-static-content etag) - (static-content (do-load etag))) - (define (do-create content-type contained static-content) - (new-content session content-type contained static-content)) - (define (do-delete etag) - (delete-content etag)) - (f get-content-type get-contained get-static-content do-create do-delete))) +(define-method (delete-content (content <content>)) + (delete-etag (etag content))) + +(define-method (delete-content (etag <string>)) + (delete-etag etag)) |