Changeset 626 for lang/scheme

Show
Ignore:
Timestamp:
10/23/07 08:49:51 (14 months ago)
Author:
cho45
Message:

lang/scheme,
lang/scheme/bloscheme,
lang/scheme/bloscheme/bloscheme.scm,
lang/scheme/bloscheme/template.scm:

bloscheme is a blosxom clone
id:jknaoya さんから代理でコミット

Location:
lang/scheme/bloscheme
Files:
1 added
1 modified

Legend:

Unmodified
Added
Removed

  • lang/scheme/bloscheme/bloscheme.scm

    r612 r626  
    55(use util.list) 
    66(use srfi-1) 
    7 (use srfi-13) 
    87(use srfi-19) 
    98(use www.cgi) 
    10 (use gauche.parameter) 
    119 
    12 (define *blog-title* "Bloscheme Test") 
    13 (define *author* "id:jknaoya") 
    1410(define *data-regexp* #/.txt$/) 
    1511(define *data-directory* "data") 
    16 (define *plugin-directory* "plugins") 
    1712(define *entry-number* 7) 
    18 (define *default-flavour* "html") 
    19 (define *server-root* #f) ; Auto if #f 
    20 ; (define *server-root* "http://example.com") 
    2113 
    22 (define path-info (make-parameter "/")) 
    23 (define flavour (make-parameter "html")) 
    24 (define title (make-parameter *blog-title*)) 
    25 (define template-hash-table 
    26   (make-parameter 
    27     (hash-table 
    28       'eq? 
    29       `(title . ,(title)) 
    30       ))) 
    31 (define-method object-apply ((ht <hash-table>) (name <symbol>)) 
    32                (hash-table-get ht name) 
    33                ) 
    34 (define (set-template-variable name val) 
    35   (hash-table-put! (template-hash-table) name val) 
    36   ) 
     14(load "./template.scm") 
    3715 
    3816; 設定に従いファイルを列挙し、 
    … …  
    5735; PATH_INFO にしたがってエントリをフィルタリング 
    5836; プラグイン?みたいなのもフィルタとして実装できる? 
    59 (define (filter-by-path-info params files) 
    60   (rxmatch-cond 
    61     ((rxmatch #/^\/(\d{4})\/?$/ (path-info)) 
    62      [#f year] 
    63      (set! year (string->number year)) 
    64      (filter (lambda (file) 
    65                (= (date-year (hash-table-get file 'date)) year)) 
    66              files) 
    67      ) 
    68     ((rxmatch #/^\/(\d{4})\/(\d\d)\/?$/ (path-info)) 
    69      [#f year month] 
    70      (set! year  (string->number year)) 
    71      (set! month (string->number month)) 
    72      (filter (lambda (file) 
    73                (and (= (date-year  (hash-table-get file 'date)) year) 
    74                     (= (date-month (hash-table-get file 'date)) month))) 
    75              files) 
    76      ) 
    77     ((rxmatch #/^\/(\d{4})\/(\d\d)\/(\d\d)\/?$/ (path-info)) 
    78      [#f year month day] 
    79      (set! year  (string->number year)) 
    80      (set! month (string->number month)) 
    81      (set! day   (string->number day)) 
    82      (filter (lambda (file) 
    83                (and (= (date-year  (hash-table-get file 'date)) year) 
    84                     (= (date-month (hash-table-get file 'date)) month) 
    85                     (= (date-day   (hash-table-get file 'date)) day))) 
    86              files) 
    87      ) 
    88     (else 
    89       (if (not (string=? (path-info) "/")) 
    90         ; individual 
    91         (filter (lambda (file) 
    92                   (string-prefix? (path-info) (hash-table-get file 'name))) 
    93                 files) 
    94         ; index 
    95         files) 
    96       )) 
     37(define (filter-by-path-info files) 
     38  #?=files 
     39  (let1 path-info (cgi-get-metavariable "PATH_INFO") 
     40        (if path-info 
     41          (rxmatch-cond 
     42            ((rxmatch #/^\/(\d{4})\/?$/ path-info) 
     43             [#f year] 
     44             (set! year (string->number year)) 
     45             (filter (lambda (file) 
     46                       (= (date-year (hash-table-get file 'date)) year)) 
     47                     files) 
     48             ) 
     49            ((rxmatch #/^\/(\d{4})\/(\d\d)\/?$/ path-info) 
     50             [#f year month] 
     51             (set! year  (string->number year)) 
     52             (set! month (string->number month)) 
     53             (filter (lambda (file) 
     54                       (and (= (date-year  (hash-table-get file 'date)) year) 
     55                            (= (date-month (hash-table-get file 'date)) month))) 
     56                     files) 
     57             ) 
     58            ((rxmatch #/^\/(\d{4})\/(\d\d)\/(\d\d)\/?$/ path-info) 
     59             [#f year month day] 
     60             (set! year  (string->number year)) 
     61             (set! month (string->number month)) 
     62             (set! day   (string->number day)) 
     63             (filter (lambda (file) 
     64                       (and (= (date-year  (hash-table-get file 'date)) year) 
     65                            (= (date-month (hash-table-get file 'date)) month) 
     66                            (= (date-day   (hash-table-get file 'date)) day))) 
     67                     files) 
     68             ) 
     69            (else 
     70              (if (not (string=? path-info "/")) 
     71                ; individual 
     72                (filter (lambda (file) 
     73                          (string=? (hash-table-get file 'name) path-info)) 
     74                        files) 
     75                ; index 
     76                (take files *entry-number*)) 
     77              )) 
     78          ; index 
     79          (take files *entry-number*) 
     80          ) 
     81        ) 
    9782  ) 
    9883 
    9984; ソートするフィルタ 
    100 (define (sort-entries params files) 
     85(define (sort-entries files) 
     86  #?=files 
    10187  (stable-sort files 
    10288               (lambda (a b) 
    10389                 (file-mtime>? (hash-table-get a 'path) (hash-table-get b 'path))) 
    10490               )) 
    105  
    106 ; プラグイン参照用 
    107 (define (last params files) 
    108   files) 
    10991 
    11092; 適用フィルタの定義 
    … …  
    11395    sort-entries 
    11496    filter-by-path-info 
    115     last 
    11697    )) 
    117  
    118 ; ref に指定したフィルタのまえに proc を追加する 
    119 (define (add-filter ref proc) 
    120   (update! *filters* (lambda (filters) 
    121                        (receive (before after) (split-at filters (list-index (pa$ eq? ref) filters)) 
    122                                 (append before (list proc) after)))) 
    123   ) 
    12498 
    12599(define (main args) 
    126100  (cgi-main 
    127101    (lambda (params) 
    128       (define plugins (directory-list *plugin-directory* 
    129                                       :filter (lambda (path) 
    130                                                 (not (rxmatch #/^_|^(\.|\.\.)/ path)) 
    131                                                 ))) 
    132       (define (process plugins) 
    133         (if (not (null? plugins)) 
    134           (begin 
    135             (load #`"./,|*plugin-directory*|/,(car plugins)") 
    136             (process (cdr plugins)) 
    137             )) 
    138         ) 
    139       (process plugins) 
    140102 
    141       (receive (dir name ext) (decompose-path (or (cgi-get-metavariable "PATH_INFO") "/")) 
    142                (flavour   (or ext *default-flavour*)) 
    143                (path-info (if (and name (not (string=? name "index"))) 
    144                             (string-join (list dir name) "/") 
    145                             (if (string=? dir "") 
    146                               "/" 
    147                               dir))) 
    148                ) 
    149  
    150       (if (not *server-root*) 
    151         (set! *server-root* (string-append "http://" (cgi-get-metavariable "SERVER_NAME")))) 
    152  
    153  
    154       (let ([template-variables 
    155               `((files . ,(fold (lambda args ; フィルタを順に適用する 
    156                                   (apply (car args) params (cdr args))) 
    157                                 (list-files) 
    158                                 *filters*)) 
    159                 (home  . ,(cgi-get-metavariable "SCRIPT_NAME")) 
    160                 (path  . ,(values-ref (decompose-path (or (cgi-get-metavariable "SCRIPT_NAME") "")) 0)) 
    161                 )]) 
    162         (for-each set-template-variable 
    163                   (map car template-variables) (map cdr template-variables)) 
    164         ) 
    165  
    166       (load #`"./template-,(flavour).scm") 
    167  
    168       (tree->string (result (template-hash-table)))) 
    169  
    170     :on-error (lambda (c) 
    171                 (use text.html-lite) 
    172                 `(,(cgi-header :content-type "text/html; charset=UTF-8" :status "500 Internal Server Error") 
    173                   ,(html-doctype :type :xhtml-1.0-strict) 
    174                   ,(html:html 
    175                      (html:head 
    176                        (html:title "Error " (html-escape-string (condition-ref c 'message))) 
    177                        (html:style :type "text/css" " 
    178                                    body { 
    179                                    margin: 0 10%; 
    180                                    background: #fff; 
    181                                    color: #555; 
    182                                    } 
    183  
    184                                    h1 { 
    185                                    color: #d06c6b; 
    186                                    font-weight: normal; 
    187                                    } 
    188  
    189                                    pre { 
    190                                    font-size: 90%; 
    191                                    padding: 1em; 
    192                                    line-height: 1.2; 
    193                                    background: #efefef; 
    194                                    border: 1px solid #ccc; 
    195                                    color: #555; 
    196                                    } 
    197                                    ") 
    198                                    ) 
    199                        (html:body 
    200                          (html:h1 "Error") 
    201                          (html:pre (html-escape-string 
    202                                      (call-with-output-string 
    203                                        (cut 
    204                                          with-error-to-port 
    205                                          <> 
    206                                          ; 現在のスタックを表示しちゃうみたい 
    207                                          (cut report-error c))))) 
    208                          ) ; /body 
    209                        ) ; /html 
    210                      ) 
    211                   ) 
    212                 )) 
     103      ; フィルタを順に適用する 
     104      (define files (fold (lambda args 
     105                            (apply (car args) (cdr args))) 
     106                          (list-files) 
     107                          *filters*)) 
     108      (tree->string (result 
     109                      (hash-table 
     110                        'eq? 
     111                        `(files . ,files) 
     112                        `(home  . ,(cgi-get-metavariable "SCRIPT_NAME")) 
     113                        `(path  . ,(values-ref (decompose-path (cgi-get-metavariable "SCRIPT_NAME")) 0)) 
     114                        `(title . "Bloscheme Test") 
     115                        ))))) 
     116  0) 
    213117 
    214118