audio-library-manager/private/util.rkt

#lang racket/base

(require racket/file
         racket/list
         racket/path
         racket/string)

(provide bool-value
         int-value
         string-value
         split-addresses
         normalized-relpath-string
         normalized-relpath->path
         normalize-relpath-string
         legacy-backslash-relpath-string
         relpath-string
         filesystem-path
         flac-path?
         opus-path?
         manager-temp-path?
         directory-file-paths
         replace-path-extension
         ensure-parent-directory!
         alist-ref/default
         alist-set)

(define (bool-value v [default #f])
  (cond [(boolean? v) v]
        [(number? v) (not (zero? v))]
        [(string? v)
         (define s (string-downcase (string-trim v)))
         (cond [(member s '("#t" "true" "yes" "y" "1" "on")) #t]
               [(member s '("#f" "false" "no" "n" "0" "off" "")) #f]
               [else default])]
        [else default]))

(define (int-value v [default 0])
  (cond [(integer? v) v]
        [(number? v) (inexact->exact (round v))]
        [(string? v) (or (string->number (string-trim v)) default)]
        [else default]))

(define (string-value v [default ""])
  (cond [(string? v) v]
        [(symbol? v) (symbol->string v)]
        [(number? v) (number->string v)]
        [(boolean? v) (if v "#t" "#f")]
        [(not v) default]
        [else (format "~a" v)]))

(define (split-addresses v)
  (define s (string-value v ""))
  (filter (lambda (x) (not (string=? x "")))
          (map string-trim (regexp-split #px"[,;]" s))))

(define (windows-extended-path-string s)
  (cond [(or (< (string-length s) 3)
             (not (eq? (system-type 'os) 'windows))
             (string-prefix? s "\\\\?\\"))
         s]
        [(and (>= (string-length s) 2)
              (char=? (string-ref s 0) #\\)
              (char=? (string-ref s 1) #\\))
         (string-append "\\\\?\\UNC\\" (substring s 2))]
        [(and (>= (string-length s) 3)
              (char-alphabetic? (string-ref s 0))
              (char=? (string-ref s 1) #\:)
              (char=? (string-ref s 2) #\\))
         (string-append "\\\\?\\" s)]
        [else s]))

(define (filesystem-path p)
  (define s (cond [(path? p) (path->string p)]
                  [(string? p) p]
                  [else (raise-argument-error 'filesystem-path "path-string? or path?" p)]))
  (simple-form-path (string->path (windows-extended-path-string s))))

(define (replace-char s from to)
  (list->string
   (for/list ([ch (in-string s)])
     (if (char=? ch from) to ch))))

(define (normalize-relpath-string s)
  (define normalized (replace-char s #\\ #\/))
  (when (or (string=? normalized "")
            (regexp-match? #rx"^[A-Za-z]:" normalized)
            (regexp-match? #rx"^/" normalized)
            (regexp-match? #rx"(^|/)\\.\\.(/|$)" normalized))
    (raise-argument-error 'normalize-relpath-string "relative path without .." s))
  normalized)

(define (legacy-backslash-relpath-string relpath)
  (replace-char (normalize-relpath-string relpath) #\/ #\\))

(define (normalized-relpath-string base p)
  (normalize-relpath-string
   (path->string (find-relative-path (filesystem-path base) (filesystem-path p)))))

(define relpath-string normalized-relpath-string)

(define (normalized-relpath->path relpath)
  (define parts (regexp-split #rx"/+" (normalize-relpath-string relpath)))
  (when (ormap (lambda (part) (or (string=? part "") (string=? part "."))) parts)
    (raise-argument-error 'normalized-relpath->path "relative normalized path" relpath))
  (apply build-path parts))

(define (extension-ci=? p ext)
  (let-values ([(base name dir?) (split-path p)])
    (and (path? name)
         (let ([e (path-get-extension name)])
           (and e (string-ci=? (bytes->string/utf-8 e) ext))))))

(define (file-exists?/quiet p)
  (with-handlers ([exn:fail? (lambda (_) #f)]) (file-exists? p)))

(define (flac-path? p)
  (and (file-exists?/quiet p) (extension-ci=? p ".flac")))

(define (opus-path? p)
  (and (file-exists?/quiet p) (extension-ci=? p ".opus")))

(define (manager-temp-path? p)
  (define-values (_base name _dir?) (split-path p))
  (and (path? name)
       (regexp-match? #rx"^\\..*\\.tmp-[0-9.]+\\.(flac|opus)$" (path->string name))))

(define (regular-file-path? p)
  (file-exists?/quiet p))

(define (directory-list/quiet dir)
  (with-handlers ([exn:fail? (lambda (_) '())])
    (directory-list dir #:build? #t)))

(define (directory-exists?/quiet p)
  (with-handlers ([exn:fail? (lambda (_) #f)])
    (directory-exists? p)))

(define (sort-paths paths)
  (sort paths string<? #:key path->string))

(define (directory-file-paths base-dir)
  ;; Tolerant recursive walker for Windows UNC/long-path trees.  A single
  ;; vanished or unreadable entry is skipped instead of aborting the scan.
  (define root (filesystem-path base-dir))
  (let loop ([dir root] [acc '()])
    (for/fold ([acc acc]) ([p (in-list (sort-paths (directory-list/quiet dir)))])
      (cond [(directory-exists?/quiet p) (loop p acc)]
            [(and (file-exists?/quiet p) (not (manager-temp-path? p))) (cons p acc)]
            [else acc]))))

(define (replace-path-extension p ext)
  (let-values ([(base name dir?) (split-path p)])
    (unless (path? name) (error 'replace-path-extension "path has no file name: ~a" p))
    (build-path base (path-replace-extension name ext))))

(define (ensure-parent-directory! p)
  (define-values (base name dir?) (split-path p))
  (when (path? base) (make-directory* base)))

(define (alist-ref/default a k [default #f])
  (define e (assoc k a))
  (if e (cdr e) default))

(define (alist-set a k v)
  (cons (cons k v) (filter (lambda (e) (not (equal? (car e) k))) a)))