[utils] to select torrents

back/chad-music.asd

@@ -2,19 +2,25 @@
   :description "chad music backend"
   :author "Innokentiy Enikeev <me@enikesha.net>"
   :license "MIT"
-  :depends-on (#:taglib
-               #:alexandria
+  :depends-on (#:alexandria
+               #:cl-cookie
                #:cl-fad
-               #:ironclad
-               #:split-sequence
-               #:woo
+               #:cl-ppcre
                #:clack
+               #:clss
+               #:dexador
+               #:ironclad
+               #:jonathan
                #:lack
+               #:myway
+               #:plump
                #:quri
-               #:zip
+               #:split-sequence
+               #:sqlite
+               #:taglib
                #:trivial-utf-8
-               #:myway
-               #:jonathan)
+               #:woo
+               #:zip)
   :serial t
   :components ((:file "utils")
                (:file "db")

back/utils.lisp

@@ -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)))