Gauche:CGI:スケジュール予定表
- Gauche:CGI:スケジュール予定表:Shiro版
- Gauche:CGI:スケジュール予定表:Shiro版:ver1
- Gauche:CGI:スケジュール予定表:Shiro版:ver2
- Gauche:CGI:スケジュール予定表:Shiro版:ver3
- Gauche:CGI:スケジュール予定表:Shiro版:ver4
スケジュール予定表CGI
LL Weekend 2004最後のセッション「その場でどう書く」のお題になった スケジュール予定表CGIスクリプト。
- カレンダー表示
- 前後の月に移動
- 各日付にメモ入力
という機能＋時間があればおまけをつけろというやつ。
で、とりあえず作ってみました。
- Shiro(2004/08/28 20:21:17 PDT): このお題、cgiスクリプトのチュートリアルに 丁度いいかも。ということでShiroバージョンも作ってみます。 Gauche:CGI:スケジュール予定表:Shiro版
ストレージには gdbm を使ってて最初の方に *mydbfile* にパス指定してるので
適宜書き換えてみてください。
本当はこういうのって誰でも確実に使える fsdbm をデフォルトにしておくべきかな。
あと、忙しくアクセスするとDBへのアクセスが一時的に使えなくて Internal Error
が発生するので、 dbm-open 〜 dbm-close 間をもっと局所化するべきかもしれない。
あるいは、 DB ファイルを月毎あるいは日毎に分ける方がいいのかな?
- というわけでDBを月毎にわける方向にしてみた。 かなりちゃかちゃかツツキまくったけどエラー発生しなくなります。 この辺(DB関係)プロのノウハウとかコメントあれば是非。
- Shiro: temporary unavailableなので、そのエラーだけ検出して
少し待ってリトライかけるようにするって手もあります。WiLiKiのコードで
やってます。もっとシビアな環境では、リクエストの統計情報から
平均トランザクション時間はこれ以下じゃなくちゃ、ってのを出して
チューンしてゆくことになります。
*** ERROR: couldn't open gdbm file "/home/cut-sea/data/sched.db": Resource temporarily unavailable Stack Trace: _______________________________________ 0 (gdbm-open path (slot-ref self 'bsize) rwopt (slot-ref self 'file- ... At line 87 of "/usr/local/share/gauche/0.8.1/lib/dbm/gdbm.scm" 1 (dbm-open <gdbm> :path *mydbfile* :rw-mode :write) At line 78 of "/usr/pkg/libexec/cgi-bin/sched.scm" [Sun Aug 29 10:27:54 2004] [error] [client 127.0.0.1] Premature end of script headers: /usr/pkg/libexec/cgi-bin/sched.scm- WiLiKi-0.5/src/wiliki/db.scm
;; private procedures (define (db-try-open dbpath dbtype rwmode) ;; Try to open the database. If it receives EAVAIL error, wait for ;; one second and try again, up to *retry-limit* times. (define (try retry mode) (with-error-handler (lambda (e) (cond ((>= retry *retry-limit*) (raise e)) ((string-contains-ci (ref e 'message) *EAVAIL-message*) (sys-sleep 1) (try (+ retry 1) mode)) (else ;; we don't want to show the path of db to unknown ;; visitors (raise (make <error> :message #`"Couldn't open database file to ,|rwmode|."))))) (lambda () (dbm-open dbtype :path dbpath :rw-mode mode)))) ;; If db file does not exist, we open it with :write mode, ;; regardless of rwmode arg, so that the empty DB is created. ;; Note that race condition will not happen here. If there's no ;; DB and two process simultaneously came to this code, only ;; one can grab the write access of DB, and another will ;; be kept waiting until the initial content is committed. (try 0 (if (dbm-db-exists? dbtype dbpath) rwmode :write)) )
- WiLiKi-0.5/src/wiliki/db.scm
gauche-devel-jp にてShiroさんが書かれていたencodeのポイント
uriを含むHTML文書を作成する場合の順序は、
(1) uriを構成する各要素 (パス名のコンポーネントや、
queryの属性名、属性値等) に対してuri-encodeをかける。
(2) uriの要素をくっつける (ここで、query-stringのセパレータである'?'や'&'、
fragmentのセパレータである'#'が挿入される。これらのセパレータは
uri-encodeしてはいけない)
(3) html-encodeする
HTMLを受け取り、uriを解釈する側の順序はこの逆で、
(1') html-decodeする
(2') uriを要素毎に切り離す
(3') uriの各要素についてuri-decodeする
となります。但し、cgiの場合は受け取るのがhtmlではないので、
上記(2'), (3')の手順だけです。(1')はクライアント側で行われます。
(注) html-encode は html-escape に相当する処理です
バグ
- 特にメモ入力文字列にスペースいれたら+になる。これはクライアントがencodeしたやつをdecodeできてないからだと思うが、どの部分で直せば良いのかがまだ分からん。
- メモ入力文字列に HTML タグとかいれると NG です。
- 上のは uri-decode-string にオプション :cgi-decode #t をつけることで回避。
- ようやくテキストエリアにHTMLを入力しても大丈夫になった。
ある程度出来てしまうと emacs 上で単純に評価しても、DB のアクセス権限で 蹴られたりして、うまく実行出来なかったりするので telnet localhost 80 から GET リクエスト出したり、 ページソースを見ることで html-escape や uri-encode の処理を確認したりした。 結構デバッグがめんどくさい。 あとは http のエラーログかな。 今気付いたけどアクセスログの方には GET/POST や フォームデータなんかも uri-encode されたのが見えるので、 この辺も今度からデバッグに有用そうな気がする。
#! /usr/local/bin/gosh
(use srfi-1)
(use srfi-13)
(use srfi-19)
(use util.list)
(use text.tree)
(use text.html-lite)
(use rfc.uri)
(use www.cgi)
(use dbm)
(use dbm.gdbm)
;;=================
;; Configure
;;=================
(define *dbclass* <gdbm>)
(define *mydbpath* "/home/cut-sea/data/schedule/") ;; close path name with "/"
;;=================
;; Trivial's
;;=================
(define (dec n) (- n 1))
(define (inc n) (+ n 1))
(define (divisible? n d) (= (modulo n d) 0))
(define (indivisible? n d) (not (= (modulo n d) 0)))
(define (split lst n off sp)
(cond ((null? lst) '())
((> n (length lst)) (list (append lst
(make-list (- n (length lst)) sp))))
(else (cons (append (make-list off sp)
(take* lst (- n off)))
(split (drop* lst (- n off)) n 0 sp)))))
(define (get-ymd ymd)
(lambda (params)
(if (null? params)
#f
(if (equal? ymd (caar params))
(cadar params)
((get-ymd ymd) (cdr params))))))
(define get-year (get-ymd "year"))
(define get-month (get-ymd "month"))
(define get-day (get-ymd "day"))
(define (query->alist query val->val)
(map (lambda (l)
(cons (uri-decode-string (car l) :cgi-decode #t)
(val->val (uri-decode-string (cadr l) :cgi-decode #t))))
(map (lambda (v)
(string-split v #\=))
(string-split query #\&))))
(define (call-with-db-file file proc)
(let ((db (dbm-open *dbclass* :path file :rw-mode :write)))
(let ((ret (proc db)))
(dbm-close db)
ret)))
(define (get-db-contents file)
(call-with-db-file
file (lambda (db)
(dbm-map db (lambda (key val) (cons key val))))))
(define (put-to-db file key val)
(call-with-db-file
file (lambda (db)
(dbm-put! db key val))))
;;=================
;; literal
;;=================
(define *self* (sys-getenv "SCRIPT_NAME"))
(define *query* (sys-getenv "QUERY_STRING"))
(define *query-alist* (if (equal? *query* "")
#f
(query->alist *query* x->number)))
(define *content* (if (sys-getenv "CONTENT_LENGTH")
(let ((len (x->number (sys-getenv "CONTENT_LENGTH"))))
(let loop ((count 1)
(ret '()))
(if (> count len)
(list->string (reverse ret))
(loop (+ count 1) (cons (read-char) ret)))))
#f))
(define *content-alist* (if *content*
(query->alist *content* identity)
#f))
(define *month* '("January" "February" "March" "April" "May" "June"
"July" "August" "September" "October" "November" "December"))
(define *weekday* '("Sun" "Mon" "Tue" "Wed" "Thu" "Fri" "Sat"))
;;=================
;; Calendar
;;=================
(define (leap? year)
(if (indivisible? year 4) #f
(if (indivisible? year 100) #t
(if (indivisible? year 400) #f #t))))
(define (days-of year . month)
(let* ((feb (if (leap? year) 29 28))
(days `(31 ,feb 31 30 31 30 31 31 30 31 30 31)))
(if (null? month)
days
(list-ref days (- (car month) 1)))))
;; Zeller's formula. ref.) UNIX USER 2003-07
;;
(define (weekday-of year month day)
(when (<= month 2)
(dec! year)
(inc! month 12))
(modulo (+ year
(quotient year 4)
(- (quotient year 100))
(quotient year 400)
(quotient (+ (* 13 month) 8) 5)
day)
7))
(define (calendar year month)
(letrec ((month-name (lambda (m) (list-ref *month* (dec m)))))
(lambda (msg)
(cond ((eq? msg 'year) year)
((eq? msg 'month) month)
((eq? msg 'caps) (string-append (month-name month) " " (x->string year)))
((eq? msg 'cal) (let ((days (days-of year month))
(wday (weekday-of year month 1)))
(split (iota days 1) 7 wday "")))
((eq? msg 'next) (if (= month 12)
(calendar (inc year) 1)
(calendar year (inc month))))
((eq? msg 'prev) (if (= month 1)
(calendar (dec year) 12)
(calendar year (dec month))))
((eq? msg 'query) (string-append *self*
"?year=" (x->string year)
"&month=" (x->string month)))
((eq? msg 'ymd) (lambda (day)
(string-append (x->string year) "-"
(x->string month) "-"
(x->string day))))
((eq? msg 'dbname) (lambda (path)
(string-append path (x->string year) "."
(x->string month))))
(else (error "ERROR: No such message found. -- CALENDAR --" msg))))))
(define (get-year calendar) (calendar 'year))
(define (get-month calendar) (calendar 'month))
(define (caption calendar) (calendar 'caps))
(define (get-calendar calendar) (calendar 'cal))
(define (next-month calendar) (calendar 'next))
(define (prev-month calendar) (calendar 'prev))
(define (get-query calendar) (calendar 'query))
(define (make-ymd-form calendar day) ((calendar 'ymd) day))
(define (dbname path calendar) ((calendar 'dbname) path))
(define (current-calendar)
(let ((now (current-date)))
(calendar (ref now 'year) (ref now 'month))))
(define (make-table calendar)
(let* ((caps (caption calendar))
(year (x->string (get-year calendar)))
(month (x->string (get-month calendar)))
(link (string-append (get-query calendar) "&day="))
(cal (get-calendar calendar)))
(html:table :border 1
(html:caption caps)
(html:tr (map (lambda (s)
(html:th s))
*weekday*))
(map (lambda (w)
(html:tr
(map (lambda (d)
(html:th
(html:a :href (string-append link (x->string d)) d)))
w)))
cal))))
;;=================
;; main logic
;;=================
(write-tree
(cgi-header))
(write-tree
(html-doctype))
(let* ((now-cal (if *query-alist*
(calendar (cdr (assoc "year" *query-alist*))
(cdr (assoc "month" *query-alist*)))
(current-calendar)))
(prev-cal (prev-month now-cal))
(next-cal (next-month now-cal)))
(write-tree
(html:html
(html:head (html:meta :http-equiv "Content-type" :content "text/html" :charset "euc-jp")
(html:title "スケジュール予定表"))
(html:body
(html:a :href (get-query prev-cal) "<<=")
" スケジュール予定表 "
(html:a :href (get-query next-cal) "=>>")
(make-table now-cal)
(if *query-alist*
(if (assoc "day" *query-alist*)
(let ((day (cdr (assoc "day" *query-alist*))))
(html:form :action (get-query now-cal) :method "POST"
(let ((ymd (make-ymd-form now-cal day)))
(html:textarea :rows 10 :cols 40
:name ymd :wrap "virtual"
(let ((dbfile (dbname *mydbpath* now-cal)))
(if (and (file-exists? dbfile)
(assoc ymd (get-db-contents dbfile)))
(html-escape-string (cdr (assoc ymd (get-db-contents dbfile))))
"")))) (html:br)
(html:input :type "submit" :name "Send" :value "Commit")))
"")
"")
(if *content-alist*
(let* ((date-content (car *content-alist*))
(date (car date-content))
(content (cdr date-content))
(dbfile (dbname *mydbpath* now-cal)))
(put-to-db dbfile date content)
(html:pre (html-escape-string (string-append date " : " content))))
"")
))))
;; EOF