blob: cda88e469b6290de4a4528f01d9cfcd5cae00688 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
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))))))))))
|
