diff options
| -rw-r--r-- | tekuti/comment.scm | 6 | ||||
| -rw-r--r-- | tekuti/git.scm | 12 | ||||
| -rw-r--r-- | tekuti/page-helpers.scm | 38 | ||||
| -rw-r--r-- | tekuti/page.scm | 22 | ||||
| -rw-r--r-- | tekuti/post.scm | 54 | ||||
| -rw-r--r-- | tekuti/util.scm | 8 | ||||
| -rw-r--r-- | tekuti/web.scm | 1 |
7 files changed, 114 insertions, 27 deletions
diff --git a/tekuti/comment.scm b/tekuti/comment.scm index b72f6c6..db6cdd6 100644 --- a/tekuti/comment.scm +++ b/tekuti/comment.scm @@ -128,7 +128,9 @@ (author_email . ,email) (author_url . ,url))) (display "\n") - (display content)))) + (display content))) + (message (format #f "comment on \"~a\" by ~a" (post-title post) + author))) (git-update-ref "refs/heads/master" (lambda (master) @@ -137,5 +139,5 @@ . (,sha1 ,sha1 blob))) '() '()) - master "new comment" #f)) + master message #f)) 5)))) diff --git a/tekuti/git.scm b/tekuti/git.scm index d154f7c..7bc174c 100644 --- a/tekuti/git.scm +++ b/tekuti/git.scm @@ -31,7 +31,8 @@ #: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-1) #:select (filter-map partition + delete-duplicates)) #:use-module (srfi srfi-11) ; let-values #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) @@ -235,10 +236,11 @@ (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) + (append (delete-duplicates + (filter-map (lambda (x) + (and (not (assoc (caar x) dents)) + (list (caar x) #f 'tree))) + dadd)) dents)))))) (define (parse-commit commit) diff --git a/tekuti/page-helpers.scm b/tekuti/page-helpers.scm index 517e8b9..ff5281c 100644 --- a/tekuti/page-helpers.scm +++ b/tekuti/page-helpers.scm @@ -39,7 +39,7 @@ post-editing-form sidebar-ul main-sidebar tag-cloud post-link admin-post-link - show-post + show-post with-authentication atom-header atom-entry)) (define (relurl . paths) @@ -61,13 +61,26 @@ (string-append "admin/modify-post/" (url:encode (post-key post))) "admin/new-post")))) - (p "title: " - (input (@ (name "title") (type "text") - (value ,(if post (post-title post) ""))))) - (div (textarea (@ (name "body") (rows "20") (cols "80")) + (p (input (@ (name "title") (type "text") + (value ,(if post (post-title post) "")))) + (label (@ (for "title")) " <- title")) + (p (input (@ (name "tags") (type "text") + (value ,(if post + (string-join (post-tags post) ", ") + "")))) + (label (@ (for "tags")) " <- tags, comma-separated")) + (p (input (@ (name "date") (type "text") + (value ,(if (and=> post post-published?) + (timestamp->rfc822-date (post-timestamp post)) + "")))) + (label (@ (for "date")) " <- date")) + (div (textarea (@ (name "body") (rows "20") (cols "60")) ,(if post (post-raw-content post) ""))) - (input (@ (type "submit") - (value ,(if post "edit post" "new post")))))) + (input (@ (type "submit") (name "status") + (value "publish"))) + " " + (input (@ (type "submit") (name "status") + (value "draft"))))) (define (sidebar-ul body) `(div (@ (id "menu")) @@ -76,7 +89,7 @@ ;; double-encoding is a hack to trick apache (define (admin-post-link post) (rellink (string-append "admin/posts/" (url:encode (post-key post))) - (post-title 'title))) + (post-title post))) (define (post-url post . tail) (apply relurl "archives/" (url:decode (post-key post)) tail)) @@ -185,6 +198,15 @@ (li (h2 "tags " ,(rellink "tags/" ">>")) ,(tag-cloud index))))) +(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 (atom-header server-name last-modified) (define (relurl tail) (string-append "http://" server-name *public-url-base* tail)) diff --git a/tekuti/page.scm b/tekuti/page.scm index 318759a..e4e5a80 100644 --- a/tekuti/page.scm +++ b/tekuti/page.scm @@ -77,8 +77,8 @@ (assq-ref index 'posts) n)) (rcons* request - 'body `(,(sidebar-ul `((li (h2 ,(rellink "admin/posts" "posts")) - (ul ,@(post-links 10))) + 'body `(,(sidebar-ul `((li (h2 "posts " ,(rellink "admin/posts" ">>")) + (ul ,@(post-links 5))) (li (h2 "recent comments") (p "ain't got none")))) (h2 "new post") @@ -100,7 +100,7 @@ (with-authentication request (lambda () - (let ((post (post-from-key (assq-ref index 'master) key))) + (let ((post (post-from-key (assq-ref index 'master) key #t))) (rcons* request 'body `((h1 ,(post-title post)) ,(post-editing-form post))))))) @@ -109,20 +109,22 @@ (with-authentication request (lambda () - (let ((form-data (request-form-data request))) + (let ((post (make-new-post (request-form-data request)))) (rcons* request 'status 201 ; created - 'output-headers (acons "Location" *public-url-base* - (rref request 'output-headers '())) - 'body `((h1 "Created") - (p "Created new post: " ,(assoc-ref form-data "title")) - (pre ,(assoc-ref form-data "body")))))))) + ;; perhaps set Location: + 'body `((h1 ,(post-title post)) + ,(post-editing-form post))))))) (define (page-admin-modify-post request index key) (with-authentication request (lambda () - (not-implemented request index)))) + (let ((post (modify-post key (request-form-data request)))) + (rcons* 'status 303 + 'body `((h1 ,(post-title post)) + ,(post-editing-form post))))))) + (define page-delete-comment not-implemented) (define page-delete-post not-implemented) diff --git a/tekuti/post.scm b/tekuti/post.scm index cf926ee..957342f 100644 --- a/tekuti/post.scm +++ b/tekuti/post.scm @@ -40,8 +40,11 @@ post-tags post-timestamp post-key post-published? post-comments-open? post-comments post-sxml-content post-readable-date post-n-comments + post-raw-content post-title + make-new-post + all-published-posts reindex-posts)) @@ -124,6 +127,57 @@ (define (post-n-comments post) (length (git-ls-tree (string-append (assq-ref post 'sha1) ":comments") #f))) +(define (string-split/trimming string delimiter) + (map string-trim-both (string-split string delimiter))) + +(define space-to-dash (s///g " +" "-")) +(define remove-extraneous (s///g "[^a-z-]+" "")) + +(define (title->name title) + (remove-extraneous (space-to-dash (string-downcase title)))) + +;; some verification necessary... +(define (make-new-post post-data) + (define (make-post-key date name) + (url:encode (string-append (date->string date "~Y/~m/~d/") + (url:encode name)))) + (let ((title (assoc-ref post-data "title")) + (body (assoc-ref post-data "body")) + (tags (assoc-ref post-data "tags")) + (date (assoc-ref post-data "date")) + (status (assoc-ref post-data "status"))) + (let ((timestamp (if (string-null? date) + (time-second (current-time)) + (rfc822-date->timestamp date)))) + (let ((metadata (with-output-to-blob + (for-each + (lambda (pair) + (format #t "~a: ~a\n" (car pair) (cdr pair))) + `((timestamp . ,timestamp) + (tags . ,tags) + (status . ,status) + (title . ,title) + (name . ,(title->name title)))))) + (content (with-output-to-blob (display body))) + (key (make-post-key (timestamp->date timestamp) + (title->name title))) + (message (format #f "new post: \"~a\"" title))) + (post-from-key + (git-update-ref + "refs/heads/master" + (lambda (master) + (git-commit-tree (munge-tree master + `(((,key) + . ("metadata" ,metadata blob)) + ((,key) + . ("content" ,content blob))) + '() + '()) + master message #f)) + 5) + key + #t))))) + (define (all-posts master) (map (lambda (pair) (post-from-tree (car pair) (cdr pair))) diff --git a/tekuti/util.scm b/tekuti/util.scm index e219784..1c04f27 100644 --- a/tekuti/util.scm +++ b/tekuti/util.scm @@ -35,6 +35,7 @@ call-with-temp-file emailish? urlish? date-increment date-comparator date-before? date-after? compose1 rfc822-date->timestamp timestamp->rfc822-date timestamp->atom-date + timestamp->date list-intersperse with-backtrace with-time-debugging define-memoized)) (define (emailish? x) @@ -244,11 +245,14 @@ (string->date str "~a, ~d ~b ~Y ~H:~M:~S GMT"))) (date-zone-offset (current-date)))) +(define (timestamp->date timestamp) + (time-utc->date (make-time time-utc 0 timestamp) 0)) + (define (timestamp->atom-date timestamp) - (date->string (time-utc->date (make-time time-utc 0 timestamp) 0) + (date->string (timestamp->date timestamp) "~Y-~m-~dT~H:~M:~SZ")) (define (timestamp->rfc822-date timestamp) - (date->string (time-utc->date (make-time time-utc 0 timestamp) 0) + (date->string (timestamp->date timestamp) "~a, ~d ~b ~Y ~H:~M:~S GMT")) diff --git a/tekuti/web.scm b/tekuti/web.scm index eebb212..171c69e 100644 --- a/tekuti/web.scm +++ b/tekuti/web.scm @@ -38,6 +38,7 @@ (define *status-names* '((200 . "OK") (201 . "Created") + (303 . "See Other") (304 . "Not Modified") (401 . "Unauthorized") (404 . "Not Found") |