[back] TG Auth/Auth support.

back/db.lisp

@@ -162,7 +162,7 @@
 
   (let ((tracks-db (db-tracks *db*))
         (album-tracks-db (db-album-tracks *db*))
-	(album-added-db (db-album-added *db*)))
+        (album-added-db (db-album-added *db*)))
     (clrhash album-tracks-db)
     (clrhash album-added-db)
     (loop for entry being the hash-values in tracks-db
@@ -212,12 +212,12 @@
 (defparameter +album<>+ (gen-comparator '(artist type original-date year album)))
 (defun album< (a b)
   (declare #.*standard-optimize-settings*
-	   (type function +album<>+))
+           (type function +album<>+))
   (< (the fixnum (funcall +album<>+ a b)) 0))
 
 (defun album-added> (a b)
   (declare #.*standard-optimize-settings*
-	   (type album a b))
+           (type album a b))
   (let ((album-added-db (db-album-added *db*)))
     (> (the fixnum (gethash (album-id a) album-added-db))
        (the fixnum (gethash (album-id b) album-added-db)))))
@@ -225,10 +225,10 @@
 (defparameter +track<>+ (gen-comparator '(no title)))
 (defun track< (a b)
   (declare #.*standard-optimize-settings*
-	   (type function +album<>+ +track<>+))
+           (type function +album<>+ +track<>+))
   (let ((albs (the fixnum (funcall +album<>+ (track-album a) (track-album b)))))
     (if (zerop albs)
-	(< (the fixnum (funcall +track<>+ a b)) 0)
+    (< (the fixnum (funcall +track<>+ a b)) 0)
         albs)))
 
 (defun match-filter (data category filter)
@@ -314,16 +314,16 @@
 (defun db-stats ()
   (declare #.*standard-optimize-settings*)
   (let ((albums (db-albums *db*))
-	(artists (make-hash-table :test 'equal)))
+    (artists (make-hash-table :test 'equal)))
     (loop for entry being the hash-values in albums
-	  summing (album-total-duration entry) into total-duration
-	  summing (album-track-count entry) into total-tracks
-	  counting t into total-albums
-	  do (setf (gethash (album-artist entry) artists) t)
-	  finally (return (list :|artists| (hash-table-count artists)
-				:|albums| total-albums
-				:|tracks| total-tracks
-				:|duration| total-duration)))))
+      summing (album-total-duration entry) into total-duration
+      summing (album-track-count entry) into total-tracks
+      counting t into total-albums
+      do (setf (gethash (album-artist entry) artists) t)
+      finally (return (list :|artists| (hash-table-count artists)
+                            :|albums| total-albums
+                            :|tracks| total-tracks
+                            :|duration| total-duration)))))
 
 (defun save-db (&optional (file-name *db-path*))
   (declare #.*standard-optimize-settings*)

back/server.lisp

@@ -6,18 +6,38 @@
 
 (defvar *path-url-mappings* nil "alist map database paths to urls")
 
+;; Server database
+(defstruct server
+  (token-user (make-hash-table :test #'equal) :type hash-table))
+(defvar *server* (make-server) "Server database")
+(defvar *server-path* "db-server.sexp")
+
+(defun save-server (&optional (file-name *server-path*))
+  (declare #.*standard-optimize-settings*)
+  (with-output-to-file (s file-name :if-exists :supersede)
+    (labels ((print-table (table)
+               (print (hash-table-plist table) s)))
+      (print-table (server-token-user *server*)))))
+
+(defun load-server (&optional (file-name *server-path*))
+  (declare #.*standard-optimize-settings*)
+  (with-input-from-file (s file-name)
+    (make-server
+     :token-user (plist-hash-table (read s nil) :test #'equal))))
+
+
 (defun get-url (path)
   (declare #.*standard-optimize-settings*)
   (when (and path (pathnamep path))
     (let ((path (uiop:unix-namestring path)))
       (loop for (path-prefix . url-prefix) in *path-url-mappings*
             do (multiple-value-bind (foundp suffix)
-		   (starts-with-subseq path-prefix path :return-suffix t)
-		 (when foundp
-                   (return-from get-url (concatenate 'string url-prefix
-                                                     (format nil "~{~A~^/~}"
-                                                             (mapcar #'quri:url-encode
-                                                                     (split-sequence:split-sequence #\/ suffix)))))))))))
+                   (starts-with-subseq path-prefix path :return-suffix t)
+                 (when foundp
+                   (return-from get-url
+                     (format nil "~A~{~A~^/~}" url-prefix
+                             (mapcar #'quri:url-encode
+                                     (split-sequence:split-sequence #\/ suffix))))))))))
 
 (defmacro maybe-key-value (key value)
   `(when ,value
@@ -50,7 +70,8 @@
     (maybe-key-value "bit_rate" (track-bit-rate track))
     (maybe-key-value "vbr" (if (track-is-vbr track) :true :false))
     (maybe-key-value "duration" (track-duration track))
-    (maybe-key-value "url" (get-url (track-path track)))))
+    (maybe-key-value "url" (get-url (track-path track)))
+    (maybe-key-value "cover" (get-url (album-cover (track-album track))))))
 
 (defparameter +400+ '(400 nil #.(trivial-utf-8:string-to-utf-8-bytes "Bad Request")))
 (defparameter +401+ '(401 nil #.(trivial-utf-8:string-to-utf-8-bytes "Unauthorized")))
@@ -64,11 +85,6 @@
   `(200 (:content-type "application/json")
         ,(trivial-utf-8:string-to-utf-8-bytes (funcall dumper data))))
 
-(defun get-category-list (params)
-  (declare #.*standard-optimize-settings*
-           (ignore params))
-  (200-json '("artist" "year" "album" "publisher" "country" "genre" "type" "status")))
-
 (let ((db-package (find-package :chad-music.db)))
   (defun getsym (place indicator)
     (declare #.*standard-optimize-settings*
@@ -111,17 +127,33 @@
                  (,offset (or (may-integer (aget ,query-params "offset")) 0))
                  (,limit (min (the fixnum +max-limit+)
                               (the fixnum (or (may-integer (aget ,query-params "limit")) +max-limit+))))
-		 (,latest (aget ,query-params "latest")))
+         (,latest (aget ,query-params "latest")))
             ,@body))
          (otherwise +404+)))))
 
+(defmacro with-user ((info) &body body)
+  (with-gensyms (auth bearer)
+    `(let* ((,auth (gethash "authorization" (getf myway:*env* :headers)))
+            (,bearer (when (and ,auth
+                                (> (length (the string ,auth)) 7)
+                                (equal "Bearer " (subseq (the string ,auth) 0 7)))
+                       (subseq (the string ,auth) 7)))
+            (,info (when ,bearer (gethash ,bearer (server-token-user *server*)))))
+       (if ,info (progn ,@body) +401+))))
+
+(defun get-category-list (params)
+  (declare #.*standard-optimize-settings* (ignore params))
+  (with-user (info)
+    (200-json '("artist" "year" "album" "publisher" "country" "genre" "type" "status"))))
+
 (defun get-category-size (params)
   (declare #.*standard-optimize-settings*)
-  (with-category (params category filter restrictions offset limit latest)
-    (declare (ignore offset limit latest))
-    (200-json (query-category category
-                              :filter filter :restrictions restrictions
-                              :count-only t))))
+  (with-user (info)
+    (with-category (params category filter restrictions offset limit latest)
+      (declare (ignore offset limit latest))
+      (200-json (query-category category
+                                :filter filter :restrictions restrictions
+                                :count-only t)))))
 
 (defun dumps-category-result (results)
   (with-output-to-string*
@@ -134,17 +166,19 @@
 
 (defun get-category (params)
   (declare #.*standard-optimize-settings*)
-  (with-category (params category filter restrictions offset limit latest)
-    (200-json (query-category category
-                              :filter filter :restrictions restrictions
-                              :limit limit :offset offset :latest latest)
-              (case category
-                (album #'to-json)
-                (t #'dumps-category-result)))))
+  (with-user (info)
+    (with-category (params category filter restrictions offset limit latest)
+      (200-json (query-category category
+                                :filter filter :restrictions restrictions
+                                :limit limit :offset offset :latest latest)
+                (case category
+                  (album #'to-json)
+                  (t #'dumps-category-result))))))
 
 (defun get-album-tracks (params)
   (declare #.*standard-optimize-settings*)
-  (200-json (album-tracks (getf params :id))))
+  (with-user (info)
+    (200-json (album-tracks (getf params :id)))))
 
 (defun file-server (root)
   (lambda (params)
@@ -158,16 +192,17 @@
 (defun update-db ()
   (let (added updated removed)
     (sb-impl::call-with-timing #'(lambda (&rest args)
-				   (push (append args
-						 (list :timestamp (get-universal-time)
-						       :added added
-						       :updated updated
-						       :removed removed))
-					 *rescans*))
-			       #'(lambda ()
-				   (multiple-value-bind (a u r) (rescan (mapcar 'car *path-url-mappings*))
-				     (save-db)
-				     (setf added a updated u removed r))))))
+                                   (push (append args
+                                                 (list :timestamp (get-universal-time)
+                                                       :added added
+                                                       :updated updated
+                                                       :removed removed))
+                                         *rescans*))
+                               #'(lambda ()
+                                   (multiple-value-bind (a u r)
+                                       (rescan (mapcar 'car *path-url-mappings*))
+                                     (save-db)
+                                     (setf added a updated u removed r))))))
 
 (defvar *rescan-lock* (bt:make-lock "Rescan lock"))
 (defvar *rescan-cond* (bt:make-condition-variable :name "Rescan requested"))
@@ -180,86 +215,77 @@
       (bt:condition-wait *rescan-cond* *rescan-lock*)
       (setf *rescan-active* t)
       (handler-case (update-db)
-	(error (e) (format t "Error updating db: ~a" e)))
+    (error (e) (format t "Error updating db: ~a" e)))
       (setf *rescan-active* nil))))
 
 (defun request-rescan (params)
   (declare #.*standard-optimize-settings* (ignorable params))
-  (bt:condition-notify *rescan-cond*)
-  +200-empty+)
+  (with-user (info)
+    (bt:condition-notify *rescan-cond*)
+    +200-empty+))
 
 (defun stats (params)
   (declare #.*standard-optimize-settings* (ignorable params))
-  (let ((stats (db-stats)))
-    (setf (getf stats :|duration|)
-	  (format-interval (getf stats :|duration|)))
-    (200-json (append stats
-		      (list :|rescans| (subseq *rescans* 0 (min (length *rescans*) 10)))))))
+  (with-user (info)
+    (let ((stats (db-stats)))
+      (setf (getf stats :|duration|)
+            (format-interval (getf stats :|duration|)))
+      (200-json (append stats
+                        (list :|rescans| (subseq *rescans* 0 (min (length *rescans*) 10))))))))
 
 (defvar *bot-token* nil "Login bot token")
 (defun validate-user (info)
   (let ((hash (prog1 (getf info :|hash|)
-		(remf info :|hash|)))
-	(check-string (format nil "~{~a=~a~^~%~}"
-			      (alist-plist
-			       (sort (plist-alist info) #'string-lessp :key #'(lambda (p) (symbol-name (car p)))))))
-	(hmac (crypto:make-hmac
-	       (crypto:digest-sequence :sha256 (crypto:ascii-string-to-byte-array *bot-token*)) :sha256)))
+        (remf info :|hash|)))
+    (check-string (format nil "~{~a=~a~^~%~}"
+                  (alist-plist
+                   (sort (plist-alist info) #'string-lessp
+                         :key #'(lambda (p) (symbol-name (car p)))))))
+    (hmac (crypto:make-hmac
+           (crypto:digest-sequence :sha256 (crypto:ascii-string-to-byte-array *bot-token*)) :sha256)))
     (crypto:update-hmac hmac (trivial-utf-8:string-to-utf-8-bytes check-string))
-    (string-equal
-     hash
-     (crypto:byte-array-to-hex-string (crypto:hmac-digest hmac)))))
+    (string-equal hash (crypto:byte-array-to-hex-string (crypto:hmac-digest hmac)))))
 
 (defparameter +telegram-api-format+ "https://api.telegram.org/bot~A/~A")
 (defun telegram-request (method params)
-  (json-request (format nil +telegram-api-format+
-			*bot-token* method)
-		:method :post
-		:content (trivial-utf-8:string-to-utf-8-bytes
-			  (to-json params))))
+  (json-request (format nil +telegram-api-format+ *bot-token* method)
+                :method :post
+                :content (trivial-utf-8:string-to-utf-8-bytes (to-json params))))
 
 (defvar *bot-auth-chat-id* nil "Authentication chat id")
 (defparameter +authorized-statuses+ '("creator" "administrator" "member"))
 (defun authorize-user (info)
   (ignore-errors
    (let* ((response (telegram-request "getChatMember"
-				      `(:|chat_id| ,*bot-auth-chat-id*
-					 :|user_id| ,(getf info :|id|))))
-	  (chat-member (getf response :|result|))
-	  (status (getf chat-member :|status|)))
+                                      `(:|chat_id| ,*bot-auth-chat-id*
+                                         :|user_id| ,(getf info :|id|))))
+          (chat-member (getf response :|result|))
+          (status (getf chat-member :|status|)))
      (member status +authorized-statuses+ :test #'equal))))
 
-(defvar *user-tokens* (make-hash-table :test #'equal))
+
 (defparameter +token-length+ 16)
 (defun user-token (info)
   (let ((token (crypto:byte-array-to-hex-string
-		(crypto:random-data +token-length+))))
-    (setf (gethash token *user-tokens*) info)
+        (crypto:random-data +token-length+))))
+    (setf (gethash token (server-user-tokens *server*)) info)
+    (save-server)
     token))
 
 (defun login (params)
   (declare #.*standard-optimize-settings* (ignorable params))
   (handler-case
       (let* ((body (trivial-utf-8:read-utf-8-string
-		    (getf myway:*env* :raw-body)
-		    :stop-at-eof t))
-	     (info (parse (coerce body 'simple-string))))
-	(unless (validate-user info)
-	  (error "Bad user info"))
-	(unless (authorize-user info)
-	  (return-from login +401+))
-	(200-json (user-token info)))
-    (error (e) +400+)))
+                    (getf myway:*env* :raw-body)
+                    :stop-at-eof t))
+             (info (parse (coerce (the string body) 'simple-string))))
+        (unless (validate-user info)
+          (error "Bad user info"))
+        (if (authorize-user info)
+            (200-json `(:|token| ,(user-token info)))
+            +401+))
+    (error () +400+)))
 
-(defmacro with-user ((info) &body body)
-  (with-gensyms (auth bearer)
-    `(let* ((,auth (gethash "authorization" (getf myway:*env* :headers)))
-	    (,bearer (when (and ,auth
-				(> (length ,auth) 7)
-				(equal "Bearer " (subseq ,auth 0 7)))
-		       (subseq ,auth 7)))
-	    (,info (when ,bearer (gethash ,bearer *user-tokens*))))
-       (if ,info (progn ,@body) +401+))))
 
 (defun user-info (params)
   (declare #.*standard-optimize-settings* (ignorable params))
@@ -284,6 +310,10 @@
                                      (asdf:find-system '#:chad-music)))))
     (load file))
 
+  ;; Load server
+  (when-let (file (probe-file *server-path*))
+    (setf *server* (load-server file)))
+
   ;; Load database
   (when-let (file (probe-file *db-path*))
     (let ((*package* (find-package :chad-music.db)))