;; disfluis, 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 hello-world)
#:use-module (webid-oidc server endpoint)
#:use-module (webid-oidc server endpoint hello)
#:use-module (webid-oidc server log)
#:use-module (webid-oidc web-i18n)
#: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 (ice-9 match)
#:use-module (sxml simple)
#:use-module (sxml match)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (oop goops)
#:duplicates (merge-generics)
#:declarative? #t)
(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")))
(complete-corresponding-source-sym
(string->symbol (G_ "command-line|complete-corresponding-source")))
(help-sym
(string->symbol (G_ "command-line|help")))
(port-sym
(string->symbol (G_ "command-line|port")))
(log-file-sym
(string->symbol (G_ "command-line|log-file")))
(error-file-sym
(string->symbol (G_ "command-line|error-file"))))
(let ((options
(let ((option-spec
`((,complete-corresponding-source-sym (single-char #\S) (value #t))
(,version-sym (single-char #\v) (value #f))
(,help-sym (single-char #\h) (value #f))
(,log-file-sym (single-char #\l) (value #t))
(,error-file-sym (single-char #\e) (value #t))
(,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.
This program is covered by the GNU Affero GPL, version 3 or
later. This license requires you to provide a way for any user over
the network to download the complete corresponding source code (with
your modifications) at no cost. The server adds a \"Source:\" header
to all responses.
Options:
-S MEANS, --~a=MEANS:
specify a way to download the complete corresponding source
code. For instance, this would be an URI pointing to a tarball.
-h, --~a:
display this help message and exit.
-v, --~a:
display the version information (~a) and exit.
-p PORT, --~a=PORT:
set the port to bind.
-l FILE.log, --~a=FILE.log:
redirect the program standard output to FILE.log.
-e FILE.err, --~a=FILE.err:
redirect the program errors to FILE.err.
")
(car (command-line))
complete-corresponding-source-sym
help-sym version-sym
cfg:version
port-sym
log-file-sym
error-file-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"))
(means-string
(let ((str (option-ref options complete-corresponding-source-sym #f)))
(unless str
(format (current-error-port)
(G_ "You are legally required to link to the complete corresponding source code.\n"))
(exit 1))
str))
(log-file (option-ref options log-file-sym #f))
(error-file (option-ref options error-file-sym #f)))
(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))
(define greeter (make ))
(let ((handler
(lambda (request request-body)
(when log-file
(prepare-log-file log-file))
(when error-file
(prepare-error-file error-file))
(parameterize ((web-locale request))
(with-exception-handler
(lambda (exn)
(unless (web-exception? exn)
(raise-exception exn))
(values
(build-response
#:code (web-exception-code exn)
#:reason-phrase (web-exception-reason-phrase exn)
#:headers `((content-type application/xhtml+xml)))
(call-with-output-string
(cute sxml->xml
`(*TOP*
(*PI* xml "version=\"1.0\" encoding=\"utf-8\"")
(html (@ (xmlns "http://www.w3.org/1999/xhtml")
(xml:lang ,(W_ "xml-lang|en")))
(body
,(call-with-input-string
(format #f (W_ "Please authenticate
"))
xml->sxml)
,(if (user-message? exn)
(user-message-sxml exn)
(call-with-input-string
(format #f (W_ "No more information.
"))
xml->sxml)))))
<>))))
(lambda ()
(set! request
(let ((user
(match (assq-ref (request-headers request) 'xxx-agent)
((? string? (= string->uri (? uri? uri)))
uri)
(else #f))))
(build-request (request-uri request)
#:meta (if user `((user . ,user)) '())
#:headers (request-headers request)
#:version (request-version request)
#:method (request-method request))))
(receive (response response-body response-meta)
(handle greeter request request-body)
(when (port? response-body)
(set! response-body
(read-response-body response)))
(values response response-body)))
#:unwind? #t)))))
(install-suspendable-ports!)
(run-server handler 'http (list #:port (string->number port-string))))))))))