WiLiKiにファイルアップロード機能を付けた
前回に続いて、こんどはファイルのアップロード機能を付けました。
セキュリティとか何も考えてないので結構怖いけど、
まあ、誰も使わないので今のところ大丈夫(?)でしょう。
前回とのdiffを貼っつけておきます。
diff --git a/src/wiliki.scm b/src/wiliki.scm
index 89ce9ce..daad884 100644
--- a/src/wiliki.scm
+++ b/src/wiliki.scm
@@ -56,7 +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:login-link wiliki:attach-link
wiliki:menu-links wiliki:page-title wiliki:breadcrumb-links
wiliki:wikiname-anchor wiliki:wikiname-anchor-string
wiliki:get-formatted-page-content
@@ -340,7 +340,139 @@
`(("SCMSESSID" "" :max-age 0)))
:location (wiliki:url :full "~a" (ref (wiliki) 'top-page))
:status "302 Moved"))))
-
+
+(define-wiliki-action attach :write (pagename
+ (afile :default #f)
+ (name :default #f)
+ (supersede :default #f)
+ (delete :default #f))
+ (define (valid-file-name? name)
+ (if (or (rxmatch #/[\/\\\"\[\]~\s]/ name)
+ (rxmatch #/^(\.)*$/ name))
+ #f
+ #t))
+ (define (move-upload-file! upload-path)
+ (receive (port path)
+ (sys-mkstemp (build-path (ref (wiliki) 'attachment-dir) "attach-"))
+ (close-output-port port)
+ (move-file upload-path path :if-exists :supersede)
+ path))
+ (define (attach-form)
+ `((h1 ,($$ "Attach new file"))
+ (form (@ (method POST) (action ,(wiliki:url))
+ (enctype multipart/form-data))
+ (input (@ (type hidden) (name c) (value attach)))
+ (input (@ (type hidden) (name p) (value ,pagename)))
+ (h3 ,($$ "Upload file"))
+ (input (@ (type file) (name afile)))
+ (h3 ,($$ "File name"))
+ (input (@ (type text) (name name)
+ ,@(if (and (not afile) name) `((value ,name)) '())))
+ (input (@ (type checkbox) (name supersede)
+ (value on) (id supersede)))
+ (label (@ (for supersede)) ,($$ "Overwrite if exists"))
+ (br)
+ (input (@ (type submit) (value ,($$ "Upload")))))))
+ (define (attachment-list att editable?)
+ `((h1 ,($$ "Attachment files"))
+ (ul
+ ,@(map
+ (lambda (x)
+ `(li
+ ,@(if editable?
+ `((a (@ (href ,(url-full "~a&c=attach&name=~a&delete"
+ pagename (car x))))
+ "[delete]")
+ " ")
+ '())
+ (a (@ (href ,(url-full "~a&c=get&name=~a" pagename (car x))))
+ ,(car x))))
+ att))))
+ (define (append-extension name original)
+ (let ((ext (rxmatch #/(.+)(\.\w+$)/ original)))
+ (if ext
+ (let ((ext-len (- (rxmatch-end ext 2) (rxmatch-start ext 2)))
+ (len (string-length name))
+ (suffix (rxmatch-substring ext 2)))
+ (if (or (< len ext-len)
+ (not
+ (string-ci=? (substring name (- len ext-len) len)
+ suffix)))
+ (string-append name suffix)
+ name))
+ name)))
+ (define (do-upload! page)
+ (if (or (not name) (string= name ""))
+ (set! name (cadr afile))
+ (set! name (append-extension name (cadr afile))))
+ (let ((att (ref page 'attachments))
+ (size (file-size (car afile)))
+ (limit (ref (wiliki) 'attachment-size)))
+ (cond
+ [(not (valid-file-name? name))
+ (format #f "Invalid file name ~s" name)]
+ [(and (not supersede) (assoc name att))
+ (format #f "File ~s has already exists" name)]
+ [(> size limit)
+ (format #f "File size ~a bytes is greater than ~a bytes" size limit)]
+ [else
+ (set! att (wiliki:delete-attachment! name att))
+ (set! (ref page 'attachments)
+ (alist-cons name (move-upload-file! (car afile)) att))
+ (wiliki:db-put! pagename page :donttouch #t)
+ (format #f "File ~s was uploaded" name)])))
+ (define (do-delete! page)
+ (let ((att (ref page 'attachments)))
+ (cond
+ [(not (assoc name att))
+ (format #f "File ~s does not exist" name)]
+ [else
+ (set! (ref page 'attachments) (wiliki:delete-attachment! name att))
+ (wiliki:db-put! pagename page :donttouch #t)
+ (format #f "File ~s was deleted" name)])))
+
+ (let* ((page (wiliki:db-get pagename)) (message #f)
+ (editable? (and page
+ (ref (wiliki) 'attachment-dir)
+ (wiliki:acl-editable? (wiliki) page))))
+ (when editable?
+ (cond [afile
+ (set! message (do-upload! page))]
+ [(and delete name)
+ (set! message (do-delete! page))]))
+ (if (and page (wiliki:acl-viewable? (wiliki) page))
+ (html-page
+ (make
+ :title (string-append (title-of (wiliki))": "($$ "Attach File"))
+ :command "c=attach"
+ :content
+ `(,@(if message `((span (@ (class "wiliki-alert"))
+ ,message)) '())
+ ,@(if (wiliki:acl-editable? (wiliki) page)
+ (attach-form)
+ '())
+ ,@(attachment-list (ref page 'attachments) editable?)
+ )))
+ (errorf "Can't view the page ~s" pagename))))
+
+(define-wiliki-action get :read (pagename
+ (name :default #f)
+ (view :default #f))
+ (let ((page (wiliki:db-get pagename #f))
+ (header
+ (cond [(and view (attachment-content-type name)) =>
+ (cut cgi-header :content-type <>)]
+ [else
+ (cgi-header
+ :content-type "application/octet-stream"
+ :content-disposition: #`"attachment; filename=,name")])))
+ (if (and page name
+ (wiliki:acl-viewable? (wiliki) page)
+ (assoc name (ref page 'attachments)))
+ `(,header
+ ,(file->string (cdr (assoc name (ref page 'attachments)))))
+ (errorf "Can't view the page ~s" pagename))))
+
;;================================================================
;; WiLiKi-specific formatting routines
;;
@@ -370,11 +502,18 @@
(wiliki:make-navi-button '() ($$ "Top"))))
(define (wiliki:edit-link page)
- (and (and (eq? (ref (wiliki) 'editable?) #t)
- (wiliki:acl-editable? (wiliki) page))
+ (and (eq? (ref (wiliki) 'editable?) #t)
(wiliki:persistent-page? page)
+ (wiliki:acl-editable? (wiliki) page)
(wiliki:make-navi-button `((p ,(ref page 'key)) (c e)) ($$ "Edit"))))
+(define (wiliki:attach-link page)
+ (and (ref (wiliki) 'attachment-dir)
+ (wiliki:persistent-page? page)
+ (wiliki:acl-viewable? (wiliki) page)
+ (wiliki:make-navi-button
+ `((p ,(ref page 'key)) (c attach)) ($$ "Attach"))))
+
(define (wiliki:history-link page)
(and (ref (wiliki) 'log-file)
(wiliki:persistent-page? page)
@@ -428,6 +567,7 @@
(tr ,@(cond-list
((wiliki:top-link page) => td)
((wiliki:edit-link page) => td)
+ ((wiliki:attach-link page) => td)
((wiliki:history-link page) => td)
((wiliki:all-link page) => td)
((wiliki:recent-link page) => td))
@@ -508,6 +648,23 @@
(and-let* ([inter-prefix (inter-wikiname-prefix head)])
(values inter-prefix after)))
(values #f name))))
+ (define (attachment-name? name)
+ (if (string-prefix? "#" name)
+ (substring name 1 (string-length name))
+ #f))
+ (define (attachment-link arg)
+ (let* ((name (if (string-prefix? "#" arg)
+ (substring arg 1 (string-length arg))
+ arg))
+ (page (wiliki:formatting-page))
+ (file-url (url-full "~a&c=get&name=~a" (ref page 'title) name)))
+ (if (assoc name (ref page 'attachments))
+ (if (and (string-prefix? "#" arg) (attachment-content-type name))
+ `((img (@ (src ,file-url) (alt ,name))))
+ `((a (@ (href ,file-url)) ,name)))
+ `(,name (a (@ (href ,(url-full "~a&c=attach&name=~a"
+ (ref page 'title) name)))
+ "?")))))
(or (reader-macro-wikiname? name)
(receive (inter-prefix real-name) (inter-wikiname? name)
(cond [inter-prefix
@@ -523,6 +680,7 @@
;; the order in cmd-view.
[(or (wiliki:db-exists? real-name) (virtual-page? real-name))
(list (wiliki:wikiname-anchor real-name))]
+ [(attachment-name? real-name) => attachment-link]
[else
`(,real-name
(a (@ (href ,(url "p=~a&c=n" (cv-out real-name)))) "?"))]))
@@ -557,5 +715,13 @@
(define html-page wiliki:std-page) ; for backward compatibility
+(define (attachment-content-type name)
+ (cond
+ [(string-suffix-ci? ".gif" name) "image/gif"]
+ [(or (string-suffix-ci? ".jpg" name)
+ (string-suffix-ci? ".jpeg" name)) "image/jpeg"]
+ [(string-suffix-ci? ".png" name) "image/png"]
+ [else #f]))
+
(provide "wiliki")
diff --git a/src/wiliki/auth.scm b/src/wiliki/auth.scm
index 5cff2e6..8187b50 100644
--- a/src/wiliki/auth.scm
+++ b/src/wiliki/auth.scm
@@ -82,7 +82,7 @@
(define (write-passwd-file db)
(receive (port path) (sys-mkstemp (auth-db-path))
- (guard ([e (else (sys-unlink path) (raise e))])
+ (guard (e [else (sys-unlink path) (raise e)])
(dolist [entry db] (format port "~a:~a\n" (car entry) (cadr entry)))
(close-output-port port)
(sys-rename path (auth-db-path)))))
@@ -171,7 +171,7 @@
(boolean (user-exists? (read-passwd-file) user)))
;; API
-;; Simply returns list of (user-name hashed-pass). The returned list
+;; Simply returns a list of (user-name hashed-pass). The returned list
;; may be extended in future to have more info. This is a simple
;; wrapper to read-passwd-file now, but we can substitute the storage
;; layer later without changing public api.
@@ -184,6 +184,14 @@
;;;
;; API
+;; A parameter points to a directory where session records are stored.
+;; In future, it may be extended to hold
+(define auth-session-directory
+ (make-parameter (build-path (temporary-directory) "wiliki")))
+
+
+;; API
+;; Returns a session key that holds the given value.
(define (auth-new-session value)
(receive (port path)
(sys-mkstemp (build-path (temporary-directory) "wiliki-"))
diff --git a/src/wiliki/core.scm b/src/wiliki/core.scm
index fcf0da9..8dfe66b 100644
--- a/src/wiliki/core.scm
+++ b/src/wiliki/core.scm
@@ -89,6 +89,7 @@
wiliki:acl-editable?
wiliki:acl-viewable?
wiliki:acl-changeable?
+ wiliki:delete-attachment!
))
(select-module wiliki.core)
@@ -158,7 +159,7 @@
;; extra event log for diagnosis.
(event-log-file :init-keyword :event-log-file :init-value #f)
-
+
;; additional paths to search localized messages by gettext.
;; (e.g. /usr/local/share/locale)
(gettext-paths :accessor gettext-paths :init-keyword :gettext-paths
@@ -185,6 +186,11 @@
:init-keyword :session-gc-divisor :init-value 100)
(password-path :accessor password-path :init-keyword :password-path
:init-value #f)
+ ;; Attachment files
+ (attachment-dir :accessor attachment-dir :init-keyword :attachment-dir
+ :init-value #f)
+ (attachment-size :accessor attachment-size :init-keyword :attachment-size
+ :init-value 1048576)
))
;;;==================================================================
@@ -224,6 +230,7 @@
(else (error "Unknown command" command))
))))
:merge-cookies #t
+ :part-handlers `((afile file+name))
:on-error error-page)))
;; aux routines for wiliki-main
@@ -813,7 +820,8 @@
:cuser (ref page 'cuser)
:mtime (ref page 'mtime)
:muser (ref page 'muser)
- :acl (ref page 'acl)))
+ :acl (ref page 'acl)
+ :attachments (ref page 'attachments)))
(display (ref page 'content)))))
;; Raw acessors
@@ -953,6 +961,14 @@
(slot-set! self 'user-name user)
user))))
+;;; Attachments
+(define (wiliki:delete-attachment! name alist)
+ (let ((pair (assoc name alist)))
+ (when pair
+ (sys-unlink (cdr pair))
+ (set! alist (alist-delete! name alist)))
+ alist))
+
;;;==================================================================
;;; Event log
;;;
diff --git a/src/wiliki/edit.scm b/src/wiliki/edit.scm
index eb8255f..2af97f0 100644
--- a/src/wiliki/edit.scm
+++ b/src/wiliki/edit.scm
@@ -156,9 +156,10 @@
(make
:title (format #f ($$ "Preview of ~a") pagename)
:content
- (edit-form (preview-box (wiliki:format-content content))
- pagename content mtime logmsg donttouch
- acl)))))
+ (parameterize ([wiliki:formatting-page page])
+ (edit-form (preview-box (wiliki:format-content content))
+ pagename content mtime logmsg donttouch
+ acl))))))
;; DONTTOUCH - If #t, don't update RecentChanges.
;; LIMITED - #t indicates this edit is generated procedurally, like comment
@@ -169,6 +170,8 @@
(now (sys-time)))
(define (erase-page)
+ (fold (lambda (pair alist) (wiliki:delete-attachment! (car pair) alist))
+ (ref p 'attachments) (ref p 'attachments))
(write-log (wiliki) pagename (ref p 'content) "" now logmsg)
(set! (ref p 'content) "")
(wiliki:db-delete! pagename)
diff --git a/src/wiliki/format.scm b/src/wiliki/format.scm
index 911db08..adec62f 100644
--- a/src/wiliki/format.scm
+++ b/src/wiliki/format.scm
@@ -63,6 +63,7 @@
wiliki:sxml->stree
wiliki:format-diff-pre
wiliki:format-diff-line
+ wiliki:formatting-page
)
)
(select-module wiliki.format)
@@ -165,6 +166,8 @@
;; Page ======================================================
+(define wiliki:formatting-page (make-parameter #f))
+
(define (wiliki:format-content page)
(define (do-fmt content)
(expand-page (wiliki-parse-string content)))
@@ -176,9 +179,10 @@
(parameterize
((wiliki-page-stack (cons page (wiliki-page-stack))))
(if (string? (ref page 'content))
- (let1 sxml (do-fmt (ref page 'content))
- (set! (ref page'content) sxml)
- sxml)
+ (parameterize ([wiliki:formatting-page page])
+ (let1 sxml (do-fmt (ref page 'content))
+ (set! (ref page'content) sxml)
+ sxml))
(ref page 'content)))))
(else page)))
diff --git a/src/wiliki/page.scm b/src/wiliki/page.scm
index c4db8ae..6b61d25 100644
--- a/src/wiliki/page.scm
+++ b/src/wiliki/page.scm
@@ -73,6 +73,8 @@
(muser :init-value #f :init-keyword :muser)
;; acl - Access control list.
(acl :init-value '() :init-keyword :acl)
+ ;; attachments - attachment files.
+ (attachments :init-value '() :init-keyword :attachments)
))
;;==================================================================