chad-music/back/utils.lisp

(in-package :cl-user)
(defpackage chad-music.utils
  (:use :cl #:audio-streams #:alexandria)
  (:export #:*standard-optimize-settings*
           #:text-tag
           #:bit-rate
           #:is-vbr
           #:duration
           #:publisher
           #:country
           #:keyify
           #:dekeyify
           #:http-request
           #:xml-request
           #:select-text
           #:json-request))
(in-package :chad-music.utils)

(eval-when (:compile-toplevel :load-toplevel :execute)
  #+dbg
  (defvar *standard-optimize-settings* '(optimize (debug 3)))
  #-dbg
  (defvar *standard-optimize-settings* '(optimize (speed 3) (safety 0) (space 0) (debug 0))))

(defgeneric text-tag (stream desc) (:method ((object t) desc) nil))
(defmethod text-tag ((mp3 id3:mp3-file) desc)
  (declare #.*standard-optimize-settings*)

  (loop for frame in (id3:get-frames mp3 '("TXXX"))
     when (string-equal (id3:desc frame) desc)
     do (return-from text-tag (id3:val frame))))

(defgeneric bit-rate (stream) (:method ((object t)) nil))
(defgeneric is-vbr (stream) (:method ((object t)) nil))
(defgeneric duration (stream) (:method ((object t)) nil))
(defgeneric publisher (stream) (:method ((object t)) nil))
(defgeneric country (stream) (:method ((object t)) nil))
(defmethod bit-rate ((mp3 id3:mp3-file))
  (let ((info (id3:audio-info mp3)))
    (when info
      (round (mpeg::bit-rate info) 1000))))

(defmethod is-vbr ((mp3 id3:mp3-file))
  (let ((info (id3:audio-info mp3)))
    (when info
      (mpeg::is-vbr info))))

(defmethod duration ((mp3 id3:mp3-file))
  (let ((info (id3:audio-info mp3)))
    (when info
      (mpeg::len info))))

(defmethod publisher ((mp3 id3:mp3-file))
  (declare #.utils:*standard-optimize-settings*)

  (let ((frames (id3:get-frames mp3 '("TPUB" "TPB"))))
    (when frames
      (return-from publisher (id3:info (first frames)))))
  nil)

(defmethod country ((mp3 id3:mp3-file))
  (text-tag mp3 "MusicBrainz Album Release Country"))

(defmethod bit-rate ((m4a m4a:mp4-file))
  (let ((info (m4a:audio-info m4a)))
    (when info
      (round (m4a::avg-bit-rate info) 1000))))

(defmethod duration ((m4a m4a:mp4-file))
  (let ((info (m4a:audio-info m4a)))
    (when info
      (m4a::seconds info))))

(defun keyify (key)
  (intern (string-upcase (substitute #\- #\_ key)) :keyword))

(defun dekeyify (keyword &optional preserve-dash)
  (let ((text (string-downcase (string keyword))))
    (if preserve-dash text (substitute #\_ #\- text))))

(defun http-default (url &optional parameters)
  (let* ((uri (quri:uri url))
         (userinfo (quri:uri-userinfo uri)))
    (when parameters
      (let ((query (quri:url-encode-params parameters :encoding :utf-8)))
        (setf (quri:uri-query uri)
              (if (and (quri:uri-query uri)
                       (string-not-equal (quri:uri-query uri) ""))
                  (concatenate 'string (quri:uri-query uri) "&" query)
                  query))))
    (when userinfo
      (setf (quri:uri-userinfo uri) nil))
    (unless (quri:uri-scheme uri)
      (setf (quri:uri-scheme uri) "http"))
    (values uri userinfo)))

(defun http-request (url &rest args &key method version parameters content headers basic-auth cookie-jar keep-alive use-connection-pool (max-redirects 5) timeout force-binary want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path user-agent)
  (declare (ignore method version content basic-auth cookie-jar keep-alive use-connection-pool max-redirects timeout force-binary want-stream ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path))
  (multiple-value-bind (uri userinfo)
      (http-default url parameters)
    (when userinfo
      (push (cons :authorization (concatenate 'string "Basic "
                                              (base64:string-to-base64-string userinfo)))
            headers))
    (when user-agent
      (push (cons :user-agent user-agent) headers)
      (remf args :user-agent))
    (remf args :parameters)
    (remf args :headers)
    (apply #'dex:request uri :headers headers args)))

;; XML processing
(defun xml-request (url &rest args &key method parameters content headers basic-auth cookie-jar keep-alive use-connection-pool timeout ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path user-agent encoding)
  (declare (ignore method parameters headers content basic-auth cookie-jar keep-alive use-connection-pool timeout ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path user-agent))
  (remf args :encoding)
  (multiple-value-bind (raw-body status headers uri)
      (apply #'http-request url :force-binary t args)
    (let ((encoding
           (or
            ;; 1. Provided encoding
            encoding
            ;; 2. Content-type header
            (ignore-errors
              (let ((ct (gethash "content-type" headers)))
                (subseq ct (1+ (position #\= ct)))))
            ;; 3. Parse first 1000 bytes
            (ignore-errors
              (let ((dom (plump:parse (flex:octets-to-string
                                       (subseq raw-body 0 (1+ (position (char-code #\>) raw-body :start 1000)))))))
                (or
                 ;; 3.1 Content-type from http-equiv
                 (ignore-errors
                   (let ((ct (loop for meta in (get-by-tag dom "meta")
                                for http-equiv = (plump:get-attribute meta "http-equiv")
                                for content = (plump:get-attribute meta "content")
                                when (equal http-equiv "Content-Type")
                                return content)))
                     (subseq ct (1+ (position #\= ct)))))
                 ;; 3.2 'content' xml node attribute
                 (ignore-errors (plump:get-attribute (plump:first-child dom) "encoding")))))
            ;; 4. Default 'utf-8'
            "utf-8")))
      (values
       (handler-bind ((flex:external-format-encoding-error
                       (lambda (c) (use-value #\? c))))
         (plump:parse
          (flex:octets-to-string raw-body :external-format (intern encoding 'keyword))))
       status headers uri))))

(defun get-by-tag (node tag)
  (nreverse (org.shirakumo.plump.dom::get-elements-by-tag-name node tag)))

(defun select-text (node &optional selector)
  (ignore-errors
    (when selector (setf node (elt (clss:select selector node) 0)))
    (plump:traverse node #'(lambda (n) (setf (plump:text n) ""))
                    :test #'plump:comment-p)
    (plump:text (plump:strip node))))

(defun trim-nil (text)
  (when text
    (let ((text (string-trim " " text)))
      (unless (zerop (length text))
        text))))

(defun text-with-cdata (node)
  "Compiles all text nodes within the nesting-node into one string."
  (with-output-to-string (stream)
    (labels ((r (node)
               (loop for child across (plump:children node)
                  do (typecase child
                       (plump:text-node (write-string (plump:text child) stream))
                       (plump:cdata (write-string (plump:text child) stream))
                       (plump:nesting-node (r child))))))
      (r node))))

(defun child-text (node tag)
  (alexandria:when-let (child (car (get-by-tag node tag)))
    (trim-nil (text-with-cdata child))))

(defun clean-text (text)
  (when text (trim-nil (plump:text (plump:parse text)))))

(defun json-request (url &rest args &key method parameters content headers basic-auth cookie-jar keep-alive use-connection-pool timeout ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path user-agent (as :plist))
  (declare (ignore method parameters basic-auth cookie-jar keep-alive use-connection-pool timeout ssl-key-file ssl-cert-file ssl-key-password stream verbose proxy insecure ca-path user-agent))
  (remf args :as)
  (when content
    (push (cons :content-type "application/json") headers))
  (remf args :headers)
  (multiple-value-bind (body status headers uri)
      (apply #'http-request url :headers headers args)
    (unless (stringp body)
      (setf body (trivial-utf-8:utf-8-bytes-to-string body)))
    (values (jojo:parse body :as as) status headers uri)))