260 lines
9.9 KiB
Racket
260 lines
9.9 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/sequence
|
|
racket/generator
|
|
racket/string
|
|
racket/path
|
|
"store.rkt"
|
|
"log.rkt"
|
|
"util.rkt"
|
|
file/glob)
|
|
|
|
(provide make-file-walker
|
|
make-file-admin
|
|
fw-add-step
|
|
os-path
|
|
)
|
|
|
|
(define (os-path str)
|
|
(let ((delim (if (eq? (system-path-convention-type) 'windows) "\\" "/")))
|
|
(string-replace str "/" delim)))
|
|
|
|
(define (make-file-walker base-path glob-pattern filter-func)
|
|
(let* ((gen (sequence->generator
|
|
(sequence-filter
|
|
(λ (p)
|
|
(let ((basename (file-name-from-path p)))
|
|
(glob-match? glob-pattern basename)))
|
|
(in-directory base-path))))
|
|
(str-base-path* (format "~a" (normalize-path base-path)))
|
|
(delim (if (eq? (system-path-convention-type) 'windows) "\\" "/"))
|
|
(str-base-path (if (string-suffix? str-base-path* delim)
|
|
str-base-path*
|
|
(string-append str-base-path* delim)))
|
|
(base-path-len (string-length str-base-path))
|
|
(result #f)
|
|
)
|
|
(λ ()
|
|
(let ((path (gen)))
|
|
(if (void? path)
|
|
(values #f #f #f)
|
|
(let* ((bd (basedir path))
|
|
(bn (format "~a" (basename path)))
|
|
(nbn (clean-os-basename bn))
|
|
)
|
|
|
|
(unless (string=? bn nbn)
|
|
(with-handlers ([exn? (λ (e)
|
|
(warn-am "Cannot rename dirty filename: ~a" nbn))])
|
|
(display "bn = ") (write bn) (display ", nbn = ") (write nbn)
|
|
(newline)
|
|
;(rename-file-or-directory (build-path bd bn)
|
|
; (build-path bn nbn) #f)
|
|
;(set! path (build-path bd nbn))
|
|
))
|
|
|
|
(let* ((str-path (path->string path))
|
|
(ext* (path-get-extension path))
|
|
(ext (string->symbol
|
|
(substring
|
|
(if (eq? ext* #f)
|
|
"."
|
|
(let ((e (string-downcase (bytes->string/utf-8 ext*))))
|
|
(if (string-contains? e " ")
|
|
"."
|
|
e))) 1)))
|
|
(path-part (substring str-path base-path-len))
|
|
(str-n-path (string-replace path-part "\\" "/"))
|
|
(info (let ((h (make-hash (list
|
|
(cons 'type 'dir)
|
|
(cons 'path str-n-path)
|
|
(cons 'ext ext)))))
|
|
(when (file-exists? path)
|
|
(hash-set! h 'type 'file)
|
|
(hash-set! h 'size (file-size path))
|
|
(hash-set! h 'mtime (file-or-directory-modify-seconds path))
|
|
)
|
|
h))
|
|
)
|
|
(filter-func base-path path info))))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (make-file-admin base-path db-store)
|
|
|
|
(define (file-info-equal? i1 i2)
|
|
(if (eq? (hash-ref i1 'type) (hash-ref i2 'type))
|
|
(if (eq? (hash-ref i1 'type) 'file)
|
|
(and
|
|
(string=? (hash-ref i1 'path) (hash-ref i2 'path))
|
|
(= (hash-ref i1 'size) (hash-ref i2 'size))
|
|
(= (hash-ref i1 'mtime) (hash-ref i2 'mtime)))
|
|
(string=? (hash-ref i1 'path) (hash-ref i2 'path))
|
|
)
|
|
#f))
|
|
|
|
(define (file-admin base-path path info)
|
|
(let* ((normalized-sub-path (hash-ref info 'path))
|
|
(in-db (store-ref db-store normalized-sub-path #f))
|
|
)
|
|
(cond
|
|
((eq? in-db #f)
|
|
(hash-set! info 'file-db 'new)
|
|
(store-set! db-store normalized-sub-path info)
|
|
(values base-path path info)
|
|
)
|
|
(else
|
|
(if (file-info-equal? info in-db)
|
|
(hash-set! in-db 'file-db 'unchanged)
|
|
(begin
|
|
(hash-set! in-db 'type (hash-ref info 'type))
|
|
(hash-set! in-db 'file-db 'changed)
|
|
(when (eq? (hash-ref info 'type #f) 'file)
|
|
(hash-set! in-db 'size (hash-ref info 'size))
|
|
(hash-set! in-db 'mtime (hash-ref info 'mtime)))))
|
|
(store-set! db-store normalized-sub-path in-db)
|
|
(values base-path path in-db)
|
|
)
|
|
)
|
|
))
|
|
|
|
(define (init-db-sweep)
|
|
(store-transaction db-store
|
|
(let ((count (store-count db-store))
|
|
(k 0)
|
|
(last-perc 0))
|
|
(store-for-each db-store
|
|
(λ (key value)
|
|
(set! k (+ k 1))
|
|
(let ((perc (quotient (* k 100) count)))
|
|
(when (and (= (remainder perc 10) 0) (> perc last-perc))
|
|
(set! last-perc perc)
|
|
(info-am "init-db-sweep: ~a%, k=~a" perc k)))
|
|
(if (eq? (hash-ref value 'file-db #f) 'deleted)
|
|
(store-remove! db-store key)
|
|
(begin
|
|
(hash-set! value 'file-db 'unknown)
|
|
(store-set! db-store key value))
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
|
|
(define (get-deleted)
|
|
(let ((count (store-count db-store))
|
|
(k 0)
|
|
(last-perc 0))
|
|
(let ((keys (store-keys db-store)))
|
|
(map (λ (key)
|
|
(let ((info (store-ref db-store key)))
|
|
(hash-set! info 'file-db 'deleted)
|
|
info))
|
|
(filter (λ (key)
|
|
(set! k (+ k 1))
|
|
(let ((perc (quotient (* k 100) count)))
|
|
(when (and (= (remainder perc 10) 0) (> perc last-perc))
|
|
(set! last-perc perc)
|
|
(info-am "get-deleted: ~a%" perc)))
|
|
(let ((v (store-ref db-store key)))
|
|
(eq? (hash-ref v 'file-db) 'unknown)))
|
|
keys))))
|
|
)
|
|
|
|
(let* ((walker-count 0)
|
|
(last-commit-s (current-seconds))
|
|
(fw (make-file-walker base-path "*"
|
|
(λ (base-path path info)
|
|
(let ((tm (current-seconds)))
|
|
(cond
|
|
((= walker-count 0)
|
|
(store-begin db-store))
|
|
((or (= (remainder walker-count 250) 0)
|
|
(> (- tm last-commit-s) 5))
|
|
(store-commit db-store)
|
|
(store-begin db-store)
|
|
(set! last-commit-s tm)
|
|
)
|
|
)
|
|
)
|
|
(set! walker-count (+ walker-count 1))
|
|
(let-values (((base-path* path* info*) (file-admin base-path path info)))
|
|
(values base-path* path* info*)))))
|
|
(deleted #f))
|
|
|
|
(init-db-sweep)
|
|
|
|
(letrec ((f (λ ()
|
|
(if (list? deleted)
|
|
(if (null? deleted)
|
|
(values #f #f #f)
|
|
(let ((r (car deleted)))
|
|
(set! deleted (cdr deleted))
|
|
(values base-path (build-path base-path (os-path (hash-ref r 'path))) r))
|
|
)
|
|
(let-values (((base-path path info) (fw)))
|
|
(if (eq? info #f)
|
|
(begin
|
|
(info-am "LAST COMMIT")
|
|
(store-commit db-store)
|
|
(set! deleted (get-deleted))
|
|
(info-am "Got ~a deleted entries" (length deleted))
|
|
(f))
|
|
(values base-path path info))
|
|
)
|
|
)
|
|
)
|
|
))
|
|
f))
|
|
)
|
|
|
|
(define (fw-add-step fw step-func)
|
|
(λ ()
|
|
(let-values (((base-path path info) (fw)))
|
|
(if (eq? info #f)
|
|
(values #f #f #f)
|
|
(step-func base-path path info))))
|
|
)
|
|
|
|
|
|
(define (clean-os-basename name)
|
|
(let* ((s0 (format "~a" name))
|
|
|
|
;; Laatste .ext apart houden.
|
|
;; Bewust eenvoudig: .flac, .opus, .jpg, .pdf, enz.
|
|
;; Namen als "Gypsy Festival vol. 2" matchen niet als extensie,
|
|
;; want daar zit een spatie na de punt.
|
|
(m (regexp-match #px"^(.*)(\\.[A-Za-z0-9][A-Za-z0-9_-]{0,15})$" s0))
|
|
(stem0 (if m (list-ref m 1) s0))
|
|
(ext (if m (list-ref m 2) ""))
|
|
|
|
;; Ongeldige OS-tekens vervangen door '-'.
|
|
(stem1 (list->string
|
|
(for/list ((ch (in-string stem0)))
|
|
(if (or (< (char->integer ch) 32)
|
|
(memq ch '(#\< #\> #\: #\" #\/ #\\ #\| #\? #\*)))
|
|
#\-
|
|
ch))))
|
|
|
|
;; Whitespace normaliseren.
|
|
(stem2 (regexp-replace* #px"\\s+" stem1 " "))
|
|
|
|
;; Alleen de stem trimmen.
|
|
;; Spatie/punt zijn Windows-probleem aan het einde.
|
|
;; '-' trimmen we hier ook zodat foo:bar?.opus -> foo-bar.opus.
|
|
(stem3 (string-trim stem2 " .-"))
|
|
|
|
;; Windows reserved device names gelden ook met extensie,
|
|
;; dus CON.flac blijft probleem als stem CON is.
|
|
(reserved? (regexp-match?
|
|
#px"(?i:^(con|prn|aux|nul|com[1-9]|lpt[1-9])$)"
|
|
stem3))
|
|
|
|
(stem4 (cond
|
|
((string=? stem3 "") "_")
|
|
(reserved? (string-append "_" stem3))
|
|
(else stem3))))
|
|
(string-append stem4 ext))) |