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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
;;; mumi -- Mediocre, uh, mail interface
;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2020 Arun Isaac <arunisaac@systemreboot.net>
;;;
;;; This program is free software: you can redistribute it and/or
;;; modify it under the terms of the GNU Affero 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
;;; Affero General Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with this program. If not, see
;;; <http://www.gnu.org/licenses/>.
(define-module (mumi xapian)
#:use-module (mumi config)
#:use-module (mumi debbugs)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 threads)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (email email)
#:use-module (xapian wrap)
#:use-module (xapian xapian)
#:use-module (rnrs bytevectors)
#:export (index! index-files search))
(define (parse-emails files)
(n-par-map 4
(lambda (file)
(list file
(call-with-input-file file
read-emails-from-bug-log)))
files))
(define (author email)
(or (and=> (assoc-ref (email-headers email) 'from)
(match-lambda
((from . rest)
(format #f "~a ~a"
(assoc-ref from 'name)
(assoc-ref from 'address)))
(from
(format #f "~a ~a"
(assoc-ref from 'name)
(assoc-ref from 'address)))))
"<unknown>"))
(define* (index-files files #:key
(dbpath (string-append (%config 'db-dir) "/mumi.xapian")))
"Parse all given Debbugs log files in FILES as a list of email
messages and index their contents in the Xapian database at DBPATH."
(define (index-chunk files+mails)
(call-with-writable-database
dbpath
(lambda (db)
(for-each
(match-lambda
((file (? pair? emails))
(let* ((bugid (basename file ".log"))
(report (first emails))
(submitter (author report))
(subjects
(string-join
(delete-duplicates
(filter-map (lambda (email)
(assoc-ref (email-headers email) 'subject))
emails))))
(authors
(string-join (delete-duplicates (map author emails)) " "))
(date
(match (assoc-ref (email-headers report) 'date)
((? string? s) #f)
(date date)))
(mdate
(match (assoc-ref (email-headers (last emails)) 'date)
((? string? s) #f)
(date date)))
(text
(string-join (map (match-lambda
((($ <mime-entity> headers body) ...)
(string-join (filter string? body) "\n"))
((? bytevector? bv) (utf8->string bv))
((? string? s) s))
(map email-body emails))
"\n"))
(idterm (string-append "Q" bugid))
(doc (make-document #:data bugid
#:terms `((,idterm . 0))
#:values
`((0 . ,(or (and date (date->string date "~Y~m~d")) "19700101"))
(1 . ,(or (and mdate (date->string mdate "~Y~m~d")) "19700101")))))
(term-generator (make-term-generator #:stem (make-stem "en")
#:document doc)))
;; Index fields with a suitable prefix. This allows for
;; searching separate fields as in subject:foo,
;; from:bar, etc.
(index-text! term-generator bugid #:prefix "B")
(index-text! term-generator submitter #:prefix "A")
(index-text! term-generator authors #:prefix "XA")
(index-text! term-generator subjects #:prefix "S")
(index-text! term-generator file #:prefix "F")
;; Index subject and body without prefixes for general
;; search.
(index-text! term-generator subjects)
(increase-termpos! term-generator)
(index-text! term-generator text)
;; Add the document to the database. The unique idterm
;; ensures each object ends up in the database only once
;; no matter how many times we run the indexer.
(replace-document! db idterm doc)))
(_ #f)) ; ignore
files+mails))))
(let ((total (length files)))
(let loop ((files files))
(let-values (((chunk rest)
(if (>= (length files) 100)
(split-at files 100)
(values files '()))))
(format (current-error-port)
"indexing ~1,2f%~%"
(exact->inexact (* 100 (/ (- total (length rest)) total))))
(index-chunk (parse-emails chunk))
(unless (null? rest)
(loop rest))))))
(define* (parse-query* querystring #:key stemmer stemming-strategy (prefixes '()))
(let ((queryparser (new-QueryParser))
(date-range-processor (new-DateRangeProcessor 0 "date:" 0))
(mdate-range-processor (new-DateRangeProcessor 1 "mdate:" 0)))
(QueryParser-set-stemmer queryparser stemmer)
(when stemming-strategy
(QueryParser-set-stemming-strategy queryparser stemming-strategy))
(for-each (match-lambda
((field . prefix)
(QueryParser-add-prefix queryparser field prefix)))
prefixes)
(QueryParser-add-rangeprocessor queryparser date-range-processor)
(QueryParser-add-rangeprocessor queryparser mdate-range-processor)
(let ((query (QueryParser-parse-query queryparser querystring)))
(delete-QueryParser queryparser)
query)))
(define* (search querystring #:key
(pagesize 10)
(dbpath (string-append (%config 'db-dir) "/mumi.xapian")))
;; Open database for reading. call-with-database automatically
;; closes the database once we're done.
(call-with-database dbpath
(lambda (db)
(let (;; Parse querystring passing a stemmer and suitable
;; prefixes for field search.
(query (parse-query* querystring
#:stemmer (make-stem "en")
#:prefixes '(("submitter" . "A")
("author" . "XA")
("subject" . "S")))))
;; Fold over the results, return bug id.
(mset-fold (lambda (item acc)
(cons
(document-data (mset-item-document item))
acc))
'()
;; Get an Enquire object from the database with the
;; search results. Then, extract the MSet from the
;; Enquire object.
(enquire-mset (enquire db query)
#:maximum-items pagesize))))))
(define* (index! #:key full?)
"Index all Debbugs log files corresponding to the selected
packages. When FULL? is #T process also archived issues."
(let* ((packages (%config 'packages))
(active-numbers (extract-bug-numbers packages))
(archived-numbers (extract-bug-numbers packages #:archived? #t))
(active-files
(map bug-id->log-file active-numbers))
(archived-files
(map (cut bug-id->log-file <> #:archived? #t)
archived-numbers)))
(index-files (if full?
(append active-files archived-files)
active-files))))
|
