SourceFifth » 履歴 » バージョン 2
Yuumi Yoshida, 2008-06-29 19:16
| 1 | 1 | Yuumi Yoshida | ＊リスト1：web-server.scm |
|---|---|---|---|
| 2 | 2 | Yuumi Yoshida | <pre> |
| 3 | 1 | Yuumi Yoshida | (use gauche.net) |
| 4 | (use rfc.uri) |
||
| 5 | (use www.cgi) |
||
| 6 | (use gauche.reload) |
||
| 7 | (use gauche.collection) |
||
| 8 | |||
| 9 | (add-load-path "./") |
||
| 10 | (use application) |
||
| 11 | |||
| 12 | (define error-page |
||
| 13 | "<html><body><h2>Error</h2></body></html>") |
||
| 14 | |||
| 15 | (define (web-server) |
||
| 16 | (let1 server-socket (make-server-socket 'inet 3030 :reuse-addr? #t) |
||
| 17 | (guard (e (else (socket-close server-socket) (raise e))) ; TODO |
||
| 18 | (while #t |
||
| 19 | (let1 client-socket (socket-accept server-socket) |
||
| 20 | (receive (path params) (get-request (socket-input-port client-socket)) |
||
| 21 | (reload-modified-modules) |
||
| 22 | (put-response |
||
| 23 | (guard (e (else (report-error e) error-page)) |
||
| 24 | (render path params)) |
||
| 25 | (socket-output-port client-socket))) |
||
| 26 | (socket-close client-socket)))))) |
||
| 27 | |||
| 28 | (define (get-request in-port) |
||
| 29 | (cond ((rxmatch #/^GET\s+(\S+)\s/ (read-line in-port)) |
||
| 30 | => (lambda (m) |
||
| 31 | (parse-uri (rxmatch-substring m 1)))) |
||
| 32 | (else (values "" ())))) |
||
| 33 | |||
| 34 | (define (parse-uri uri) |
||
| 35 | (receive (host path query fragment) (uri-decompose-hierarchical uri) |
||
| 36 | (values path (cgi-parse-parameters :query-string (or query ""))))) |
||
| 37 | |||
| 38 | (define (put-response content out-port) |
||
| 39 | (display "HTTP/1.1 200 OK\r\n" out-port) |
||
| 40 | (display "Content-Type: text/html; charset=utf-8\r\n" out-port) |
||
| 41 | 2 | Yuumi Yoshida | (display #@"Content-Length: ,(string-size content)\r\n" out-port) |
| 42 | 1 | Yuumi Yoshida | (display "\r\n" out-port) |
| 43 | (display content out-port)) |
||
| 44 | |||
| 45 | (web-server) |
||
| 46 | 2 | Yuumi Yoshida | </pre> |
| 47 | 1 | Yuumi Yoshida | |
| 48 | ＊リスト2：simple-template.scm |
||
| 49 | 2 | Yuumi Yoshida | <pre> |
| 50 | 1 | Yuumi Yoshida | (define-module simple-template |
| 51 | (use file.util) |
||
| 52 | (export template templ-render)) |
||
| 53 | (select-module simple-template) |
||
| 54 | |||
| 55 | (define-macro (template tmpl-file . args) |
||
| 56 | 2 | Yuumi Yoshida | @(templ-render ,tmpl-file (quote ,args) (list ,@args))) |
| 57 | 1 | Yuumi Yoshida | |
| 58 | (define (templ-render templ-file vars args) |
||
| 59 | (apply (eval (templ-func templ-file vars) (interaction-environment)) |
||
| 60 | args)) |
||
| 61 | |||
| 62 | (define (templ-func templ-file vars) |
||
| 63 | (read-from-string |
||
| 64 | 2 | Yuumi Yoshida | #@"(lambda ,vars |
| 65 | 1 | Yuumi Yoshida | (let1 port (open-output-string) |
| 66 | ,(expand-templ (file->string templ-file)) |
||
| 67 | (get-output-string port)))")) |
||
| 68 | |||
| 69 | (define (expand-templ templ) |
||
| 70 | (cond ((#/(.*?)<%25=(.*?)%25>(.*)/ templ) |
||
| 71 | => (lambda(m) |
||
| 72 | 2 | Yuumi Yoshida | #@",(expand-templ (m 1)) (display ,(m 2) port) ,(expand-templ (m 3))")) |
| 73 | 1 | Yuumi Yoshida | ((#/(.*?)<%25(.*?)%25>(.*)/ templ) |
| 74 | => (lambda(m) |
||
| 75 | 2 | Yuumi Yoshida | #@",(expand-templ (m 1)) ,(m 2) ,(expand-templ (m 3))")) |
| 76 | 1 | Yuumi Yoshida | (else (format "(display ~s port)" templ)))) |
| 77 | |||
| 78 | (provide "simple-template") |
||
| 79 | 2 | Yuumi Yoshida | </pre> |
| 80 | 1 | Yuumi Yoshida | |
| 81 | ＊リスト3：application.scm |
||
| 82 | 2 | Yuumi Yoshida | <pre> |
| 83 | 1 | Yuumi Yoshida | (define-module application |
| 84 | (use srfi-13) |
||
| 85 | (use www.cgi) |
||
| 86 | (use dbi) |
||
| 87 | (use gauche.collection) |
||
| 88 | (use simple-template) |
||
| 89 | (export render)) |
||
| 90 | (select-module application) |
||
| 91 | |||
| 92 | (define *db-name* "dbi:sqlite3:alih.db") |
||
| 93 | |||
| 94 | (define-macro (db-let* db-conn vars . body) |
||
| 95 | 2 | Yuumi Yoshida | @(let1 ,db-conn (dbi-connect *db-name*) |
| 96 | 1 | Yuumi Yoshida | (guard |
| 97 | (e (else (dbi-close ,db-conn) (raise e))) |
||
| 98 | (let* (,@vars |
||
| 99 | (ret-value (begin ,@body))) |
||
| 100 | (dbi-close ,db-conn) |
||
| 101 | ret-value)))) |
||
| 102 | |||
| 103 | (define (render path params) |
||
| 104 | (cond ((string= path "/edit") (edit params)) |
||
| 105 | ((string= path "/update") (update params)) |
||
| 106 | (else (index params)))) |
||
| 107 | |||
| 108 | (define (index params) |
||
| 109 | (db-let* conn |
||
| 110 | ((res (dbi-do conn |
||
| 111 | "SELECT id, no, name, g FROM player WHERE pos='F' ORDER BY no")) |
||
| 112 | (getter (relation-accessor res))) |
||
| 113 | (template "list.tmpl" res getter))) |
||
| 114 | |||
| 115 | (define (edit params) |
||
| 116 | (db-let* conn |
||
| 117 | ((id (cgi-get-parameter "id" params)) |
||
| 118 | (res (dbi-do conn |
||
| 119 | "SELECT id, no, name, g FROM player WHERE id=?" |
||
| 120 | '() |
||
| 121 | id)) |
||
| 122 | (getter (relation-accessor res))) |
||
| 123 | (template "edit.tmpl" res getter))) |
||
| 124 | |||
| 125 | (define (update params) |
||
| 126 | (db-let* conn () |
||
| 127 | (dbi-do conn |
||
| 128 | "UPDATE player SET no=?, name=?, g=? WHERE id=?" |
||
| 129 | '() |
||
| 130 | (cgi-get-parameter "no" params) |
||
| 131 | (cgi-get-parameter "name" params) |
||
| 132 | (cgi-get-parameter "g" params) |
||
| 133 | (cgi-get-parameter "id" params)) |
||
| 134 | (template "update.tmpl"))) |
||
| 135 | |||
| 136 | (provide "application") |
||
| 137 | 2 | Yuumi Yoshida | </pre> |
| 138 | 1 | Yuumi Yoshida | |
| 139 | ＊リスト4：list.tmpl |
||
| 140 | 2 | Yuumi Yoshida | <pre> |
| 141 | 1 | Yuumi Yoshida | <html> |
| 142 | <body> |
||
| 143 | <h2>Asia League Ice Hockey</h2> |
||
| 144 | <table border="1"> |
||
| 145 | <form action="edit"> |
||
| 146 | <%25 (for-each (lambda (row) %25> |
||
| 147 | <tr> |
||
| 148 | <td><input type="radio" name="id" value="<%25= (getter row "id")%25>"></td> |
||
| 149 | <td><%25= (getter row "no") %25></td> |
||
| 150 | <td><%25= (getter row "name") %25></td> |
||
| 151 | <td><%25= (getter row "g") %25></td> |
||
| 152 | </tr> |
||
| 153 | <%25 ) res) %25> |
||
| 154 | </table> |
||
| 155 | <input type="submit" value="Edit"> |
||
| 156 | </form> |
||
| 157 | </body> |
||
| 158 | </html> |
||
| 159 | 2 | Yuumi Yoshida | </pre> |
| 160 | 1 | Yuumi Yoshida | |
| 161 | ＊リスト5：edit.tmpl |
||
| 162 | 2 | Yuumi Yoshida | <pre> |
| 163 | 1 | Yuumi Yoshida | <html> |
| 164 | <body> |
||
| 165 | <h2>Edit</h2> |
||
| 166 | <form action="update"> |
||
| 167 | <%25 (let1 row (find (lambda (x) #t) res) %25> |
||
| 168 | <input type="hidden" name="id" value="<%25= (getter row "id")%25>"> |
||
| 169 | <table border="0"> |
||
| 170 | <tr><td>No: </td><td><input type="text" name="no" value="<%25= (getter row "no")%25>"></td></tr> |
||
| 171 | <tr><td>Name: </td><td><input type="text" name="name" value="<%25= (getter row "name")%25>"></td></tr> |
||
| 172 | <tr><td>Goal: </td><td><input type="text" name="g" value="<%25= (getter row "g")%25>"></td></tr> |
||
| 173 | <%25 ) %25> |
||
| 174 | </table> |
||
| 175 | <input type="submit" value="Update"> |
||
| 176 | </form> |
||
| 177 | </body> |
||
| 178 | </html> |
||
| 179 | 2 | Yuumi Yoshida | </pre> |
| 180 | 1 | Yuumi Yoshida | |
| 181 | ＊リスト6：update.tmpl |
||
| 182 | 2 | Yuumi Yoshida | <pre> |
| 183 | 1 | Yuumi Yoshida | <html> |
| 184 | <head> |
||
| 185 | <meta http-equiv="refresh" content="0;URL=/"> |
||
| 186 | </head> |
||
| 187 | <body></body> |
||
| 188 | </html> |
||
| 189 | 2 | Yuumi Yoshida | </pre> |
| 190 | 1 | Yuumi Yoshida | |
| 191 | ＊リスト7：application.scm |
||
| 192 | 2 | Yuumi Yoshida | <pre> |
| 193 | 1 | Yuumi Yoshida | (define-module application |
| 194 | (use srfi-13) |
||
| 195 | (use srfi-27) |
||
| 196 | (use www.cgi) |
||
| 197 | (use dbi) |
||
| 198 | (use gauche.collection) |
||
| 199 | (use simple-template) |
||
| 200 | (export render)) |
||
| 201 | (select-module application) |
||
| 202 | |||
| 203 | (define *db-name* "dbi:sqlite3:alih.db") |
||
| 204 | (define *conts* (make-hash-table 'eqv?)) |
||
| 205 | (define *max-cid* (expt 2 64)) |
||
| 206 | |||
| 207 | |||
| 208 | (define (get-cont params) |
||
| 209 | (hash-table-get *conts* |
||
| 210 | (cgi-get-parameter "@cont@" params :convert string->number) |
||
| 211 | #f)) |
||
| 212 | |||
| 213 | (define (push-cont! cont) |
||
| 214 | (let1 cid (random-integer *max-cid*) |
||
| 215 | (cond ((hash-table-get *conts* cid #f) (push-cont! cont)) |
||
| 216 | (else (hash-table-put! *conts* cid cont) cid)))) |
||
| 217 | |||
| 218 | (define-macro (db-let* db-conn vars . body) |
||
| 219 | 2 | Yuumi Yoshida | @(let1 ,db-conn (dbi-connect *db-name*) |
| 220 | 1 | Yuumi Yoshida | (guard |
| 221 | (e (else (dbi-close ,db-conn) (raise e))) |
||
| 222 | (let* (,@vars |
||
| 223 | (ret-value (begin ,@body))) |
||
| 224 | (dbi-close ,db-conn) |
||
| 225 | ret-value)))) |
||
| 226 | |||
| 227 | (define-macro (define-continuation args . body) |
||
| 228 | 2 | Yuumi Yoshida | @(push-cont! (lambda ,args ,@body))) |
| 229 | 1 | Yuumi Yoshida | |
| 230 | |||
| 231 | (define (render path params) |
||
| 232 | (cond ((get-cont params) => (lambda(c) (c params))) |
||
| 233 | ((string= path "/edit") (edit params)) |
||
| 234 | ((string= path "/update") (update params)) |
||
| 235 | (else (index params)))) |
||
| 236 | |||
| 237 | (define (index params) |
||
| 238 | (db-let* conn |
||
| 239 | ((res (dbi-do conn |
||
| 240 | "SELECT id, no, name, g FROM player WHERE pos='F' ORDER BY no")) |
||
| 241 | (getter (relation-accessor res))) |
||
| 242 | (template "list.tmpl" res getter))) |
||
| 243 | |||
| 244 | |||
| 245 | (define (edit params) |
||
| 246 | (db-let* conn |
||
| 247 | ((id (cgi-get-parameter "id" params)) |
||
| 248 | (res (dbi-do conn |
||
| 249 | "SELECT id, no, name, g FROM player WHERE id=?" |
||
| 250 | '() |
||
| 251 | id)) |
||
| 252 | (getter (relation-accessor res)) |
||
| 253 | (cid (define-continuation (params) |
||
| 254 | (db-let* conn () |
||
| 255 | (dbi-do conn |
||
| 256 | "UPDATE player SET no=?, name=?, g=? WHERE id=?" |
||
| 257 | '() |
||
| 258 | (cgi-get-parameter "no" params) |
||
| 259 | (cgi-get-parameter "name" params) |
||
| 260 | (cgi-get-parameter "g" params) |
||
| 261 | id) |
||
| 262 | (template "update.tmpl"))))) |
||
| 263 | (template "edit.tmpl" res getter cid))) |
||
| 264 | |||
| 265 | (provide "application") |
||
| 266 | 2 | Yuumi Yoshida | </pre> |
| 267 | 1 | Yuumi Yoshida | |
| 268 | ＊リスト8：edit.tmpl |
||
| 269 | 2 | Yuumi Yoshida | <pre> |
| 270 | 1 | Yuumi Yoshida | <html> |
| 271 | <body> |
||
| 272 | <h2>Edit</h2> |
||
| 273 | <form action="update"> |
||
| 274 | <%25 (let1 row (find (lambda (x) #t) res) %25> |
||
| 275 | <input type="hidden" name="@cont@" value="<%25= cid %25>"> |
||
| 276 | <table border="0"> |
||
| 277 | <tr><td>No: </td><td><input type="text" name="no" value="<%25= (getter row "no")%25>"></td></tr> |
||
| 278 | <tr><td>Name: </td><td><input type="text" name="name" value="<%25= (getter row "name")%25>"></td></tr> |
||
| 279 | <tr><td>Goal: </td><td><input type="text" name="g" value="<%25= (getter row "g")%25>"></td></tr> |
||
| 280 | <%25 ) %25> |
||
| 281 | </table> |
||
| 282 | <input type="submit" value="Update"> |
||
| 283 | </form> |
||
| 284 | </body> |
||
| 285 | </html> |
||
| 286 | 2 | Yuumi Yoshida | </pre> |