add missing files
This commit is contained in:
Andy Wingo
parent
dbed5b113d
commit
a9141efbe6
2 changed files with 273 additions and 0 deletions
101
tekuti/index.scm
Normal file
101
tekuti/index.scm
Normal file
|
|
@ -0,0 +1,101 @@
|
|||
;; Tekuti
|
||||
;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com>
|
||||
|
||||
;; 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 3 of
|
||||
;; the License, 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 program; if not, contact:
|
||||
;;
|
||||
;; Free Software Foundation Voice: +1-617-542-5942
|
||||
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
|
||||
;; Boston, MA 02111-1307, USA gnu@gnu.org
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; Indexing of the persistent data store.
|
||||
;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (tekuti index)
|
||||
#:use-module ((srfi srfi-1) #:select (fold))
|
||||
#:use-module (tekuti util)
|
||||
#:use-module (tekuti git)
|
||||
#:use-module (tekuti post)
|
||||
#:use-module (tekuti tags)
|
||||
#:export (maybe-reindex read-index))
|
||||
|
||||
(define index-specs
|
||||
`((posts ,reindex-posts ,write ,read)
|
||||
(tags ,reindex-tags ,write-hash ,read-hash)))
|
||||
|
||||
(define (reindex oldindex master)
|
||||
(with-backtrace
|
||||
(with-time-debugging
|
||||
(fold (lambda (pair index)
|
||||
(acons (car pair) ((cadr pair) oldindex index)
|
||||
index))
|
||||
(acons 'master master '())
|
||||
index-specs))))
|
||||
|
||||
(define (assoc-list-ref alist key n default)
|
||||
(let ((l (assoc key alist)))
|
||||
(if l (list-ref l n) default)))
|
||||
|
||||
(define (index->blob key value)
|
||||
(with-output-to-blob
|
||||
((assoc-list-ref index-specs key 2 write) value)))
|
||||
|
||||
(define (blob->index name sha1)
|
||||
(with-input-from-blob
|
||||
sha1
|
||||
((assoc-list-ref index-specs (string->symbol name) 3 read))))
|
||||
|
||||
(define (write-index index oldref)
|
||||
(let ((new (git-commit-tree
|
||||
(git-mktree
|
||||
(pk (map (lambda (pair)
|
||||
(list (car pair)
|
||||
(index->blob (car pair) (cdr pair))
|
||||
'blob))
|
||||
index)))
|
||||
oldref "reindex\n"
|
||||
(commit-utc-timestamp (assq-ref index 'master)))))
|
||||
(or (false-if-git-error
|
||||
(git "update-ref" "refs/heads/index" new (or oldref "")))
|
||||
(warn "could not update indexes ref"))
|
||||
new))
|
||||
|
||||
(define (read-index)
|
||||
(let* ((ref (false-if-git-error (git-rev-parse "refs/heads/index")))
|
||||
(dents (if ref (git-ls-tree ref #f) '())))
|
||||
(cons ref
|
||||
(and (and-map (lambda (spec)
|
||||
(assoc (symbol->string (car spec)) dents))
|
||||
index-specs)
|
||||
(map (lambda (dent)
|
||||
(cons (string->symbol (car dent))
|
||||
(blob->index (car dent) (cadr dent))))
|
||||
dents)))))
|
||||
|
||||
(define (maybe-reindex old-index)
|
||||
(let ((master (git-rev-parse "refs/heads/master"))
|
||||
(old-index-sha1 (and=> old-index car))
|
||||
(old-index-data (if old-index (cdr old-index) '())))
|
||||
(if (equal? (assq-ref old-index-data 'master) master)
|
||||
old-index
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(let ((new-index (reindex old-index-data master)))
|
||||
(cons (write-index new-index old-index-sha1)
|
||||
new-index)))
|
||||
(lambda (key . args)
|
||||
(warn "error while reindexing:" key args)
|
||||
old-index)))))
|
||||
172
tekuti/page-helpers.scm
Normal file
172
tekuti/page-helpers.scm
Normal file
|
|
@ -0,0 +1,172 @@
|
|||
;; Tekuti
|
||||
;; Copyright (C) 2008 Andy Wingo <wingo at pobox dot com>
|
||||
|
||||
;; 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 3 of
|
||||
;; the License, 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 program; if not, contact:
|
||||
;;
|
||||
;; Free Software Foundation Voice: +1-617-542-5942
|
||||
;; 59 Temple Place - Suite 330 Fax: +1-617-542-2652
|
||||
;; Boston, MA 02111-1307, USA gnu@gnu.org
|
||||
|
||||
;;; Commentary:
|
||||
;;
|
||||
;; Helper bits, mostly verbose-like SXML stuff.
|
||||
;;
|
||||
;;; Code:
|
||||
|
||||
(define-module (tekuti page-helpers)
|
||||
#:use-module (tekuti config)
|
||||
#:use-module (tekuti util)
|
||||
#:use-module (tekuti git)
|
||||
#:use-module (tekuti post)
|
||||
#:use-module (tekuti comment)
|
||||
#:use-module (tekuti url)
|
||||
#:use-module (tekuti request)
|
||||
#:use-module (srfi srfi-19)
|
||||
#:use-module (scheme kwargs)
|
||||
#:export (relurl rellink
|
||||
published-posts
|
||||
post-editing-form
|
||||
sidebar-ul main-sidebar tag-cloud
|
||||
post-link admin-post-link
|
||||
show-post
|
||||
atom-header atom-entry))
|
||||
|
||||
(define (relurl path)
|
||||
(string-append *public-url-base* path))
|
||||
|
||||
(define (rellink path . body)
|
||||
`(a (@ (href ,(relurl path)))
|
||||
,@body))
|
||||
|
||||
(define (published-posts index n)
|
||||
(filter-mapn (lambda (post)
|
||||
(and (post-published? post) post))
|
||||
(assq-ref index 'posts)
|
||||
n))
|
||||
|
||||
(define (post-editing-form post)
|
||||
`(form (@ (method "POST")
|
||||
(action ,(relurl (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 (post-title post) "")))))
|
||||
(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)))
|
||||
|
||||
;; double-encoding is a hack to trick apache
|
||||
(define (admin-post-link post)
|
||||
(rellink (string-append "admin/posts/"
|
||||
(url:encode (post-key post)))
|
||||
(assq-ref post 'title)))
|
||||
|
||||
(define (post-link post)
|
||||
(rellink (string-append "archives/" (url:decode (post-key post)))
|
||||
(assq-ref post 'title)))
|
||||
|
||||
(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))
|
||||
'())))
|
||||
|
||||
;; 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<?)))
|
||||
`(ul (li (@ (style "line-height: 150%"))
|
||||
,@(list-intersperse
|
||||
(map (lambda (name size)
|
||||
`(a (@ (href ,(string-append
|
||||
*public-url-base* "tags/"
|
||||
(url:encode name)))
|
||||
(rel "tag")
|
||||
(style ,(format #f "font-size: ~d%" size)))
|
||||
,name))
|
||||
(map car top-20)
|
||||
(determine-sizes (map cdr top-20)))
|
||||
" "))
|
||||
)))
|
||||
|
||||
(define (main-sidebar request index)
|
||||
(sidebar-ul
|
||||
`((li (h2 (a (@ (href ,(relurl "feed/atom")))
|
||||
"subscribe "
|
||||
(img (@ (src ,(relurl "wp-content/feed-icon-14x14.png"))
|
||||
(alt "subscribe to this feed")))
|
||||
)))
|
||||
(li (h2 "tags "
|
||||
(a (@ (href ,(string-append *public-url-base* "tags/")))
|
||||
">>"))
|
||||
,(tag-cloud index)))))
|
||||
|
||||
(define (atom-header server-name last-modified)
|
||||
(define (relurl tail)
|
||||
(string-append "http://" server-name *public-url-base* tail))
|
||||
`(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"))))))
|
||||
|
||||
(define (atom-entry server-name post)
|
||||
(define (relurl tail)
|
||||
(string-append "http://" server-name *public-url-base* tail))
|
||||
`(entry
|
||||
(author (name ,*name*) (uri ,(relurl "")))
|
||||
(title (@ (type "text")) ,(post-title post))
|
||||
(id ,(relurl (url:decode (post-key post)))) ;hack
|
||||
(published ,(timestamp->atom-date (post-timestamp post)))
|
||||
(updated ,(timestamp->atom-date (post-timestamp post)))
|
||||
(content (@ (type "xhtml"))
|
||||
(div (@ (xmlns "http://www.w3.org/1999/xhtml"))
|
||||
,(post-sxml-content post)))))
|
||||
Loading…
Reference in a new issue