c0f32d5484
* tekuti/comment.scm (make-new-comment): Refactor to decouple comment.scm from post.scm. * tekuti/git.scm (run): Generalize so it can run any executable. (git-ls-tree, git-ls-subdirs): Check for a #f treeish, return directly in that case, avoiding tracebacks in the forked kid. (git-mktree): Return #f if the tree is empty. (git-rev-list): New command, something like git log. (patch-blob): New function; unused, though. Perhaps I should just delete it. (git-commit-reverse-operations): New function, constructs munge-tree operations to revert a commit. (git-revert): New operator, reverts a commit. Can't use git's revert because it requires a working tree. (munge-tree): Rewrite to unify the various commands, and process the commands in order. Makes a bit more garbage, but is much more understandable. * tekuti/page-helpers.scm (post-editing-form): Add a preview. (admin-post-url): New helper. (redirect): New helper. (admin-post-redirect): New helper. * tekuti/page.scm (page-admin): Show recent changes in the sidebar. (page-admin-new-post): Redirect to the new post. (page-new-comment): Rework for make-new-comment changes, and redirect to the post. Would be nice to redirect to the comment though. (page-admin-changes): New page, lists recent changes. (page-admin-change): New page, shows a change, allowing it to be undone. (page-admin-revert-change): New page, actually reverts a change. Thus we have comment deletion. * tekuti/post.scm (munge-post): New helper, factored out of make-new-post. (parse-post-data): Another new helper. Needs to do more validation, though. (modify-post): Post editing, yay! * tekuti/request.scm (parse-www-form-urlencoded): Factored out of request-form-data. (*request-initializers*): Initialize 'query to have the parsed query string data. * tekuti/url.scm (url:path-part, url:query-part): New somewhat hacky functions. url.scm needs some love. (url:path-split): Split on only the "path part" of the URL. * tekuti/util.scm (foldn): New export. Probably a bad idea. (match-case): New macro, not used though. (string-split/trimming): New util. * tekuti/web.scm (choose-handler): Update the set of pages.
187 lines
6.1 KiB
Scheme
187 lines
6.1 KiB
Scheme
;;; www/url.scm --- URL manipulation tools
|
||
|
||
;; Copyright (C) 1997,2001,2002 Free Software Foundation, Inc.
|
||
;;
|
||
;; This program is free software; you can redistribute it and/or modify
|
||
;; it under the terms of the GNU General Public License as published by
|
||
;; the Free Software Foundation; either version 2, or (at your option)
|
||
;; any later version.
|
||
;;
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this software; see the file COPYING. If not, write to
|
||
;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||
;; Boston, MA 02111-1307 USA
|
||
;;
|
||
|
||
;;; Commentary:
|
||
|
||
;; This module exports the following procedures:
|
||
;; (url:scheme url)
|
||
;; (url:address url)
|
||
;; (url:unknown url)
|
||
;; (url:user url)
|
||
;; (url:host url)
|
||
;; (url:port url)
|
||
;; (url:path url)
|
||
;; (url:make scheme . args)
|
||
;; (url:make-http host port path)
|
||
;; (url:make-ftp user host port path)
|
||
;; (url:make-mailto address)
|
||
;; (url:parse url)
|
||
;; (url:unparse url)
|
||
;; (url:decode str)
|
||
;; (url:encode str reserved-chars)
|
||
|
||
;;; Code:
|
||
|
||
|
||
;; TODO:
|
||
;; * support `user:password@' strings where appropriate in URLs.
|
||
;; * make URL parsing smarter. This is good for most TCP/IP-based
|
||
;; URL schemes, but parsing is actually specific to each URL scheme.
|
||
;; * fill out url:encode, include facilities for URL-scheme-specific
|
||
;; encoding methods (e.g. a url-scheme-reserved-char-alist)
|
||
|
||
(define-module (tekuti url)
|
||
#:use-module ((srfi srfi-1) #:select (filter))
|
||
#:use-module (ice-9 regex))
|
||
|
||
;; `url:scheme' is an unfortunate term, but it is the technical
|
||
;; name for that portion of the URL according to RFC 1738. Sigh.
|
||
|
||
(define-public (url:scheme url) (vector-ref url 0))
|
||
(define-public (url:address url) (vector-ref url 1))
|
||
(define-public (url:unknown url) (vector-ref url 1))
|
||
(define-public (url:user url) (vector-ref url 1))
|
||
(define-public (url:host url) (vector-ref url 2))
|
||
(define-public (url:port url) (vector-ref url 3))
|
||
(define-public (url:path url) (vector-ref url 4))
|
||
|
||
(define-public (url:make scheme . args)
|
||
(apply vector scheme args))
|
||
(define-public (url:make-http host port path)
|
||
(vector 'http #f host port path))
|
||
(define-public (url:make-ftp user host port path)
|
||
(vector 'ftp user host port path))
|
||
(define-public (url:make-mailto address)
|
||
(vector 'mailto address))
|
||
|
||
(define http-regexp (make-regexp "^http://([^:/]+)(:([0-9]+))?(/(.*))?$"))
|
||
(define ftp-regexp
|
||
(make-regexp "^ftp://(([^@:/]+)@)?([^:/]+)(:([0-9]+))?(/(.*))?$"))
|
||
(define mailto-regexp (make-regexp "^mailto:(.*)$"))
|
||
|
||
(define-public (url:parse url)
|
||
(cond
|
||
((regexp-exec http-regexp url)
|
||
=> (lambda (m)
|
||
(url:make-http (match:substring m 1)
|
||
(cond ((match:substring m 3) => string->number)
|
||
(else #f))
|
||
(match:substring m 5))))
|
||
|
||
((regexp-exec ftp-regexp url)
|
||
=> (lambda (m)
|
||
(url:make-ftp (match:substring m 2)
|
||
(match:substring m 3)
|
||
(cond ((match:substring m 5) => string->number)
|
||
(else #f))
|
||
(match:substring m 7))))
|
||
|
||
((regexp-exec mailto-regexp url)
|
||
=> (lambda (m)
|
||
(url:make-mailto (match:substring m 1))))
|
||
|
||
(else
|
||
(url:make 'unknown url))))
|
||
|
||
|
||
(define-public (url:unparse url)
|
||
(define (pathy scheme username url) ; username not used!
|
||
(format #f "~A://~A~A~A"
|
||
scheme
|
||
(url:host url)
|
||
(cond ((url:port url) => (lambda (port) (format #f ":~A" port)))
|
||
(else ""))
|
||
(cond ((url:path url) => (lambda (path) (format #f "/~A" path)))
|
||
(else ""))))
|
||
(case (url:scheme url)
|
||
((http) (pathy 'http #f url))
|
||
((ftp) (pathy 'ftp (url:user url) url))
|
||
((mailto) (format #f "mailto:~A" (url:address url)))
|
||
((unknown) (url:unknown url))))
|
||
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; (url-decode STR)
|
||
;; Turn + into space, and hex-encoded %XX strings into their
|
||
;; eight-bit characters. Is a regexp faster than character
|
||
;; scanning? Does it incur more overhead (which may be more
|
||
;; important for code that frequently gets restarted)?
|
||
|
||
(define-public (url:decode str)
|
||
(regexp-substitute/global
|
||
#f "\\+|%([0-9A-Fa-f][0-9A-Fa-f])" str
|
||
'pre
|
||
(lambda (m)
|
||
(cond ((string=? "+" (match:substring m 0)) " ")
|
||
(else (integer->char
|
||
(string->number
|
||
(match:substring m 1)
|
||
16)))))
|
||
'post))
|
||
|
||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
;; (url-encode STR)
|
||
;; The inverse of url-decode. Can't be done easily with
|
||
;; a regexp: we would have to construct a regular expression
|
||
;; like "[\277-\377]", for example, and Guile strings don't
|
||
;; let you interpolate character literals. Pity.
|
||
;; URL-encode any characters in STR that are not safe: these
|
||
;; include any character not in the SAFE-CHARS list and any
|
||
;; character that *is* in the RESERVED-CHARS list argument.
|
||
|
||
(define-public (url:encode str)
|
||
(with-output-to-string
|
||
(lambda ()
|
||
(for-each (lambda (ch)
|
||
(if (safe-char? ch)
|
||
(display ch)
|
||
(begin
|
||
(display #\%)
|
||
(display (number->string (char->integer ch) 16)))))
|
||
(string->list str)))))
|
||
|
||
(define special-chars
|
||
(string->list "$-_.+!*'()"))
|
||
(define reserved-chars
|
||
(string->list ";/?:@&="))
|
||
|
||
(define (safe-char? ch)
|
||
;; ``Thus, only alphanumerics, the special characters "$-_.+!*'(),", and
|
||
;; reserved characters used for their reserved purposes may be used
|
||
;; unencoded within a URL.'' RFC 1738, #2.2.
|
||
(or (char-alphabetic? ch)
|
||
(char-numeric? ch)
|
||
(memv ch special-chars)))
|
||
|
||
(define-public (url:path-part path)
|
||
(substring path 0 (or (string-index path #\?) (string-length path))))
|
||
|
||
(define-public (url:query-part path)
|
||
(let ((q (string-index path #\?)))
|
||
(if q (substring path (1+ q)) #f)))
|
||
|
||
(define-public (url:path-split path)
|
||
(filter (lambda (x) (not (string-null? x)))
|
||
(map url:decode (string-split (url:path-part path) #\/))))
|
||
|
||
(define-public (url:path-join path)
|
||
(string-join (map url:encode path) "/"))
|
||
|
||
;;; www/url.scm ends here
|