-
Notifications
You must be signed in to change notification settings - Fork 2
/
chaton-entry
executable file
·112 lines (101 loc) · 4.11 KB
/
chaton-entry
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
#!/usr/bin/env gosh
;; Entrance of the room. Obtains a new client id from the comet daemon
;; and provide the "outer frame" of the chat room.
(add-load-path "@@server-data-dir@@")
(define-module chaton.entry
(use www.cgi)
(use rfc.http)
(use text.html-lite)
(use text.tree)
(use file.util)
(use srfi-1)
(export entry-main))
(select-module chaton.entry)
(define-constant +chaton-url+ "https://chaton.practical-scheme.net/")
(define-constant +viewer+ "@@comet-url@@:@@comet-port@@/")
(define-constant +credential+ "@@server-data-dir@@auth")
(define-constant +secure-connection?+
(list? (read-from-string "@@tls-settings@@")))
(define (entry-main args)
(set! (port-buffering (current-error-port)) :line)
(cgi-main (lambda (_) (emit-content (get-cid)))))
(define (get-cid)
(and-let* ([ (file-exists? +credential+) ]
[cred (file->string +credential+)])
(rxmatch-let (#/\/\/([^\/]+)\// +viewer+) (_ host)
(receive (status hdrs body) (http-get host #"/getcid?cred=~cred"
:secure +secure-connection?+)
(and (equal? status "200")
(guard (e [(<read-error> e) #f])
(let1 p (read-from-string body)
(and-let* ([ (list? p) ]
[ (every pair? p) ]
[x (assq 'cid p)])
(cdr x)))))))))
(define (emit-content cid)
(if cid
`(,(cgi-header :content-type "text/html; charset=utf-8")
,(the-page cid))
`(,(cgi-header :status "503" :content-type "text/plain; charset=utf-8")
"Service Temporarily Unavailable")))
(define (the-page cid)
(html:html
(html:head
(html:title "Chaton "@@room-name/escd@@)
(html:link :href "@@httpd-url@@@@url-path@@chaton.css" :rel "Stylesheet"
:type "text/css")
(html:link :href "@@httpd-url@@@@url-path@@var/index.rdf" :rel "alternate" :type "application/rss+xml")
(html:script :src "@@prototype-url@@" :type "text/javascript")
(html:script :src "@@httpd-url@@@@url-path@@@@chaton-js@@"
:type "text/javascript"))
(html:body :id "the-body" :onload "initMainBody();"
;; Title ------------------
(html:h1 :id "room-title"
(html:img :class "room-icon" :src "@@icon-url@@" :align "absmiddle" :alt "")
@@room-name/escd@@)
;; Right pane -------------
(html:div :id "right-pane"
(html:div :class "chaton-logo"
"Built on "(html:a :href +chaton-url+ "Chaton"))
(html:div :class "room-description" @@room-description/escd@@)
(html:div :class "room-links"
(html:a :href "@@httpd-url@@@@url-path@@search.html" "Search")
" | "(html:a :href "@@httpd-url@@@@url-path@@badge.html" "Badge")
" | "(html:a :href #"~|+chaton-url+|/doc/Tools" "Tools"))
)
;; Left pane --------------
(html:div :id "left-pane"
(html:div :id "navigation"
(html:a :href "a/yesterday" "Read Archive")
" | "(html:a :href "@@httpd-url@@@@url-path@@var/index.rdf" "RSS"))
(html:div :id "view-frame-container"
(html:iframe :src #"~|+viewer+|?c=~cid" :id "view-frame"))
(html:form :onsubmit "post(); return false;" :id "post-form"
(html:table
(html:tr
(html:td "Nickname:")
(html:td
(html:input :type "text" :name "nick" :id "post-nick")
(html:input :type "checkbox" :name "remember" :id "post-remember")
(html:label :for "remember" "Remember me")))
(html:tr
(html:td "Text:")
(html:td
(html:textarea :name "text" :id "post-text" :rows "3" :cols "40"))
(html:td :valign "bottom"
(html:input :type "submit" :name "submit" :id "post-submit"
:value "chat")))
(html:tr
(html:td)
(html:td
(html:input :type "checkbox" :name "post-by-return"
:id "post-by-return")
(html:label :for "post-by-return" "'Return' key to post (you can insert CR by shift+RET)"))))))
)))
;;;===================================================================
(select-module user)
(import chaton.entry)
(define main entry-main)
;; Local variables:
;; mode: scheme
;; end: