chad-music/back/server.lisp

(in-package :cl-user)
(defpackage chad-music.server
  (:use :cl #:alexandria #:chad-music.db #:chad-music.utils #:jonathan)
  (:export #:main))
(in-package :chad-music.server)

(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
                     (format nil "~A~{~A~^/~}" url-prefix
                             (mapcar #'quri:url-encode
                                     (split-sequence:split-sequence #\/ suffix))))))))))

(defmacro maybe-key-value (key value)
  `(when ,value
     (write-key-value ,key ,value)))

(defmethod %to-json ((album album))
  (with-object
    (maybe-key-value "id" (album-id album))
    (maybe-key-value "artist" (album-artist album))
    (maybe-key-value "year" (album-year album))
    (maybe-key-value "album" (album-album album))
    (maybe-key-value "original_date" (album-original-date album))
    (maybe-key-value "publisher" (album-publisher album))
    (maybe-key-value "country" (album-country album))
    (maybe-key-value "genre" (album-genre album))
    (maybe-key-value "type" (or (album-type album) "album"))
    (maybe-key-value "status" (album-status album))
    (maybe-key-value "mb_id" (album-mb-id album))
    (maybe-key-value "track_count" (album-track-count album))
    (maybe-key-value "total_duration" (album-total-duration album))
    (maybe-key-value "cover" (get-url (album-cover album)))))

(defmethod %to-json ((track track))
  (with-object
    (maybe-key-value "artist" (track-artist track))
    (maybe-key-value "album" (album-album (track-album track)))
    (maybe-key-value "year" (album-year (track-album track)))
    (maybe-key-value "no" (clear-track-no (track-no track)))
    (maybe-key-value "title" (track-title track))
    (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 "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")))
(defparameter +404+ '(404 nil #.(trivial-utf-8:string-to-utf-8-bytes "Not found")))
(defparameter +200-empty+ '(200 (:content-type "application/json")
                            #.(trivial-utf-8:string-to-utf-8-bytes "{}")))

(defun 200-json (data &optional (dumper #'to-json))
  (declare #.*standard-optimize-settings*
           (type function dumper))
  `(200 (:content-type "application/json")
        ,(trivial-utf-8:string-to-utf-8-bytes (funcall dumper data))))

(let ((db-package (find-package :chad-music.db)))
  (defun getsym (place indicator)
    (declare #.*standard-optimize-settings*
             (type list place)
             (type symbol indicator))
    (intern (string-upcase (getf place indicator)) db-package)))

(defun aget (place indicator &key (test #'equal))
  (declare #.*standard-optimize-settings*
           (type list place)
           (type (or string symbol) indicator)
           (type function test))
  (cdr (assoc indicator place :test test)))

(defun may-integer (string)
  (declare #.*standard-optimize-settings*
           (type (or null string) string))
  (when string
    (parse-integer string :junk-allowed t)))

(defun get-restrictions (query-params)
  (declare #.*standard-optimize-settings*
           (type list query-params))
  (loop for key in '(artist year album publisher country genre type status)
     for value = (aget query-params (string-downcase (symbol-name key)))
     when value collect (cons key (case key
                                    (year (parse-integer value :junk-allowed t))
                                    (otherwise value)))))

(defparameter +max-limit+ 100)
(defmacro with-category ((params category filter restrictions offset limit latest) &body body)
  (with-gensyms (query-string query-params)
    `(let ((,category (getsym ,params :category)))
       (case ,category
         ((artist year album publisher country genre type status)
          (let* ((,query-string (getf myway:*env* :query-string))
                 (,query-params (and ,query-string (quri:url-decode-params ,query-string)))
                 (,filter (aget ,query-params "filter"))
                 (,restrictions (get-restrictions ,query-params))
                 (,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")))
            ,@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*)))))
       (when (and (not ,info)
		  (equal (getf myway:*env* :remote-addr) "127.0.0.1"))
	 (setf ,info `(:|username| "admin" :|id| 0 :|first_name| "cli" :|last_name| "admin"))
       (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-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*
    (with-array
      (loop for (cat . count) in results
         do (write-item
             (with-object
               (write-key-value "item" cat)
               (write-key-value "count" count)))))))

(defun get-category (params)
  (declare #.*standard-optimize-settings*)
  (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*)
  (with-user (info)
    (200-json (album-tracks (getf params :id)))))

(defun file-server (root)
  (lambda (params)
    (declare #.*standard-optimize-settings*)
    (let ((file (probe-file (cl-fad:merge-pathnames-as-file
                             root (car (getf params :splat))))))
      (if file (list 200 nil file) +404+))))

;; Admin tools
(defvar *rescans* nil)
(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))))))

(defvar *rescan-lock* (bt:make-lock "Rescan lock"))
(defvar *rescan-cond* (bt:make-condition-variable :name "Rescan requested"))
(defvar *rescan-thread* nil)
(defvar *rescan-active* nil)

(defun rescanner ()
  (loop
    (bt:with-lock-held (*rescan-lock*)
      (bt:condition-wait *rescan-cond* *rescan-lock*)
      (setf *rescan-active* t)
      (handler-case (update-db)
    (error (e) (format t "Error updating db: ~a" e)))
      (setf *rescan-active* nil))))

(defun request-rescan (params)
  (declare #.*standard-optimize-settings* (ignorable params))
  (with-user (info)
    (bt:condition-notify *rescan-cond*)
    +200-empty+))

(defun stats (params)
  (declare #.*standard-optimize-settings* (ignorable params))
  (with-user (info)
    (let ((stats (db-stats)))
      (setf (getf stats :|duration|)
            (format-interval (getf stats :|duration|)))
      (200-json (append stats
                        (list :|rescans| (subseq (the list *rescans*)
						 0 (min (length (the list *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)))
    (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)))))

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

(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|)))
     (member status +authorized-statuses+ :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 (server-token-user *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 (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 (e) (log:error e) +400+)))

(defun user-info (params)
  (declare #.*standard-optimize-settings* (ignorable params))
  (with-user (info)
    (200-json info)))

(defvar *mapper* (myway:make-mapper))
(myway:connect *mapper* "/api/cat/:category/size" 'get-category-size)
(myway:connect *mapper* "/api/cat/:category" 'get-category)
(myway:connect *mapper* "/api/cat" 'get-category-list)
(myway:connect *mapper* "/api/album/:id/tracks" 'get-album-tracks)
(myway:connect *mapper* "/api/stats" 'stats)
(myway:connect *mapper* "/api/rescan" 'request-rescan :method :POST)
(myway:connect *mapper* "/api/login" 'login :method :POST)
(myway:connect *mapper* "/api/user" 'user-info)

(defun main (&rest args &key (port 5000) (debug nil) (use-thread t) (serve-files nil) &allow-other-keys)
  ;; Load config file
  (when-let (file (probe-file
                   (merge-pathnames "config.lisp"
                                    (asdf:component-pathname
                                     (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)))
      (setf *db* (load-db file))))

  ;; Set up debug file server
  (when serve-files
    (loop for (path-prefix . url-prefix) in *path-url-mappings*
       do (myway:connect *mapper* (concatenate 'string url-prefix "*")
                         (file-server path-prefix))))

  ;; Start rescan processor
  (setf *rescan-thread* (bt:make-thread 'rescanner :name "DB rescanner"))

  ;; Start application
  (apply #'clack:clackup
         (myway:to-app *mapper*)
         :server :woo
         :port port
         :debug debug
         :use-default-middlewares nil
         :use-thread use-thread
         (alexandria:remove-from-plist args :data :port :debug :use-thread)))