mixboard/.orchestra/cloud-upload-v1/server-patch.lisp

;;; ==========================================================
;;; Cloud Upload v1 — server.lisp additions for chad-music
;;; ==========================================================
;;;
;;; Add these definitions to back/server.lisp
;;; Register the route after existing myway:connect calls
;;;
;;; Also requires config.lisp changes — see bottom of file.
;;;
;;; Woo body streaming: VERIFIED — (getf myway:*env* :raw-body)
;;; returns a stream. read-sequence in 64KB chunks streams to
;;; disk without buffering the entire file in memory.
;;;
;;; Review findings addressed (Codex + Gemini):
;;; - Byte-counting in read loop (don't trust Content-Length)
;;; - Atomic write: temp file + rename on success, delete on error
;;; - Content-Type parameter stripping (handles "audio/mpeg; charset=binary")
;;; - Stronger filename sanitization (allowlist + truncation)
;;; - 503 for unconfigured upload (not 200)
;;; - Random suffix for collision avoidance (get-universal-time is 1s resolution)

;; ---- Configuration ----

(defvar *upload-dir* nil
  "Upload directory path. Set in config.lisp.
Must also be mapped in *path-url-mappings* for streaming.")

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

(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\"}")))

;; ---- Helpers ----

(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))
         ;; Strip leading dots and dashes (avoid hidden files / CLI confusion)
         (trimmed (string-left-trim ".-" clean))
         ;; Truncate to 200 chars (well under 255 FS limit)
         (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)))))

;; ---- Upload endpoint ----

(defun upload-file (params)
  (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))
             ;; Write to .tmp suffix first, rename on success
             (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))))))))

;; ---- Route registration (add after existing myway:connect calls) ----

(myway:connect *mapper* "/api/upload" 'upload-file :method :PUT)


;;; ==========================================================
;;; config.lisp additions
;;; ==========================================================
;;;
;;; Add to your existing config.lisp:
;;;
;;;   ;; Upload directory
;;;   (setf chad-music.server:*upload-dir*
;;;         #p"/data/upload/mixboard/")
;;;
;;;   ;; Map upload dir to URL prefix so uploaded tracks are streamable
;;;   (push (cons "/data/upload/mixboard/" "/upload/")
;;;         chad-music.server:*path-url-mappings*)
;;;
;;; The /upload/ URL prefix lets file-server serve uploaded files
;;; for streaming before beets moves them to the organized library.