Gauche:CGI:MiniWiKi

Gauche:CGI:MiniWiKi

MiniWiKi

メモ

私が初めてWiKiなるものに触れたのがWiLiKiで、 「すげぇ！こんなん作れちゃうのか〜信じられん」 と興奮したのを覚えてます。 WiKi Way とか読むと原理は簡単とか書いてたけど信用してなかった。 機能はめちゃめちゃ低いけどこんなんが作れるようになると嬉しいですね。 ちなみに一番最初のバージョンは113行でした。 cut-sea:2004/09/03 07:34:02 PDT

TODO

書式関係はこの辺にして、もっと本質的な部分としてMUSTなもの。

  1. DBアクセス中のリクエストに対する処置(一時DBアクセス不可対応)
  2. 書きこみの衝突（Ａさんedit,Bさんedit,Bさんcommit,Aさんcommit)時の処置
    1. ページ毎にバージョン（commitの度にincrement)番号に相当する数をもたせる。
    2. edit しようとしたらキーとしてバージョン番号を渡す
    3. commit 時にはバージョン番号を送らせる。
    4. 現在のバージョン番号と同じ番号ならDBに書きこんでバージョン番号をincrement
    5. 現在のバージョン番号より古いやつを送ってきたら衝突検出
      • 簡単なのはとりあえずエラーメッセージのページ出力
      • diff とってedit画面にしてやれば、なお親切なんだろう

ソース 

#! /usr/local/bin/gosh
(use dbm)
(use dbm.gdbm)
(use text.html-lite)
(use gauche.parameter)
(use gauche.charconv)
(use rfc.uri)
(use www.cgi)
(use srfi-13)
;(use gauche.logger)

;;===============================
;; user configuration
;;===============================
;(define *log* (log-open "/home/cut-sea/data/wiki.log")) ;; for logging
(define *db-file* "/home/cut-sea/data/wiki.db") ;; dbfile as storage
(define *wiki* "MiniWiKi")                      ;; top page
(define *wait-max* 10)
(define *DB-BUSY-message* "resource temporarily unavailable")

;;===============================
;; Style Sheet
;;===============================
(define *style* "
  body {
    font-family: verdana, arial, helvetica, sans-serif;
    color: black;
    background-color: #fffff8;
  }
  :link    { text-decoration: none; color: #00bb00; }
  :visited { text-decoration: none; color: #557722; }
  h1 { 
    text-align: center;
    font-size: 190%;
    color: #444400;
    margin-top: 20pt;
    margin-bottom: 20pt;
    border-bottom: solid thick #888844;
  }

  h2 {
    text-align: left;
    font-size: 150%;
    color: #448800;
    margin-top: 30pt;
    border-bottom: solid thin #448800;
  }

  h3, h4, h5, h6 {
     text-align: left;
     color: #448800;
     background: transparent;
  }
  h3 { font-size: 130% }
  h4 { font-size: 110% }
  h5 { font-size: 100% }
  h6 { font-size: 100%; font-style: italic }

  blockquote {
    background-color: #fffff0;
    border: dashed thin #ffbb22;
  }

  blockquote.preview {
    background-color: #eeffee;
    border: dashed thin #ff55cc;
  }

  pre {
    margin-left: 2em;
    margin-right: 2em;
    font-family: monospace;
    background-color: #bbccf8;
    border: solid thin #ff2222;
  }

  hr {
    width: 80%;
  }

  table {
    background-color: #eeeecc;
    border: solid thin #ffffee;
  }
  ")
;;===============================
;; for database
;;===============================
(define db (make-parameter #f))

(define (db-try-open dbtype dbpath)
  (define (try retry)
    (with-error-handler
      (lambda (e)
        (cond ((>= retry *wait-max*) (raise e))
              ((string-contains-ci (ref e 'message) *DB-BUSY-message*)
               (sys-sleep 1) (try (+ retry 1)))
              (else
               (raise
                (make <error> :message "Couldn't open database file.")))))
      (lambda ()
        (dbm-open dbtype
                  :path dbpath
                  :rw-mode :write
                  :key-convert #t
                  :value-convert #t))))
  (try 0))

(define-syntax with-db
  (syntax-rules ()
    ((with-db (db path) . body)
     (parameterize
         ((db (db-try-open <gdbm> path)))
       (with-error-handler
         (lambda (e) (dbm-close (db)) (raise e))
         (lambda ()
           (begin0
             (begin . body)
             (dbm-close (db)))))))))

;;===============================
;; construct HTML from WiKi form
;;===============================
(define eof? eof-object?)
(define (hr? line) (#/^----$/ line))
(define (p-sep? line) (#/^$/ line))
(define (pre? line) (#/^[ \t]+/ line))
(define (pre-in? line) (#/^\{\{\{$/ line))
(define (pre-out? line) (#/^\}\}\}$/ line))
(define (block-in? line) (#/^<<<$/ line))
(define (block-out? line) (#/^>>>$/ line))
(define (ul? line) (#/^-[ \t]+/ line))
(define (ol? line) (#/^#[ \t]+/ line))
(define (table? line) (#/^(\|\|.*)\|\|$/ line))
(define (tbl? line) (#/(.*)\|\|/ line))
(define (h*? line) (#/^\*{1,3}/ line))
(define (h2? line) (#/^\*[ \t]+/ line))
(define (h3? line) (#/^\*\*[ \t]+/ line))
(define (h4? line) (#/^\*\*\*[ \t]+/ line))
(define (br? line) (#/~%/ line))
(define (escape? line) (#/`([^`]+)`/ line))
(define (strong? line) (#/'''([^']+)'''/ line))
(define (em? line) (#/''([^']+)''/ line))
(define (wikiname? line) (#/\[\[([^\[]+)?\]\]/ line))

(define (wikiname->link ttl)
  (if (dbm-exists? (db) ttl)
      (html:a :href #`"?t=,(uri-encode-string ttl)"
              (html-escape-string ttl))
      (list (html-escape-string ttl)
            (html:a :href #`"?t=,(uri-encode-string ttl)&c=e" "?"))))

(define (wikiform->html text)
  (call-with-input-string text
    (lambda (in) (form->html in))))

(define (make-block->html terminate? return)
  (lambda (in)
    (define (loop tree line)
      (define (traverse-unit func)
        (loop (cons (func line) tree)
              (read-line in)))
      (define (traverse-block func)
        (loop (cons (func in) tree)
              (read-line in)))
      (define (traverse-lines func)
        (let* ((sub (func line in))
               (next-line (car sub))
               (subtree (cdr sub)))
          (loop (cons subtree tree) next-line)))
      (cond ((terminate? line) (return tree))
            ((h*? line) (traverse-unit h-block))
            ((hr? line) (traverse-unit hr-block))
            ((p-sep? line) (traverse-lines p-block))
            ((pre? line) (traverse-lines pre-lines))
            ((pre-in? line) (traverse-block pre-block))
            ((block-in? line) (traverse-block bq-block))
            ((ul? line) (traverse-lines ul-lines))
            ((ol? line) (traverse-lines ol-lines))
            ((table? line) (traverse-lines tr-lines))
            (else (traverse-lines p-block))))
    (loop '() (read-line in))))

(define form->html (make-block->html eof? reverse))
(define bq-block (make-block->html
                  (any-pred eof? block-out?)
                  (lambda (tree) (html:blockquote (reverse tree)))))

(define (h-block line)
  (define (return tag)
    (lambda (m)
      (tag (line->html (m 'after)))))
  (cond ((h2? line) => (return html:h2))
        ((h3? line) => (return html:h3))
        ((h4? line) => (return html:h4))))

(define (hr-block line)
  (html:hr))

(define (p-block line in)
  (define (return line tree)
    (cons line (html:p (reverse tree))))
  (define terminate?
    (any-pred eof? p-sep? h*? hr? pre? pre-in? block-in? block-out? ul? ol? table?))
  (define (loop tree line)
    (if (terminate? line)
        (return line tree)
        (loop (cons (line->html line) tree)
              (read-line in))))
  (loop '() (if (string=? line "")
                (read-line in)
                line)))

(define (pre-lines line in)
  (define (return line tree)
    (cons line (html:pre (reverse tree))))
  (define (loop tree line)
    (cond ((pre? line)
           => (lambda (m)
                (loop (cons (html:br)
                            (cons (m 'after) tree))
                      (read-line in))))
          (else (return line tree))))
  (loop '() line))

(define (pre-block in)
  (define (return tree) (html:pre (reverse tree)))
  (define terminate? (any-pred eof? pre-out?))
  (define (loop tree line)
    (if (terminate? line)
        (return tree)
        (loop (cons (html:br)
                    (cons line tree))
              (read-line in))))
  (loop '() (read-line in)))

(define (make-ul&ol self-pred? alter-pred? tag)
  (lambda (line in)
    (define (return line tree) (cons line tree))
    (define terminate?
      (any-pred eof? p-sep? h*? hr? pre? pre-in? block-in? block-out? table? alter-pred?))
    (define (list->ulol lst)
      (tag (map (lambda (item)
                  (html:li (line->html item)))
                lst)))
    (define (loop tree line)
      (cond ((terminate? line) (return line (list->ulol (reverse tree))))
            ((self-pred? line) => (lambda (m)
                                    (loop (cons (m 'after) tree)
                                          (read-line in))))
            (else (let ((last-line (car tree))
                        (prev-tree (cdr tree)))
                    (loop (cons (string-append last-line line) prev-tree)
                          (read-line in))))))
    (loop '() line)))

(define ul-lines (make-ul&ol ul? ol? html:ul))
(define ol-lines (make-ul&ol ol? ul? html:ol))

(define (tr-lines line in)
  (define (return line tree)
    (cons line (html:table :border 1 (reverse tree))))
  (define terminate?
    (any-pred eof? p-sep? h*? hr? pre? pre-in? block-in? block-out? ul? ol?))
  (define (line->tr line)
    (define (item->td item)
      (html:td (line->html item)))
    (let rec ((line line)
              (tree '()))
      (cond ((tbl? line) => (lambda (m)
                              (rec (m 1)
                                   (cons (item->td (m 'after))
                                         tree))))
            (else (html:tr tree)))))
  (define (loop tree line)
    (cond ((terminate? line) (return line tree))
          ((table? line) => (lambda (m)
                              (loop (cons (line->tr (m 1)) tree)
                                    (read-line in))))
          (else (return line tree))))
  (loop '() line))

(define (line->html line)
  (define (trans tag fn n)
    (lambda (m)
      (list (line->html (m 'before))
            (tag (fn (m n)))
            (line->html (m 'after)))))
  (cond ((escape? line) => (trans identity identity 1))
        ((strong? line) => (trans html:strong line->html 1))
        ((em? line) => (trans html:em line->html 1))
        ((br? line) => (trans (lambda (_) (html:br)) identity 0))
        ((wikiname? line) => (trans identity wikiname->link 1))
        (else line)))

;;===============================
;; command of generate page
;;===============================
(define (page . content)
  `(,(cgi-header
      :content-type #`"text/html; char-set=,(gauche-character-encoding)")
    ,(html:html
      (html:head (html:meta :http-equiv "Content-type"
                            :content "text/html"
                            :charset #`",(gauche-character-encoding)")
                 (html:title *wiki*)
                 (html:style :type "text/css" *style*))
      (apply html:body content))))

(define (cmd-show-page ttl)
;  (log-format *log* "*** cmd-show-page[~a] ***" ttl)
  (let* ((data (dbm-get (db) ttl (cons 0.0 "")))
         (key (car data))
         (article (cdr data)))
    (page
     (html:h1 (html-escape-string ttl))
     (html:a :href #`"?t=,(uri-encode-string ttl)&c=e" "[編集]")
     (html:a :href #`"?t=,(uri-encode-string *wiki*)" "[トップ]")
     (wikiform->html article))))

(define (cmd-edit-page ttl)
;  (log-format *log* "*** cmd-edit-page[~a] ***" ttl)
  (let* ((data (dbm-get (db) ttl (cons 0.0 "")))
         (key (car data))
         (article (cdr data)))
    (page
     (html:form :method "POST"
                (html:h1 (html-escape-string #`",|ttl|の編集"))
                (html:input :type "hidden" :name "c" :value "c")
                (html:input :type "hidden" :name "t" :value ttl)
                (html:input :type "hidden" :name "k" :value key)
                (html:p (html:input :type "submit" :name "commit" :value "変更")
                        (html:input :type "submit" :name "preview" :value "プレビュー"))
                (html:p (html:textarea :rows 45 :cols 100 :name "a"
                                       (html-escape-string article)))))))

(define (cmd-commit-page ttl art key)
;  (log-format *log* "*** cmd-commit-page[~a] ***" ttl)
  (let* ((data (dbm-get (db) ttl (cons 0.0 "")))
         (org-key (car data))
         (org-art (cdr data)))
    (cond ((= key org-key) (begin
                             (if (and art (not (string=? art "")))
                                 (dbm-put! (db) ttl (cons (+ key 0.1) art))
                                 (dbm-delete! (db) ttl))
                             (cgi-header :status "302 Moved"
                                         :location #`"?t=,(uri-encode-string ttl)")))
          ((< key org-key) (cmd-collision-page ttl art key))
          (else (cmd-illegal-error-page ttl)))))


(define (cmd-preview-page ttl art key)
;  (log-format *log* "*** cmd-preview-page[~a] ***" ttl)
  (page
   (html:h1 (html-escape-string ttl))
   (html:blockquote :class "preview"
                    (if art (wikiform->html art) (html:p)))
   (html:form :method "POST"
              (html:h2 (html-escape-string #`",|ttl|の編集"))
              (html:input :type "hidden" :name "c" :value "c")
              (html:input :type "hidden" :name "t" :value ttl)
              (html:input :type "hidden" :name "k" :value key)
              (html:p (html:input :type "submit" :name "commit" :value "変更")
                      (html:input :type "submit" :name "preview" :value "プレビュー"))
              (html:p (html:textarea :rows 45 :cols 100 :name "a"
                                     (html-escape-string art))))))

(define (cmd-collision-page ttl art key)
;  (log-format *log* "*** cmd-collision-page[~a] ***" ttl)
  (page
   (html:h1 (html-escape-string ttl))
   (html:p "衝突を検出しました！")))

(define (cmd-illegal-error-page ttl)
;  (log-format *log* "*** cmd-illegal-error-page[~a] ***" ttl)
  (page
   (html:h1 (html-escape-string ttl))
   (html:p "本来ありえない異常なアクセスを検出しました！")))

;;===============================
;; main logic
;;===============================
(define (main args)
  (cgi-main
   (lambda (params)
     (let ((ttl (cgi-get-parameter "t" params :convert (cut ces-convert <> "*jp")))
           (art (cgi-get-parameter "a" params :convert (cut ces-convert <> "*jp")))
           (cmd (cgi-get-parameter "c" params))
           (key (cgi-get-parameter "k" params :convert x->number))
           (sbm (cgi-get-parameter "commit" params))
           (prv (cgi-get-parameter "preview" params)))
       (with-db (db *db-file*)
                (if ttl
                    (cond ((not cmd) (cmd-show-page ttl))
                          ((string=? cmd "e")
                           (cmd-edit-page ttl))
                          ((string=? cmd "c")
                           (cond (sbm (cmd-commit-page ttl art key))
                                 (prv (cmd-preview-page ttl art key)))))
                    (cmd-show-page *wiki*)))))))

db 周辺

最初 with-db じゃなくて、自前で実装した macro を使ってたんだけど、 それだと db を掴んだ状態で再帰的に db を open しようとするところが あって(WiKiNameをみるところ)、ひたすらエラーと戦ってた。
で、ようやく parameter のありがたさが分かり、 Gauche:CGI:スケジュール予定表:Shiro版で解説された db まわりを

パクらせてもらって修正するところに落ち着いた。 とりあえず、WiLiKi同様の WiKiName のみをサポートした貧弱 WiKi ですけど。 Gauche:CGI:スケジュール予定表:Shiro版の構成を勉強したおかげで、 コード自体Gauche:CGI:スケジュール予定表を書いたときより ずっと綺麗に書けたと思う。

エスケープのポイント

Shiro (2004/09/03 19:14:47 PDT)現在のコードだと、ページタイトルに特殊文字が 入った場合がやばいですね。原則は次の通り。

どうにも uri-encode を忘れてしまいます。 書いているとユーザ側から見てどうなるとか受け取ったときにどうなっているとか、 まだまだ頭がついていけないっす。 ってのは言い訳で完全に忘れてました。 (use rfc.uri) すらしてなかったです。 ちなみに cmd-edit-page の html:h1 の内容のところを html-escape すると エンコードされて表示されるので、これは違うかなと思ったんで、やってません。 例えば & とかの名称を含む WiKiName を入れたときに &amp; とかに 置き換わって表示されちゃいます。これは & としたいかなと。cut-sea:2004/09/04 01:07:15 PDT

teranishi:line->htmlのcondは、=>を使えば正規表現のマッチングを一回で済ますことができます。

あと、'* ||- 1||# 2||'のように、本来混在できないものが処理されてしまうようなのですが、問題ないのでしょうか。

teranishi: 個人的な趣味ですが、orsよりGaucheRefj:any-predを使いたいし、 line->htmlでは関数を2つ渡さずにGaucheRefj:composeを使いたいですね。 遅くなるかもしれませんが。

Topics
Sponsored Links
Search
Recent Changes
More ...
Last modified : 2012/02/07 08:10:06 UTC
WiLiKi 0.8.3 running on Gauche 0.9.15