-
Notifications
You must be signed in to change notification settings - Fork 2
/
chaton-apilogin
69 lines (58 loc) · 2.35 KB
/
chaton-apilogin
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
#!/usr/bin/env gosh
;; A prototype of API access gateway
(add-load-path "@@server-data-dir@@")
(use www.cgi)
(use rfc.http)
(use rfc.uri)
(use file.util)
(use util.match)
(use scheme.list)
(use gauche.logger)
(use chaton)
(define-constant +logfile+ "@@server-data-dir@@/logs/api.log")
(define-constant +poster+ "@@httpd-url@@@@url-path@@@@cgi-script@@")
(define-constant +viewer+ "@@comet-url@@:@@comet-port@@/")
(define-constant +icon+ "@@icon-url@@")
(define-constant +credential+ "@@server-data-dir@@auth")
(define (main args)
(set! (port-buffering (current-error-port)) :line)
(log-open +logfile+)
(cgi-main handle-request))
(define (handle-request ps)
(let1 m (cgi-get-metavariable "REQUEST_METHOD")
(if (not (equal? m "POST"))
(reply-error "405 Method not allowed" m)
(check-login ps))))
(define (check-login ps)
(let ([who (cgi-get-parameter "who" ps)]
[fmt (cgi-get-parameter "s" ps :default "1")]) ; default for sexpr and s=0 for json for backward compatibility.
(cond [(not who) (reply-error "401 Unauthorized" "'who' parameter missing")]
[(get-cid) => (cute reply-ok who <> (equal? fmt "1"))]
[(reply-error "503 Service Unavailable" "couldn't obtain cid")])))
(define (get-cid)
(and-let* ([ (file-exists? +credential+) ]
[cred (file->string +credential+)])
(match-let1 (scheme host+port) (uri-ref +viewer+ '(scheme host+port))
(receive (status hdrs body)
(http-get host+port #"/getcid?cred=~cred"
:secure (equal? scheme "https"))
(and (equal? status "200")
(guard (e [(<read-error> e) #f])
(let1 p (read-from-string body)
(and (list? p) (every pair? p) p))))))))
(define (reply-ok name params sexp?)
(log-format "authenticated ~a (~a)" name (remote-addr))
`(,(cgi-header :content-type #`"application/,(if sexp? 'x-sexpr 'json); \
charset=utf-8"
:cache-control "no-cache")
,(chaton-alist->stree
`((post-uri . ,+poster+) (comet-uri . ,+viewer+)
(icon-uri . ,+icon+) (room-name . "@@room-name@@") ,@params)
sexp?)))
(define (reply-error msg reason)
(log-format "~a: ~a (~a)" msg reason (remote-addr))
(cgi-header :status msg))
(define (remote-addr) (cgi-get-metavariable "REMOTE_ADDR"))
;; Local variables:
;; mode: scheme
;; end: