diff --git a/asteroid.asd b/asteroid.asd index 7cae886..117038b 100644 --- a/asteroid.asd +++ b/asteroid.asd @@ -36,6 +36,7 @@ :r-data-model (:interface :auth) (:interface :database) + (:interface :rate) (:interface :user)) :pathname "./" :components ((:file "app-utils") @@ -43,6 +44,7 @@ (:module :config :components ((:file radiance-postgres))) (:file "conditions") + (:file "limiter") (:file "database") (:file "template-utils") (:file "parenscript-utils") diff --git a/asteroid.lisp b/asteroid.lisp index a88e22c..288f678 100644 --- a/asteroid.lisp +++ b/asteroid.lisp @@ -39,7 +39,10 @@ (define-api-format json (data) "JSON API format for Radiance" (setf (header "Content-Type") "application/json") - (cl-json:encode-json-to-string data)) + (let ((status (gethash "status" data))) + (when (and status (boundp '*response*)) + (setf (return-code *response*) status)) + (cl-json:encode-json-to-string data))) ;; Set JSON as the default API format (setf *default-api-format* "json") @@ -1128,16 +1131,16 @@ |# ;; Auth status API endpoint -(define-api asteroid/auth-status () () +(define-api-with-limit asteroid/auth-status () () "Check if user is logged in and their role" (with-error-handling (let* ((user-id (session:field "user-id")) (user (when user-id (find-user-by-id user-id)))) (api-output `(("loggedIn" . ,(if user t nil)) ("isAdmin" . ,(if (and user (user-has-role-p user :admin)) t nil)) - ("username" . ,(if user + ("username" . ,(if user (dm:field user "username") - nil))))))) + nil))))))) ;; User profile API endpoints (define-api asteroid/user/profile () () @@ -1199,66 +1202,66 @@ artists))))))) ;; Register page (GET) -(define-page register #@"/register" () +(define-page-with-limit register #@"/register" () "User registration page" - (let ((username (radiance:post-var "username")) - (email (radiance:post-var "email")) - (password (radiance:post-var "password")) - (confirm-password (radiance:post-var "confirm-password"))) - (if (and username password) - ;; Handle registration form submission - (cond - ;; Validate passwords match - ((not (string= password confirm-password)) - (format t "Failed to register new user '~a': passwords do not match.~%" username) - (clip:process-to-string - (load-template "register") - :title "Asteroid Radio - Register" - :display-error "display: block;" - :display-success "display: none;" - :error-message "Passwords do not match" - :success-message "")) - - ;; Check if username already exists - ((find-user-by-username username) - (format t "Failed to register new user '~a': Username already exists.~%" username) - (clip:process-to-string - (load-template "register") - :title "Asteroid Radio - Register" - :display-error "display: block;" - :display-success "display: none;" - :error-message "Username already exists" - :success-message "")) - - ;; Create the user - (t - (if (create-user username email password :role :listener :active t) - (progn - ;; Auto-login after successful registration - (let ((user (find-user-by-username username))) - (when user - (let ((user-id (dm:id user))) - (setf (session:field "user-id") user-id)))) - ;; Redirect new users to their profile page - (radiance:redirect "/asteroid/profile")) - (clip:process-to-string - (load-template "register") - :title "Asteroid Radio - Register" - :display-error "display: block;" - :display-success "display: none;" - :error-message "Registration failed. Please try again." - :success-message "")))) - ;; Show registration form (no POST data) - (clip:process-to-string - (load-template "register") - :title "Asteroid Radio - Register" - :display-error "display: none;" - :display-success "display: none;" - :error-message "" - :success-message "")))) + (let ((username (radiance:post-var "username")) + (email (radiance:post-var "email")) + (password (radiance:post-var "password")) + (confirm-password (radiance:post-var "confirm-password"))) + (if (and username password) + ;; Handle registration form submission + (cond + ;; Validate passwords match + ((not (string= password confirm-password)) + (format t "Failed to register new user '~a': passwords do not match.~%" username) + (clip:process-to-string + (load-template "register") + :title "Asteroid Radio - Register" + :display-error "display: block;" + :display-success "display: none;" + :error-message "Passwords do not match" + :success-message "")) -(define-page player #@"/player" () - (clip:process-to-string + ;; Check if username already exists + ((find-user-by-username username) + (format t "Failed to register new user '~a': Username already exists.~%" username) + (clip:process-to-string + (load-template "register") + :title "Asteroid Radio - Register" + :display-error "display: block;" + :display-success "display: none;" + :error-message "Username already exists" + :success-message "")) + + ;; Create the user + (t + (if (create-user username email password :role :listener :active t) + (progn + ;; Auto-login after successful registration + (let ((user (find-user-by-username username))) + (when user + (let ((user-id (dm:id user))) + (setf (session:field "user-id") user-id)))) + ;; Redirect new users to their profile page + (radiance:redirect "/asteroid/profile")) + (clip:process-to-string + (load-template "register") + :title "Asteroid Radio - Register" + :display-error "display: block;" + :display-success "display: none;" + :error-message "Registration failed. Please try again." + :success-message "")))) + ;; Show registration form (no POST data) + (clip:process-to-string + (load-template "register") + :title "Asteroid Radio - Register" + :display-error "display: none;" + :display-success "display: none;" + :error-message "" + :success-message "")))) + +(define-page-with-limit player #@"/player" (:limit-group "public") + (clip:process-to-string (load-template "player") :title "Asteroid Radio - Web Player" :stream-base-url *stream-base-url* @@ -1270,18 +1273,18 @@ :player-status "Stopped")) ;; Player content frame (for frameset mode) -(define-page player-content #@"/player-content" () +(define-page-with-limit player-content #@"/player-content" (:limit-group "public") "Player page content (displayed in content frame)" - (clip:process-to-string + (clip:process-to-string (load-template "player-content") :title "Asteroid Radio - Web Player" :stream-base-url *stream-base-url* :default-stream-url (format nil "~a/asteroid.aac" *stream-base-url*) :default-stream-encoding "audio/aac")) -(define-page popout-player #@"/popout-player" () +(define-page-with-limit popout-player #@"/popout-player" (:limit-group "public") "Pop-out player window" - (clip:process-to-string + (clip:process-to-string (load-template "popout-player") :stream-base-url *stream-base-url* :curated-channel-name (get-curated-channel-name) @@ -1289,27 +1292,27 @@ :default-stream-encoding "audio/aac")) ;; About page (non-frameset mode) -(define-page about-page #@"/about" () +(define-page-with-limit about-page #@"/about" (:limit-group "public") "About Asteroid Radio" - (clip:process-to-string + (clip:process-to-string (load-template "about") :title "About - Asteroid Radio")) ;; About content (for frameset mode) -(define-page about-content #@"/about-content" () +(define-page-with-limit about-content #@"/about-content" (:limit-group "public") "About page content (displayed in content frame)" - (clip:process-to-string + (clip:process-to-string (load-template "about-content") :title "About - Asteroid Radio")) ;; Status content (for frameset mode) -(define-page status-content #@"/status-content" () +(define-page-with-limit status-content #@"/status-content" (:limit-group "public") "Status page content (displayed in content frame)" - (clip:process-to-string + (clip:process-to-string (load-template "status-content") :title "Status - Asteroid Radio")) -(define-api asteroid/status () () +(define-api-with-limit asteroid/status () () "Get server status" (api-output `(("status" . "running") ("server" . "asteroid-radio") @@ -1323,23 +1326,23 @@ ("stream-status" . "live")))) ;; Live stream status from Icecast -(define-api asteroid/icecast-status () () +(define-api-with-limit asteroid/icecast-status () () "Get live status from Icecast server" (with-error-handling (let* ((icecast-url (format nil "~a/admin/stats.xml" *stream-base-url*)) - (response (drakma:http-request icecast-url - :want-stream nil - :basic-authorization '("admin" "asteroid_admin_2024")))) + (response (drakma:http-request icecast-url + :want-stream nil + :basic-authorization '("admin" "asteroid_admin_2024")))) (if response - (let ((xml-string (if (stringp response) - response + (let ((xml-string (if (stringp response) + response (babel:octets-to-string response :encoding :utf-8)))) ;; Simple XML parsing to extract source information ;; Look for sections and extract title, listeners, etc. (multiple-value-bind (match-start match-end) (cl-ppcre:scan "" xml-string) (if match-start - (let* ((source-section (subseq xml-string match-start + (let* ((source-section (subseq xml-string match-start (or (cl-ppcre:scan "" xml-string :start match-start) (length xml-string)))) (titlep (cl-ppcre:all-matches "" source-section)) @@ -1360,12 +1363,13 @@ ;;; Listener Statistics API Endpoints -(define-api asteroid/stats/current () () +(define-api-with-limit asteroid/stats/current () () "Get current listener count from recent snapshots" - (let ((listeners (get-current-listeners))) - (api-output `(("status" . "success") - ("listeners" . ,listeners) - ("timestamp" . ,(get-universal-time)))))) + (with-error-handling + (let ((listeners (get-current-listeners))) + (api-output `(("status" . "success") + ("listeners" . ,listeners) + ("timestamp" . ,(get-universal-time))))))) (define-api asteroid/stats/daily (&optional (days "30")) () "Get daily listener statistics (admin only)" diff --git a/auth-routes.lisp b/auth-routes.lisp index 0734465..c360274 100644 --- a/auth-routes.lisp +++ b/auth-routes.lisp @@ -4,7 +4,7 @@ (in-package :asteroid) ;; Login page (GET) -(define-page login #@"/login" () +(define-page-with-limit login #@"/login" () "User login page" (let ((username (radiance:post-var "username")) (password (radiance:post-var "password"))) diff --git a/frontend-partials.lisp b/frontend-partials.lisp index 86f35a9..4035e71 100644 --- a/frontend-partials.lisp +++ b/frontend-partials.lisp @@ -91,7 +91,7 @@ (:listeners . ,total-listeners) (:track-id . ,(find-track-by-title title)))))))) -(define-api asteroid/partial/now-playing (&optional mount) () +(define-api-with-limit asteroid/partial/now-playing (&optional mount) (:limit 3 :timeout 1) "Get Partial HTML with live status from Icecast server. Optional MOUNT parameter specifies which stream to get metadata from. Always polls both streams to keep recently played lists updated." @@ -121,7 +121,7 @@ :connection-error t :stats nil)))))) -(define-api asteroid/partial/now-playing-inline (&optional mount) () +(define-api-with-limit asteroid/partial/now-playing-inline (&optional mount) (:limit 3 :timeout 1) "Get inline text with now playing info (for admin dashboard and widgets). Optional MOUNT parameter specifies which stream to get metadata from." (with-error-handling @@ -135,7 +135,7 @@ (setf (header "Content-Type") "text/plain") "Stream Offline"))))) -(define-api asteroid/partial/now-playing-json (&optional mount) () +(define-api-with-limit asteroid/partial/now-playing-json (&optional mount) (:limit 2 :timeout 1) "Get JSON with now playing info including track ID for favorites. Optional MOUNT parameter specifies which stream to get metadata from." (with-error-handling @@ -153,7 +153,7 @@ ("title" . "Stream Offline") ("track_id" . nil))))))) -(define-api asteroid/channel-name () () +(define-api-with-limit asteroid/channel-name () (:limit 2 :timeout 1) "Get the current curated channel name for live updates. Returns JSON with the channel name from the current playlist's PHASE header." (with-error-handling diff --git a/limiter.lisp b/limiter.lisp new file mode 100644 index 0000000..84f79e1 --- /dev/null +++ b/limiter.lisp @@ -0,0 +1,56 @@ +;;;; limiter.lisp - Rate limiter definitions for the application + +(in-package :asteroid) + +(defun render-rate-limit-error-page() + (clip:process-to-string + (load-template "error") + :error-message "It seems that your acceleration has elevated your orbit out of your designated path." + :error-action "Please wait a moment for it to stabilize and try your request again.")) + +(defun api-limit-error-output () + (api-output `(("status" . "error") + ("message" . "It seems that your acceleration has elevated your orbit out of your designated path.")) + :message "It seems that your acceleration has elevated your orbit out of your designated path." + :status 429)) + +(defun extract-limit-options (options) + "Extracts the rate-limit options and forwards the reamaining radiance route options" + (let ((limit (getf options :limit)) + (timeout (getf options :timeout)) + (group (getf options :limit-group)) + (rest (loop for (k v) on options by #'cddr + unless (member k '(:limit :timeout :limit-group)) + append (list k v)))) + (values limit timeout group rest))) + + +(defmacro define-page-with-limit (name uri options &body body) + "Rate limit for a page route. Defaults to 30 requests per minute." + (multiple-value-bind (limit timeout group rest) (extract-limit-options options) + (let* ((limit-name (string-upcase (format nil "~a-route-limit" (or group name)))) + (limit-sym (intern limit-name)) + (limit (or limit 30)) + (timeout (or timeout 60))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (rate:define-limit ,limit-sym (time-left :limit ,limit :timeout ,timeout) + ;; (format t "Route limit '~a' hit. Wait ~a seconds and retry.~%" ,(string name) time-left) + (render-rate-limit-error-page)) + (define-page ,name ,uri ,rest + (rate:with-limitation (,limit-sym) + ,@body)))))) + +(defmacro define-api-with-limit (name args options &body body) + "Rate limit for api routes. Defaults to 60 requests per minute." + (multiple-value-bind (limit timeout group rest) (extract-limit-options options) + (let* ((limit-name (string-upcase (format nil "~a-api-limit" (or group name)))) + (limit-sym (intern limit-name)) + (limit (or limit 60)) + (timeout (or timeout 60))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (rate:define-limit ,limit-sym (time-left :limit ,limit :timeout ,timeout) + ;; (format t "API Rate limit '~a' hit. Wait ~a seconds and retry.~%" ,(string name) time-left) + (api-limit-error-output)) + (define-api ,name ,args ,rest + (rate:with-limitation (,limit-sym) + ,@body)))))) diff --git a/stream-media.lisp b/stream-media.lisp index 5486f56..ecb7cf2 100644 --- a/stream-media.lisp +++ b/stream-media.lisp @@ -135,6 +135,7 @@ ;; Simple file copy endpoint for manual uploads (define-page copy-files #@"/admin/copy-files" () "Copy files from incoming directory to library" + (require-role :admin) (handler-case (let ((incoming-dir (merge-pathnames "music/incoming/" (asdf:system-source-directory :asteroid))) diff --git a/template/error.ctml b/template/error.ctml new file mode 100644 index 0000000..3907fc4 --- /dev/null +++ b/template/error.ctml @@ -0,0 +1,57 @@ +<!DOCTYPE html> +<html lang="en"> +<head> + <title>Error - Asteroid Radio + + + + + + + + +
+
+

+ Asteroid + ASTEROID RADIO + Asteroid +

+ +
+
+
+

+ + + + + + ⚠️ Something went wrong with your request! + + +

+

+ + + + + + We seem to be unable to process your request right now. + + +

+ + +

+ + +
+
+
+ +