|
|
@@ -7,7 +7,13 @@
|
|
|
#:is-vbr
|
|
|
#:duration
|
|
|
#:publisher
|
|
|
- #:country))
|
|
|
+ #:country
|
|
|
+ #:keyify
|
|
|
+ #:dekeyify
|
|
|
+ #:http-request
|
|
|
+ #:xml-request
|
|
|
+ #:select-text
|
|
|
+ #:json-request))
|
|
|
(in-package :chad-music.utils)
|
|
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
|
@@ -64,3 +70,125 @@
|
|
|
(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)))
|
