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