Add native Emacs Lisp info method

This info method is a pure elisp implementation for Ogg Vorbis, Opus and
FLAC file formats.

1 files changed, 491 insertions, 0 deletions

diff --git a/emms-info-native.el b/emms-info-native.el
new file mode 100644
index 0000000..a51dad4
--- /dev/null
+++ b/emms-info-native.el
@@ -0,0 +1,491 @@
+;;; emms-info-native.el --- Native Emacs Lisp info method for EMMS
+
+;; Copyright (C) 2020 Free Software Foundation, Inc.
+
+;; Author: Petteri Hintsanen <petterih@iki.fi>
+
+;; This file is part of EMMS.
+
+;; EMMS is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3, or (at your option)
+;; any later version.
+
+;; EMMS is distributed in the hope that it will be useful, but WITHOUT
+;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
+;; or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public
+;; License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with EMMS; see the file COPYING. If not, write to the Free
+;; Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
+;; MA 02110-1301, USA.
+
+;;; Commentary:
+
+;; This file provides a native emms-info-method for EMMS.  Here
+;; "native" means a pure Emacs Lisp implementation instead of one
+;; relying on external tools or libraries like ‘emms-info-ogginfo’ or
+;; ‘emms-info-libtag’.
+;;
+;; To use this method, add ‘emms-info-native’ to
+;; ‘emms-info-functions’.
+;;
+;; The following file formats are supported:
+;;
+;; - Vorbis: Ogg Vorbis I Profile, filename extension ‘.ogg’,
+;;   elemetary streams only.  Based on xiph.org’s Vorbis I
+;;   specification, see URL
+;;   ‘https://xiph.org/vorbis/doc/Vorbis_I_spec.html’.
+;;
+;; - Opus: Ogg Opus profile, filename extesion ‘.opus’, elementary
+;;   streams only.  Based on RFC 7845, see URL
+;;   ‘https://tools.ietf.org/html/rfc7845.html’.
+;;
+;; - FLAC: FLAC streams in native encapsulation format, filename
+;;   extesion ‘.flac’.  Based on xiph.org’s FLAC format specification,
+;;   see URL ‘https://xiph.org/flac/format.html’.
+;;
+;; Format detection is based solely on filename extension, which is
+;; matched case-insensitively.
+
+;;; Code:
+
+(require 'bindat)
+
+(defconst emms-info-native--max-peek-size (* 512 1024)
+  "Maximum buffer size for metadata decoding.
+Functions called by ‘emms-info-native’ read certain amounts of
+data into a temporary buffer while attempting to read metadata
+information.  This variable controls the maximum size of that
+buffer: if more than ‘emms-info-native--max-peek-size’ bytes are
+needed, an error is signaled.
+
+Technically metadata blocks can have almost arbitrary lengths,
+but in practice processing must be constrained to prevent memory
+exhaustion in case of garbled or malicious inputs.")
+
+;;;; Ogg code
+
+(defconst emms-info-native--ogg-magic-array
+  [79 103 103 83]
+  "Ogg format magic capture pattern ‘OggS’.")
+
+(defconst emms-info-native--ogg-page-size 65307
+  "Maximum size for a single Ogg container page.
+Ogg files are read in chunks of this size during decoding.")
+
+(defconst emms-info-native--ogg-page-bindat-spec
+  '((capture-pattern vec 4)
+    (eval (when (not (equal last emms-info-native--ogg-magic-array))
+            (error "Ogg framing mismatch: expected ‘%s’, got ‘%s’"
+                   emms-info-native--ogg-magic-array
+                   last)))
+    (stream-structure-version u8)
+    (eval (when (not (= last 0))
+            (error ("Ogg stream structure version mismatch: expected 0, got %s")
+                   last)))
+    (header-type-flag u8)
+    (granule-position vec 8)
+    (stream-serial-number vec 4)
+    (page-sequence-no vec 4)
+    (page-checksum vec 4)
+    (page-segments u8)
+    (segment-table vec (page-segments))
+    (payload vec (eval (seq-reduce #'+ last 0))))
+  "Ogg page structure specification.
+Framing and stream structure versions are verified, otherwise the
+data is assumed to be valid.")
+
+(defun emms-info-native--decode-ogg (filename packets)
+  "Decode at least PACKETS number of packets from Ogg file FILENAME.
+Read in data from the start of FILENAME, remove Ogg packet
+frames, and concatenate payloads until at least PACKETS number of
+packets have been decoded.  Return the decoded packets in a
+vector, concatenated.
+
+Data is read in ‘emms-info-native--ogg-page-size’ chunks.  If the
+total length of concatenated packets becomes greater than
+‘emms-info-native--max-peek-size’, an error is signaled.
+
+Only elementary streams are supported, that is, FILENAME should
+contain only a single logical stream.  Note that this assumption
+is not verified: with non-elementary streams packets from
+different streams will be mixed together without an error."
+  (with-temp-buffer
+    (set-buffer-multibyte nil)
+    (let ((npackets 0)
+          (offset 0)
+          (stream (vector))
+          page)
+      (while (< npackets packets)
+        (insert-file-contents-literally filename
+                                        nil
+                                        offset
+                                        (+ offset
+                                           emms-info-native--ogg-page-size)
+                                        t)
+        (setq page
+              (bindat-unpack emms-info-native--ogg-page-bindat-spec
+                             (buffer-string)))
+        (setq offset
+              (+ offset
+                 (bindat-length emms-info-native--ogg-page-bindat-spec page)))
+        (setq stream (vconcat stream (bindat-get-field page 'payload)))
+        (when (> (length stream) emms-info-native--max-peek-size)
+          (error "Ogg payload is too large"))
+        ;; Look for packet boundaries: every element that is less than 255
+        ;; in the segment table represents a packet boundary.
+        (setq npackets
+              (+ (length (seq-filter (lambda (elt) (< elt 255))
+                                     (bindat-get-field page 'segment-table)))
+                 npackets)))
+      stream)))
+
+(defun emms-info-native--ogg-decode-comments (filename stream-type)
+  "Decode comment header from Ogg file FILENAME.
+The file is assumed to contain a single stream of type
+STREAM-TYPE, which must either ‘vorbis’ or ‘opus’.
+
+Return a list of comments.  Depending on STREAM-TYPE, its
+elements are either of type
+‘emms-info-native--vorbis-comment-header-bindat-spec’ or
+‘emms-info-native--opus-comment-header-bindat-spec’."
+  (let ((packets (emms-info-native--decode-ogg filename 2))
+        stream)
+    (setq stream
+          (cond ((eq stream-type 'vorbis)
+                 (bindat-unpack emms-info-native--vorbis-headers-bindat-spec
+                                packets))
+                ((eq stream-type 'opus)
+                 (bindat-unpack emms-info-native--opus-headers-bindat-spec
+                                packets))
+                (t (error "Unknown stream type %s" stream-type))))
+    (bindat-get-field stream 'comment-header 'user-comment)))
+
+;;;; Vorbis code
+
+(defconst emms-info-native--max-num-vorbis-comments 1024
+  "Maximum number of Vorbis comment fields in a stream.
+Technically a single Vorbis stream may have up to 2^32 comments,
+but in practice processing must be constrained to prevent memory
+exhaustion in case of garbled or malicious inputs.
+
+This limit is used with Opus and FLAC streams as well, since
+their comments have almost the same format as Vorbis.")
+
+(defconst emms-info-native--max-vorbis-comment-size (* 64 1024)
+  "Maximum length for a single Vorbis comment field.
+Technically a single Vorbis comment may have a length up to 2^32
+bytes, but in practice processing must be constrained to prevent
+memory exhaustion in case of garbled or malicious inputs.
+
+This limit is used with Opus and FLAC streams as well, since
+their comments have almost the same format as Vorbis.")
+
+(defconst emms-info-native--max-vorbis-vendor-length 1024
+  "Maximum length of Vorbis vendor string.
+Technically a vendor string can be up to 2^32 bytes long, but in
+practice processing must be constrained to prevent memory
+exhaustion in case of garbled or malicious inputs.
+
+This limit is used with Opus and FLAC streams as well, since
+their comments have almost the same format as Vorbis.")
+
+(defconst emms-info-native--vorbis-magic-array
+  [118 111 114 98 105 115]
+  "Header packet magic pattern ‘vorbis’.")
+
+(defconst emms-info-native--vorbis-identification-header-bindat-spec
+  '((packet-type u8)
+    (eval (when (not (= last 1))
+            (error "Vorbis identification header type mismatch: expected 1, got %s"
+                   last)))
+    (vorbis vec 6)
+    (eval (when (not (equal last emms-info-native--vorbis-magic-array))
+            (error "Vorbis framing mismatch: expected ‘%s’, got ‘%s’"
+                   emms-info-native--vorbis-magic-array
+                   last)))
+    (vorbis-version u32r)
+    (eval (when (not (= last 0))
+            (error "Vorbis version mismatch: expected 0, got %s" last)))
+    (audio-channels u8)
+    (audio-sample-rate u32r)
+    (bitrate-maximum u32r)
+    (bitrate-nominal u32r)
+    (bitrate-minimum u32r)
+    (blocksize u8)
+    (framing-flag u8)
+    (eval (unless (= last 1))
+          (error "Vorbis framing bit mismatch: expected 1, got %s" last)))
+  "Vorbis identification header specification.
+Identification, framing and version data are verified, otherwise
+the data is assumed to be valid.")
+
+(defconst emms-info-native--vorbis-comment-header-bindat-spec
+  '((packet-type u8)
+    (eval (when (not (= last 3))
+            (error "Vorbis comment header type mismatch: expected 3, got %s"
+                   last)))
+    (vorbis vec 6)
+    (eval (when (not (equal last emms-info-native--vorbis-magic-array))
+            (error "Vorbis framing mismatch: expected ‘%s’, got ‘%s’"
+                   emms-info-native--vorbis-magic-array
+                   last)))
+    (vendor-length u32r)
+    (eval (when (> last emms-info-native--max-vorbis-vendor-length)
+            (error "Vorbis vendor length %s is too long" last)))
+    (vendor-string vec (vendor-length))
+    (user-comment-list-length u32r)
+    (eval (when (> last emms-info-native--max-num-vorbis-comments)
+            (error "Vorbis user comment list length %s is too long" last)))
+    (user-comment repeat
+                  (user-comment-list-length)
+                  (struct emms-info-native--vorbis-comment-field-bindat-spec))
+    (framing-bit u8)
+    (eval (unless (= last 1))
+          (error "Vorbis framing bit mismatch: expected 1, got %s" last)))
+  "Vorbis comment header specification.
+Header type and framing data are verified.  Too long vendor
+string and comment list will also trigger an error.")
+
+(defconst emms-info-native--vorbis-comment-field-bindat-spec
+  '((length u32r)
+    (eval (when (> last emms-info-native--max-vorbis-comment-size)
+            (error "Vorbis comment is too long, length %s" last)))
+    (user-comment vec (length)))
+  "Vorbis comment field specification.
+Too long comment will trigger an error.
+
+This field is used in Opus and FLAC comment structures as well.")
+
+(defconst emms-info-native--vorbis-headers-bindat-spec
+  '((identification-header struct emms-info-native--vorbis-identification-header-bindat-spec)
+    (comment-header struct emms-info-native--vorbis-comment-header-bindat-spec))
+  "Specification for two first Vorbis header packets.
+They are always an identification header followed by a comment
+header.")
+
+(defun emms-info-native--split-vorbis-comment (comment)
+  "Split Vorbis comment to a field-value pair.
+Vorbis comments are of form ‘FIELD=VALUE’.  FIELD is a
+case-insensitive field name with a restricted set of ASCII
+characters.  VALUE is an arbitrary UTF-8 encoded octet stream.
+
+Return a cons cell (FIELD . VALUE), where FIELD is converted to
+upper case and VALUE is the decoded value."
+  (let ((comment-string (decode-coding-string (mapconcat
+                                               #'byte-to-string
+                                               comment
+                                               "")
+                                              'utf-8)))
+    (when (string-match "^\\(.+?\\)=\\(.+?\\)$" comment-string)
+      (cons (upcase (match-string 1 comment-string))
+            (match-string 2 comment-string)))))
+
+;;;; Opus code
+
+(defconst emms-info-native--opus-head-magic-array
+  [79 112 117 115 72 101 97 100]
+  "Opus identification header magic pattern ‘OpusHead’.")
+
+(defconst emms-info-native--opus-tags-magic-array
+  [79 112 117 115 84 97 103 115]
+  "Opus comment header magic pattern ‘OpusTags’.")
+
+(defconst emms-info-native--opus-channel-mapping-table
+  '((stream-count u8)
+    (coupled-count u8)
+    (channel-mapping vec (channel-count)))
+  "Opus channel mapping table specification.")
+
+(defconst emms-info-native--opus-identification-header-bindat-spec
+  '((opus-head vec 8)
+    (eval (when (not (equal last emms-info-native--opus-head-magic-array))
+            (error "Opus framing mismatch: expected ‘%s’, got ‘%s’"
+                   emms-info-native--opus-head-magic-array
+                   last)))
+    (opus-version u8)
+    (eval (when (not (< last 16))
+            (error "Opus version mismatch: expected less than 16, got %s"
+                   last)))
+    (channel-count u8)
+    (pre-skip u16r)
+    (sample-rate u32r)
+    (output-gain u16r)
+    (channel-mapping-family u8)
+    (eval (> last 0) (struct opus-channel-mapping-table)))
+  "Opus identification header specification.
+Framing and version data are verified, otherwise the data is
+assumed to be valid.")
+
+(defconst emms-info-native--opus-comment-header-bindat-spec
+  '((opus-tags vec 8)
+    (eval (when (not (equal last emms-info-native--opus-tags-magic-array))
+            (error "Opus framing mismatch: expected ‘%s’, got ‘%s’"
+                   emms-info-native--opus-tags-magic-array
+                   last)))
+    (vendor-length u32r)
+    (eval (when (> last emms-info-native--max-vorbis-vendor-length)
+            (error "Opus vendor length %s is too long" last)))
+    (vendor-string vec (vendor-length))
+    (user-comment-list-length u32r)
+    (eval (when (> last emms-info-native--max-num-vorbis-comments)
+            (error "Opus user comment list length %s is too long" last)))
+    (user-comment repeat
+                  (user-comment-list-length)
+                  (struct emms-info-native--vorbis-comment-field-bindat-spec)))
+  "Opus comment header specification.
+Framing is verified.  Too long vendor string and comment list
+will also trigger an error.")
+
+(defconst emms-info-native--opus-headers-bindat-spec
+  '((identification-header struct emms-info-native--opus-identification-header-bindat-spec)
+    (comment-header struct emms-info-native--opus-comment-header-bindat-spec))
+  "Specification for two first Opus header packets.
+They are always an identification header followed by a comment
+header.")
+
+;;;; FLAC code
+
+(defconst emms-info-native--flac-metadata-block-header-bindat-spec
+  '((block-type u8)
+    (block-length u24))
+  "FLAC metadata block header specification.")
+
+(defconst emms-info-native--flac-comment-bindat-spec
+  '((vendor-length u32r)
+    (eval (when (> last emms-info-native--max-vorbis-vendor-length)
+            (error "FLAC vendor length %s is too long" last)))
+    (vendor-string vec (vendor-length))
+    (user-comment-list-length u32r)
+    (eval (when (> last emms-info-native--max-num-vorbis-comments)
+            (error "FLAC user comment list length %s is too long" last)))
+    (user-comment repeat
+                  (user-comment-list-length)
+                  (struct emms-info-native--vorbis-comment-field-bindat-spec)))
+  "FLAC Vorbis comment block specification.
+Too long vendor string and comment list will trigger an error.")
+
+(defun emms-info-native--has-flac-signature (filename)
+  "Check for FLAC stream marker at the beginning of FILENAME.
+Return t if there is a valid stream marker, nil otherwise."
+  (with-temp-buffer
+    (set-buffer-multibyte nil)
+    (insert-file-contents-literally filename nil 0 4)
+    (looking-at "fLaC")))
+
+(defun emms-info-native--flac-decode-block-header (filename offset)
+  "Read and decode FLAC metadata block header from FILENAME starting at OFFSET.
+Return a list (TYPE NEXT-OFFSET LAST).  Here, TYPE is the FLAC
+metadata block type; NEXT-OFFSET is the starting offset of the
+next block; and LAST is t if this was the last metadata block in
+the stream, otherwise nil."
+  (let (block-header
+        block-type
+        block-length
+        end
+        last-flag)
+    (insert-file-contents-literally filename nil offset (+ offset 4) t)
+    (setq offset (+ offset 4))
+    (setq block-header
+          (bindat-unpack emms-info-native--flac-metadata-block-header-bindat-spec
+                         (buffer-string)))
+    (setq block-type
+          (logand (bindat-get-field block-header 'block-type)
+                  #x7F))
+    (setq block-length (bindat-get-field block-header 'block-length))
+    (when (> block-type 6)
+      (error "FLAC block type error: expected <= 6, got %s" block-type))
+    (when (= block-length 0)
+      (error "FLAC block length error: expected >0, got zero"))
+    (setq last-flag (= (logand (bindat-get-field block-header 'block-type)
+                               #x80)
+                       1))
+    (setq end (+ offset block-length))
+    (list block-type end last-flag)))
+
+(defun emms-info-native--flac-decode-comment-block (filename)
+  "Find and decode a comment block from FLAC file FILENAME.
+Return the comment block in a vector.  Trigger an error if any
+metadata block larger than ‘emms-info-native--max-peek-size’ is
+encountered."
+  (with-temp-buffer
+    (set-buffer-multibyte nil)
+    (unless (emms-info-native--has-flac-signature filename)
+      (error "Invalid FLAC stream"))
+    (let ((offset 4)
+          (comment-block (vector))
+          block-type
+          end
+          last-flag)
+      (while (not last-flag)
+        (cl-multiple-value-setq (block-type
+                                 end
+                                 last-flag)
+          (emms-info-native--flac-decode-block-header filename offset))
+        (when (> (- end offset) emms-info-native--max-peek-size)
+          (error "FLAC metadata block is too large: %s" (- end offset)))
+        (when (= block-type 4)
+          ;; Comment block found, extract it.
+          (insert-file-contents-literally filename nil (+ offset 4) end t)
+          (setq comment-block (vconcat (buffer-string))
+                last-flag t))
+        (setq offset end))
+      comment-block)))
+
+(defun emms-info-native--flac-decode-comments (filename)
+  "Read and decode comments from FLAC file FILENAME.
+Return a list of comments.  See
+‘emms-info-native--vorbis-comment-field-bindat-spec’ for comment
+structure."
+  (bindat-get-field (bindat-unpack emms-info-native--flac-comment-bindat-spec
+                                   (emms-info-native--flac-decode-comment-block filename))
+                    'user-comment))
+
+;;;; EMMS code
+
+(defun emms-info-native--find-stream-type (filename)
+  "Deduce the stream type from FILENAME.
+This is a naive implementation that relies solely on filename
+extension.
+
+Return one of symbols ‘vorbis’, ‘opus’, or ‘flac’."
+  (let ((case-fold-search t))
+    (cond ((string-match ".ogg$" filename) 'vorbis)
+          ((string-match ".opus$" filename) 'opus)
+          ((string-match ".flac$" filename) 'flac)
+          (t nil))))
+
+(defun emms-info-native (track)
+  "Set info fields for TRACK.
+Supports Ogg Vorbis/Opus and FLAC files.
+
+Return t if TRACK was updated, nil otherwise."
+  (let* ((filename (emms-track-name track))
+         (stream-type (emms-info-native--find-stream-type filename))
+         (comments)
+         update-flag)
+    (setq comments
+          (cond ((or (eq stream-type 'vorbis) (eq stream-type 'opus))
+                 (emms-info-native--ogg-decode-comments filename stream-type))
+                ((eq stream-type 'flac)
+                 (emms-info-native--flac-decode-comments filename))
+                (t nil)))
+    (dolist (comment comments)
+      (let ((pair (emms-info-native--split-vorbis-comment
+                   (cdr (assoc 'user-comment comment)))))
+        (when pair
+          (let ((name (intern-soft (concat "info-" (downcase (car pair)))))
+                (value (cdr pair)))
+            (setq update-flag (or update-flag name))
+            (emms-track-set track
+                            name
+                            (if (eq name 'info-playing-time)
+                                (string-to-number value)
+                              value))))))
+    update-flag))
+
+(provide 'emms-info-native)
+
+;;; emms-info-native.el ends here