gauche cgi カレンダー

今年の初めの頃にやった写経。面白かった～これ。

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

#! /usr/local/bin/gosh

;; http://practical-scheme.net/wiliki/wiliki.cgi?Gauche:CGI:%E3%82%B9%E3%82%B1%E3%82%B8%E3%83%A5%E3%83%BC%E3%83%AB%E4%BA%88%E5%AE%9A%E8%A1%A8:Shiro%E7%89%88

(use srfi-1 :only (iota))
(use srfi-19)
(use util.list :only (slices))
(use text.html-lite)
(use text.tree)
(use gauche.sequence)
(use gauche.charconv)
(use gauche.parameter)
(use www.cgi)
(use dbm.gdbm)


;;
;; variables
;;

(define *db-name* "/var/www/cgi-bin/test/data/cal.data")

(define db (make-parameter #f))

(define *style* "
  span.planned {
                background-color : #ffcccc
                }
")

;;
;; utilities
;;

(define-syntax with-db
  (syntax-rules ()
    ((_ (db path) . body)
     (parameterize ((db (dbm-open <gdbm> :path path :rw-mode :write)))
       (with-error-handler
         (^e (dbm-close (db))
             (raise e))
         (^ _
            (begin0
                (begin . body)
              (dbm-close (db)))))))))

(define (db-key y m d)
  #`",|y|-,|m|-,|d|")

;;
;; calendar logic
;;

(define (make-month m y)
  (make-date 0 0 0 0 1 m y
             (date-zone-offset (current-date))))

(define (first-day-of-month date)
  (make-month (date-month date)
              (date-year date)))

(define (next-month date)
  (let ((m (date-month date))
        (y (date-year date)))
    (if (= m 12)
        (make-month 1 (+ y 1))
        (make-month (+ m 1) y))))

(define (prev-month date)
  (let ((m (date-month date))
        (y (date-year date)))
    (if (= m 1)
        (make-month 12 (- y 1))
        (make-month (- m 1) y))))

(define (days-of-month date)
  (inexact->exact
   (- (date->modified-julian-day (next-month date))
      (date->modified-julian-day (first-day-of-month date)))))

(define (date-slices-of-month date)
  (slices (append
           (make-list (date-week-day
                       (first-day-of-month date)) #f)
           (iota (days-of-month date) 1))
          7 #t #f))

;;
;; display
;;

(define (month->link date content)
  (html:a :href #`"?y=,(date-year date)&m=,(date-month date)" content ))

(define (date-cell year month date)
  (if date
      (html:a :href #`"?y=,|year|&m=,|month|&d=,|date|"
              (if (dbm-exists? (db)(db-key year month date))
                  (html:span :class "planned" date)
                  date))
      ""))

(define (calendar date)
  (html:table
   (html:tr (html:td (month->link (prev-month date) "←"))
            (html:td :colspan 5 :align "center"
                     #`",(date-year date)/,(date-month date)")
            (html:td (month->link (next-month date) "→")))
   (html:tr (map html:td
                 '("sun" "mon" "tue" "wed" "thu" "fri" "sut")))
   (map (^w (html:tr
             (map (^d (html:td (date-cell (date-year date)
                                          (date-month date)
                                          d)))
                  w)))
        (date-slices-of-month date))))

(define (page . content)
  `(,(cgi-header
      :contetn-type #`"text/html; char-set=,(gauche-character-encoding)")
    ,(html-doctype :type :xhtml-1.0-transitional)
    ,(html:html
      (html:head (html:title "schedule")
                 (html:style :type "text/css" *style*))
      (apply html:body content))))

;;
;; commands
;;

(define (cmd-show-calendar y m)
  (page
   (calendar (if (and y m (<= 1 m 12)(<= 1753 y))
                 (make-month m y)
                 (current-date)))))

(define (cmd-show-plan y m d)
  (let1 plan (dbm-get (db) (db-key y m d) "")
    (page
     (calendar (make-month m y))
     (html:form
      (html:p #`"schedule of ,|y|/,|m|/,d")
      (html:pre (html-escape-string plan))
      (html:a :href #`"?y=,|y|&m=,|m|&d=,|d|&c=e" "edit schdule")
      ))))

(define (cmd-change-plan y m d plan)
  (if (and plan (not (string=? plan "")))
      (dbm-put! (db) (db-key y m d) plan)
      (dbm-delete! (db)(db-key y m d)))
  (cgi-header :status "302 moved"
              :location #`"?y=,|y|&m=,|m|&d=,|d|"))

(define (cmd-edit-plan y m d)
  (let ((inp (cut html:input :type <> :name <> :value <>))
        (plan (dbm-get (db)(db-key y m d) "")))
    (page
     (html:form
      (html:p #`"schedule of  ,|y|/,|m|/,|d|")
      (inp "hidden" "c" "c")
      (inp "hidden" "y" (x->string y))
      (inp "hidden" "m" (x->string m))
      (inp "hidden" "d" (x->string d))
      (html:p (html:textarea :rows 8 :cols 40 :name "p"
                             (html-escape-string plan)))
      (html:p (html:input :type "submit" :name "submit" :value "modify"))))))

;;
;; main entry
;;

(define (main args)
  (cgi-main
   (^p (let1 cgp (cut cgi-get-parameter <> p :convert x->integer)
         (let ((y (cgp "y"))(m (cgp "m"))(d (cgp "d"))
               (cmd (cgi-get-parameter "c" p))
               (plan (cgi-get-parameter "p" p
                                        :convert (cut ces-convert <> "*jp"))))
           (with-db (db *db-name*)
                    (if (and y m d)
                        (cond ((equal? cmd "e")
                               (cmd-edit-plan y m d))
                              ((equal? cmd "c")
                               (cmd-change-plan y m d plan))
                              (else
                               (cmd-show-plan y m d)))
                        (cmd-show-calendar y m))))))))