From 5863e990a70ab01b98540bed49bbe9ca38cba638 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Wed, 2 Jun 2021 17:18:12 +0200
Subject: An API to manipulate contents on the server

---
 src/scm/webid-oidc/server/resource/content.scm | 91 ++++++++++++++++++++++++++
 1 file changed, 91 insertions(+)
 create mode 100644 src/scm/webid-oidc/server/resource/content.scm

(limited to 'src/scm/webid-oidc/server/resource/content.scm')

diff --git a/src/scm/webid-oidc/server/resource/content.scm b/src/scm/webid-oidc/server/resource/content.scm
new file mode 100644
index 0000000..2bbf4f0
--- /dev/null
+++ b/src/scm/webid-oidc/server/resource/content.scm
@@ -0,0 +1,91 @@
+(define-module (webid-oidc server resource content)
+  #:use-module (webid-oidc errors)
+  #:use-module ((webid-oidc stubs) #:prefix stubs:)
+  #:use-module (webid-oidc rdf-index)
+  #:use-module ((webid-oidc refresh-token) #:prefix refresh:)
+  #: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 (rnrs bytevectors)
+  #:use-module (oop goops)
+  #:export
+  (
+
+   with-session
+
+   ))
+
+(define (default-dir)
+  (string-append (refresh:default-dir) "/server"))
+
+(define-class <content> ()
+  (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 dir etag)
+  (let ((first-char (substring etag 0 1))
+        (rest (substring etag 1)))
+    (call-with-input-file (format #f "~a/content/~a/~a" dir 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 dir 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/content/~a" dir first-char))
+      (let ((port (open (format #f "~a/content/~a/~a" dir 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 dir etag)
+  (let ((first-char (substring etag 0 1))
+        (rest (substring etag 1)))
+    (delete-file (format #f "~a/content/~a/~a" dir first-char rest))))
+
+(define* (with-session f #:key (dir default-dir))
+  (when (thunk? dir)
+    (set! dir (dir)))
+  (let ((session (make-hash-table)))
+    (define (do-load etag)
+      (or (hash-ref session etag)
+          (load-content session dir 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 dir content-type contained static-content))
+    (define (do-delete etag)
+      (delete-content dir etag))
+    (f get-content-type get-contained get-static-content do-create do-delete)))
-- 
cgit v1.2.3