#lang racket/base (require racket/sequence racket/generator racket/string racket/path "store.rkt" "log.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* ((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)) (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 (= (remainder perc 10) 0) (info-am "get-deleteed: ~a%" perc))) (let ((v (store-ref db-store key))) (eq? (hash-ref v 'file-db) 'unknown))) keys)))) ) (let* ((walker-count 0) (fw (make-file-walker base-path "*" (λ (base-path path info) (cond ((= walker-count 0) (store-begin db-store)) ((= (remainder walker-count 250) 0) (store-commit db-store) (store-begin db-store)) ) (set! walker-count (+ walker-count 1)) (let-values (((base-path* path* info*) (file-admin base-path path info))) (when (eq? info* #f) (store-commit db-store)) (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 (set! deleted (get-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)))) )