From 5f6437959c641647447fe8801bee917a0d56c3dc Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Wed, 13 Oct 2021 17:44:51 +0200
Subject: server: add a hello world backend

---
 src/scm/webid-oidc/server/endpoint/hello.scm | 80 ++++++++++++++++++++++++++++
 1 file changed, 80 insertions(+)
 create mode 100644 src/scm/webid-oidc/server/endpoint/hello.scm

(limited to 'src/scm/webid-oidc/server/endpoint/hello.scm')

diff --git a/src/scm/webid-oidc/server/endpoint/hello.scm b/src/scm/webid-oidc/server/endpoint/hello.scm
new file mode 100644
index 0000000..b03c8f4
--- /dev/null
+++ b/src/scm/webid-oidc/server/endpoint/hello.scm
@@ -0,0 +1,80 @@
+;; 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 server endpoint hello)
+  #:use-module (webid-oidc errors)
+  #:use-module (webid-oidc server endpoint)
+  #:use-module (webid-oidc provider-confirmation)
+  #:use-module ((webid-oidc parameters) #:prefix p:)
+  #:use-module ((webid-oidc config) #:prefix cfg:)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:use-module (web server)
+  #:use-module (web client)
+  #:use-module (ice-9 optargs)
+  #:use-module (ice-9 receive)
+  #:use-module (webid-oidc web-i18n)
+  #:use-module (ice-9 getopt-long)
+  #:use-module (ice-9 suspendable-ports)
+  #:use-module (ice-9 control)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 exceptions)
+  #:use-module (sxml simple)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (oop goops)
+  #:duplicates (merge-generics)
+  #:declarative? #t
+  #:export
+  (
+   <greeter>
+   ))
+
+(define-class <greeter> (<endpoint>))
+
+(define-method (handle (endpoint <greeter>) request request-body)
+  (let ((user (assq-ref (request-meta request) 'user)))
+    (unless user
+      (raise-exception
+       (make-exception
+        (make-web-exception 401 (W_ "reason-phrase|Unauthorized"))
+        (make-user-message
+         (call-with-input-string
+             (format #f (W_ "<p>You are not authentified.</p>"))
+           xml->sxml)))))
+    (let ((page
+           `(*TOP*
+             (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+             (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+                      (xml:lang ,(W_ "xml-lang|en")))
+                   (body
+                    ,(xml->sxml
+                      (format #f (W_ "<h1>Hello, ~a!</h1>")
+                              (call-with-output-string
+                                (lambda (port)
+                                  (sxml->xml
+                                   `(a (@ (href ,(uri->string user)))
+                                       ,(uri->string user))
+                                   port)))))
+                    ,(xml->sxml
+                      (format #f (W_ "<p>You are authenticated with Solid.</p>"))))))))
+      (values
+       (build-response
+        #:headers `((content-type application/xhtml+xml)))
+       (call-with-output-string
+         (cute sxml->xml page <>))
+       '()))))
-- 
cgit v1.2.3