プロジェクト

全般

プロフィール

履歴

SourceFifth » 履歴 » リビジョン 2

リビジョン 1 (Yuumi Yoshida, 2008-06-29 19:16) → リビジョン 2/3 (Yuumi Yoshida, 2008-06-29 19:16) 

＊リスト1：web-server.scm 
 <pre> {{{ 
 (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: #`"Content-Length: ,(string-size content)\r\n" out-port)  
   (display "\r\n" out-port)  
   (display content out-port)) 

 (web-server) 
 </pre> }}} 

 ＊リスト2：simple-template.scm 
 <pre> {{{ 
 (define-module simple-template 
   (use file.util) 
   (export template templ-render)) 
 (select-module simple-template) 

 (define-macro (template tmpl-file . args) 
   @(templ-render `(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 #`"(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 #`",(expand-templ (m 1)) (display ,(m 2) port) ,(expand-templ (m 3))")) 
         ((#/(.*?)<%25(.*?)%25>(.*)/ templ)  
          => (lambda(m) 
               #@",(expand-templ #`",(expand-templ (m 1)) ,(m 2) ,(expand-templ (m 3))")) 
         (else (format "(display ~s port)" templ)))) 

 (provide "simple-template") 
 </pre> }}} 

 ＊リスト3：application.scm 
 <pre> {{{ 
 (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 `(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") 
 </pre> }}} 

 ＊リスト4：list.tmpl 
 <pre> {{{ 
 <html> 
   <body> 
     <h2>Asia League Ice Hockey</h2> 
     <table border="1"> 
     <form action="edit"> 
     <%25 (for-each (lambda (row) %25> 
       <tr> 
         <td><input type="radio" name="id" value="<%25= (getter row "id")%25>"></td> 
         <td><%25= (getter row "no") %25></td> 
         <td><%25= (getter row "name") %25></td> 
         <td><%25= (getter row "g") %25></td> 
       </tr> 
      <%25 ) res) %25> 
     </table> 
     <input type="submit" value="Edit"> 
     </form>  
   </body> 
 </html> 
 </pre> }}} 

 ＊リスト5：edit.tmpl 
 <pre> {{{ 
 <html> 
   <body> 
     <h2>Edit</h2> 
     <form action="update"> 
     <%25 (let1 row (find (lambda (x) #t) res)    %25> 
     <input type="hidden" name="id" value="<%25= (getter row "id")%25>"> 
     <table border="0"> 
       <tr><td>No: </td><td><input type="text" name="no" value="<%25= (getter row "no")%25>"></td></tr> 
       <tr><td>Name: </td><td><input type="text" name="name" value="<%25= (getter row "name")%25>"></td></tr> 
       <tr><td>Goal: </td><td><input type="text" name="g" value="<%25= (getter row "g")%25>"></td></tr> 
      <%25 ) %25> 
     </table> 
 <input type="submit" value="Update"> 
     </form>  
   </body> 
 </html> 
 </pre> }}} 

 ＊リスト6：update.tmpl 
 <pre> {{{ 
 <html> 
   <head> 
     <meta http-equiv="refresh" content="0;URL=/">  
   </head> 
   <body></body> 
 </html> 
 </pre> }}} 

 ＊リスト7：application.scm 
 <pre> {{{ 
 (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 `(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! `(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") 
 </pre> }}} 

 ＊リスト8：edit.tmpl 
 <pre> {{{ 
 <html> 
   <body> 
     <h2>Edit</h2> 
     <form action="update"> 
     <%25 (let1 row (find (lambda (x) #t) res)    %25> 
     <input type="hidden" name="@cont@" value="<%25= cid %25>"> 
     <table border="0"> 
       <tr><td>No: </td><td><input type="text" name="no" value="<%25= (getter row "no")%25>"></td></tr> 
       <tr><td>Name: </td><td><input type="text" name="name" value="<%25= (getter row "name")%25>"></td></tr> 
       <tr><td>Goal: </td><td><input type="text" name="g" value="<%25= (getter row "g")%25>"></td></tr> 
      <%25 ) %25> 
     </table> 
     <input type="submit" value="Update"> 
     </form>  
   </body> 
 </html> 
 </pre> }}}