initial import from racket-sound -> racket-audio

2026-05-04 12:07:45 +02:00
parent f500f1711b
commit 87980f508a
28 changed files with 6282 additions and 16 deletions
@@ -0,0 +1,358 @@
+#lang racket/base
+
+(require racket/contract
+         racket/path
+         racket/string
+         racket/runtime-path
+         )
+
+(provide audio-format?
+         audio-sniff-format
+         audio-sniff-format/extension
+         audio-sniff-extension
+         audio-format-matches?
+         audio-format-known?)
+
+(define audio-formats
+  '(mp3 flac ogg vorbis opus wav aiff
+        mp4 aac alac encrypted-audio
+        ac3 ape wavpack wma matroska))
+
+(define audio-status-formats
+  '(unknown file-not-found file-not-readable not-a-file))
+
+(define known-formats
+  (append audio-formats audio-status-formats))
+
+(define (audio-format? v)
+  (not (eq? (memq v known-formats) #f)))
+
+(define sniff-bytes 4096)
+
+(define mp4-head-peek-sizes
+  '(4096 8192 16384 32768 65536 131072 153600))
+
+(define mp4-tail-peek-blocks
+  '(4096 8192 16384 32768 65536 65536))
+
+(define (audio-sniff-extension* file)
+  (let ([ext (path-get-extension (build-path file))])
+    (cond
+      [(not ext) #f]
+      [else
+       (let ([s (string-downcase (bytes->string/utf-8 ext #\?))])
+         (if (and (> (string-length s) 0)
+                  (char=? (string-ref s 0) #\.))
+             (substring s 1)
+             s))])))
+
+(define (file-readable-status file)
+  (cond
+    [(not (file-exists? file)) 'file-not-found]
+    [else
+     (let ([typ (file-or-directory-type file #f)])
+       (cond
+         [(not typ) 'file-not-found]
+         [(not (eq? typ 'file)) 'not-a-file]
+         [else #t]))]))
+
+(define (read-prefix/status file [n sniff-bytes])
+  (with-handlers ([exn:fail:filesystem?
+                   (lambda (_) 'file-not-readable)])
+    (call-with-input-file file
+      (lambda (in)
+        (let ([b (read-bytes n in)])
+          (if (eof-object? b) #"" b)))
+      #:mode 'binary)))
+
+(define (read-block/status file start size)
+  (with-handlers ([exn:fail:filesystem?
+                   (lambda (_) 'file-not-readable)])
+    (call-with-input-file file
+      (lambda (in)
+        (file-position in start)
+        (let ([b (read-bytes size in)])
+          (if (eof-object? b) #"" b)))
+      #:mode 'binary)))
+
+(define (u8 b i)
+  (bytes-ref b i))
+
+(define (bytes-prefix? b prefix)
+  (and (>= (bytes-length b) (bytes-length prefix))
+       (bytes=? (subbytes b 0 (bytes-length prefix)) prefix)))
+
+(define (bytes-at? b pos marker)
+  (and (>= (bytes-length b) (+ pos (bytes-length marker)))
+       (bytes=? (subbytes b pos (+ pos (bytes-length marker)))
+                marker)))
+
+(define (bytes-contains? b marker)
+  (let ([blen (bytes-length b)]
+        [mlen (bytes-length marker)])
+    (cond
+      [(zero? mlen) #t]
+      [(< blen mlen) #f]
+      [else
+       (let loop ([i 0])
+         (cond
+           [(> (+ i mlen) blen) #f]
+           [(bytes=? (subbytes b i (+ i mlen)) marker) #t]
+           [else (loop (add1 i))]))])))
+
+(define asf-guid
+  (bytes #x30 #x26 #xb2 #x75 #x8e #x66 #xcf #x11
+         #xa6 #xd9 #x00 #xaa #x00 #x62 #xce #x6c))
+
+(define (riff-wave? b)
+  (and (bytes-at? b 0 #"RIFF")
+       (bytes-at? b 8 #"WAVE")))
+
+(define (aiff? b)
+  (and (bytes-at? b 0 #"FORM")
+       (or (bytes-at? b 8 #"AIFF")
+           (bytes-at? b 8 #"AIFC"))))
+
+(define (iso-bmff? b)
+  (bytes-at? b 4 #"ftyp"))
+
+(define (matroska-or-webm? b)
+  (bytes-prefix? b #"\x1a\x45\xdf\xa3"))
+
+(define (ac3? b)
+  (bytes-prefix? b #"\x0b\x77"))
+
+(define (ape? b)
+  (bytes-prefix? b #"MAC "))
+
+(define (wavpack? b)
+  (bytes-prefix? b #"wvpk"))
+
+(define (sniff-ogg-subtype b)
+  (cond
+    [(bytes-contains? b #"OpusHead") 'opus]
+    [(bytes-contains? b #"\x01vorbis") 'vorbis]
+    [(bytes-contains? b #"vorbis") 'vorbis]
+    [(bytes-contains? b #"fLaC") 'flac]
+    [else 'ogg]))
+
+(define (mp4-codec-peek b)
+  (cond
+    [(bytes-contains? b #"enca") 'encrypted-audio]
+    [(bytes-contains? b #"alac") 'alac]
+    [(bytes-contains? b #"mp4a") 'aac]
+    [else #f]))
+
+(define (mp4-codec-peek/tail file)
+  (with-handlers ([exn:fail:filesystem?
+                   (lambda (_) 'file-not-readable)])
+    (let ([file-len (file-size file)])
+      (let loop ([blocks mp4-tail-peek-blocks]
+                 [end file-len])
+        (cond
+          [(null? blocks) #f]
+          [(<= end 0) #f]
+          [else
+           (let* ([block-size (car blocks)]
+                  [start (max 0 (- end block-size))]
+                  [size (- end start)]
+                  [b (read-block/status file start size)])
+             (cond
+               [(not (bytes? b)) b]
+               [else
+                (let ([r (mp4-codec-peek b)])
+                  (if r
+                      r
+                      (loop (cdr blocks) start)))]))])))))
+
+(define (mp4-codec-peek/head file)
+  (let loop ([sizes (cdr mp4-head-peek-sizes)])
+    (cond
+      [(null? sizes) #f]
+      [else
+       (let ([b (read-prefix/status file (car sizes))])
+         (cond
+           [(not (bytes? b)) b]
+           [else
+            (let ([r (mp4-codec-peek b)])
+              (if r
+                  r
+                  (loop (cdr sizes))))]))])))
+
+(define (mp4-codec-peek/file file head)
+  (let ([r0 (mp4-codec-peek head)])
+    (cond
+      [r0 r0]
+      [else
+       (let ([rtail (mp4-codec-peek/tail file)])
+         (cond
+           [rtail rtail]
+           [else
+            (let ([rhead (mp4-codec-peek/head file)])
+              (if rhead rhead #f))]))])))
+
+(define (id3? b)
+  (and (bytes-at? b 0 #"ID3")
+       (>= (bytes-length b) 10)
+       (not (= (u8 b 3) #xff))
+       (not (= (u8 b 4) #xff))
+       (zero? (bitwise-and (u8 b 6) #x80))
+       (zero? (bitwise-and (u8 b 7) #x80))
+       (zero? (bitwise-and (u8 b 8) #x80))
+       (zero? (bitwise-and (u8 b 9) #x80))))
+
+(define (synchsafe-size b0 b1 b2 b3)
+  (+ (arithmetic-shift b0 21)
+     (arithmetic-shift b1 14)
+     (arithmetic-shift b2 7)
+     b3))
+
+(define (id3-total-size b)
+  (and (id3? b)
+       (+ 10
+          (synchsafe-size (u8 b 6)
+                          (u8 b 7)
+                          (u8 b 8)
+                          (u8 b 9)))))
+
+(define (valid-mp3-frame-at? b i)
+  (and (>= (bytes-length b) (+ i 4))
+       (let* ([b0 (u8 b i)]
+              [b1 (u8 b (+ i 1))]
+              [b2 (u8 b (+ i 2))]
+              [b3 (u8 b (+ i 3))]
+              [version (bitwise-and (arithmetic-shift b1 -3) #x03)]
+              [layer (bitwise-and (arithmetic-shift b1 -1) #x03)]
+              [bitrate (bitwise-and (arithmetic-shift b2 -4) #x0f)]
+              [sample-rate (bitwise-and (arithmetic-shift b2 -2)
+                                         #x03)]
+              [emphasis (bitwise-and b3 #x03)])
+         (and (= b0 #xff)
+              (= (bitwise-and b1 #xe0) #xe0)
+              (not (= version #b01))
+              (not (= layer #b00))
+              (not (= bitrate #b0000))
+              (not (= bitrate #b1111))
+              (not (= sample-rate #b11))
+              (not (= emphasis #b10))))))
+
+(define (mp3-frame-sync? b)
+  (or (valid-mp3-frame-at? b 0)
+      (let ([id3-size (id3-total-size b)])
+        (and id3-size
+             (< id3-size (bytes-length b))
+             (valid-mp3-frame-at? b id3-size)))))
+
+(define (mp3? b)
+  (or (id3? b)
+      (mp3-frame-sync? b)))
+
+(define (aac-adts-sync? b)
+  (and (>= (bytes-length b) 7)
+       (= (u8 b 0) #xff)
+       (= (bitwise-and (u8 b 1) #xf6) #xf0)
+       (= (bitwise-and (u8 b 1) #x06) #x00)
+       (not (= (bitwise-and (arithmetic-shift (u8 b 2) -2)
+                            #x0f)
+               #x0f))))
+
+(define (audio-sniff-format* file)
+  (let ([status (file-readable-status file)])
+    (cond
+      [(not (eq? status #t)) status]
+      [else
+       (let ([b (read-prefix/status file)])
+         (cond
+           [(symbol? b) b]
+
+           ;; Hard signatures
+           [(bytes-prefix? b #"fLaC") 'flac]
+           [(bytes-prefix? b #"OggS") (sniff-ogg-subtype b)]
+           [(riff-wave? b) 'wav]
+           [(aiff? b) 'aiff]
+           [(iso-bmff? b)
+            (let ([codec (mp4-codec-peek/file file b)])
+              (if codec codec 'mp4))]
+           [(bytes-prefix? b asf-guid) 'wma]
+           [(matroska-or-webm? b) 'matroska]
+           [(ac3? b) 'ac3]
+           [(ape? b) 'ape]
+           [(wavpack? b) 'wavpack]
+
+           ;; Heuristics
+           [(mp3? b) 'mp3]
+           [(aac-adts-sync? b) 'aac]
+
+           [else 'unknown]))])))
+
+(define (audio-sniff-format/extension* file)
+  (let ([fmt (audio-sniff-format* file)])
+    (cond
+      [(not (eq? (memq fmt
+                       '(file-not-found file-not-readable not-a-file))
+                 #f))
+       fmt]
+      [(not (eq? fmt 'unknown)) fmt]
+      [else
+       (case (string->symbol (or (audio-sniff-extension* file) ""))
+         [(mp3 mp2 mp1) 'mp3]
+         [(flac) 'flac]
+         [(ogg oga) 'ogg]
+         [(opus) 'opus]
+         [(wav wave) 'wav]
+         [(aif aiff aifc) 'aiff]
+         [(m4a mp4 m4b m4p) 'mp4]
+         [(aac) 'aac]
+         [(alac) 'alac]
+         [(ac3) 'ac3]
+         [(ape) 'ape]
+         [(wv wvp wvpk wavpack) 'wavpack]
+         [(wma asf) 'wma]
+         [(webm mka mkv) 'matroska]
+         [else 'unknown])])))
+
+(define (audio-format-known?* fmt)
+  (not (eq? (memq fmt audio-formats) #f)))
+
+(define (audio-format-matches?* file formats)
+  (not (eq? (memq (audio-sniff-format/extension* file) formats) #f)))
+
+(define/contract (audio-sniff-extension file)
+  (-> path-string? (or/c string? #f))
+  (audio-sniff-extension* file))
+
+(define/contract (audio-sniff-format file)
+  (-> path-string? audio-format?)
+  (audio-sniff-format* file))
+
+(define/contract (audio-sniff-format/extension file)
+  (-> path-string? audio-format?)
+  (audio-sniff-format/extension* file))
+
+(define/contract (audio-format-known? fmt)
+  (-> symbol? boolean?)
+  (audio-format-known?* fmt))
+
+(define/contract (audio-format-matches? file formats)
+  (-> path-string? (listof symbol?) boolean?)
+  (audio-format-matches?* file formats))
+
+(define-runtime-path audio-tests "tests")
+
+(define (sniff-test)
+  (for-each (λ (ext)
+              (let* ((dir (build-path audio-tests))
+                     (ext* (format ".~a" ext))
+                     (files (map (λ (f)
+                                   (build-path audio-tests f))
+                                 (filter (λ (f)
+                                           (string-suffix? (format "~a" f) ext*))
+                                         (directory-list dir))))
+                     )
+                (for-each (λ (f)
+                            (displayln (format "~a: ~a" f (audio-sniff-format/extension f))))
+                          files)
+                )
+              )
+            '(aac adts flac mp3 ogg ts ac3 aiff m4a mp4 ogx wav wv mp2))
+  )