Gauche 関連情報

＊リスト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
"Error")

(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 ((#/(.?)<%25=(.?)%25>(.)/ templ)
=> (lambda(m)
#`",(expand-templ (m 1)) (display ,(m 2) port) ,(expand-templ (m 3))"))
((#/(.?)<%25(.?)%25>(.)/ 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
{{{


Asia League Ice Hockey


<%25 (for-each (lambda (row) %25>

">
<%25= (getter row "no") %25>
<%25= (getter row "name") %25>
<%25= (getter row "g") %25>

<%25 ) res) %25>





}}}

＊リスト5：edit.tmpl
{{{


Edit

<%25 (let1 row (find (lambda (x) #t) res) %25>
">

No: ">
Name: ">
Goal: ">
<%25 ) %25>





}}}

＊リスト6：update.tmpl
{{{






}}}

＊リスト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
{{{


Edit

<%25 (let1 row (find (lambda (x) #t) res) %25>
">

No: ">
Name: ">
Goal: ">
<%25 ) %25>





}}}