Changeset 12365 in project


Ignore:
Timestamp:
11/05/08 23:26:34 (11 years ago)
Author:
sjamaan
Message:

Import sxml-fu, which consists of the SXML stuff that used to be in spiffy-utils, made independent of Spiffy. Very early stuff, do not use yet!

Location:
release/4/sxml-fu
Files:
1 added
5 deleted
4 copied

Legend:

Unmodified
Added
Removed
  • release/4/sxml-fu/sxml-fu.meta

    r12134 r12365  
    1 ;;; spiffy-utils.meta -*- Hen -*-
    2 ((egg "spiffy-utils.egg")
    3  (files "spiffy-utils.setup" "spiffy-utils.scm" "spiffy-utils.html")
    4  (synopsis "Utility library for Spiffy")
    5  (needs spiffy url sxml-transforms)
     1;;; sxml-fu.meta -*- Hen -*-
     2
     3((egg "sxml-fu.egg")
     4 (files "sxml-fu.setup" "sxml-pagination.scm" "sxml-fu.html")
     5 (synopsis "SXML transformations ruleset library")
     6 (needs sxml-transforms uri-generic)
    67 (category web)
     8 (doc-from-wiki)
    79 (license "BSD")
    810 (author "Peter Bex"))
  • release/4/sxml-fu/sxml-fu.setup

    r12134 r12365  
    1 (compile -s -O2 -d1 spiffy-utils.scm)
    2 (install-extension 'spiffy-utils '("spiffy-utils.so" "spiffy-utils.html")
    3                    '((version 0.7) (documentation "spiffy-utils.html")))
     1(compile -s -O2 sxml-pagination.scm -j sxml-pagination)
     2(compile -s -O2 sxml-pagination.import.scm)
     3
     4(install-extension
     5  'sxml-pagination
     6  '("sxml-pagination.so" "sxml-pagination.import.so")
     7  `((version 0.1)
     8    (documentation "sxml-fu.html")))
     9
     10(compile -s -O2 sxml-shortcuts.scm -j sxml-shortcuts)
     11(compile -s -O2 sxml-shortcuts.import.scm)
     12
     13(install-extension
     14  'sxml-shortcuts
     15  '("sxml-shortcuts.so" "sxml-shortcuts.import.so")
     16  `((version 0.1)
     17    (documentation "sxml-fu.html")))
  • release/4/sxml-fu/sxml-pagination.scm

    r12134 r12365  
    1 ;;; spiffy-utils.scm
     1;;; sxml-pagination.scm
    22;
    3 ; Copyright (c) 2004-2006 Peter Bex (Peter.Bex@student.kun.nl)
     3; Copyright (c) 2004-2008 Peter Bex (Peter.Bex@xs4all.nl)
    44; All rights reserved.
    55;
     
    2828; SUCH DAMAGE.
    2929
    30 (declare
    31   (export write-cookie delete-cookie request-cookies
    32           post-var get-var cookie-var
    33           link-to string->boolean string->bool string->number! shortcut-rules
    34           page-var page-size current-page page-count first-entry last-entry
    35           replace-get-var pagination-rules sxml-apply-rules output-html))
     30(module sxml-pagination
     31  (page-var page-size base-uri determine-page page-count first-entry
     32   last-entry pagination-rules)
    3633
    37 (use regex url sxml-transforms)
     34(import chicken scheme extras data-structures)
    3835
    39 ;
    40 ; Multiple Set-Cookie headers are allowed in one request
    41 ;
    42 ; See RFC 2109
    43 ; TODO: Have a good look at RFC 2965, which is supposed to supersede RFC 2109
    44 ;
    45 (define (write-cookie name value . args)
    46   (let ((conc-cond (lambda (s1 s2 s3) (if s2 (conc s1 s2 s3) ""))))
    47     (let-optionals args ((comment #f) (max-age #f) (domain #f) (path #f)
    48                          (secure #f))
    49       (set-header!
    50         (string-append "Set-Cookie: "
    51                        (->string name) "=\"" (->string value) "\""
    52                        (conc-cond "; Comment=\"" comment "\"")
    53                        (conc-cond "; Max-Age=\"" max-age "\"")
    54                        (conc-cond "; Domain=\"" domain "\"")
    55                        (conc-cond "; Path=\"" path "\"")
    56                        (if secure "; Secure" "")
    57                        "; Version=1")))))
     36(require-extension sxml-transforms srfi-1 srfi-13 uri-generic)
    5837
    59 ;;; Delete a cookie by settings its maximum age to 0 seconds
    60 (define (delete-cookie name . args)
    61   (let-optionals args ((domain #f) (path #f))
    62     (write-cookie (->string name) "" #f 0 domain path)))
    63 
    64 ;;; Extract cookies from request attributes
    65 (define (attributes->cookies req-attrs)
    66   (let ((cookie-hdr (alist-ref "cookie" req-attrs string=?)))
    67     (and cookie-hdr
    68          (remove null?
    69            (map (lambda (x)
    70                   ;; Each cookie is a 'name=value' pair.  Otherwise ignore it.
    71                   (match
    72                    (string-match "[ \t]*([^ \t]+)[ \t]*=[ \t]*\"([^ \t]*)\"[ \t]*" x)
    73                    ((_ name value) (cons name value))
    74                    (_ '())))
    75                 ; RFC says we should accept `,' and `;' as cookie separators
    76                 (string-split cookie-hdr ",;") ) ) ) ))
    77 
    78 (define (request-cookies)
    79   (attributes->cookies (http:request-attributes (current-request))))
    80 
    81 (define (extract-var alist varname . rest)
    82   (let-optionals rest ((string->type identity)
    83                        (default #f))
    84     (let ((var (alist-ref (->string varname) alist string=?)))
    85       (if var
    86           (string->type var)
    87           default))))
    88 
    89 ; Get POST variable value
    90 (define (post-var varname . args)
    91   (apply extract-var (http:request-body (current-request)) varname args))
    92 
    93 ; Get GET variable value
    94 (define (get-var varname . args)
    95   (apply extract-var (current-urlencoded-arguments) varname args))
    96 
    97 ; Get "cookie variable" value
    98 ; TODO: Implement cookie handling better we can get a cookie's Path/Domain
    99 ;        and make the `$Version' cookie disappear to the user.
    100 (define (cookie-var varname . args)
    101   (apply extract-var (request-cookies) varname args))
    102 
    103 ;; (link-to "index.ssp" '((foo . 10) (bar . #t)))
    104 ;; => "index.ssp?foo=10&bar=%23t"
    105 (define (link-to url alist)
    106   (string-append
    107    url "?" (string-intersperse                  ; or SRFI-13's string-join
    108             (map (lambda (entry)
    109                    (string-append (url-encode (->string (car entry)))
    110                                   "="
    111                                   (url-encode (->string (cdr entry)))))
    112                  alist)
    113             "&")))
    114 
    115 ;; Handy if you want to pass booleans as arguments.
    116 ;; Note that this is not very readable, but it fits better with the
    117 ;; ->string function in link-to.
    118 (define (string->boolean b)
    119   (string-ci=? b "#t"))
    120 
    121 (define string->bool string->boolean)
    122 
    123 (define (string->number! s)
    124   (or (string->number s) 0))
    125 
    126 (define shortcut-rules
    127   `((url *macro* . ,(lambda (tag href . contents)
    128                       `(a (@ (href ,href))
    129                           ,@(if (not (null? contents))
    130                                 contents
    131                                 (list href)))))
    132     (pic *macro* . ,(lambda (tag src alt . rest)
    133                       (let-optionals* rest ((title alt) more)
    134                         `(img (@ ,@(append `((src ,src)
    135                                              (alt ,alt)
    136                                              (title ,title)
    137                                              ,@more)))))))
    138     (movie *macro* . ,(lambda (tag src title . rest)
    139                         `(object (@ (type "video/quicktime"))
    140                                  (param (@ (name "src") (value ,src)))
    141                                  (param (@ (name "controller") (value "true")))
    142                                  ,@rest
    143                                  ;; Fallback if no viewer
    144                                  (url ,src ,title))))
    145     (*text* . ,(lambda (tag str) str))
    146     (*default* . ,(lambda x x))))
    147 
    148 ;;;
    149 ;;; Pagination support
    150 ;;;
     38;; Variable fetching and link generation should be done differently
    15139(define page-size (make-parameter 20))
    152 (define page-var (make-parameter 'page))
     40(define page-var (make-parameter "page"))
     41(define base-uri (make-parameter (uri-reference "")))
    15342
    15443;; Always returns a good page
    155 (define (current-page len)
    156   (let ((page (inexact->exact (get-var (page-var) string->number! 1))))
     44(define (determine-page len)
     45  (let ((page (inexact->exact
     46               (or (string->number
     47                    (alist-ref (uri-query (base-uri)) (page-var) string=? "1"))
     48                   1))))
    15749    (cond
    15850     ((< page 1) 1)
     
    16456
    16557(define (first-entry nentries . rest)
    166   (* (page-size) (sub1 (current-page nentries))))
     58  (* (page-size) (sub1 (determine-page nentries))))
    16759
    16860(define (last-entry nentries . rest)
     
    17365(define (slice list first last)
    17466  (take (drop list first) (- last first -1)))
    175 
    176 (define (replace-get-var var val)
    177   (alist-cons var val
    178               (alist-delete (->string var)
    179                             (current-urlencoded-arguments))))
    18067
    18168(define (expand-entries code entries size)
     
    19683                            `(pagination-info ,size)))
    19784     (current-page . ,(lambda (tag)
    198                         (current-page size)))
     85                        (determine-page size)))
    19986     (page-count . ,(lambda (tag)
    20087                      (page-count size)))
     
    21198      '()
    21299      (let ((pages (page-count nentries))
    213             (pagenr (current-page nentries)))
     100            (pagenr (determine-page nentries)))
    214101        `(ol (@ (class "page-navigation"))
    215102             (li (@ (class "first"))
     
    235122                      ">>"))))))
    236123
     124;; XXX Hack, for now
     125(define (make-uri-string pg)
     126  (uri->string
     127   (uri-relative-to
     128    (uri-reference
     129     (sprintf "?~A" (string-join
     130                     (map (lambda (p)
     131                            (conc (car p) "=" (cdr p)))
     132                          (alist-update! (page-var) pg (uri-query (base-uri))))
     133                     "&")))
     134    (base-uri))))
     135
    237136(define pagination-rules
    238137  `((paginate-list *macro* .
     
    254153    (page-link *macro* .
    255154     ,(lambda (tag pg txt . rest)
    256         `(url ,(link-to "" (replace-get-var (page-var) pg)) ,txt)))
     155        `(a (@ (href ,(make-uri-string pg))) ,txt)))
    257156    (*text* . ,(lambda (tag str) str))
    258157    (*default* . ,(lambda x x))))
    259 
    260 (define (sxml-apply-rules content . rules)
    261    (fold (lambda (rules content)
    262                           (pre-post-order content rules)) content rules))
    263 
    264 (define (output-html content . rules)
    265   (SRV:send-reply (apply sxml-apply-rules content rules)))
     158)
Note: See TracChangeset for help on using the changeset viewer.