From dbed5b113d63a3e3dcbb52c7873e75c0bb10d628 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Fri, 29 Feb 2008 00:32:49 +0100 Subject: cleanups, refactorings, what-not --- tekuti/comment.scm | 200 +++++------------------------------------- tekuti/filters.scm | 80 +++++++++++++++-- tekuti/git.scm | 170 +++++++++++++++++++++--------------- tekuti/page.scm | 251 +++++++---------------------------------------------- tekuti/post.scm | 91 +++++++++++-------- tekuti/request.scm | 9 +- tekuti/util.scm | 77 +++++++++++++++- 7 files changed, 370 insertions(+), 508 deletions(-) diff --git a/tekuti/comment.scm b/tekuti/comment.scm index 670fc25..60d9a2c 100644 --- a/tekuti/comment.scm +++ b/tekuti/comment.scm @@ -33,32 +33,26 @@ #:use-module (srfi srfi-19) #:use-module (sxml transform) #:use-module (match-bind) - #:export (comment-from-object comment-sxml-content comment-timestamp build-comment-skeleton comment-readable-date - bad-new-comment-post? make-new-comment)) + #:export (blob->comment comment-sxml-content comment-timestamp + comment-readable-date bad-new-comment-post? make-new-comment)) (define *comment-spec* `((timestamp . ,string->number))) -(define (comment-from-object encoded-name sha1) + +(define (blob->comment encoded-name sha1) (let ((blob (git "show" sha1))) (match-bind "\n\n(.*)$" blob (_ content) - (fold cons - (filter - identity - (match-lines (substring blob 0 (- (string-length blob) - (string-length _))) - "^([^: ]+): +(.*)$" (_ k v) - (let* ((k (string->symbol k)) - (parse (assq-ref *comment-spec* k))) - (if parse - (catch 'parse-error - (lambda () - (cons k (parse v))) - (lambda args #f)) - (cons k v))))) - `((raw-content . ,content) - (sha1 . ,sha1) - (key . ,encoded-name)))))) + (append + `((raw-content . ,content) + (sha1 . ,sha1) + (key . ,encoded-name)) + (match-lines (substring blob 0 (- (string-length blob) + (string-length _))) + "^([^: ]+): +(.*)$" (_ k v) + (let* ((k (string->symbol k)) + (parse (or (assq-ref *comment-spec* k) identity))) + (cons k (parse v)))))))) (define (comment-readable-date comment) (let ((date (time-utc->date @@ -78,117 +72,21 @@ (define (comment-timestamp comment-alist) (or (assq-ref comment-alist 'timestamp) #f)) -(define (build-comment-skeleton comments) - (fold (lambda (sha1 parent) - (let* ((ts (comment-timestamp sha1)) - (env (list "GIT_COMMMITTER=tekuti" - (format #f "GIT_COMMITTER_DATE=~a +0100" ts) - (format #f "GIT_AUTHOR_DATE=~a +0100" ts)))) - (string-trim-both - (git* (cons* "commit-tree" sha1 (if parent (list "-p" parent) '())) - #:input "comment\n" #:env env)))) - #f - comments)) - -(define (emailish? x) - (match-bind "^([a-zA-Z0-9.+-]+)@([a-zA-Z0-9-]+\\.)+[a-zA-Z]+$" - x (_ . args) - x - #f)) - (define (bad-email? x) (if (emailish? x) #f `(p "Please pretend to specify a valid email address."))) -(define (urlish? x) - (match-bind "^https?://([a-zA-Z0-9-]+\\.)+[a-zA-Z]+/[a-zA-Z0-9$_.+!*'(),;/?:@&=-]*$" - x (_ . args) - x - #f)) - (define (bad-url? x) (if (or (string-null? x) (urlish? x)) #f `(p "Bad URL. (Only http and https are allowed.)"))) -(define *allowed-tags* - `((a (href . ,urlish?) title) - (abbr title) - (acronym title) - (b) - (br) - (blockquote (cite . ,urlish?)) - (code) - (em) - (i) - (p) - (pre) - (strike) - (strong))) - -(define (compile-sxslt-rules tags) - (define (ok . body) - body) - (define (compile-attribute-rule rule) - (if (symbol? rule) - `(,rule . ,ok) - `(,(car rule) . ,(lambda (tag text) - (or ((cdr rule) text) - (throw 'bad-attr-value text)) - (list tag text))))) - `(,@(map (lambda (spec) - `(,(car spec) - ((@ *preorder* - . ,(let ((rules `((@ (,@(map compile-attribute-rule - (cdr spec)) - (*text* - . ,(lambda (tag text) text)) - (*default* - . ,(lambda (tag . body) - (throw 'bad-attr tag)))) - . ,ok)))) - (lambda tree - (pre-post-order tree rules))))) - . ,ok)) - *allowed-tags*) - (*text* . ,(lambda (tag text) - text)) - (*default* . ,(lambda (tag . body) - (throw 'bad-tag tag))))) - -;; could be better, reflect nesting rules... -(define *valid-xhtml-rules* - `((div ,(compile-sxslt-rules *allowed-tags*) - . ,(lambda body body)))) - -(use-modules (sxml transform) (tekuti filters)) -(define (bad-xhtml? x) - (catch #t - (lambda () - (pre-post-order (wordpress->sxml x) *valid-xhtml-rules*) - #f) - (lambda (key . args) - `(div (p "Invalid XHTML") - ,(case key - ((parser-error) - `(pre ,(with-output-to-string - (lambda () (write args))))) - ((bad-tag) - `(p "XHTML tag disallowed: " ,(symbol->string (car args)))) - ((bad-attr) - `(p "XHTML attribute disallowed: " ,(symbol->string (car args)))) - ((bad-attr-value) - `(p "XHTML attribute has bad value: " ,(car args))) - (else - (pk key args) - `(p "Jesus knows why, and so do you"))))))) - (define *new-comment-spec* `(("author" ,(lambda (x) #f)) ("email" ,bad-email?) ("url" ,bad-url?) - ("comment" ,bad-xhtml?) + ("comment" ,bad-user-submitted-xhtml?) ("submit" ,(lambda (x) #f)))) (define (bad-new-comment-post? post-data) @@ -204,59 +102,6 @@ ((cadr pair) (assoc-ref post-data (car pair)))) *new-comment-spec*))) -(use-modules (srfi srfi-11)) -(define (make-tree-deep treeish add remove change) - (define (local? x) (null? (car x))) - (define (assert-added-files-not-present names dents) - (for-each - (lambda (dent) - (if (member (car dent) names) - (error "file already added" dent))) - dents)) - (define (assert-referenced-files-present names dents) - (for-each - (lambda (name) - (if (not (assoc name dent-names)) - (error "file already removed" name))) - names)) - (let-values (((dents) (if treeish (git-ls-tree treeish #f) '())) - ((ladd dadd) (partition local? add)) - ((lremove dremove) (partition local? remove)) - ((lchange dchange) (partition local? change))) - (assert-added-files-not-present (map cadr ladd) dents) - (assert-referenced-files-present - (append (map cdr lremove) (map caar lchange)) dents) - ; (trc 'make-tree-deep treeish add remove change) - (git-mktree - (append - (map cdr ladd) - (filter-map - (lambda (dent) - (cond - ((member (car dent) (map cdr lremove)) - #f) - ((member (car dent) (map cadr lchange)) - (cdr lchange)) - ((and (eq? (caddr dent) 'tree) - (member (car dent) - (map caar (append dadd dremove dchange)))) - (let ((level-down (lambda (x) - (if (equal? (caar x) (car dent)) - (cons (cdar x) (cdr x)) - #f)))) - (list (car dent) - (make-tree-deep (cadr dent) - (filter-map level-down dadd) - (filter-map level-down dremove) - (filter-map level-down dchange)) - 'tree))) - (else dent))) - (append (filter-map (lambda (x) - (and (not (assoc (caar x) dents)) - (list (caar x) #f 'tree))) - dadd) - dents)))))) - (define de-newline (s///g "[\n\r]" " ")) (define (make-new-comment post post-data) @@ -277,13 +122,10 @@ (git-update-ref "refs/heads/master" (lambda (master) - (git-commit-tree - (make-tree-deep master - `(((,(assq-ref post 'key) "comments") - . (,sha1 ,sha1 blob))) - '() - '()) - master - "new comment" - #f)) + (git-commit-tree (munge-tree master + `(((,(assq-ref post 'key) "comments") + . (,sha1 ,sha1 blob))) + '() + '()) + master "new comment" #f)) 5)))) diff --git a/tekuti/filters.scm b/tekuti/filters.scm index b6bce67..d7b914b 100644 --- a/tekuti/filters.scm +++ b/tekuti/filters.scm @@ -28,7 +28,9 @@ #:use-module (sxml simple) #:use-module (sxml transform) #:use-module (match-bind) - #:export (wordpress->sxml)) + #:use-module (tekuti util) + #:export (wordpress->sxml + *allowed-tags* bad-user-submitted-xhtml?)) (define blocks '(table thead tfoot caption colgroup tbody tr td th div dl dd dt ul ol li pre select form map area blockquote @@ -76,10 +78,6 @@ (lp #f (cdr in) (cons (car in) (pclose p out)))))))) -(wpautop 'div - `((b "foo") "\n\n" (b "bar"))) - - (define (wordpress->sxml text) (let ((sxml (cadr (with-input-from-string (string-append "
" text "
") xml->sxml)))) @@ -91,3 +89,75 @@ (cons tag body)))) (*text* . ,(lambda (tag text) text)))))) + +(define *allowed-tags* + `((a (href . ,urlish?) title) + (abbr title) + (acronym title) + (b) + (br) + (blockquote (cite . ,urlish?)) + (code) + (em) + (i) + (p) + (pre) + (strike) + (strong))) + +(define (compile-sxslt-rules tags) + (define (ok . body) + body) + (define (compile-attribute-rule rule) + (if (symbol? rule) + `(,rule . ,ok) + `(,(car rule) . ,(lambda (tag text) + (or ((cdr rule) text) + (throw 'bad-attr-value text)) + (list tag text))))) + `(,@(map (lambda (spec) + `(,(car spec) + ((@ *preorder* + . ,(let ((rules `((@ (,@(map compile-attribute-rule + (cdr spec)) + (*text* + . ,(lambda (tag text) text)) + (*default* + . ,(lambda (tag . body) + (throw 'bad-attr tag)))) + . ,ok)))) + (lambda tree + (pre-post-order tree rules))))) + . ,ok)) + *allowed-tags*) + (*text* . ,(lambda (tag text) + text)) + (*default* . ,(lambda (tag . body) + (throw 'bad-tag tag))))) + +;; could be better, reflect nesting rules. +(define *valid-xhtml-rules* + `((div ,(compile-sxslt-rules *allowed-tags*) + . ,(lambda body body)))) + +(define (bad-user-submitted-xhtml? x) + (catch #t + (lambda () + (pre-post-order (wordpress->sxml x) *valid-xhtml-rules*) + #f) + (lambda (key . args) + `(div (p "Invalid XHTML") + ,(case key + ((parser-error) + `(pre ,(with-output-to-string + (lambda () (write args))))) + ((bad-tag) + `(p "XHTML tag disallowed: " ,(symbol->string (car args)))) + ((bad-attr) + `(p "XHTML attribute disallowed: " ,(symbol->string (car args)))) + ((bad-attr-value) + `(p "XHTML attribute has bad value: " ,(car args))) + (else + (pk key args) + `(p "Jesus knows why, and so do you"))))))) + diff --git a/tekuti/git.scm b/tekuti/git.scm index 723882a..d154f7c 100644 --- a/tekuti/git.scm +++ b/tekuti/git.scm @@ -20,7 +20,7 @@ ;;; Commentary: ;; -;; This is the main script that will launch tekuti. +;; Using git's object database as a persistent store. ;; ;;; Code: @@ -31,20 +31,25 @@ #:use-module (tekuti config) #:use-module (scheme kwargs) #:use-module (match-bind) + #:use-module ((srfi srfi-1) #:select (filter-map partition)) + #:use-module (srfi srfi-11) ; let-values #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (&git-condition git-condition? git-condition-argv git-condition-output git-condition-status false-if-git-error git git* ensure-git-repo git-ls-tree git-ls-subdirs - parse-metadata parse-commit commit-utc-timestamp - commit-parents git-mktree git-rev-parse - git-hash-object git-update-ref + git-mktree git-rev-parse git-hash-object git-update-ref git-commit-tree - with-output-to-blob with-input-from-blob + munge-tree parse-commit commit-utc-timestamp + + with-output-to-blob with-input-from-blob)) - write-indices read-indices)) + +;;; +;;; git conditions +;;; (define-condition-type &git-condition &condition git-condition? (argv git-condition-argv) @@ -55,6 +60,10 @@ `(,guard (c ((,git-condition? c) #f)) ,@body)) +;;; +;;; running git +;;; + (define *debug* #f) (define (trc . args) (if *debug* @@ -86,17 +95,7 @@ (output output) (status ret)))))))) -(define (call-with-temp-file contents proc) - (let* ((template (string-copy "/tmp/tekutiXXXXXX")) - (tmp (mkstemp! template))) - (display contents tmp) - (close tmp) - (unwind-protect - (proc template) - (delete-file template)))) - (define/kwargs (git* args (input #f) (env '())) - ;; foolishness regarding env (if input (call-with-temp-file input @@ -108,6 +107,10 @@ (define (git . args) (git* args)) +;;; +;;; git commands +;;; + (define (is-dir? path) (catch 'system-error (lambda () (eq? (stat:type (stat path)) 'directory)) @@ -137,45 +140,6 @@ (cons name object))) '())) -(define (parse-metadata treeish specs) - (filter - identity - (match-lines (git "show" treeish) - "^([^: ]+): +(.*)$" (_ k v) - (let* ((k (string->symbol k)) - (parse (assq-ref specs k))) - (if parse - (catch 'parse-error - (lambda () - (cons k (parse v))) - (lambda args #f)) - (cons k v)))))) - -(define (parse-commit commit) - (let ((text (git "cat-file" "commit" commit))) - (match-bind - "\n\n(.*)$" text (_ message) - (acons - 'message message - (match-lines (substring text 0 (- (string-length text) (string-length _))) - "^([^ ]+) (.*)$" (_ k v) - (cons (string->symbol k) v)))))) - -(define (commit-utc-timestamp commit) - (match-bind - "^(.*) ([0-9]+) ([+-][0-9]+)" (assq-ref (parse-commit commit) 'committer) - (_ who ts tz) - (let ((ts (string->number ts)) (tz (string->number tz))) - (- ts (* (+ (* (quotient tz 100) 60) (remainder tz 100)) 60))))) - -;; fixme: do to commits what i already did to posts - -(define (commit-parents commit) - (map cdr - (filter - (lambda (x) (eq? (car x) 'parent)) - (parse-commit commit)))) - (define (git-mktree alist) (string-trim-both (git* '("mktree") @@ -197,18 +161,6 @@ (string-trim-both (git* '("hash-object" "-w" "--stdin") #:input contents))) -(define (with-output-to-blob* thunk) - (git-hash-object (with-output-to-string thunk))) - -(define-macro (with-output-to-blob . forms) - `(,with-output-to-blob* (lambda () ,@forms))) - -(define (with-input-from-blob* sha1 thunk) - (with-input-from-string (git "show" sha1) thunk)) - -(define-macro (with-input-from-blob sha1 . forms) - `(,with-input-from-blob* ,sha1 (lambda () ,@forms))) - (define (git-update-ref refname proc count) (let* ((ref (git-rev-parse refname)) (commit (proc ref))) @@ -233,5 +185,87 @@ (format #f "GIT_AUTHOR_DATE=~a +0100" timestamp)) (list "GIT_COMMMITTER=tekuti"))))) -;; fixme: map-pairs +;;; +;;; utilities +;;; + +(define (munge-tree treeish add remove change) + (define (local? x) (null? (car x))) + (define (assert-added-files-not-present names dents) + (for-each + (lambda (dent) + (if (member (car dent) names) + (error "file already added" dent))) + dents)) + (define (assert-referenced-files-present names dents) + (for-each + (lambda (name) + (if (not (assoc name dent-names)) + (error "file already removed" name))) + names)) + (let-values (((dents) (if treeish (git-ls-tree treeish #f) '())) + ((ladd dadd) (partition local? add)) + ((lremove dremove) (partition local? remove)) + ((lchange dchange) (partition local? change))) + (assert-added-files-not-present (map cadr ladd) dents) + (assert-referenced-files-present + (append (map cdr lremove) (map caar lchange)) dents) + ; (trc 'munge-tree treeish add remove change) + (git-mktree + (append + (map cdr ladd) + (filter-map + (lambda (dent) + (cond + ((member (car dent) (map cdr lremove)) + #f) + ((member (car dent) (map cadr lchange)) + (cdr lchange)) + ((and (eq? (caddr dent) 'tree) + (member (car dent) + (map caar (append dadd dremove dchange)))) + (let ((level-down (lambda (x) + (if (equal? (caar x) (car dent)) + (cons (cdar x) (cdr x)) + #f)))) + (list (car dent) + (munge-tree (cadr dent) + (filter-map level-down dadd) + (filter-map level-down dremove) + (filter-map level-down dchange)) + 'tree))) + (else dent))) + (append (filter-map (lambda (x) + (and (not (assoc (caar x) dents)) + (list (caar x) #f 'tree))) + dadd) + dents)))))) + +(define (parse-commit commit) + (let ((text (git "cat-file" "commit" commit))) + (match-bind + "\n\n(.*)$" text (_ message) + (acons + 'message message + (match-lines (substring text 0 (- (string-length text) (string-length _))) + "^([^ ]+) (.*)$" (_ k v) + (cons (string->symbol k) v)))))) +(define (commit-utc-timestamp commit) + (match-bind + "^(.*) ([0-9]+) ([+-][0-9]+)" (assq-ref (parse-commit commit) 'committer) + (_ who ts tz) + (let ((ts (string->number ts)) (tz (string->number tz))) + (- ts (* (+ (* (quotient tz 100) 60) (remainder tz 100)) 60))))) + +(define (with-output-to-blob* thunk) + (git-hash-object (with-output-to-string thunk))) + +(define-macro (with-output-to-blob . forms) + `(,with-output-to-blob* (lambda () ,@forms))) + +(define (with-input-from-blob* sha1 thunk) + (with-input-from-string (git "show" sha1) thunk)) + +(define-macro (with-input-from-blob sha1 . forms) + `(,with-input-from-blob* ,sha1 (lambda () ,@forms))) diff --git a/tekuti/page.scm b/tekuti/page.scm index 0974935..cc6456b 100644 --- a/tekuti/page.scm +++ b/tekuti/page.scm @@ -32,6 +32,7 @@ #:use-module (tekuti comment) #:use-module (tekuti url) #:use-module (tekuti request) + #:use-module (tekuti page-helpers) #:use-module (srfi srfi-34) #:use-module (srfi srfi-19) #:use-module (scheme kwargs) @@ -52,17 +53,9 @@ page-search page-show-post page-feed-atom - page-feed-rss2 page-debug page-not-found)) -(define (relurl path) - (string-append *public-url-base* path)) - -(define (rellink path . body) - `(a (@ (href ,(relurl path))) - ,@body)) - (define (make-post-key . parts) (url:encode (format #f "~{~a~^/~}" (map url:encode parts)))) @@ -73,34 +66,6 @@ (p "Path handler not yet implemented: " ,(rref request 'path-str))))) -(define (post-editing-form post) - `(form (@ (method "POST") - (action ,(string-append *public-url-base* - (if post - (string-append "admin/modify-post/" - (url:encode (assq-ref post 'key))) - "admin/new-post")))) - (p "title: " - (input (@ (name "title") (type "text") - (value ,(if post (assq-ref post 'title) ""))))) - (div (textarea (@ (name "body") (rows "20") (cols "80")) - ,(if post (post-raw-content post) ""))) - (input (@ (type "submit") - (value ,(if post "edit post" "new post")))))) - -(define (sidebar-ul body) - `(div (@ (id "menu")) - (ul ,@body))) - -(define (with-authentication request thunk) - (if (request-authenticated? request) - (thunk) - (rcons* (rpush 'output-headers - '("WWW-Authenticate" . "Basic realm=\"Tekuti\"") - request) - 'status 401 - 'body `((p "Authentication required, yo"))))) - (define (page-admin request index) (with-authentication request @@ -119,24 +84,13 @@ (h2 "new post") ,(post-editing-form #f)))))) -(define (admin-post-link post) - (rellink (string-append "admin/posts/" - (url:encode (assq-ref post 'key))) - (assq-ref post 'title))) - -(define (post-link post) - (rellink (string-append "archives/" (url:decode (assq-ref post 'key))) - (assq-ref post 'title))) - (define (page-admin-posts request index) (with-authentication request (lambda () (define (post-headers) (map (lambda (post) - ;; double-encoding is a hack to trick apache - `(h3 ,(rellink (string-append "admin/posts/" (url:encode (assq-ref post 'key))) - (assq-ref post 'title)))) + `(h3 ,(admin-post-link post))) (assq-ref index 'posts))) (rcons* request 'body `((h1 "all your posts are belong to tekuti") @@ -148,7 +102,7 @@ (lambda () (let ((post (post-from-key (assq-ref index 'master) key))) (rcons* request - 'body `((h1 ,(assq-ref post 'title)) + 'body `((h1 ,(post-title post)) ,(post-editing-form post))))))) (define (page-admin-new-post request index) @@ -164,25 +118,6 @@ (p "Created new post: " ,(assoc-ref form-data "title")) (pre ,(assoc-ref form-data "body")))))))) -(define (show-post post comments?) - `((h2 (@ (class "storytitle")) - ,(post-link post)) - (div (@ (class "post")) - (h3 (@ (class "meta")) - ,(post-readable-date post) - " (" ,@(list-intersperse (post-tag-links post) - " | ") - ")") - (div (@ (class "storycontent")) - ,(post-sxml-content post)) - ,@(if comments? '() - (list (post-sxml-n-comments post)))) - ,@(if comments? - (list (post-sxml-comments post)) - '()))) - -;; (a (@ (href ,new-url)) ,new-url) - (define (page-admin-modify-post request index key) (with-authentication request @@ -191,118 +126,46 @@ (define page-delete-comment not-implemented) (define page-delete-post not-implemented) -;; fixme: borks in the no-tags case -(define (tag-cloud index) - (define (determine-sizes counts) - (let ((maxcount (apply max counts))) - (map (lambda (x) - (floor (+ 80 (* 120 (/ x maxcount))))) - counts))) - (let* ((hash (assq-ref index 'tags)) - (cats (if hash - (hash-fold (lambda (k v seed) (acons k (length v) seed)) - '() hash) - '())) - (top-20 (dsu-sort (take-max (dsu-sort cats cdr >) 20) - car string>")) - ,(tag-cloud index))))) - - (define (page-index request index) (rcons* request 'body `(,(main-sidebar request index) ,@(map (lambda (post) (show-post post #f)) - (take-max (assq-ref index 'posts) 10))))) + (published-posts index 10))))) (define (page-show-post request index year month day post) - (let ((slug (make-post-key year month day post))) - (cond - ((false-if-git-error - (git-rev-parse (string-append (assq-ref index 'master) ":" slug))) - => (lambda (tree) - (let ((post (post-from-tree slug tree))) - (rcons* request - 'title (string-append (assq-ref post 'title) - " -- " *title*) - 'body (show-post post #t))))) - (else - (page-not-found request index))))) - -(define (page-new-comment request index year month day post) - (let ((slug (make-post-key year month day post)) - (data (request-form-data request))) + (cond + ((post-from-key (assq-ref index 'master) + (make-post-key year month day post)) + => (lambda (post) + (rcons* request + 'title (string-append (post-title post) " -- " *title*) + 'body (show-post post #t)))) + (else + (page-not-found request index)))) + +(define (page-new-comment request index year month day name) + (let ((data (request-form-data request))) (cond - ((false-if-git-error - (git-rev-parse (string-append (assq-ref index 'master) ":" slug))) - => (lambda (tree) + ((post-from-key (assq-ref index 'master) + (make-post-key year month day name)) + => (lambda (post) (cond ((bad-new-comment-post? data) => (lambda (reason) - (pk reason) (rcons* request - 'body `((p "Bad post data: " ,reason))))) + 'body `((p "Bad post data: " ,(pk reason)))))) (else - (let ((comment (make-new-comment (post-from-tree slug tree) data))) + (let ((comment (make-new-comment post data))) + ;; nb: at this point, `post' is out-of-date (rcons* request 'title "comment posted" - 'body `((p "Comment, posted, thanks.") + 'body `((p "Comment posted, thanks.") ;; fixme: show the post directly; or a redirect? - (p "Back to the post: " - ,(rellink (string-append "archives/" (url:decode slug)) - post))))))))) - + (p "Back to the post: " ,(post-link post))))))))) (else (page-not-found request index))))) -(define/kwargs (date-increment date (day 0) (month 0) (year 0)) - (make-date (date-nanosecond date) (date-second date) - (date-minute date) (date-minute date) - (+ (date-day date) day) (+ (date-month date) month) - (+ (date-year date) year) (date-zone-offset date))) - -(define (date-comparator date comp) - (let ((this (time-second (date->time-utc date)))) - (lambda (that) - (comp that this)))) - -(define (date-before? date) - (date-comparator date <)) - -(define (date-after? date) - (date-comparator date >)) - -(define (compose1 proc . procs) - (if (null? procs) - proc - (let ((other (apply compose1 procs))) - (lambda (x) - (proc (other x)))))) - ;; fixme exception handling for input (define (page-archives request index year month day) (let ((year (and=> year string->number)) @@ -322,7 +185,7 @@ (define (make-date-header post) (lambda (x) #f)) - (let lp ((posts (assq-ref index 'posts))) + (let lp ((posts (published-posts index -1))) (cond ((or (null? posts) (too-early? (car posts))) (rcons* request 'title *title* @@ -362,41 +225,16 @@ (define page-search not-implemented) (define (page-not-found request index) - (pk request) - (rcons* request + (rcons* (pk 'not-found request) 'status 404 'body `((h1 "Page not found") (p "Unknown path: " ,(rref request 'path-str))))) -(define (page-feed-rss2 request index) - (not-implemented request index)) - - -(define (rfc822-date->timestamp str) - (+ (time-second (date->time-utc - (string->date str "~a, ~d ~b ~Y ~H:~M:~S GMT"))) - (date-zone-offset (current-date)))) - -(define (timestamp->atom-date timestamp) - (date->string (time-utc->date (make-time time-utc 0 timestamp) 0) - "~Y-~m-~dT~H:~M:~SZ")) - -(define (timestamp->rfc822-date timestamp) - (date->string (time-utc->date (make-time time-utc 0 timestamp) 0) - "~a, ~d ~b ~Y ~H:~M:~S GMT")) - -(define (request-relurl request) - (let ((headers (rref request 'headers))) - (let ((server (or (assoc-ref headers "Host") - (assoc-ref headers "server-ip-addr")))) - (lambda (tail) - (string-append "http://" server "/" tail))))) - (define (page-feed-atom request index) - (let ((last-modified (let ((posts (assq-ref index 'posts))) + (let ((last-modified (let ((posts (published-posts index 1))) (and (pair? posts) (assq-ref (car posts) 'timestamp)))) - (relurl (request-relurl request))) + (server-name (request-server-name request))) (cond ((let ((since (assoc-ref (rref request 'headers '()) "If-Modified-Since"))) @@ -411,31 +249,8 @@ request) 'doctype "" 'content-type "application/atom+xml" - 'sxml `(feed - (@ (xmlns "http://www.w3.org/2005/Atom") - (xml:base ,(relurl "feed/atom"))) - (title (@ (type "text")) ,*title*) - (subtitle (@ (type "text")) ,*subtitle*) - (updated ,(timestamp->atom-date last-modified)) - (generator (@ (uri "http://wingolog.org/software/tekuti") - (version "what")) - "tekuti") - (link (@ (rel "alternate") (type "text/html") - (href ,(relurl "")))) - (id ,(relurl "feed/atom")) - (link (@ (rel "self") (type "application/atom+xml") - (href ,(relurl "feed/atom")))) - ,@(map - (lambda (post) - `(entry - (author (name ,*name*) (uri ,(relurl ""))) - (title (@ (type "text")) ,(assq-ref post 'title)) - (id ,(relurl (url:decode (assq-ref post 'key)))) ;hack - (published ,(timestamp->atom-date - (assq-ref post 'timestamp))) - (updated ,(timestamp->atom-date - (assq-ref post 'timestamp))) - (content (@ (type "xhtml")) - (div (@ (xmlns "http://www.w3.org/1999/xhtml")) - ,(post-sxml-content post))))) - (take-max (assq-ref index 'posts) 10)))))))) + 'sxml (append (atom-header server-name last-modified) + (map + (lambda (post) + (atom-entry server-name post)) + (published-posts index 10)))))))) diff --git a/tekuti/post.scm b/tekuti/post.scm index f8e0970..7e2e72f 100644 --- a/tekuti/post.scm +++ b/tekuti/post.scm @@ -35,16 +35,50 @@ #:use-module (tekuti filters) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) - #:export (reindex-posts post-from-tree post-from-key post-tags - post-timestamp post-key - post-sxml-content post-raw-content all-published-posts - post-readable-date post-tag-links post-sxml-n-comments - post-sxml-comments)) + #:export (post-from-tree post-from-key - -;; introducing new assumption: post urls like yyyy/dd/mm/post; post dirnames the urlencoded post + post-tags post-timestamp post-key post-published? + post-sxml-content post-raw-content post-readable-date post-tag-links post-sxml-n-comments + post-sxml-comments post-title + + all-published-posts + + reindex-posts)) + +;;; +;;; pulling posts out of git +;;; + +(define *post-spec* + `((timestamp . ,string->number) + (tags . ,(lambda (v) (map string-trim-both (string-split v #\,)))) + (title . ,identity))) + +(define (post-from-tree encoded-name sha1) + (append `((key . ,encoded-name) + (sha1 . ,sha1)) + (match-lines + (git "show" (string-append sha1 ":metadata")) + "^([^: ]+): +(.*)$" (_ k v) + (let* ((k (string->symbol k)) + (parse (or (assq-ref *post-spec* k) + identity))) + (cons k (parse v)))))) + +(define (post-from-key master key . allow-unpublished) + (false-if-git-error + (let ((pairs (git-ls-subdirs master key))) + (and (= (length pairs) 1) + (let ((post (post-from-tree key (cdar pairs)))) + (if (or (post-published? post) + (and (pair? allow-unpublished) (car allow-unpublished))) + post + #f)))))) + +;;; +;;; accessors +;;; -;; perhaps push this processing into post-from-tree (define (post-published? post-alist) (equal? (assq-ref post-alist 'status) "publish")) @@ -57,16 +91,8 @@ (define (post-key post) (assq-ref post 'key)) -(define *post-spec* - `((timestamp . ,string->number) - (tags . ,(lambda (v) (map string-trim-both (string-split v #\,)))) - (title . ,identity))) - -(define (post-from-tree encoded-name sha1) - (acons 'key encoded-name - (acons 'sha1 sha1 - (parse-metadata (string-append sha1 ":metadata") - *post-spec*)))) +(define (post-title post) + (assq-ref post 'title)) (define (post-raw-content post) (git "show" (string-append (assq-ref post 'sha1) ":content"))) @@ -92,26 +118,10 @@ (define (post-tag-links post) (map tag-link (post-tags post))) -(define (post-from-key master key) - (let ((pairs (git-ls-subdirs master key))) - (and (= (length pairs) 1) - (post-from-tree key (cdar pairs))))) - -(define (all-posts master) - (map (lambda (pair) - (post-from-tree (car pair) (cdr pair))) - (git-ls-subdirs master #f))) - -(define (all-published-posts master) - (dsu-sort - (filter post-published? (all-posts master)) - post-timestamp - >)) - (define (post-comments post) (dsu-sort (map (lambda (pair) - (comment-from-object (car pair) (cadr pair))) + (blob->comment (car pair) (cadr pair))) (git-ls-tree (string-append (assq-ref post 'sha1) ":comments") #f)) comment-timestamp <)) @@ -180,6 +190,17 @@ "#comments"))) "(" ,(post-n-comments post) ")"))) +(define (all-posts master) + (map (lambda (pair) + (post-from-tree (car pair) (cdr pair))) + (git-ls-subdirs master #f))) + +(define (all-published-posts master) + (dsu-sort + (filter post-published? (all-posts master)) + post-timestamp + >)) + (define (hash-fill proc list) (let ((table (make-hash-table))) (for-each (lambda (x) (proc x table)) diff --git a/tekuti/request.scm b/tekuti/request.scm index d3b3c0c..0a82be4 100644 --- a/tekuti/request.scm +++ b/tekuti/request.scm @@ -34,7 +34,7 @@ #:use-module (tekuti base64) #:export (make-request rcons rcons* rpush rpush* rref let-request request-path-case request-authenticated? - request-form-data)) + request-form-data request-server-name)) (define (header-ref headers key default) (let ((pair (assoc key headers))) @@ -189,3 +189,10 @@ (,let-request ,request (method path) (cons method path)) ,@clauses)) + +(define (request-server-name request) + (let ((headers (rref request 'headers))) + (or (assoc-ref headers "Host") + (assoc-ref headers "server-ip-addr")))) + + diff --git a/tekuti/util.scm b/tekuti/util.scm index 2dd4240..e219784 100644 --- a/tekuti/util.scm +++ b/tekuti/util.scm @@ -20,18 +20,44 @@ ;;; Commentary: ;; -;; This is the main script that will launch tekuti. +;; Utility procedures and macros. ;; ;;; Code: (define-module (tekuti util) #:use-module (match-bind) + #:use-module (scheme kwargs) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:export (expanduser match-lines dbg unwind-protect dbg dsu-sort - hash-push! list-has-length? list-head-match mapn + hash-push! list-has-length? list-head-match mapn filter-mapn take-max read-hash write-hash shell:quote + call-with-temp-file emailish? urlish? + date-increment date-comparator date-before? date-after? compose1 + rfc822-date->timestamp timestamp->rfc822-date timestamp->atom-date list-intersperse with-backtrace with-time-debugging define-memoized)) +(define (emailish? x) + (match-bind "^([a-zA-Z0-9.+-]+)@([a-zA-Z0-9-]+\\.)+[a-zA-Z]+$" + x (_ . args) + x + #f)) + +(define (urlish? x) + (match-bind "^https?://([a-zA-Z0-9-]+\\.)+[a-zA-Z]+/[a-zA-Z0-9$_.+!*'(),;/?:@&=-]*$" + x (_ . args) + x + #f)) + +(define (call-with-temp-file contents proc) + (let* ((template (string-copy "/tmp/tekutiXXXXXX")) + (tmp (mkstemp! template))) + (display contents tmp) + (close tmp) + (unwind-protect + (proc template) + (delete-file template)))) + (define (shell:quote str) (with-output-to-string (lambda () @@ -103,6 +129,16 @@ (reverse out) (lp (cdr in) (cons (proc (car in)) out) (1- n))))) +(define (filter-mapn proc l nmax) + (let lp ((in l) (out '()) (n nmax)) + (if (or (null? in) (zero? n)) + (reverse out) + (let ((val (proc (car in)))) + (if val + (lp (cdr in) (cons val out) (1- n)) + (lp (cdr in) out n)) + )))) + (define (list-intersperse src-l elem) (if (null? src-l) src-l (let loop ((l (cdr src-l)) (dest (cons (car src-l) '()))) @@ -179,3 +215,40 @@ (read)) h)) +(define/kwargs (date-increment date (day 0) (month 0) (year 0)) + (make-date (date-nanosecond date) (date-second date) + (date-minute date) (date-minute date) + (+ (date-day date) day) (+ (date-month date) month) + (+ (date-year date) year) (date-zone-offset date))) + +(define (date-comparator date comp) + (let ((this (time-second (date->time-utc date)))) + (lambda (that) + (comp that this)))) + +(define (date-before? date) + (date-comparator date <)) + +(define (date-after? date) + (date-comparator date >)) + +(define (compose1 proc . procs) + (if (null? procs) + proc + (let ((other (apply compose1 procs))) + (lambda (x) + (proc (other x)))))) + +(define (rfc822-date->timestamp str) + (+ (time-second (date->time-utc + (string->date str "~a, ~d ~b ~Y ~H:~M:~S GMT"))) + (date-zone-offset (current-date)))) + +(define (timestamp->atom-date timestamp) + (date->string (time-utc->date (make-time time-utc 0 timestamp) 0) + "~Y-~m-~dT~H:~M:~SZ")) + +(define (timestamp->rfc822-date timestamp) + (date->string (time-utc->date (make-time time-utc 0 timestamp) 0) + "~a, ~d ~b ~Y ~H:~M:~S GMT")) + -- cgit v1.2.3-54-g00ecf