Add experimental FTS indexer

This commit is contained in:
Cadence Ember 2023-11-10 17:09:18 +13:00
parent b8ccd6cc3e
commit 43c3f70736
Signed by: cadence
GPG key ID: BC1C2C61CF521B17

89
archiver/fts.rkt Normal file
View file

@ -0,0 +1,89 @@
#lang racket/base
(require racket/function
racket/future
racket/match
racket/path
racket/promise
racket/port
racket/string
file/gunzip
db
db/unsafe/sqlite3
json
json-pointer
"../lib/html-parsing/main.rkt"
"../lib/xexpr-utils.rkt"
"../lib/tree-updater.rkt")
(define (class-has? attributes substrs)
(define cl (or (get-attribute 'class attributes) ""))
(ormap (λ (substr) (string-contains? cl substr)) substrs))
(define (updater element element-type attributes children)
(cond
[(class-has? attributes '("collapsed" "selflink" "label" "toc" "editsection" "reviews"))
(list 'div '() '())]
[#t
(list element-type attributes children)]))
(define slc (sqlite3-connect #:database "../storage/fts-separate.db"))
(sqlite3-load-extension slc "fts5")
(define (writer page)
(for ([bit page])
(cond
[(memq bit '(div p li td)) (displayln "")]
[(symbol? bit) (void)]
[(and (pair? bit) (eq? (car bit) '*COMMENT*)) (void)]
[(and (pair? bit) (eq? (car bit) '@)) (void)]
[(pair? bit) (writer bit)]
[(string? bit) (display bit)])))
(define wikiname "sto")
(define tablename (format "page_~a" wikiname))
(define ((extract f)) ; f - filename
(with-handlers
([exn:fail? (λ (err) (println f) (raise err))])
(define j
(case (path-get-extension f)
[(#".json")
(with-input-from-file f (λ () (read-json)))]
[(#".gz")
(define-values (in out) (make-pipe))
(with-input-from-file f (λ () (gunzip-through-ports (current-input-port) out)))
(read-json in)]
[else #f]))
(define title (json-pointer-value "/parse/title" j))
(define page-html (preprocess-html-wiki (json-pointer-value "/parse/text" j)))
(define page (update-tree updater (html->xexp page-html)))
(define text (with-output-to-string (λ () (writer page))))
(define shrink-text (regexp-replace* #px"([ \t]*\r?\n+)+" text "\n"))
(values title shrink-text)))
(println "extracting text...")
(define results
(time
(for/list ([f (directory-list (format "../storage/archive/~a" wikiname) #:build? #t)]
#:when (member (path-get-extension f) '(#".json" #".gz")))
(extract f))))
(println "inserting...")
(query-exec slc "begin transaction")
#;(query-exec slc (format "create virtual table \"~a\" using fts5 (title, body, tokenize='porter unicode61')" wikiname))
(time
(for ([fut results]
[i (in-naturals 1)])
(display "-")
(when (and (> i 0) (= (modulo i 100) 0))
(println i))
(define-values (title shrink-text) (fut))
(query-exec slc (format "insert into \"~a\" (title, body) values (?, ?)" tablename) title shrink-text)))
(println "running optimize...")
(query-exec slc (format "insert into \"~a\" (\"~a\") values ('optimize')" tablename tablename))
(println "committing...")
(query-exec slc "commit")
(disconnect slc)