1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
|
;; Tekuti
;; Copyright (C) 2008, 2010, 2012 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 (system repl error-handling)
#:use-module (tekuti util)
#:use-module (tekuti git)
#:use-module (tekuti post)
#:use-module (tekuti tags)
#:use-module (tekuti cache)
#:export (maybe-reindex read-index update-index))
(define index-specs
`((posts ,reindex-posts ,write-hash ,read-hash)
(posts-by-date ,reindex-posts-by-date ,write ,read)
(tags ,reindex-tags ,write-hash ,read-hash)
(cache ,(lambda _ (make-empty-cache)) ,(lambda (x) #f) ,(lambda () '()))))
(define (reindex oldindex master)
(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
(let lp ((index index))
(cond
((null? index) '())
((eq? (caar index) 'index) (lp (cdr index)))
(else (cons (list (caar index)
(index->blob (caar index) (cdar index))
'blob)
(lp (cdr 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) '())))
(acons 'index 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")))
(if (equal? (assq-ref old-index 'master) master)
old-index
(call-with-error-handling
(lambda ()
(let ((new-index (reindex old-index master)))
(acons
'index (write-index new-index (assq-ref old-index 'index))
new-index)))
#:on-error 'backtrace
#:post-error (lambda _ old-index)))))
(define (update-index index key update)
(cond
((null? index) (acons key (update '()) '()))
((eq? (caar index) key) (acons key (update index) (cdr index)))
(else (cons (car index) (update-index (cdr index) key update)))))
|
