Changeset 629 for lang/scheme

Timestamp:

10/23/07 08:49:53 (14 months ago)

Author:

cho45

Message:

lang/scheme/bloscheme/bloscheme.scm:

コミットもれ

Files:

• lang/scheme/bloscheme/bloscheme.scm (modified) (3 diffs)

lang/scheme/bloscheme/bloscheme.scm

@@ -5 +5 @@
 (use util.list)
 (use srfi-1)
+(use srfi-13)
 (use srfi-19)
 (use www.cgi)
-
+(use gauche.parameter)
+
+(define *blog-title* "Bloscheme Test")
+(define *author* "id:jknaoya")
 (define *data-regexp* #/.txt$/)
 (define *data-directory* "data")
+(define *plugin-directory* "plugins")
 (define *entry-number* 7)
-
-(load "./template.scm")
+(define *default-flavour* "html")
+(define *server-root* #f) ; Auto if #f
+; (define *server-root* "http://example.com")
+
+(define path-info (make-parameter "/"))
+(define flavour (make-parameter "html"))
+(define title (make-parameter *blog-title*))
+(define template-hash-table
+  (make-parameter
+    (hash-table
+      'eq?
+      `(title . ,(title))
+      )))
+(define-method object-apply ((ht <hash-table>) (name <symbol>))
+               (hash-table-get ht name)
+               )
+(define (set-template-variable name val)
+  (hash-table-put! (template-hash-table) name val)
+  )
 
 ; 設定に従いファイルを列挙し、
@@ -35 +57 @@
 ; PATH_INFO にしたがってエントリをフィルタリング
 ; プラグイン?みたいなのもフィルタとして実装できる?
-(define (filter-by-path-info files)
-  #?=files
-  (let1 path-info (cgi-get-metavariable "PATH_INFO")
-        (if path-info
-          (rxmatch-cond
-            ((rxmatch #/^\/(\d{4})\/?$/ path-info)
-             [#f year]
-             (set! year (string->number year))
-             (filter (lambda (file)
-                       (= (date-year (hash-table-get file 'date)) year))
-                     files)
-             )
-            ((rxmatch #/^\/(\d{4})\/(\d\d)\/?$/ path-info)
-             [#f year month]
-             (set! year  (string->number year))
-             (set! month (string->number month))
-             (filter (lambda (file)
-                       (and (= (date-year  (hash-table-get file 'date)) year)
-                            (= (date-month (hash-table-get file 'date)) month)))
-                     files)
-             )
-            ((rxmatch #/^\/(\d{4})\/(\d\d)\/(\d\d)\/?$/ path-info)
-             [#f year month day]
-             (set! year  (string->number year))
-             (set! month (string->number month))
-             (set! day   (string->number day))
-             (filter (lambda (file)
-                       (and (= (date-year  (hash-table-get file 'date)) year)
-                            (= (date-month (hash-table-get file 'date)) month)
-                            (= (date-day   (hash-table-get file 'date)) day)))
-                     files)
-             )
-            (else
-              (if (not (string=? path-info "/"))
-                ; individual
-                (filter (lambda (file)
-                          (string=? (hash-table-get file 'name) path-info))
-                        files)
-                ; index
-                (take files *entry-number*))
-              ))
-          ; index
-          (take files *entry-number*)
-          )
-        )
+(define (filter-by-path-info params files)
+  (rxmatch-cond
+    ((rxmatch #/^\/(\d{4})\/?$/ (path-info))
+     [#f year]
+     (set! year (string->number year))
+     (filter (lambda (file)
+               (= (date-year (hash-table-get file 'date)) year))
+             files)
+     )
+    ((rxmatch #/^\/(\d{4})\/(\d\d)\/?$/ (path-info))
+     [#f year month]
+     (set! year  (string->number year))
+     (set! month (string->number month))
+     (filter (lambda (file)
+               (and (= (date-year  (hash-table-get file 'date)) year)
+                    (= (date-month (hash-table-get file 'date)) month)))
+             files)
+     )
+    ((rxmatch #/^\/(\d{4})\/(\d\d)\/(\d\d)\/?$/ (path-info))
+     [#f year month day]
+     (set! year  (string->number year))
+     (set! month (string->number month))
+     (set! day   (string->number day))
+     (filter (lambda (file)
+               (and (= (date-year  (hash-table-get file 'date)) year)
+                    (= (date-month (hash-table-get file 'date)) month)
+                    (= (date-day   (hash-table-get file 'date)) day)))
+             files)
+     )
+    (else
+      (if (not (string=? (path-info) "/"))
+        ; individual
+        (filter (lambda (file)
+                  (string-prefix? (path-info) (hash-table-get file 'name)))
+                files)
+        ; index
+        files)
+      ))
   )
 
 ; ソートするフィルタ
-(define (sort-entries files)
-  #?=files
+(define (sort-entries params files)
   (stable-sort files
                (lambda (a b)
                  (file-mtime>? (hash-table-get a 'path) (hash-table-get b 'path)))
                ))
+
+; プラグイン参照用
+(define (last params files)
+  files)
 
 ; 適用フィルタの定義
@@ -95 +113 @@
     sort-entries
     filter-by-path-info
+    last
     ))
+
+; ref に指定したフィルタのまえに proc を追加する
+(define (add-filter ref proc)
+  (update! *filters* (lambda (filters)
+                       (receive (before after) (split-at filters (list-index (pa$ eq? ref) filters))
+                                (append before (list proc) after))))
+  )
 
 (define (main args)
   (cgi-main
     (lambda (params)
-
-      ; フィルタを順に適用する
-      (define files (fold (lambda args
-                            (apply (car args) (cdr args)))
-                          (list-files)
-                          *filters*))
-      (tree->string (result
-                      (hash-table
-                        'eq?
-                        `(files . ,files)
-                        `(home  . ,(cgi-get-metavariable "SCRIPT_NAME"))
-                        `(path  . ,(values-ref (decompose-path (cgi-get-metavariable "SCRIPT_NAME")) 0))
-                        `(title . "Bloscheme Test")
-                        )))))
-  0)
-
-
-
+      (define plugins (directory-list *plugin-directory*
+                                      :filter (lambda (path)
+                                                (not (rxmatch #/^_|^(\.|\.\.)/ path))
+                                                )))
+      (define (process plugins)
+        (if (not (null? plugins))
+          (begin
+            (load #`"./,|*plugin-directory*|/,(car plugins)")
+            (process (cdr plugins))
+            ))
+        )
+      (process plugins)
+
+      (receive (dir name ext) (decompose-path (or (cgi-get-metavariable "PATH_INFO") "/"))
+               (flavour   (or ext *default-flavour*))
+               (path-info (if (and name (not (string=? name "index")))
+                            (string-join (list dir name) "/")
+                            (if (string=? dir "")
+                              "/"
+                              dir)))
+               )
+
+      (if (not *server-root*)
+        (set! *server-root* (string-append "http://" (cgi-get-metavariable "SERVER_NAME"))))
+
+
+      (let ([template-variables
+              `((files . ,(fold (lambda args ; フィルタを順に適用する
+                                  (apply (car args) params (cdr args)))
+                                (list-files)
+                                *filters*))
+                (home  . ,(cgi-get-metavariable "SCRIPT_NAME"))
+                (path  . ,(values-ref (decompose-path (or (cgi-get-metavariable "SCRIPT_NAME") "")) 0))
+                )])
+        (for-each set-template-variable
+                  (map car template-variables) (map cdr template-variables))
+        )
+
+      (load #`"./template-,(flavour).scm")
+
+      (tree->string (result (template-hash-table))))
+
+    :on-error (lambda (c)
+                (use text.html-lite)
+                `(,(cgi-header :content-type "text/html; charset=UTF-8" :status "500 Internal Server Error")
+                  ,(html-doctype :type :xhtml-1.0-strict)
+                  ,(html:html
+                     (html:head
+                       (html:title "Error " (html-escape-string (condition-ref c 'message)))
+                       (html:style :type "text/css" "
+                                   body {
+                                   margin: 0 10%;
+                                   background: #fff;
+                                   color: #555;
+                                   }
+
+                                   h1 {
+                                   color: #d06c6b;
+                                   font-weight: normal;
+                                   }
+
+                                   pre {
+                                   font-size: 90%;
+                                   padding: 1em;
+                                   line-height: 1.2;
+                                   background: #efefef;
+                                   border: 1px solid #ccc;
+                                   color: #555;
+                                   }
+                                   ")
+                                   )
+                       (html:body
+                         (html:h1 "Error")
+                         (html:pre (html-escape-string
+                                     (call-with-output-string
+                                       (cut
+                                         with-error-to-port
+                                         <>
+                                         ; 現在のスタックを表示しちゃうみたい
+                                         (cut report-error c)))))
+                         ) ; /body
+                       ) ; /html
+                     )
+                  )
+                ))
+
+
+