私が初めてWiKiなるものに触れたのがWiLiKiで、 「すげぇ！こんなん作れちゃうのか〜信じられん」 と興奮したのを覚えてます。 WiKi Way とか読むと原理は簡単とか書いてたけど信用してなかった。 機能はめちゃめちゃ低いけどこんなんが作れるようになると嬉しいですね。 ちなみに一番最初のバージョンは113行でした。 cut-sea:2004/09/03 07:34:02 PDT
書式関係はこの辺にして、もっと本質的な部分としてMUSTなもの。
#! /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*)))))))
最初 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 を入れたときに & とかに 置き換わって表示されちゃいます。これは & としたいかなと。cut-sea:2004/09/04 01:07:15 PDT
</style ></head ><body><h1>MiniWiKi</h1 ><a href="?t=MiniWiKi&c=e">[編集]</a ><a href="?t=MiniWiKi">[トップ]</a
><p><a href="?t=MiniWiKi">MiniWiKi</a >へようこそ！<br />WiKi<a href="?t=WiKi&c=e">?</a >ですので気軽に書いてください。<br />このWiKi<a href="?t=WiKi&c=e">?</a >サイトはGauche<a href="?t=Gauche&c=e">?</a >という川合史朗氏の作成された<a href="?t=Scheme">Scheme</a >インタプリタにて実装しております。<br /><pre>このサイトの使い方<br />[編集]ボタンを押してください。<br />[トップ]を押してください。<br /><a href="?t=MiniWiKi">MiniWiKi</a >は<a href="?t=cut-sea">cut-sea</a >が作りました。</pre
><hr />個人のページ<br /><a href="?t=cut-sea">cut-sea</a ><br /><a href="?t=%26lt%3b%b0%d5%c3%cf%b0%ad%26gt%3b"><意地悪></a ><br /><a href="?t=%26lt%3bp%26gt%3b%26amp%3b%25%3f%2b%3d%23!%40%26lt%3b%2fp%26gt%3b"><p>&%?+=#!@</p></a ><br /><a href="?t=%26lt%3btt%26gt%3b%a4%b3%a4%f3%a4%ca%a5%da%a1%bc%a5%b8%26lt%3b%2ftt%26gt%3b"><tt>こんなページ</tt></a ><br /><br /><blockquote>この中がブロックになります。<br />わかるかな？Shiro<a href="?t=Shiro&c=e">?</a >さん<blockquote>入れ子です。しってますよね？<blockquote>入れ子は困る？そんなん言わないでよ。</blockquote >入れ子できまっせ。<a href="?t=cut-sea">cut-sea</a ><br /></blockquote > こんな感じでできますね。すばらしい！</blockquote ></p ></body ></html >
(define (wikiform->html text)
(with-input-from-string text
(lambda ()
(let loop ((line (read-line)))
(log-format *log* "~a" line) ;;<=ここね
(if (eof-object? line) ""
(cons (wikiline->html line) (loop (read-line))))))))
これがCGIが最初に受け取っているところなので、これでアクセスしてみると
Sep 4 20:59:19 wiki.scm[26466]: [[MiniWiKi]]へようこそ！ Sep 4 20:59:19 wiki.scm[26466]: [[WiKi]]ですので気軽に書いてください。 Sep 4 20:59:19 wiki.scm[26466]: この[[WiKi]]サイトは[[Gauche]]という川合史朗氏の作成された[[Scheme]]インタプリタにて実装しております。 Sep 4 20:59:19 wiki.scm[26466]: このサイトの使い方 Sep 4 20:59:19 wiki.scm[26466]: ---- Sep 4 20:59:19 wiki.scm[26466]: 個人のページ Sep 4 20:59:19 wiki.scm[26466]: [[cut-sea]] Sep 4 20:59:19 wiki.scm[26466]: [[<意地悪>]] Sep 4 20:59:19 wiki.scm[26466]: [[<p>&%?+=#!@</p>]] Sep 4 20:59:19 wiki.scm[26466]: [[<tt>こんなページ</tt>]] Sep 4 20:59:19 wiki.scm[26466]: <<< Sep 4 20:59:19 wiki.scm[26466]: #<eof>こうなります。と言うことでエスケープされた状態で(ブラウザからhttpd経由で) 受け取っているってことですよね？ とすると、これをデコードしてやらにゃならんと思うのですが、html-lite には無いですよね？
gosh> (dbm-map db (lambda (k v) (print k " : " v))) <意地悪> : 意地悪なページです。 (snip) <p>&%?+=#!@</p> : へんてこな名前のページです。 [[<p>&%?+=#!@</p>]]って名前ですよ。 <tt>こんなページ</tt> : おっけーな感じか？ (snip)WiLiKiで試すと<tt>こんなページ</tt>ってそのままdbに格納されてたので やっぱりおかしい。
teranishi:line->htmlのcondは、=>を使えば正規表現のマッチングを一回で済ますことができます。
あと、'* ||- 1||# 2||'のように、本来混在できないものが処理されてしまうようなのですが、問題ないのでしょうか。
teranishi: 個人的な趣味ですが、orsよりGaucheRefj:any-predを使いたいし、 line->htmlでは関数を2つ渡さずにGaucheRefj:composeを使いたいですね。 遅くなるかもしれませんが。