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) "release"))
    (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))
  (let ((album-artist (album-artist (track-album track)))
        (track-artist (track-artist track)))
    (with-object
      (maybe-key-value "id" (track-id track))
      (maybe-key-value "artist" track-artist)
      (maybe-key-value "album_artist" (unless (equal track-artist album-artist) album-artist))
      (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 "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 +413+
  '(413 (:content-type "application/json")
    #.(trivial-utf-8:string-to-utf-8-bytes
       "{\"status\":\"error\",\"message\":\"File too large (max 200 MB)\"}")))
(defparameter +503+
  '(503 (:content-type "application/json")
    #.(trivial-utf-8:string-to-utf-8-bytes
       "{\"status\":\"error\",\"message\":\"Upload not configured on server\"}")))
(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+ 10000)
(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 headers)
    `(let* ((,headers (getf myway:*env* :headers))
            (,auth (ignore-errors (gethash "authorization" ,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 (null ,info) (null (gethash "x-real-ip" ,headers)))
         (setf ,info `(:|username| "admin" :|id| 0 :|first_name| "cli" :|last_name| "admin")))
       (if ,info (handler-case (progn ,@body) (error (e) (log:error e) (print e)))
           +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 (uiop:parse-unix-namestring (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")
(defun tg-get-chat-member (user-id &optional (chat-id *bot-auth-chat-id*))
  (getf (telegram-request "getChatMember"
                          `(:|chat_id| ,chat-id :|user_id| ,user-id))
        :|result|))

(defparameter +authorized-statuses+ '("creator" "administrator" "member"))
(defun authorize-user (info)
  (ignore-errors
   (let* ((chat-member (tg-get-chat-member (getf info :|id|)))
          (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 self-info (params)
  (declare #.*standard-optimize-settings* (ignorable params))
  (with-user (info)
    (200-json info)))

(defun find-user-info (username)
  (first
   (sort
    (loop for info being the hash-value of (server-token-user *server*)
          when (equal username (getf info :|username|))
          collect info)
    #'< :key (lambda (i) (getf i :|auth_date|)))))

(defun user-info (params)
  (declare #.*standard-optimize-settings* (ignorable params))
  (with-user (info)
    (let ((info (find-user-info (getf params :user))))
      (if info
          (progn
            (dolist (ind '(:|hash| :|id| :|auth_date|)) (remf info ind))
            (200-json info))
          +404+))))

(defvar *mapper* (myway:make-mapper))

;; ---- Upload configuration ----

(defvar *upload-dir* nil
  "Upload directory path. Set in config.lisp.")

(defparameter *max-upload-size* (* 200 1024 1024)
  "Maximum upload file size in bytes (200 MB).")

(defparameter +allowed-upload-types+
  '("audio/mpeg" "audio/flac" "audio/mp4" "audio/x-m4a"
    "audio/wav" "audio/aiff" "audio/ogg"))

(defun sanitize-filename (name)
  "Keep only safe characters (alphanumeric, dot, dash, underscore, space).
Truncate to 200 chars. Reject empty or all-dot results."
  (let* ((clean (remove-if-not
                  (lambda (c)
                    (or (alphanumericp c) (find c ".-_ ")))
                  name))
         (trimmed (string-left-trim ".-" clean))
         (truncated (if (> (length trimmed) 200)
                        (subseq trimmed 0 200)
                        trimmed)))
    (if (or (zerop (length truncated))
            (every (lambda (c) (char= c #\.)) truncated))
        "unnamed-upload"
        truncated)))

(defun parse-media-type (content-type)
  "Extract base media type from Content-Type, stripping parameters.
E.g. 'audio/mpeg; charset=binary' -> 'audio/mpeg'."
  (when content-type
    (string-trim " " (first (split-sequence:split-sequence
                              #\; content-type :count 1)))))

(defun upload-file (params)
  "PUT /api/upload — receive a raw audio file and add to library."
  (declare #.*standard-optimize-settings* (ignorable params))
  (with-user (info)
    (unless *upload-dir*
      (return-from upload-file +503+))
    (let* ((headers (getf myway:*env* :headers))
           (content-type (parse-media-type (gethash "content-type" headers)))
           (content-length
             (ignore-errors
               (parse-integer
                 (or (gethash "content-length" headers) "")
                 :junk-allowed nil)))
           (raw-filename (or (gethash "x-filename" headers) "upload"))
           (filename (sanitize-filename raw-filename))
           (body (getf myway:*env* :raw-body))
           (upload-dir (uiop:ensure-directory-pathname *upload-dir*)))
      ;; Validate content type
      (unless (member content-type +allowed-upload-types+
                      :test #'string-equal)
        (return-from upload-file +400+))
      ;; Early reject if Content-Length exceeds limit
      (when (and content-length (> content-length *max-upload-size*))
        (return-from upload-file +413+))
      ;; Ensure upload directory exists
      (ensure-directories-exist upload-dir)
      ;; Generate unique filename: timestamp-random-sanitized
      (let* ((dest-name (format nil "~D-~4,'0D-~A"
                                (get-universal-time) (random 10000) filename))
             (dest (merge-pathnames dest-name upload-dir))
             (temp (merge-pathnames (concatenate 'string dest-name ".tmp")
                                    upload-dir)))
        ;; Stream to temp file with byte counting
        (handler-case
            (progn
              (with-open-file (out temp
                               :direction :output
                               :element-type '(unsigned-byte 8)
                               :if-exists :supersede)
                (let ((buf (make-array 65536 :element-type '(unsigned-byte 8)))
                      (total 0))
                  (loop for n = (read-sequence buf body)
                        while (plusp n)
                        do (incf total n)
                           (when (> total *max-upload-size*)
                             (error "Upload exceeds size limit"))
                           (write-sequence buf out :end n))))
              ;; Success — atomic rename
              (rename-file temp dest))
          (error (e)
            ;; Cleanup temp file on any error
            (ignore-errors (delete-file temp))
            (if (search "size limit" (princ-to-string e))
                (return-from upload-file +413+)
                (progn (log:error e)
                       (return-from upload-file +400+)))))
        ;; Synchronous rescan — lock to avoid racing with rescanner thread
        (bt:with-lock-held (*rescan-lock*)
          (multiple-value-bind (added updated removed)
              (rescan (list (namestring upload-dir)))
            (declare (ignore removed))
            (save-db)
            (200-json
              (list :|status| "imported"
                    :|tracks_added| added
                    :|albums_updated| updated))))))))

(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" 'self-info)
(myway:connect *mapper* "/api/user/:user" 'user-info)
(myway:connect *mapper* "/api/upload" 'upload-file :method :PUT)

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