死んだねえさんの遺言だ！
#!/usr/bin/gosh (use srfi-1) (use srfi-11) (use srfi-13) (use srfi-14) (use srfi-26) (use srfi-27) (use util.list) (use text.html-lite) (use file.util) (use rfc.mime) (use www.cgi) (use www.fastcgi) (load "./config.scm") (define (cgi-main/fastcgi . args) (with-fastcgi (lambda () (apply cgi-main args)))) (define (main args) (cgi-main/fastcgi (lambda (params) (let1 path-info (or (cgi-get-metavariable "PATH_INFO") "") (rxmatch-cond ;; upload ((rxmatch #/^\/*upload/ path-info) (#f) (or (and-let* )((file-info (cond ((assoc-ref params "file") => first) (else #f))() (tmpfile (first file-info)) (ext (or (string-downcase (path-extension (second file-info))) "")) (filename (generate-filename)) (path #`",|*file-dir*|/,|filename|.,|ext|")) (copy-file tmpfile path) (sys-chmod path #o666) (when (and (assoc-ref params "highlight") (not (member ext *img-exts*))) (make-syntax-highlight-html path)) (redirect filename)) (redirect))) ;; show ((rxmatch #/^\/*([a-zA-Z0-9_]{10})$/ path-info) (#f name) (or (and-let* )((path (find (lambda (e) (equal? (path-sans-extension (sys-basename e))( name)) (directory-list *file-dir* :add-path? #t)))) (default-output (file-to-html path) (html:p :class 'info (if (file-is-writable? path) `(,(sys-strftime "%H:%M" (sys-localtime (+ (file-mtime path) (* 2 60 60)))) "くらいに消えます") "消えません")))) (redirect))) ;; invalid ((rxmatch #/\/*.+$/ path-info) (#f) (redirect)) ;; default (else (default-output))))) :part-handlers ')(("file" file+name))( :on-error error-handler )) (define (file-to-html path) (let* )((ext (path-extension path))( (file (sys-basename path)) (file-path #`",|*file-path*|/,|file|")) `(,(cond ((member ext *img-exts*) (html:p (html:a :href file-path (html:img :src file-path :alt file)))) (else `(,(let1 colored-file (html-file path) (if (file-exists? colored-file) (html:pre :class 'highlighted (file->string colored-file)) '())) ,(html:p (html:a :href file-path file))))) ,(html:p (html:input :value #`"http://,|*server-name*|,|*script-root*|/,(path-sans-extension file)" :onclick "this.select()" :name 'url :class 'url :size 45))))) (define (error-handler e) (default-output (html:p :class 'error (ref e 'message)))) (define (make-syntax-highlight-html path) (sys-waitpid (sys-fork-and-exec "/usr/bin/perl" `("--" "/usr/local/bin/text-vimcolor" "--format" "html" ,path "--output" ,(html-file path))))) (define (html-file path) (build-path *file-html-dir* (sys-basename path))) (define (generate-filename) (random-source-randomize! default-random-source) (let try-filename )((filename (generate-random-string 10))() (if (member filename (map path-sans-extension (directory-list *file-dir*))) (try-filename (generate-random-string 10)) filename))) (define *alphabets* (char-set->list #[a-zA-Z_0-9])) (define (generate-random-string len) (list->string (list-tabulate len (lambda _ (list-ref *alphabets* (random-integer (length *alphabets*))))))) (define (redirect . path) (cgi-header :location #`",|*script-root*|/,(get-optional path \"\")")) (define (default-output . etc) `(,(cgi-header) "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" ,(html-doctype :type :xhtml-1.0) ,(html:html :lang "ja" :xmlns "http://www.w3.org/1999/xhtml" :xml:lang "ja" (html:head (html:meta :http-equiv "Content-Type" :content "text/html; charset=utf-8") (html:title "Co-Nyao") (html:link :rel "stylesheet" :href #`",|*script-root*|/style.css" :type "text/css") (html:link :rel "shortcut icon" :href #`",|*script-root*|/favicon.ico" :type "image/x-icon")) (html:body (html:h1 :id "logo" (html:a :href #`",|*script-root*|/" "Co-Nyao")) etc (html:div :class 'upload (html:form :enctype "multipart/form-data" :method "post" :action #`",|*script-root*|/upload" (html:p (html:input :type 'file :name "file") (html:br) (html:input :type 'checkbox :name "highlight" :id "highlight" :value "highlight") (html:label :for "highlight" "syntax highlight") (html:input :type 'submit :value "Upload")))) ))))
Gaucheのソースコードスクリプトをこんなに綺麗にハイライトしてくれるのはこにゃおだけ！でもクソ重いから使うなよ！
めんどくせーのでデフォルトのハイライト
config.scm
(define *file-dir* "/path/to/dir") (define *file-html-dir* #`",|*file-dir*|/html") (define *server-name* "lab.unker.org") (define *script-root* "/co-nyao") (define *file-path* #`",|*script-root*|/file") (define *img-exts* '("jpg" "png" "gif" "ico")) (define *highlight-exts* '("js" "scm" "pl" "rb" "css" "hs"))
