操作
＊リスト1：web-server.scm
(use gauche.net)
(use rfc.uri)
(use www.cgi)
(use gauche.reload)
(use gauche.collection)
(add-load-path "./")
(use application)
(define error-page
"<html><body><h2>Error</h2></body></html>")
(define (web-server)
(let1 server-socket (make-server-socket 'inet 3030 :reuse-addr? #t)
(guard (e (else (socket-close server-socket) (raise e))) ; TODO
(while #t
(let1 client-socket (socket-accept server-socket)
(receive (path params) (get-request (socket-input-port client-socket))
(reload-modified-modules)
(put-response
(guard (e (else (report-error e) error-page))
(render path params))
(socket-output-port client-socket)))
(socket-close client-socket))))))
(define (get-request in-port)
(cond ((rxmatch #/^GET\s+(\S+)\s/ (read-line in-port))
=> (lambda (m)
(parse-uri (rxmatch-substring m 1))))
(else (values "" ()))))
(define (parse-uri uri)
(receive (host path query fragment) (uri-decompose-hierarchical uri)
(values path (cgi-parse-parameters :query-string (or query "")))))
(define (put-response content out-port)
(display "HTTP/1.1 200 OK\r\n" out-port)
(display "Content-Type: text/html; charset=utf-8\r\n" out-port)
(display #@"Content-Length: ,(string-size content)\r\n" out-port)
(display "\r\n" out-port)
(display content out-port))
(web-server)
＊リスト2：simple-template.scm
(define-module simple-template
(use file.util)
(export template templ-render))
(select-module simple-template)
(define-macro (template tmpl-file . args)
@(templ-render ,tmpl-file (quote ,args) (list ,@args)))
(define (templ-render templ-file vars args)
(apply (eval (templ-func templ-file vars) (interaction-environment))
args))
(define (templ-func templ-file vars)
(read-from-string
#@"(lambda ,vars
(let1 port (open-output-string)
,(expand-templ (file->string templ-file))
(get-output-string port)))"))
(define (expand-templ templ)
(cond ((#/(.*?)<%=(.*?)%>(.*)/ templ)
=> (lambda(m)
#@",(expand-templ (m 1)) (display ,(m 2) port) ,(expand-templ (m 3))"))
((#/(.*?)<%(.*?)%>(.*)/ templ)
=> (lambda(m)
#@",(expand-templ (m 1)) ,(m 2) ,(expand-templ (m 3))"))
(else (format "(display ~s port)" templ))))
(provide "simple-template")
＊リスト3：application.scm
(define-module application
(use srfi-13)
(use www.cgi)
(use dbi)
(use gauche.collection)
(use simple-template)
(export render))
(select-module application)
(define *db-name* "dbi:sqlite3:alih.db")
(define-macro (db-let* db-conn vars . body)
@(let1 ,db-conn (dbi-connect *db-name*)
(guard
(e (else (dbi-close ,db-conn) (raise e)))
(let* (,@vars
(ret-value (begin ,@body)))
(dbi-close ,db-conn)
ret-value))))
(define (render path params)
(cond ((string= path "/edit") (edit params))
((string= path "/update") (update params))
(else (index params))))
(define (index params)
(db-let* conn
((res (dbi-do conn
"SELECT id, no, name, g FROM player WHERE pos='F' ORDER BY no"))
(getter (relation-accessor res)))
(template "list.tmpl" res getter)))
(define (edit params)
(db-let* conn
((id (cgi-get-parameter "id" params))
(res (dbi-do conn
"SELECT id, no, name, g FROM player WHERE id=?"
'()
id))
(getter (relation-accessor res)))
(template "edit.tmpl" res getter)))
(define (update params)
(db-let* conn ()
(dbi-do conn
"UPDATE player SET no=?, name=?, g=? WHERE id=?"
'()
(cgi-get-parameter "no" params)
(cgi-get-parameter "name" params)
(cgi-get-parameter "g" params)
(cgi-get-parameter "id" params))
(template "update.tmpl")))
(provide "application")
＊リスト4：list.tmpl
<html>
<body>
<h2>Asia League Ice Hockey</h2>
<table border="1">
<form action="edit">
<% (for-each (lambda (row) %>
<tr>
<td><input type="radio" name="id" value="<%= (getter row "id")%>"></td>
<td><%= (getter row "no") %></td>
<td><%= (getter row "name") %></td>
<td><%= (getter row "g") %></td>
</tr>
<% ) res) %>
</table>
<input type="submit" value="Edit">
</form>
</body>
</html>
＊リスト5：edit.tmpl
<html>
<body>
<h2>Edit</h2>
<form action="update">
<% (let1 row (find (lambda (x) #t) res) %>
<input type="hidden" name="id" value="<%= (getter row "id")%>">
<table border="0">
<tr><td>No: </td><td><input type="text" name="no" value="<%= (getter row "no")%>"></td></tr>
<tr><td>Name: </td><td><input type="text" name="name" value="<%= (getter row "name")%>"></td></tr>
<tr><td>Goal: </td><td><input type="text" name="g" value="<%= (getter row "g")%>"></td></tr>
<% ) %>
</table>
<input type="submit" value="Update">
</form>
</body>
</html>
＊リスト6：update.tmpl
<html>
<head>
<meta http-equiv="refresh" content="0;URL=/">
</head>
<body></body>
</html>
＊リスト7：application.scm
(define-module application
(use srfi-13)
(use srfi-27)
(use www.cgi)
(use dbi)
(use gauche.collection)
(use simple-template)
(export render))
(select-module application)
(define *db-name* "dbi:sqlite3:alih.db")
(define *conts* (make-hash-table 'eqv?))
(define *max-cid* (expt 2 64))
(define (get-cont params)
(hash-table-get *conts*
(cgi-get-parameter "@cont@" params :convert string->number)
#f))
(define (push-cont! cont)
(let1 cid (random-integer *max-cid*)
(cond ((hash-table-get *conts* cid #f) (push-cont! cont))
(else (hash-table-put! *conts* cid cont) cid))))
(define-macro (db-let* db-conn vars . body)
@(let1 ,db-conn (dbi-connect *db-name*)
(guard
(e (else (dbi-close ,db-conn) (raise e)))
(let* (,@vars
(ret-value (begin ,@body)))
(dbi-close ,db-conn)
ret-value))))
(define-macro (define-continuation args . body)
@(push-cont! (lambda ,args ,@body)))
(define (render path params)
(cond ((get-cont params) => (lambda(c) (c params)))
((string= path "/edit") (edit params))
((string= path "/update") (update params))
(else (index params))))
(define (index params)
(db-let* conn
((res (dbi-do conn
"SELECT id, no, name, g FROM player WHERE pos='F' ORDER BY no"))
(getter (relation-accessor res)))
(template "list.tmpl" res getter)))
(define (edit params)
(db-let* conn
((id (cgi-get-parameter "id" params))
(res (dbi-do conn
"SELECT id, no, name, g FROM player WHERE id=?"
'()
id))
(getter (relation-accessor res))
(cid (define-continuation (params)
(db-let* conn ()
(dbi-do conn
"UPDATE player SET no=?, name=?, g=? WHERE id=?"
'()
(cgi-get-parameter "no" params)
(cgi-get-parameter "name" params)
(cgi-get-parameter "g" params)
id)
(template "update.tmpl")))))
(template "edit.tmpl" res getter cid)))
(provide "application")
＊リスト8：edit.tmpl
<html>
<body>
<h2>Edit</h2>
<form action="update">
<% (let1 row (find (lambda (x) #t) res) %>
<input type="hidden" name="@cont@" value="<%= cid %>">
<table border="0">
<tr><td>No: </td><td><input type="text" name="no" value="<%= (getter row "no")%>"></td></tr>
<tr><td>Name: </td><td><input type="text" name="name" value="<%= (getter row "name")%>"></td></tr>
<tr><td>Goal: </td><td><input type="text" name="g" value="<%= (getter row "g")%>"></td></tr>
<% ) %>
</table>
<input type="submit" value="Update">
</form>
</body>
</html>
Yuumi Yoshida さんが約10年前に更新 · 3件の履歴