WiLiKiにアクセス制御機能を付けた
説明するより実物を見たほうが早いでしょう。
以下はdiffです。
(物好きな人は)ご自由にお使いください
diff --git a/src/wiliki.scm b/src/wiliki.scm
index e1f15c8..89ce9ce 100644
--- a/src/wiliki.scm
+++ b/src/wiliki.scm
@@ -27,6 +27,8 @@
;;;
(define-module wiliki
+ (use file.util)
+ (use rfc.cookie)
(use srfi-1)
(use srfi-11)
(use srfi-13)
@@ -43,6 +45,7 @@
(use gauche.version)
(use gauche.parameter)
(use gauche.sequence)
+ (use wiliki.auth)
(use wiliki.format)
(use wiliki.page)
(use wiliki.db)
@@ -53,6 +56,7 @@
wiliki:language-link wiliki:make-navi-button
wiliki:top-link wiliki:edit-link wiliki:history-link
wiliki:all-link wiliki:recent-link wiliki:search-box
+ wiliki:login-link
wiliki:menu-links wiliki:page-title wiliki:breadcrumb-links
wiliki:wikiname-anchor wiliki:wikiname-anchor-string
wiliki:get-formatted-page-content
@@ -131,7 +135,11 @@
(define-wiliki-action v :read (pagename)
;; NB: see the comment in format-wikiname about the order of
;; wiliki-db-get and virtual-page? check.
- (cond [(wiliki:db-get pagename) => html-page]
+ (cond [(wiliki:db-get pagename) =>
+ (lambda (page)
+ (if (wiliki:acl-viewable? (wiliki) page)
+ (html-page page)
+ (errorf "Can't view the page ~s" pagename)))]
[(virtual-page? pagename) (html-page (handle-virtual-page pagename))]
[(equal? pagename (top-page-of (wiliki)))
(let1 toppage (make
@@ -166,7 +174,9 @@
,(if page
`(,#`"mtime: ,(ref page 'mtime)\n"
"\n"
- ,(ref page 'content))
+ ,(if (wiliki:acl-viewable? (wiliki) page)
+ (ref page 'content)
+ (format #f "Can't view the page ~s" pagename)))
`(,#`"mtime: 0\n"
"\n")))))
@@ -181,7 +191,13 @@
:content `((ul
,@(map (lambda (k)
`(li ,(wiliki:wikiname-anchor k)))
- (sort (wiliki:db-map (lambda (k v) k)) stringinteger :default 0)
(logmsg :convert cv-in)
+ (acl :convert cv-in :default #f)
(donttouch :default #f))
((if commit cmd-commit-edit cmd-preview)
- pagename content mtime logmsg donttouch #f))
+ pagename content mtime logmsg donttouch #f acl))
;;
;; History
;;
(define-wiliki-action h :read (pagename
(s :convert x->integer :default 0))
- (cmd-history pagename s))
+ (if (wiliki:acl-viewable? (wiliki) (wiliki:db-get pagename))
+ (cmd-history pagename s)
+ (errorf (errorf "Can't view the page ~s" pagename))))
(define-wiliki-action hd :read (pagename
(t :convert x->integer :default 0)
(t1 :convert x->integer :default 0))
- (cmd-diff pagename t t1))
+ (if (wiliki:acl-viewable? (wiliki) (wiliki:db-get pagename))
+ (cmd-diff pagename t t1)
+ (errorf (errorf "Can't view the page ~s" pagename))))
(define-wiliki-action hv :read (pagename
(t :convert x->integer :default 0))
- (cmd-viewold pagename t))
-
+ (if (wiliki:acl-viewable? (wiliki) (wiliki:db-get pagename))
+ (cmd-viewold pagename t)
+ (errorf (errorf "Can't view the page ~s" pagename))))
+
+(define-wiliki-action login :write (_
+ (user :default #f)
+ (pass :default #f))
+ (parameterize ([auth-db-path (ref (wiliki) 'password-path)]
+ [temporary-directory (ref (wiliki) 'session-dir)])
+ (cond
+ [(and user pass (auth-valid-password? user pass))
+ `(,(cgi-header
+ :cookies (construct-cookie-string
+ `(("SCMSESSID" ,(auth-new-session user))))
+ :location (wiliki:url :full "~a" (ref (wiliki) 'top-page))
+ :status "302 Moved"))]
+ [else
+ (html-page
+ (make
+ :title (string-append (title-of (wiliki))": "($$ "Login"))
+ :command "c=login"
+ :content
+ `(,@(if (or user pass)
+ `((span (@ (class "wiliki-alert"))
+ "Invalid user name or password"))
+ '())
+ (form
+ (@ (method POST) (action ,(wiliki:url)))
+ (input (@ (type hidden) (name c) (value login)))
+ (table
+ (tr (td "User name")
+ (td (input (@ (type text) (name user)))))
+ (tr (td "Password")
+ (td (input (@ (type password) (name pass)))))
+ (tr (td "")
+ (td (input (@ (type submit) (value ,($$ "Login")))))))))
+ ))])))
+
+(define-wiliki-action logout :read (_)
+ (parameterize ([temporary-directory (ref (wiliki) 'session-dir)])
+ (auth-delete-session! (ref (wiliki) 'session-id))
+ `(,(cgi-header
+ :cookies (construct-cookie-string
+ `(("SCMSESSID" "" :max-age 0)))
+ :location (wiliki:url :full "~a" (ref (wiliki) 'top-page))
+ :status "302 Moved"))))
+
;;================================================================
;; WiLiKi-specific formatting routines
;;
@@ -304,7 +370,8 @@
(wiliki:make-navi-button '() ($$ "Top"))))
(define (wiliki:edit-link page)
- (and (eq? (ref (wiliki) 'editable?) #t)
+ (and (and (eq? (ref (wiliki) 'editable?) #t)
+ (wiliki:acl-editable? (wiliki) page))
(wiliki:persistent-page? page)
(wiliki:make-navi-button `((p ,(ref page 'key)) (c e)) ($$ "Edit"))))
@@ -331,6 +398,14 @@
(class "navi-button")))
)))
+(define (wiliki:login-link)
+ (if (and (ref (wiliki) 'session-dir) (ref (wiliki) 'password-path))
+ (if (ref (wiliki) 'session-id)
+ `(,(string-append (symbol->string (ref (wiliki) 'user-name)) " | ")
+ (a (@ (href ,(url "c=logout"))) ,($$ "Logout")))
+ `((a (@ (href ,(url "c=login"))) ,($$ "Login"))))
+ '()))
+
(define (wiliki:breadcrumb-links page delim)
(define (make-link-comp rcomps acc)
(if (null? acc)
@@ -365,7 +440,8 @@
(ref page 'title)))))
(define (wiliki:default-page-header page opts)
- `(,@(wiliki:page-title page)
+ `((div (@ (align "right")) ,@(wiliki:login-link))
+ ,@(wiliki:page-title page)
(div (@ (align "right")) ,@(wiliki:breadcrumb-links page ":"))
(div (@ (align "right")) ,@(wiliki:menu-links page))
(hr)))
diff --git a/src/wiliki/core.scm b/src/wiliki/core.scm
index 58fc5d0..fcf0da9 100644
--- a/src/wiliki/core.scm
+++ b/src/wiliki/core.scm
@@ -34,12 +34,14 @@
(define-module wiliki.core
(use srfi-1)
(use srfi-13)
+ (use srfi-27)
(use gauche.parameter)
(use gauche.charconv)
(use gauche.logger)
(use file.util)
(use rfc.uri)
(use www.cgi)
+ (use wiliki.auth)
(use wiliki.page)
(use util.list)
(use util.match)
@@ -84,6 +86,9 @@
wiliki:contains-spam?
wiliki:ip-blacklist wiliki:ip-blacklist-append!
wiliki:from-blacklisted-ip?
+ wiliki:acl-editable?
+ wiliki:acl-viewable?
+ wiliki:acl-changeable?
))
(select-module wiliki.core)
@@ -165,6 +170,21 @@
:init-value 40)
(textarea-cols :accessor textarea-cols-of :init-keyword :textarea-cols
:init-value 80)
+ ;; Access control list
+ (acl :accessor acl :init-keyword :acl
+ :init-value '((default . all) (admin . all)))
+ (user-name :accessor user-name :init-keyword :user-name
+ :init-value 'default)
+ ;; Session
+ (session-dir :accessor session-dir :init-keyword :session-dir
+ :init-value #f)
+ (session-id :accessor session-id :init-value #f)
+ (session-lifetime :accessor session-lifetime :init-keyword :session-lifetime
+ :init-value 3600)
+ (session-gc-divisor :accessor session-gc-divisor
+ :init-keyword :session-gc-divisor :init-value 100)
+ (password-path :accessor password-path :init-keyword :password-path
+ :init-value #f)
))
;;;==================================================================
@@ -184,7 +204,14 @@
(lambda (param)
(let ((pagename (get-page-name self param))
(command (cgi-get-parameter "c" param))
- (language (cgi-get-parameter "l" param :convert string->symbol)))
+ (language (cgi-get-parameter "l" param :convert string->symbol))
+ (key (cgi-get-parameter "SCMSESSID" param)))
+ (when (ref self 'session-dir)
+ (when (> (/ 1 (ref (wiliki) 'session-gc-divisor)) (random-real))
+ (parameterize ([temporary-directory (ref (wiliki) 'session-dir)])
+ (auth-clean-sessions! (ref self 'session-lifetime))))
+ (when key
+ (set-session-user! self key)))
(parameterize ((wiliki:lang (or language (ref self'language))))
(cgi-output-character-encoding (wiliki:output-charset))
(setup-textdomain self language)
@@ -785,7 +812,8 @@
(write (list :ctime (ref page 'ctime)
:cuser (ref page 'cuser)
:mtime (ref page 'mtime)
- :muser (ref page 'muser)))
+ :muser (ref page 'muser)
+ :acl (ref page 'acl)))
(display (ref page 'content)))))
;; Raw acessors
@@ -829,7 +857,13 @@
(write-recent-changes db r)))
(define (wiliki:db-recent-changes)
- (read-recent-changes (check-db)))
+ (fold-right
+ (lambda (p acc)
+ (if (wiliki:acl-viewable? (wiliki) (wiliki:db-get (car p)))
+ (cons p acc)
+ acc))
+ '()
+ (read-recent-changes (check-db))))
(define (wiliki:db-fold proc seed)
(dbm-fold (check-db)
@@ -849,7 +883,11 @@
(sort
(dbm-fold (check-db)
(lambda (k v r)
- (if (pred k v) (acons k (read-from-string v) r) r))
+ (if (and (not (string-prefix? " " k))
+ (wiliki:acl-viewable? (wiliki) k v)
+ (pred k v))
+ (acons k (read-from-string v) r)
+ r))
'())
(get-optional maybe-sorter
(lambda (a b)
@@ -865,6 +903,56 @@
w v (cut string-contains-ci <> key))))
maybe-sorter)))
+;;; Access control
+(define-method wiliki:parents-acl ((page ) delim)
+ (define (append-acl! rev-list acc)
+ (let* ((name (string-join (reverse rev-list) delim))
+ (page (wiliki:db-get name)))
+ (if page
+ (append! acc (ref page 'acl))
+ acc)))
+ (let ((combs (string-split (ref page 'title) delim)))
+ (pair-fold append-acl! '() (cdr (reverse combs)))))
+
+(define-method wiliki:page-acl ((self ) (page ))
+ (append (ref page 'acl)
+ (wiliki:parents-acl page ":")
+ (ref self 'acl)))
+
+(define-method wiliki:acl-editable? ((self ) (page ))
+ (let* ((acl (wiliki:page-acl self page))
+ (auth (assoc (ref self 'user-name) acl)))
+ (if (and auth (member (cdr auth)'(all write)))
+ #t
+ #f)))
+
+(define-method wiliki:acl-viewable? ((self ) (page ))
+ (let* ((acl (wiliki:page-acl self page))
+ (auth (assoc (ref self 'user-name) acl)))
+ (if (and auth (member (cdr auth) '(all write read)))
+ #t
+ #f)))
+
+(define-method wiliki:acl-viewable? ((self ) key value)
+ (let ((page (apply make :title key (read-from-string value))))
+ (wiliki:acl-viewable? self page)))
+
+(define-method wiliki:acl-changeable? ((self ) (page ))
+ (let* ((acl (wiliki:page-acl self page))
+ (auth (assoc (ref self 'user-name) acl)))
+ (if (and auth (member (cdr auth) '(all)))
+ #t
+ #f)))
+
+;;; Session
+(define-method set-session-user! ((self ) key)
+ (guard (e [else #f])
+ (parameterize ([temporary-directory (ref self 'session-dir)])
+ (let* ((user (string->symbol (auth-get-session key))))
+ (slot-set! self 'session-id key)
+ (slot-set! self 'user-name user)
+ user))))
+
;;;==================================================================
;;; Event log
;;;
diff --git a/src/wiliki/edit.scm b/src/wiliki/edit.scm
index 4414a31..eb8255f 100644
--- a/src/wiliki/edit.scm
+++ b/src/wiliki/edit.scm
@@ -41,7 +41,7 @@
(define $$ gettext)
-(define (edit-form preview pagename content mtime logmsg donttouch)
+(define (edit-form preview pagename content mtime logmsg donttouch acl)
(define (buttons)
(if preview
`((input (@ (type submit) (name preview) (value ,($$ "Preview again"))))
@@ -74,6 +74,11 @@
(rows 2)
(cols ,(ref (wiliki)'textarea-cols)))
,logmsg)
+ ,@(if acl
+ (list
+ `(p ,($$ "Access control list (please write like this: ((default . read) (admin . all))"))
+ `(input (@ (type text) (name acl) (value ,acl))))
+ '())
(br)
,@(buttons)
(br)
@@ -134,27 +139,32 @@
(errorf "Can't edit the page ~s: the database is read-only" pagename))
(let* ((page (wiliki:db-get pagename #t))
(content (or (get-old-content page) (ref page 'content)))
+ (acl (ref page 'acl))
)
+ (unless (wiliki:acl-editable? (wiliki) page)
+ (errorf "Can't edit the page ~s: the page is not editable" pagename))
(wiliki:std-page
(make
:title pagename
:content
- (edit-form #f pagename content (ref page 'mtime) "" #f)))))
+ (edit-form #f pagename content (ref page 'mtime) "" #f
+ (and (wiliki:acl-changeable? (wiliki) page) acl))))))
-(define (cmd-preview pagename content mtime logmsg donttouch restricted)
+(define (cmd-preview pagename content mtime logmsg donttouch restricted acl)
(let ((page (wiliki:db-get pagename #t)))
(wiliki:std-page
(make
:title (format #f ($$ "Preview of ~a") pagename)
:content
(edit-form (preview-box (wiliki:format-content content))
- pagename content mtime logmsg donttouch)))))
+ pagename content mtime logmsg donttouch
+ acl)))))
;; DONTTOUCH - If #t, don't update RecentChanges.
;; LIMITED - #t indicates this edit is generated procedurally, like comment
;; feature. It is allowed if EDITABLE? == limited.
-(define (cmd-commit-edit pagename content mtime logmsg donttouch limited)
+(define (cmd-commit-edit pagename content mtime logmsg donttouch limited acl)
(let ((p (wiliki:db-get pagename #t))
(now (sys-time)))
@@ -165,13 +175,18 @@
(wiliki:redirect-page (ref (wiliki)'top-page)))
(define (update-page content)
- (when (page-changed? content (ref p 'content))
- (let1 new-content
- (parameterize ([wiliki:page-stack (list p)])
- (expand-writer-macros content))
+ (when (or (page-changed? content (ref p 'content))
+ (and acl
+ (not (equal? (read-from-string acl) (ref p 'acl)))))
+ (let ((new-content
+ (parameterize ([wiliki:page-stack (list p)])
+ (expand-writer-macros content)))
+ (aclist (and acl (read-from-string acl))))
+ (unless (list? aclist) (set! aclist '()))
(write-log (wiliki) pagename (ref p 'content) new-content now logmsg)
(set! (ref p 'mtime) now)
(set! (ref p 'content) new-content)
+ (when acl (set! (ref p 'acl) aclist))
(wiliki:db-put! pagename p :donttouch donttouch)))
(wiliki:redirect-page pagename))
@@ -238,6 +253,8 @@
(when (or (not editable)
(and (not limited) (eq? editable 'limited)))
(errorf "Can't edit the page ~s: the database is read-only" pagename)))
+ (unless (wiliki:acl-editable? (wiliki) p)
+ (errorf "Can't edit the page ~s: the page is not editable" pagename))
(cond
[(suspicious?)
=> (lambda (reason)
@@ -269,7 +286,10 @@
,(wiliki:format-diff-pre diff)
(a (@ (name "edit")) (hr))
,($$ "The following shows what you are about to submit. Please re-edit the content and submit again.
")
- ,@(edit-form #f (ref page 'key) content (ref page 'mtime) logmsg donttouch)
+ ,@(edit-form #f (ref page 'key) content (ref page 'mtime) logmsg
+ donttouch
+ (and (wiliki:acl-changeable? (wiliki) page)
+ (ref page 'acl)))
))))
(define (preview-box content)
diff --git a/src/wiliki/page.scm b/src/wiliki/page.scm
index 02d04d1..c4db8ae 100644
--- a/src/wiliki/page.scm
+++ b/src/wiliki/page.scm
@@ -71,6 +71,8 @@
(cuser :init-value #f :init-keyword :cuser)
(mtime :init-value #f :init-keyword :mtime)
(muser :init-value #f :init-keyword :muser)
+ ;; acl - Access control list.
+ (acl :init-value '() :init-keyword :acl)
))
;;==================================================================
[…] 前回に続いて、こんどはファイルのアップロード機能を付けました。 […]