From 1cd51a1728a34aaf85b964bff7636733ef732999 Mon Sep 17 00:00:00 2001
From: Vivien Kraus <vivien@planete-kraus.eu>
Date: Mon, 7 Dec 2020 22:20:53 +0100
Subject: Create a hello world server

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

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

diff --git a/src/scm/webid-oidc/hello-world.scm b/src/scm/webid-oidc/hello-world.scm
new file mode 100644
index 0000000..cda88e4
--- /dev/null
+++ b/src/scm/webid-oidc/hello-world.scm
@@ -0,0 +1,117 @@
+(define-module (webid-oidc hello-world)
+  #:use-module (webid-oidc resource-server)
+  #:use-module (webid-oidc jti)
+  #: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 (ice-9 optargs)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 i18n)
+  #:use-module (ice-9 getopt-long)
+  #:use-module (ice-9 suspendable-ports)
+  #:use-module (sxml simple)
+  #:use-module (srfi srfi-19))
+
+(define (G_ text)
+  (let ((out (gettext text)))
+    (if (string=? out text)
+        ;; No translation, disambiguate
+        (car (reverse (string-split text #\|)))
+        out)))
+
+(define-public (main)
+  (setvbuf (current-output-port) 'none)
+  (setvbuf (current-error-port) 'none)
+  (setlocale LC_ALL "")
+  (bindtextdomain cfg:package cfg:localedir)
+  (textdomain cfg:package)
+  (let ((version-sym
+         (string->symbol (G_ "command-line|version")))
+        (help-sym
+         (string->symbol (G_ "comand-line|help")))
+        (port-sym
+         (string->symbol (G_ "comand-line|port"))))
+    (let ((options
+           (let ((option-spec
+                  `((,version-sym (single-char #\v) (value #f))
+                    (,help-sym (single-char #\h) (value #f))
+                    (,port-sym (single-char #\p) (value #t)))))
+             (getopt-long (command-line) option-spec))))
+      (cond
+       ((option-ref options help-sym #f)
+        (format #t (G_ "~a [OPTIONS]...
+
+Display your identity contained in the XXX-Agent header.
+
+Options:
+  -h, --~a:
+      display this help message and exit.
+  -v, --~a:
+      display the version information (~a) and exit.
+  -p PORT, --port=~a:
+      set the port to bind.
+")
+                (car (command-line))
+                help-sym version-sym
+                cfg:version
+                port-sym))
+       ((option-ref options version-sym #f)
+        (format #t (G_ "~a version ~a\n")
+                cfg:package cfg:version))
+       (else
+        (let ((port-string
+               (option-ref options port-sym "8080"))
+              (jti-list (make-jti-list)))
+          (unless (and (string->number port-string)
+                       (integer? (string->number port-string))
+                       (>= (string->number port-string) 0)
+                       (<= (string->number port-string) 65535))
+            (format (current-error-port)
+                    (G_ "The port should be a number between 0 and 65535.\n"))
+            (exit 1))
+          (let ((handler
+                 (lambda (request request-body)
+                   (if (eq? (request-method request) 'GET)
+                       (let ((agent (assoc-ref (request-headers request) 'xxx-agent)))
+                         (if (and agent (string->uri agent))
+                             (values
+                              (build-response
+                               #:headers '((content-type application/xhtml+xml)))
+                              (with-output-to-string
+                                (lambda ()
+                                  (sxml->xml
+                                   `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+                                           (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+                                                    (xml:lang "en"))
+                                                 (body
+                                                  (h1 "Hello, "
+                                                      (a (@ (href ,(uri->string (string->uri agent))))
+                                                         ,(uri->string (string->uri agent))) "!"))))))))
+                             (values
+                              (build-response #:code 401
+                                              #:reason-phrase "Unauthorized"
+                                              #:headers '((content-type application/xhtml+xml)))
+                              (with-output-to-string
+                                (lambda ()
+                                  (sxml->xml
+                                   `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+                                           (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+                                                    (xml:lang "en"))
+                                                 (body
+                                                  (h1 "Please authenticate!"))))))))))
+                       (values
+                        (build-response #:code 405
+                                        #:reason-phrase "Method Not Allowed"
+                                        #:headers '((content-type application/xhtml+xml)))
+                        (with-output-to-string
+                          (lambda ()
+                            (sxml->xml
+                             `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
+                                     (html (@ (xmlns "http://www.w3.org/1999/xhtml")
+                                              (xml:lang "en"))
+                                           (body
+                                            (h1 "Please issue a GET request."))))))))))))
+            (install-suspendable-ports!)
+            (run-server handler 'http (list #:port (string->number port-string))))))))))
-- 
cgit v1.2.3