Changeset 18634 in project


Ignore:
Timestamp:
06/26/10 18:22:45 (11 years ago)
Author:
sjamaan
Message:

qwiki: Copy over the svnwiki-sxml branch to qwiki trunk. No mergetracking??... :(

Location:
release/4/qwiki/trunk
Files:
1 added
9 edited

Legend:

Unmodified
Added
Removed
  • release/4/qwiki/trunk/qwiki-install.scm

    r17683 r18634  
    3434;;  POSSIBILITY OF SUCH DAMAGE.
    3535
    36 (use posix svn-client qwiki-svn qwiki-sxml qwiki qwiki-nowiki qwiki-search)
     36(use posix svn-client qwiki-svn qwiki-sxml qwiki qwiki-search qwiki-menu)
    3737
    3838(unless (= (length (command-line-arguments)) 3)
     
    5959
    6060;; TODO: This ought to be configurable!
    61 (nowiki-install!)
    6261(search-install!)
     62(menu-install!)
    6363
    6464(checkout-sources! (qwiki-source-path))
  • release/4/qwiki/trunk/qwiki-menu.scm

    r18382 r18634  
    3838
    3939(import chicken scheme)
    40 (use data-structures files wiki-parse qwiki qwiki-sxml sxml-transforms)
     40(use data-structures files svnwiki-sxml qwiki qwiki-sxml sxml-transforms)
    4141
    4242(define menu-file (make-parameter "/menu"))
     
    4848       . ,(lambda (tag contents)
    4949            (if (file-exists? (make-pathname (qwiki-source-path) (menu-file)))
    50                 (cons `(div (@ (id "menu"))
     50                `(body (div (@ (id "menu"))
    5151                            ,(call-with-input-file
    5252                                 (make-pathname (qwiki-source-path) (menu-file))
    53                                wiki-parse))
    54                       contents)
    55                 contents))))
     53                               svnwiki->sxml))
     54                       . ,contents)
     55                `(body . ,contents)))))
    5656     . ,(lambda contents contents))
    5757    ,@alist-conv-rules*))
     
    6161    (qwiki-clear-cache!)))
    6262
    63 (define (delete-menu! path page)
     63(define (delete-menu! path)
    6464  (when (and (menu-file) (equal? path (string-split (menu-file) "/")))
    6565    (qwiki-clear-cache!)))
  • release/4/qwiki/trunk/qwiki-search.scm

    r18223 r18634  
    4040(import chicken scheme)
    4141(use data-structures extras srfi-1 srfi-13 intarweb uri-common
    42      wiki-parse qwiki qwiki-sxml sxml-transforms estraier-client)
     42     qwiki qwiki-sxml sxml-transforms sxpath sxpath-lolevel estraier-client)
     43(require-library regex)
     44(import irregex)
    4345
    4446(define search-server-uri
     
    5860
    5961;; Convert a wiki page to an estraier document plus attributes
    60 (define (wiki-page->estraier-doc page)
    61   (receive (contents attribs)
    62     (let scan ((node page)
    63                (contents (list))
    64                (attribs (list)))
    65       (cond
    66        ((null? node)
    67         (values contents attribs))
    68        ((string? node)
    69         (values (cons node contents) attribs))
    70        ((not (pair? node)) ;; No idea what to do with these
    71         (values contents attribs))
    72        ((not (symbol? (car node)))
    73         (receive (contents attribs)
    74           (scan (car node) contents attribs)
    75           (scan (cdr node) contents attribs)))
    76        (else
    77         (case (car node)
    78           ((definition)
    79            ;; TODO: Add more parsing to be able to obtain just the identifier?
    80            ;; otherwise you would get bogus search results (we search in
    81            ;; procedure arguments too, this way...)
    82            (let* ((type (cadr node))
    83                   (old-defs (alist-ref type attribs eq? ""))
    84                   (def (caddr node))
    85                   (new-defs (sprintf "~A ~A" def old-defs)))
    86              (values (cons def contents) ; Also find when searching contents!
    87                      (alist-update! type new-defs attribs))))
    88           (else
    89            (scan (cdr node) contents attribs))))))
    90     (values (reverse! contents) attribs)))
     62(define wiki-page->estraier-doc
     63  (let ((contents-sxpath (sxpath '(// *text*)))
     64        ;; TODO: Add more parsing to be able to obtain just the identifier?
     65        ;; otherwise you would get bogus search results (we search in
     66        ;; procedure arguments too, this way...)
     67        (attribs-sxpath (sxpath '(// def sig *)))
     68        (add-def! (lambda (key value alist)
     69                    (let* ((old-item (alist-ref key alist eq? ""))
     70                           (new-item (string-append old-item " " value))
     71                           (old-ids (alist-ref 'identifier alist eq? ""))
     72                           (new-ids (string-append old-ids " " value)))
     73                      (alist-update! 'identifier new-ids
     74                                     (alist-update! key new-item alist))))))
     75    (lambda (doc)
     76      (let loop ((items (attribs-sxpath doc))
     77                 (attrs '()))
     78        (if (null? items)
     79            (values (contents-sxpath doc) (alist-delete! #f attrs))
     80            (loop (cdr items)
     81                  (add-def! (sxml:element-name (car items))
     82                            (sxml:text (car items))
     83                            attrs)))))))
    9184
    9285(define (update-search-entry! path page)
     
    10598       *preorder*
    10699       . ,(lambda (tag contents)
    107             (cons `(div (@ (id "search"))
     100            `(body (div (@ (id "search"))
    108101                        (form (@ (action "/search"))
    109                               (label "text"
    110                                      (input (@ (type "text") (name "phrase"))))
    111                               (label "attributes"
    112                                      (input (@ (type "text") (name "attrs"))))
    113                               (input (@ (type "submit") (value "search")))
    114                               (a (@ (href "/search-help")) "search help")))
    115                   contents))))
     102                              (div
     103                               (label "free text"
     104                                      (input (@ (type "text") (name "text"))))
     105                               (label "identifier"
     106                                      (input (@ (type "text") (name "ident"))))
     107                               (input (@ (type "submit") (value "search")))
     108                               (a (@ (href "/search-help")) "search help"))))
     109                   . ,contents))))
    116110     . ,(lambda contents contents))
    117111    ,@alist-conv-rules*))
     
    120114  (ensure-qwiki-node-exists!)
    121115  (let* ((query (uri-query (request-uri request)))
    122          (phrase (alist-ref 'phrase query))
    123          (attrs (alist-ref 'attrs query))
    124          (attr-phrases (if attrs (list attrs) (list)))
     116         ;; accept search like "procedure: foo" or just "foo"
     117         (ident-m (irregex-match '(seq (* white) (submatch (+ print))
     118                                       (* white) ":" (+ white)
     119                                       (submatch (+ print)) (* white))
     120                                 (alist-ref 'ident query eq? "")))
     121         (type (if ident-m (irregex-match-substring ident-m 1) "identifier"))
     122         (ident (if ident-m
     123                    (irregex-match-substring ident-m 2)
     124                    (string-trim-both (alist-ref 'ident query eq? ""))))
     125         (attr-phrases (if (not (string-null? ident))
     126                           (list (conc type " STRINC " ident))
     127                           (list)))
     128         (text (alist-ref 'text query eq? ""))
     129         (phrase (if (string-null? (string-trim-both text))
     130                     ;; Search for the identifier in main text so it shows
     131                     ;; that text's context in the results (not perfect but
     132                     ;; better than nothing)
     133                     ident
     134                     text))
    125135         (page (or (string->number (alist-ref 'page query eq? "0")) 0))
    126136         (page-size 10))
     
    133143      (send-content
    134144       `(wiki-page
     145         (Header (title ,(sprintf "Search results for \"~A\"" phrase))
     146                 . ,(if (qwiki-css-file)
     147                        `((style ,(uri->string
     148                                   (uri-relative-to (qwiki-css-file)
     149                                                    (qwiki-base-uri)))))
     150                        '()))
    135151         (body
    136           (h1 "Search results")
    137           ,(if (null? docs)
    138                "I'm terribly sorry, but I could not find anything to match your query. Please try a different query."
    139                `(dl
    140                  ,@(map (lambda (doc)
    141                           (let* ((matches (car doc))
    142                                  (uri (alist-ref '@uri (cdr doc)))
    143                                  (title (alist-ref '@title (cdr doc) eq? uri)))
    144                             `((dt (a (@ (href ,uri)) ,title))
    145                               (dd ,(map (lambda (m)
    146                                           (if (car m) `(em ,(car m)) (cdr m)))
    147                                         matches)))))
    148                         docs)))))))))
     152          (div (@ (id "search-results"))
     153               (h1 "Search results")
     154               ,(if (null? docs)
     155                    `(p (@ (id "no-results-message"))
     156                        "I'm terribly sorry, but I could not find anything "
     157                        "to match your query. Please try a different query.")
     158                    `(dl (@ (id "result-list"))
     159                         . ,(map
     160                             (lambda (doc)
     161                               (let* ((matches (car doc))
     162                                      (uri (alist-ref '@uri (cdr doc)))
     163                                      (title (alist-ref '@title (cdr doc) eq? uri)))
     164                                 `((dt (a (@ (href ,uri)) ,title))
     165                                   (dd ,@(fold-right
     166                                          (lambda (match info)
     167                                            (cond
     168                                             ((car match)
     169                                              `(#t ((em ,(car match))
     170                                                    . ,(cadr info))))
     171                                             ((car info) ;; Still same snippet?
     172                                              `(#f (,(cdr match)
     173                                                    . ,(cadr info))))
     174                                             (else
     175                                              `(#f (,(cdr match) " ... "
     176                                                    . ,(cadr info))))))
     177                                          '(#f ())
     178                                          matches)))))
     179                             docs))))))))))
    149180
    150181(define (search-install!)
  • release/4/qwiki/trunk/qwiki-svn.scm

    r17683 r18634  
    3939  (qwiki-repos-uri qwiki-repos-username qwiki-repos-password
    4040   get-history call-with-input-revision checkout-sources! update-sources!
    41    store-changes! undo-changes!)
     41   store-changes! undo-changes! get-extended-property get-last-modified-revision)
    4242
    4343(import chicken scheme)
    44 (use regex posix files srfi-18 svn-client)
     44(use data-structures regex posix files srfi-18 svn-client)
    4545
    4646;; The version control system's repos uri, username and password
     
    8787              (qwiki-repos-username) (qwiki-repos-password)))
    8888
     89(define (get-last-modified-revision path)
     90  (and-let* ((i (get-info path)))
     91    (svn-info-last-changed-rev i)))
     92
    8993(define (get-info path)
    9094  (let ((info '()))
     
    122126              (loop (pathname-directory path))))))))
    123127
     128(define (get-extended-property path property)
     129  (and-let* ((retval (svn-propget property path
     130                                  (qwiki-repos-username)
     131                                  (qwiki-repos-password) '()))
     132             (props (alist-ref path retval string=?))
     133             (prop (car props)))
     134    prop))
     135
    124136)
  • release/4/qwiki/trunk/qwiki-sxml.scm

    r18464 r18634  
    4444(import chicken scheme)
    4545
    46 (use posix srfi-1 srfi-13 data-structures regex )
    47 (use matchable sxml-transforms doctype uri-generic)
     46(use posix srfi-1 srfi-13 data-structures extras)
     47(use matchable sxml-transforms doctype uri-generic sxpath colorize html-parser)
    4848
    4949(require-library multidoc)
     
    5252                (LaTeX-transformation-rules multidoc-LaTeX-transformation-rules)))
    5353
    54 (define lookup-def
    55   (lambda (k lst . rest)
    56     (let-optionals rest ((default #f))
    57       (alist-ref k lst eq? default))))
    58 
    59 
    6054;;;;
    6155;;;;  HTML stylesheet
     
    7165           `(html:begin . ,elems)))
    7266
    73      (wiki
    74       *macro*
    75       . ,(lambda (tag elems)
    76            (match elems
    77                   ((href . contents)
    78                    `(a (@ (class "wiki-page") (href ,href))
    79                        ,(if (pair? contents) contents
    80                             href)))
    81                   (else
    82                    (error 'qwiki-html-transformation-rules
    83                           "wiki elements must be of the form (wiki href . contents)")))))
    84 
    85    
    8667     ;; Maybe this should be done in multiple steps to make it more "hookable"
    8768     (history
     
    9475                 (th "description"))
    9576             ,@(map (lambda (item)
    96                       `(tr (td (url ,(string-append
    97                                       "?action=show&rev="
    98                                       (number->string (car item)))
    99                                     ,(car item)))
     77                      `(tr (td (link ,(string-append
     78                                       "?action=show&rev="
     79                                       (number->string (car item)))
     80                                     ,(car item)))
    10081                           (td ,(cadr item))
    10182                           (td ,(time->string (caddr item)))
     
    10889         `(div (@ (id "content")) . ,contents)))
    10990
    110      (special
    111       ((@
    112         ((tags
    113           *preorder* .
    114           ,(lambda (tag page-tags)
    115              `(ul (@ (class "tags"))
    116                   . ,(map (lambda (tag) `(li ,tag))
    117                           (string-split (car page-tags)))))))
    118         . ,(lambda (tag elems) elems)))
    119       . ,(lambda (tag elems) elems))
     91     (tags
     92      *preorder* .
     93      ,(lambda (tag page-tags)
     94         `(ul (@ (class "tags"))
     95              . ,(map (lambda (tag) `(li ,tag))
     96                      (string-split (car page-tags))))))
     97
     98     (highlight
     99      *macro*
     100      . ,(lambda (tag elems)
     101           (let* ((lang (car elems))
     102                  (classname (conc "highlight " lang "-language"))
     103                  (code (handle-exceptions exn
     104                          (cdr elems)
     105                          (map (lambda (s)
     106                                 (cdr (html->sxml (html-colorize lang s))))
     107                               (cdr elems)))))
     108             `(pre (@ (class ,classname)) . ,code))))
    120109     
     110     (examples
     111      ((example
     112        ((init
     113          *macro*
     114          . ,(lambda (tag elems)
     115               `(div (@ (class "init")) (highlight scheme . ,elems))))
     116         (expr
     117          *macro*
     118          . ,(lambda (tag elems)
     119               `(div (@ (class "expression")) (highlight scheme . ,elems))))
     120         (input
     121          *macro*
     122          . ,(lambda (tag elems)
     123               `(div (@ (class "io input")) (em "input: ")
     124                     (highlight scheme . ,elems))))
     125         (output
     126          *macro*
     127          . ,(lambda (tag elems)
     128               `(div (@ (class "io output")) (em "output: ")
     129                     (highlight scheme . ,elems))))
     130         (result
     131          *macro*
     132          . ,(lambda (tag elems)
     133               `(div (@ (class "result"))
     134                     (span (@ (class "result-symbol")) " => ")
     135                     (highlight scheme . ,elems))))) ;; Or use "basic lisp" here?
     136        . ,(lambda (tag elems)
     137             `(div (@ (class "example")) . ,elems))))
     138      . ,(lambda (tag elems)
     139           `(div (@ (class "examples"))
     140                 (span (@ (class "examples-heading")) "Examples:") . ,elems)))     
    121141     (page-specific-links
    122142      *macro*
    123       . ,(lambda _
    124            `(ul (@ (class "page-specific-links"))
    125                 (li (url "?action=show" "show"))
    126                 (li (url "?action=edit" "edit"))
    127                 (li (url "?action=history" "history")))))
     143      . ,(lambda (tag elems)
     144           `(ul (@ (id "page-specific-links"))
     145                (li ,(if ((if-sxpath '(// new-file)) (cons tag elems))
     146                         `(span (@ (class "disabled")
     147                                   (title "This page doesn't exist yet"))
     148                                "show")
     149                         `(link "?action=show" "show")))
     150                (li ,(if ((if-sxpath '(// read-only)) (cons tag elems))
     151                         `(span (@ (class "disabled")
     152                                   (title "This page has been frozen. "
     153                                          "Only someone with direct access "
     154                                          "to the repository can edit it."))
     155                                "edit")
     156                         `(link "?action=edit" "edit")))
     157                (li ,(if ((if-sxpath '(// new-file)) (cons tag elems))
     158                         `(span (@ (class "disabled")
     159                                   (title "This page doesn't exist yet"))
     160                                "history")
     161                         `(link "?action=history" "history"))))))
    128162
    129163     ,@alist-conv-rules*
     
    172206              )))
    173207
    174      (wiki
    175       *macro*
    176       . ,(lambda (tag elems)
    177            (match elems
    178                   ((href . contents)
    179                    (begin
    180                      (LaTeX-add-package! 'hyperref "hypertex")
    181                      `((tex "\\hyperref[" ,(LaTeX-label href) "]")
    182                        (tex "{")
    183                        ,(if (null? contents) href (or contents href))
    184                        (tex "}"))))
    185                   (else
    186                    (error 'qwiki-LaTeX-transformation-rules
    187                           "wiki elements must be of the form (wiki href . contents)")))))
     208     ;; No syntax highlighting yet, present as preformatted
     209     (highlight
     210      *macro*
     211      . ,(lambda (tag elems)
     212           ;; (highlight LANGUAGE "text" ...)
     213           `(pre . ,(cdr elems))))
     214     
     215     (examples
     216      ((example
     217        ((init
     218          *macro*
     219          . ,(lambda (tag elems)
     220               `(pre . ,elems)))
     221         (expr
     222          *macro*
     223          . ,(lambda (tag elems)
     224               `(pre . ,elems)))
     225         (input
     226          *macro*
     227          . ,(lambda (tag elems)
     228               `((em "input: ")
     229                 (pre . ,elems))))
     230         (output
     231          *macro*
     232          . ,(lambda (tag elems)
     233               `((em "output: ")
     234                 (pre . ,elems))))
     235         (result
     236          *macro*
     237          . ,(lambda (tag elems)
     238               `(pre " => " . ,elems))))
     239        . ,(lambda (tag elems)
     240             elems)))
     241      . ,(lambda (tag elems)
     242           elems))
    188243
    189244     ,@alist-conv-rules*
     
    203258    (
    204259     (wiki-page
    205       . ,(lambda (tag elems)
    206              (list
    207                "\\input texinfo" nl
    208                nl
    209                (cons 'html:begin elems)
    210                )))
    211 
    212      (wiki
    213       *macro*
    214       . ,(lambda (tag elems)
    215            (match elems
    216                   ((href . contents)
    217                    `((texinfo "@uref{" ,href "}") " "
    218                      ,(if (null? contents) href (or contents href))
    219                      ))
    220                   (else
    221                    (error 'qwiki-Texinfo-transformation-rules
    222                           "wiki elements must be of the form (wiki href . contents)")))))
    223 
     260      *macro* .
     261      ,(lambda (tag elems) (cons 'body elems)))
     262
     263
     264     ;; No syntax highlighting yet, present as preformatted
     265     (highlight
     266      *macro*
     267      . ,(lambda (tag elems)
     268           ;; (highlight LANGUAGE "text" ...)
     269           `(pre . ,(cdr elems))))
     270     
     271     (examples
     272      ((example
     273        ((init
     274          *macro*
     275          . ,(lambda (tag elems)
     276               `(pre . ,elems)))
     277         (expr
     278          *macro*
     279          . ,(lambda (tag elems)
     280               `(pre . ,elems)))
     281         (input
     282          *macro*
     283          . ,(lambda (tag elems)
     284               `((em "input: ")
     285                 (pre . ,elems))))
     286         (output
     287          *macro*
     288          . ,(lambda (tag elems)
     289               `((em "output: ")
     290                 (pre . ,elems))))
     291         (result
     292          *macro*
     293          . ,(lambda (tag elems)
     294               `(pre " => " . ,elems)))
     295         (*text* . ,(lambda (tag elems) elems))
     296         (*default* . ,(lambda (tag elems) '())))
     297        . ,(lambda (tag elems)
     298             elems)))
     299      . ,(lambda (tag elems)
     300           elems))
    224301
    225302     ,@alist-conv-rules
  • release/4/qwiki/trunk/qwiki.meta

    r18360 r18634  
    11((synopsis "qwiki - the quick wiki")
    2  (depends matchable wiki-parse intarweb uri-common spiffy (doctype "1.2")
    3           (sxml-transforms "1.4") multidoc (svn-client "0.11") estraier-client
    4           sxpath)
     2 (depends matchable intarweb uri-common spiffy (doctype "1.2")
     3          (sxml-transforms "1.4") multidoc (svn-client "0.13") estraier-client
     4          sxpath sha1 (svnwiki-sxml 0.2.1) html-parser colorize)
    55 (author "Peter Bex")
    66 (category www)
  • release/4/qwiki/trunk/qwiki.scm

    r18360 r18634  
    6060   send-content
    6161   write-content
     62   blocked-ip-addresses-file
    6263   )
    6364
     
    6566(use extras files posix ports data-structures srfi-1 srfi-13 srfi-14
    6667     intarweb uri-common spiffy sxml-transforms sxpath
    67      wiki-parse qwiki-sxml doctype
     68     svnwiki-sxml qwiki-sxml doctype sha1
    6869     ;; There should be a way to parameterize the versioning implementation
    6970     qwiki-svn)
     
    7273(define qwiki-docroot (make-parameter "/"))
    7374
    74 ;; The docroot. This will be parameterize to be identical to the Spiffy
     75;; The docroot. This will be parameterized to be identical to the Spiffy
    7576;; docroot when running inside the webserver.  The post-commit-hook
    7677;; could need to customize this.
     
    107108(define qwiki-css-file
    108109  (make-parameter #f (lambda (x) (and x (uri-reference x)))))
     110
     111(define blocked-ip-addresses-file
     112  (make-parameter "edit-deny"))
    109113
    110114;; This must match name-to-base in svnwiki/deps.scm
     
    127131
    128132(define wiki-link-normalization
    129   `((wiki . ,(lambda (tag tree)
    130                (let* ((href (car tree))
    131                       (contents (cdr tree))
    132                       (pretty-href (simplify-pagename href)))
    133                  (if (pair? contents)
    134                      `(wiki ,pretty-href ,@contents)
    135                      `(wiki ,pretty-href ,href)))))
    136     ,@alist-conv-rules*))
     133  `((int-link . ,(lambda (tag tree)
     134                   (let* ((href (car tree))
     135                          (contents (cdr tree))
     136                          (pretty-href (simplify-pagename href)))
     137                     (if (pair? contents)
     138                         `(int-link ,pretty-href . ,contents)
     139                         `(int-link ,pretty-href ,href)))))
     140    . ,alist-conv-rules*))
    137141
    138142;; The rules used for transforming page SXML structure
     
    152156             headers)))
    153157    `(wiki-page (Header . ,headers)
    154                 (body (page-specific-links)
     158                (body (page-specific-links . ,headers)
    155159                      (wiki-content ,contents)))))
    156160
     
    177181;; Handle index files where needed.  Never try to open a directory as file
    178182(define (normalize-path path)
    179   (if (directory? (path->source-filename path))
    180       (append path '("index"))
    181       path))
     183  (remove! string-null?
     184           (if (directory? (path->source-filename path))
     185               (append path '("index"))
     186               path)))
    182187
    183188;; Like with-output-to-file, only this creates parent directories as needed.
     
    202207(define (write-content content)
    203208  (output-xml content (qwiki-transformation-steps content)))
    204  
    205209
    206210
    207211;;; Actions
    208212(define (qwiki-history path req)
    209   (let* ((source-file (path->source-filename path))
    210          (rev (string->number
    211                (alist-ref 'rev (uri-query (request-uri req)) eq? "")))
    212          (history (get-history source-file rev #f)) ; no pagination yet
    213          (content (qwiki-sxml-page-template `(history . ,history))))
    214     (send-content content)))
     213  (let ((source-file (path->source-filename path)))
     214    (if (not (file-exists? source-file))
     215        (redirect-to-qwiki-page req action: "show")       
     216        (let* ((rev (string->number
     217                    (alist-ref 'rev (uri-query (request-uri req)) eq? "")))
     218              (history (get-history source-file rev #f)) ; no pagination yet
     219              (content (qwiki-sxml-page-template
     220                        `(history . ,history)
     221                        ;; We could determine the current title by parsing
     222                        ;; the wiki page. That would be a bit wasteful though...
     223                        ;; Perhaps read out svnwiki:title instead?
     224                        `(title ,(sprintf "Edit history for page: ~A"
     225                                          (string-join path "/")))
     226                        (if (frozen? source-file) '(read-only) '(read-write)))))
     227          (send-content content)))))
     228
     229(define (blocked-ip-address? ip-address)
     230  (and-let* ((f (blocked-ip-addresses-file))
     231             (file (make-pathname (qwiki-source-path) f))
     232             ((file-exists? file)))
     233    (call-with-input-file file
     234      (lambda (p)
     235        (let loop ((line (read-line p)))
     236          (if (eof-object? line)
     237              #f
     238              (or (string=? (string-trim-both line) ip-address)
     239                  (loop (read-line p)))))))))
    215240
    216241(define (qwiki-edit path req)
    217242  (let* ((source-file (path->source-filename path))
     243         (auth-required (requires-authentication? source-file))
    218244         (postdata (if (eq? 'POST (request-method req))
    219245                       (form-urldecode (read-request-data req))
    220246                       '()))
     247         (new-file (not (file-exists? source-file)))
     248         (file-revision (if new-file 0 (get-last-modified-revision source-file)))
    221249         (source (or (alist-ref 'source postdata)
    222                      (and (file-exists? source-file)
     250                     (and (not new-file)
    223251                          (with-input-from-file source-file read-string))
    224252                     ""))
     253         (sxml (call-with-input-string source svnwiki->sxml))
    225254         (comment (alist-ref 'comment postdata eq? ""))
    226255         (username (alist-ref 'username postdata eq? ""))
    227256         (password (alist-ref 'password postdata eq? ""))
    228          (auth (alist-ref 'auth postdata eq?))
     257         (make-spam-control-hash
     258          (lambda (answer time)
     259            (sha1-digest (sprintf "Answer: ~A for file ~A (r~A) at ~A"
     260                                  answer source-file file-revision time))))
     261         (auth (or auth-required (alist-ref 'auth postdata)))
     262         (title ((sxpath '(// (section 1) (*text* 1))) (cons 'root sxml)))
     263         ;; If spambot provided auth, it will fail on bad credentials later
     264         (likely-human
     265          (or auth (and-let* ((hash (alist-ref 'captcha-hash postdata))
     266                              (ans (alist-ref 'captcha-answer postdata))
     267                              (time (alist-ref 'captcha-time postdata))
     268                              ((> (string->number time) ; max half an hour old
     269                                  (- (current-seconds) 108000)))
     270                              (expected-hash (make-spam-control-hash ans time)))
     271                     ;; The hash is unique for this form since this file
     272                     ;; will only be changed for this revision once and
     273                     ;; the revision/filename combination is unforgeable.
     274                     ;; We could use crypt() instead of sha1 for added
     275                     ;; security but it hardly seems worth it because the
     276                     ;; challenge itself is rather weak...
     277                     (string=? hash expected-hash))))
    229278         ;; TODO: Clean this up, maybe put it in a transformation rule so
    230279         ;; it can be extended by plugins.  The names of the buttons are
     
    234283            (qwiki-sxml-page-template
    235284             `(,(if (alist-ref 'preview postdata)
    236                     `(div (@ (class "preview"))
    237                           (h2 "Preview")
    238                           ,(wiki-parse source))
     285                    `(div (@ (class "preview")) (h2 "Preview") ,sxml)
    239286                    "")
    240287               ,(if message
     
    252299                                           ,comment)))
    253300                     (div (@ (id "auth"))
    254                           (label "I would like to authenticate"
    255                                  (input (@ (type "checkbox")
    256                                            (name "auth")
    257                                            ,@(if auth
    258                                                  '((checked "checked"))
    259                                                  '()))))
    260                           (label "Username:"
    261                                  (input (@ (type "text")
    262                                            (name "username")
    263                                            (value ,username))))
    264                           (label "Password:"
    265                                  (input (@ (type "password")
    266                                            (name "password")
    267                                            (value ,password)))))
     301                          ,(if auth-required
     302                               `(label "This file is " (em "locked.")
     303                                       " To edit it, you "
     304                                       (em "must authenticate.")
     305                                       (input (@ (type "hidden")
     306                                                 (name "auth")
     307                                                 (value "true"))))
     308                               `(label "I would like to authenticate"
     309                                       (input (@ (type "checkbox")
     310                                                 (name "auth")
     311                                                 (id "auth-checkbox")
     312                                                 (value "true")
     313                                                 . ,(if auth
     314                                                        '((checked "checked"))
     315                                                        '())))))
     316                          (div (@ (id "credentials"))
     317                               (h3 "Authentication")
     318                               (label "Username:"
     319                                      (input (@ (type "text")
     320                                                (name "username")
     321                                                (value ,username))))
     322                               (label "Password:"
     323                                      (input (@ (type "password")
     324                                                (name "password")
     325                                                (value ,password))))))
     326                     ,(if auth-required ;; No point in including a spam check
     327                          `(div)
     328                          (let* ((op (car (shuffle '(+ - *) random)))
     329                                 (a (random (if (eq? op '*) 10 25)))
     330                                 (b (random (if (eq? op '*) 10 25)))
     331                                 (res ((case op ((+) +) ((-) -) ((*) *)) a b))
     332                                 (time (->string (current-seconds))))
     333                           `(div (@ (id "antispam"))
     334                                 (h3 "Spam control")
     335                                 (p "What do you get when you "
     336                                    ,(case op
     337                                       ((-) (sprintf " subtract ~A from ~A?" b a))
     338                                       ((*) (sprintf " multiply ~A by ~A?" a b))
     339                                       ((+) (sprintf " add ~A to ~A?" a b))))
     340                                 (input (@ (type "hidden") (name "captcha-time")
     341                                           (value ,time)))
     342                                 (input (@ (type "hidden") (name "captcha-hash")
     343                                           (value ,(make-spam-control-hash
     344                                                    res time))))
     345                                 (input (@ (type "text") (name "captcha-answer")
     346                                           ;; prevent Firefox from pre-filling:
     347                                           (value "")))
     348                                 ;; Really nasty inline JS, but this keeps
     349                                 ;; it lean and mean; no external JS needed.
     350                                 (script (@ (type "text/javascript"))
     351                                         "var box = document.getElementById('auth-checkbox');"
     352                                         "var as = document.getElementById('antispam').style;"
     353                                         "var cs = document.getElementById('credentials').style;"
     354                                         "if (box.checked)"
     355                                         "  as.display = 'none';"
     356                                         " else "
     357                                         "  cs.display = 'none';"
     358                                         "box.onclick = function() {"
     359                                         "  if (box.checked) {"
     360                                         "    as.display = 'none';"
     361                                         "    cs.display = 'block';"
     362                                         "  } else {"
     363                                         "    as.display = 'block';"
     364                                         "    cs.display = 'none';"
     365                                         "  }"
     366                                         "};"))))
    268367                     (div (@ (id "actions"))
    269368                          (input (@ (type "submit")
     
    272371                          (input (@ (type "submit")
    273372                                    (name "preview")
    274                                     (value "Preview"))))))))))
    275     (if (alist-ref 'save postdata)
     373                                    (value "Preview"))))))
     374             `(title ,(sprintf "Editing page: ~A" (if (null? title)
     375                                                      (string-join path "/")
     376                                                      (car title))))
     377             (if new-file '(new-file) '(existing-file))))))
     378    (cond
     379     ((frozen? source-file) (redirect-to-qwiki-page req action: "show"))
     380     ((blocked-ip-address? (remote-address))
     381      (send-content
     382       (make-form (conc "You have been blocked from making any edits. "
     383                        "If you believe this is in error, please contact "
     384                        "the administrators of this wiki."))))
     385     ((and (alist-ref 'save postdata) (not likely-human))
     386      (send-content
     387       (make-form (conc "Your answer to the spam control question was "
     388                        "incorrect.  Are you a spammer?  Gosh, I hope not! "
     389                        "Try again, but please try a little harder!"))))
     390     ((alist-ref 'save postdata)
     391      (with-output-to-path source-file (lambda () (display source)))
     392      (handle-exceptions exn
    276393        (begin
    277           (with-output-to-path source-file (lambda () (display source)))
    278           (handle-exceptions exn
    279             (begin
    280               (undo-changes! source-file)
    281               ;; No idea how to cleanly ensure a proper update...
    282               ;; The enclosing directory might have been removed, or the file
    283               ;; might have been deleted, renamed etc.  Let's just update the
    284               ;; whole tree (but this can take a long time)
    285               (ensure-latest-sources! #t)
    286               (send-content (make-form (conc "Warning! Someone has edited this page while you were editing it. You can click save again to overwrite those changes with yours if this is the case."
    287                                              (if auth
    288                                                  " It is also possible your username/password are incorrect."
    289                                                  "")))))
    290             (store-changes! source-file comment
    291                             (and auth username) (and auth password))
    292             (redirect-to-qwiki-page req action: "show")))
    293         (send-content (make-form)))))
     394          (undo-changes! source-file)
     395          ;; No idea how to cleanly ensure a proper update...
     396          ;; The enclosing directory might have been removed, or the file
     397          ;; might have been deleted, renamed etc.  Let's just update the
     398          ;; whole tree (but this can take a long time)
     399          (ensure-latest-sources! #t)
     400          (send-content (make-form (conc "Warning! Someone has edited this "
     401                                         "page while you were editing it. "
     402                                         "You can click save again to "
     403                                         "overwrite those changes with yours "
     404                                         "if this is the case."
     405                                         (if auth
     406                                             (conc " It is also possible your "
     407                                                   "username/password are "
     408                                                   "incorrect.")
     409                                             "")))))
     410       
     411        (store-changes! source-file
     412                        (if auth
     413                            comment
     414                            (sprintf "Anonymous wiki edit for IP [~A]: ~A"
     415                                     (remote-address) comment))
     416                        (and auth username) (and auth password))
     417        (redirect-to-qwiki-page req action: "show")))
     418     (else (send-content (make-form))))))
    294419
    295420(define (redirect-to-qwiki-page req
     
    312437  (let* ((html-file (path->html-filename path))
    313438         (html-path (make-pathname (qwiki-web-path) html-file))
    314          (source-file (path->source-filename path))
    315          (rev (string->number
    316                (alist-ref 'rev (uri-query (request-uri req)) eq? ""))))
    317     (if (file-exists? source-file)
    318         (if rev
    319             (send-content ; Do not store if old rev
    320              (let* ((sxml (call-with-input-revision source-file rev wiki-parse))
    321                     (title ((sxpath '(// (Section 1) *text*)) (cons 'root sxml))))
    322                (qwiki-sxml-page-template
    323                 sxml `(title ,(sprintf "~A (historical revision ~A)"
    324                                        (if (null? title)
    325                                            path
    326                                            (car title))
    327                                        rev)))))
    328             (begin
    329               (when (or (not (file-exists? html-path))
    330                         (file-newer? source-file html-path))
    331                 (qwiki-update-file! path))
    332              (send-static-file html-file)))
    333         (redirect-to-qwiki-page req action: "edit"))))
     439         (source-file (path->source-filename path)))
     440    (cond
     441     ((not (file-exists? source-file))
     442      (redirect-to-qwiki-page req action: "edit"))
     443     ((string->number (alist-ref 'rev (uri-query (request-uri req)) eq? ""))
     444      => (lambda (rev) ; Do not cache HTML file if historical rev was requested
     445           (send-content
     446            (let* ((sxml (call-with-input-revision
     447                          source-file rev svnwiki->sxml))
     448                   (title ((sxpath '(// (section 1) (*text* 1)))
     449                           (cons 'root sxml))))
     450              (qwiki-sxml-page-template
     451               sxml
     452               `(title ,(sprintf "~A (historical revision ~A)"
     453                                 (if (null? title)
     454                                     (string-join path "/")
     455                                     (car title))
     456                                 rev))
     457               (if (frozen? source-file) '(read-only) '(read-write)))))))
     458     (else (when (or (not (file-exists? html-path))
     459                     (file-newer? source-file html-path))
     460             (qwiki-update-file! path))
     461           (send-static-file html-file)))))
     462
     463(define (frozen? source-file)
     464  (and-let* ((value (get-extended-property source-file "svnwiki:frozen")))
     465    (string=? (string-trim-both value) "yes")))
     466
     467(define (requires-authentication? source-file)
     468  (and-let* ((value (get-extended-property source-file "svnwiki:authenticate")))
     469    (string=? (string-trim-both value) "yes")))
    334470
    335471(define (file-newer? a b)
     
    339475(define (regenerate-html-file! path page)
    340476  (let* ((html-file (make-pathname (qwiki-web-path) (path->html-filename path)))
    341          (title ((sxpath '(// (Section 1) *text*)) (cons 'root page))))
     477         (title ((sxpath '(// (section 1) (*text* 1))) (cons 'root page))))
    342478    (with-output-to-path html-file
    343479      (lambda ()
    344480        (let ((content (qwiki-sxml-page-template
    345                         page `(title  ,(if (null? title)
    346                                            path
    347                                            (car title))))))
     481                        page
     482                        `(title  ,(if (null? title)
     483                                      (string-join path "/")
     484                                      (car title)))
     485                        (if (frozen? (path->source-filename path))
     486                            '(read-only)
     487                            '(read-write)))))
    348488          (output-xml content (qwiki-transformation-steps content)))))))
    349489
    350490(define (qwiki-update-file! path)
    351491  (let* ((source-file (path->source-filename path))
    352          (page (call-with-input-file source-file wiki-parse)))
     492         (page (call-with-input-file source-file svnwiki->sxml)))
    353493    (parameterize ((qwiki-current-file (string-join path "/")))
    354494      (for-each (lambda (handler) (handler path page))
    355                 (cons regenerate-html-file! (qwiki-update-handlers))))))
     495                (append (qwiki-update-handlers) (list regenerate-html-file!))))))
    356496
    357497(define (delete-html-file! path)
     
    373513
    374514(define (qwiki-delete-file! path)
    375   (for-each (lambda (handler) (handler path))
    376             (cons delete-html-file! (qwiki-delete-handlers))))
     515  (parameterize ((qwiki-current-file (string-join path "/")))
     516    (for-each (lambda (handler) (handler path))
     517              (cons delete-html-file! (qwiki-delete-handlers)))))
    377518
    378519;;; Request dispatching
     
    415556      (let ((uri (request-uri (current-request))))
    416557        (cond
     558         ((equal? (uri-path uri) (uri-path (qwiki-css-file)))
     559          (send-static-file
     560           (make-pathname (qwiki-docroot)
     561                          (string-join (cdr (uri-path (qwiki-css-file))) "/"))))
    417562         ((find (lambda (a)
    418563                  (equal? (uri-path uri) (list '/ (->string (car a)))))
  • release/4/qwiki/trunk/qwiki.setup

    r18360 r18634  
    3535        (compile -O2 -s qwiki-menu.import.scm))
    3636       
    37        ((dynld-name "qwiki-nowiki") ("qwiki-nowiki.scm" )
    38         (compile -O -d2 -s qwiki-nowiki.scm -j qwiki-nowiki))
    39 
    40        ((dynld-name "qwiki-nowiki.import") ("qwiki-nowiki.import.scm")
    41         (compile -O2 -s qwiki-nowiki.import.scm))
    42 
    4337       ((dynld-name "qwiki-post-commit-hook") ("qwiki-post-commit-hook.scm" )
    4438        (compile -O -d2 qwiki-post-commit-hook.scm))
     
    5852   (dynld-name "qwiki-menu")
    5953   (dynld-name "qwiki-menu.import")
    60    (dynld-name "qwiki-nowiki")
    61    (dynld-name "qwiki-nowiki.import")
    6254   (dynld-name "qwiki-post-commit-hook")
    6355   (dynld-name "qwiki-install")
     
    7365    "qwiki-search.so" "qwiki-search.import.so"
    7466    "qwiki-menu.so" "qwiki-menu.import.so"
    75     "qwiki-nowiki.so" "qwiki-nowiki.import.so"
    76    
    7767    )
    78   `((version 0.3)
     68  `((version 0.4)
    7969    (documentation "qwiki.html")))
    8070
     
    8272  'qwiki-post-commit-hook
    8373  '("qwiki-post-commit-hook")
    84   '((version 0.3)))
     74  '((version 0.4)))
    8575
    8676(install-script
    8777  'qwiki-install
    8878  '("qwiki-install")
    89   '((version 0.3)))
     79  '((version 0.4)))
  • release/4/qwiki/trunk/tests/run.scm

    r18464 r18634  
    11
    2 (require-extension qwiki-sxml sxml-transforms wiki-parse)
     2(require-extension qwiki-sxml sxml-transforms svnwiki-sxml)
    33
    44;; From sxml-fu
     
    88                        tree rulesets)))
    99
    10 (let ((content (call-with-input-file "tests/simple.wiki" wiki-parse)))
    11   (output-xml `(body ,content) (qwiki-html-transformation-rules content)))
     10(let ((content (call-with-input-file "tests/simple.wiki" svnwiki->sxml)))
     11  (output-xml `(wiki-page (Header (read-only)) (body (wiki-content ,content)))
     12              (qwiki-html-transformation-rules content)))
    1213
    13 (let ((content (call-with-input-file "tests/simple.wiki" wiki-parse)))
    14   (output-xml `(wiki-page (body ,content)) (qwiki-LaTeX-transformation-rules content)))
     14(let ((content (call-with-input-file "tests/simple.wiki" svnwiki->sxml)))
     15  (output-xml `(wiki-page ,content) (qwiki-LaTeX-transformation-rules content)))
    1516
    16 (let ((content (call-with-input-file "tests/simple.wiki" wiki-parse)))
    17   (output-xml `(body ,content) (qwiki-Texinfo-transformation-rules content)))
     17(let ((content (call-with-input-file "tests/simple.wiki" svnwiki->sxml)))
     18  (output-xml `(wiki-page ,content) (qwiki-Texinfo-transformation-rules content)))
Note: See TracChangeset for help on using the changeset viewer.