;; disfluid, implementation of the Solid specification
;; Copyright (C) 2020, 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 .
(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:)
#:use-module ((webid-oidc parameters) #:prefix p:)
#:use-module (web uri)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 exceptions)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
#:use-module (ice-9 iconv)
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 match)
#:use-module (srfi srfi-26)
#:use-module (oop goops)
#:declarative? #t
#:export
(
etag
content-type
contained
static-content
cache
delete-content
current-content-cache
))
(define-class ()
(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-class ()
(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 ) 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 "))))))
(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-method (delete-content (content ))
(delete-etag (etag content)))
(define-method (delete-content (etag ))
(delete-etag etag))