audio-library-manager/private/fingerprint.rkt

#lang racket/base

(require file/sha1
         racket/list
         racket/port
         racket/string
         "util.rkt")

(provide read-flac-streaminfo
         flac-streaminfo-sample-rate
         flac-streaminfo-fingerprint
         flac-taglib-fingerprint)

(struct flac-streaminfo
  (min-blocksize max-blocksize min-framesize max-framesize sample-rate channels bits-per-sample total-samples audio-md5)
  #:transparent)

(define (u16be b i)
  (+ (arithmetic-shift (bytes-ref b i) 8)
     (bytes-ref b (+ i 1))))

(define (u24be b i)
  (+ (arithmetic-shift (bytes-ref b i) 16)
     (arithmetic-shift (bytes-ref b (+ i 1)) 8)
     (bytes-ref b (+ i 2))))

(define (u64be b i)
  (for/fold ([n 0]) ([j (in-range i (+ i 8))])
    (+ (arithmetic-shift n 8) (bytes-ref b j))))

(define (hex-bytes b)
  (bytes->hex-string b))

(define (sha256-string s)
  (bytes->hex-string (sha256-bytes (string->bytes/utf-8 s))))

(define (read-exact-bytes who in n)
  (define b (read-bytes n in))
  (unless (and (bytes? b) (= (bytes-length b) n))
    (error who "unexpected end of file"))
  b)

(define (syncsafe-byte? b)
  (< b #x80))

(define (u28-syncsafe b i)
  (unless (and (syncsafe-byte? (bytes-ref b i))
               (syncsafe-byte? (bytes-ref b (+ i 1)))
               (syncsafe-byte? (bytes-ref b (+ i 2)))
               (syncsafe-byte? (bytes-ref b (+ i 3))))
    (error 'read-flac-streaminfo "invalid ID3v2 syncsafe size"))
  (+ (arithmetic-shift (bytes-ref b i) 21)
     (arithmetic-shift (bytes-ref b (+ i 1)) 14)
     (arithmetic-shift (bytes-ref b (+ i 2)) 7)
     (bytes-ref b (+ i 3))))

(define (read-flac-marker path in)
  (define first (read-exact-bytes 'read-flac-streaminfo in 4))
  (cond [(bytes=? first #"fLaC") 'native]
        [(and (= (bytes-ref first 0) (char->integer #\I))
              (= (bytes-ref first 1) (char->integer #\D))
              (= (bytes-ref first 2) (char->integer #\3)))
         (let* ([_0 (file-position in 0)]
                [id3-header (read-exact-bytes 'read-flac-streaminfo in 10)]
                [flags (bytes-ref id3-header 5)]
                [tag-size (u28-syncsafe id3-header 6)]
                [footer-size (if (not (zero? (bitwise-and flags #x10))) 10 0)]
                [_1 (file-position in (+ 10 tag-size footer-size))]
                [marker (read-exact-bytes 'read-flac-streaminfo in 4)])
           (unless (bytes=? marker #"fLaC")
             (error 'read-flac-streaminfo
                    "ID3v2 prefix found, but no FLAC marker after prefix: ~a"
                    path))
           'id3v2-prefixed)]
        [else
         (error 'read-flac-streaminfo "not a native FLAC file: ~a" path)]))

(define (read-flac-streaminfo path)
  (call-with-input-file path
    (lambda (in)
      (read-flac-marker path in)
      (let loop ()
        (define header (read-exact-bytes 'read-flac-streaminfo in 4))
        (define last? (not (zero? (bitwise-and (bytes-ref header 0) #x80))))
        (define block-type (bitwise-and (bytes-ref header 0) #x7f))
        (define len (u24be header 1))
        (cond [(= block-type 0)
               (unless (= len 34)
                 (error 'read-flac-streaminfo "invalid STREAMINFO length ~a for ~a" len path))
               (define b (read-exact-bytes 'read-flac-streaminfo in len))
               (define packed (u64be b 10))
               (define sample-rate (bitwise-and (arithmetic-shift packed -44) #xfffff))
               (define channels (+ 1 (bitwise-and (arithmetic-shift packed -41) #x7)))
               (define bits-per-sample (+ 1 (bitwise-and (arithmetic-shift packed -36) #x1f)))
               (define total-samples (bitwise-and packed #xfffffffff))
               (flac-streaminfo (u16be b 0)
                                (u16be b 2)
                                (u24be b 4)
                                (u24be b 7)
                                sample-rate
                                channels
                                bits-per-sample
                                total-samples
                                (subbytes b 18 34))]
              [last? (error 'read-flac-streaminfo "STREAMINFO block not found in ~a" path)]
              [else
               (define skipped (read-bytes len in))
               (unless (and (bytes? skipped) (= (bytes-length skipped) len))
                 (error 'read-flac-streaminfo "unexpected end of file while skipping metadata block"))
               (loop)])))
    #:mode 'binary))

(define (flac-streaminfo-fingerprint-data path)
  (define si (read-flac-streaminfo path))
  (list (cons 'kind 'flac-streaminfo)
        (cons 'min-blocksize (flac-streaminfo-min-blocksize si))
        (cons 'max-blocksize (flac-streaminfo-max-blocksize si))
        (cons 'min-framesize (flac-streaminfo-min-framesize si))
        (cons 'max-framesize (flac-streaminfo-max-framesize si))
        (cons 'sample-rate (flac-streaminfo-sample-rate si))
        (cons 'channels (flac-streaminfo-channels si))
        (cons 'bits-per-sample (flac-streaminfo-bits-per-sample si))
        (cons 'total-samples (flac-streaminfo-total-samples si))
        (cons 'audio-md5 (hex-bytes (flac-streaminfo-audio-md5 si)))))

(define (canonical-value v)
  (cond [(string? v) v]
        [(symbol? v) (symbol->string v)]
        [(number? v) v]
        [(boolean? v) v]
        [(bytes? v) (list 'bytes-sha256 (bytes-length v) (hex-bytes (sha256-bytes v)))]
        [(list? v) (map canonical-value v)]
        [(eq? v #f) #f]
        [else (format "~s" v)]))

(define (taglib-fingerprint-data path)
  (define call-with-id3-tags (dynamic-require 'racket-audio/taglib 'call-with-id3-tags))
  (define tags-valid? (dynamic-require 'racket-audio/taglib 'tags-valid?))
  (define tags-keys (dynamic-require 'racket-audio/taglib 'tags-keys))
  (define tags-ref (dynamic-require 'racket-audio/taglib 'tags-ref))
  (define tags-picture (dynamic-require 'racket-audio/taglib 'tags-picture))
  (define id3-picture? (dynamic-require 'racket-audio/taglib 'id3-picture?))
  (define id3-picture-mimetype (dynamic-require 'racket-audio/taglib 'id3-picture-mimetype))
  (define id3-picture-kind (dynamic-require 'racket-audio/taglib 'id3-picture-kind))
  (define id3-picture-size (dynamic-require 'racket-audio/taglib 'id3-picture-size))
  (define id3-picture-bytes (dynamic-require 'racket-audio/taglib 'id3-picture-bytes))
  (define id3-picture-description (dynamic-require 'racket-audio/taglib 'id3-picture-description))
  (call-with-id3-tags
   path
   (lambda (tags)
     (unless (tags-valid? tags)
       (error 'taglib-fingerprint-data "invalid tags for ~a" path))
     (define keys (sort (map canonical-value (tags-keys tags)) string<? #:key (lambda (x) (format "~a" x))))
     (define values
       (for/list ([k (in-list keys)])
         (cons k (canonical-value (tags-ref tags k)))))
     (define picture (tags-picture tags))
     (define picture-data
       (if (and picture (id3-picture? picture))
           (list (cons 'mimetype (id3-picture-mimetype picture))
                 (cons 'kind (id3-picture-kind picture))
                 (cons 'size (id3-picture-size picture))
                 (cons 'description (id3-picture-description picture))
                 (cons 'bytes-sha256 (hex-bytes (sha256-bytes (id3-picture-bytes picture)))))
           #f))
     (list (cons 'kind 'taglib)
           (cons 'properties values)
           (cons 'picture picture-data)))
   #:mode 'read))

(define (flac-taglib-fingerprint path)
  (sha256-string (format "~s" (list (flac-streaminfo-fingerprint-data path)
                                    (taglib-fingerprint-data path)))))

(define (flac-streaminfo-fingerprint path)
  (sha256-string (format "~s" (flac-streaminfo-fingerprint-data path))))