Gauche:CGI:スケジュール予定表

Gauche:CGI:スケジュール予定表



スケジュール予定表CGI

LL Weekend 2004最後のセッション「その場でどう書く」のお題になった スケジュール予定表CGIスクリプト。

  1. カレンダー表示
  2. 前後の月に移動
  3. 各日付にメモ入力

という機能+時間があればおまけをつけろというやつ。

で、とりあえず作ってみました。

ストレージには gdbm を使ってて最初の方に *mydbfile* にパス指定してるので 適宜書き換えてみてください。 本当はこういうのって誰でも確実に使える fsdbm をデフォルトにしておくべきかな。
あと、忙しくアクセスするとDBへのアクセスが一時的に使えなくて Internal Error が発生するので、 dbm-open 〜 dbm-close 間をもっと局所化するべきかもしれない。 あるいは、 DB ファイルを月毎あるいは日毎に分ける方がいいのかな?

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 に相当する処理です

バグ

  1. 特にメモ入力文字列にスペースいれたら+になる。これはクライアントがencodeしたやつをdecodeできてないからだと思うが、どの部分で直せば良いのかがまだ分からん。
  2. メモ入力文字列に HTML タグとかいれると NG です。

#! /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

Tags: CGI, Tutorial

More ...