diff options
Diffstat (limited to 'vampire.lisp')
| -rw-r--r-- | vampire.lisp | 326 |
1 files changed, 35 insertions, 291 deletions
diff --git a/vampire.lisp b/vampire.lisp index 57e474f..8ca4b79 100644 --- a/vampire.lisp +++ b/vampire.lisp @@ -19,25 +19,6 @@ ;;; RESOURCE MODEL -(defclass/bknr keyed () - ((key - :r :std (nuid) - :index-type string-unique-index - :index-reader object-with-key))) - -(defclass/bknr playlist (keyed) - ((title :with :std (default-name "playlist")) - (tracks editors :with :std (list)) - (cover-image :with :std nil :doc "A url to the cover of this album.") - (user :with - :std (error "A USER is required to have created the content.")))) - -(defmethod initialize-instance :after ((pl playlist) &key) - (pushnew pl (user-playlists (playlist-user pl)) :test #'eq)) - -(defclass/bknr track (keyed) - ((source file title artist album thumb-url duration codec :with) - (playlists :with :std (list) :doc "A list of playlists in which this track appears"))) (defclass/bknr user (keyed) ((name :with :std "") @@ -46,43 +27,18 @@ ;;; RESOURCE ACCESS OPERATIONS -(defun playlist-duration (pl) - (reduce #'+ - (playlist-tracks pl) - :key 'track-duration - :initial-value 0)) - -(defun add-track (tr pl &optional (n -1)) - (setf (playlist-tracks pl) - (insert-nth tr n (playlist-tracks pl)))) - -(defun remove-nth-from-playlist (pl n) - (multiple-value-bind (newlist track) - (remove-nth n (playlist-tracks pl) t) - (setf (playlist-tracks pl) newlist - (track-playlists track) (delete pl (track-playlists track) - :test #'eq :count 1)))) ;;; TRANSACTIONS -(defun append-track (pl tr) - (with-transaction () - (add-track tr pl))) + (defun new-user (&key name) (with-transaction () (make-instance 'user :name name))) -(defun new-playlist (user &key title) - (with-transaction () - (make-instance 'playlist :title title :user user))) -(defun new-track (file trackinfo) - "Trackinfo is a plist containing information about the track to create." - (with-transaction () - (let ((track (apply #'make-instance 'track trackinfo))) - (setf (track-file track) (namestring file)) - track))) + + ;;; CLIENT @@ -146,251 +102,39 @@ (princ title out)))) -;;; PLAYLIST CONTROL - -(defclass/std playlist/ctl () - ((playlist track-list track-display audio->track now-playing :std nil))) - -(defmethod (setf now-playing) :before (newval ctl) - (with-slots (now-playing) ctl - (when now-playing - (remove-class (parent-element now-playing) "now-playing"))) - (when newval - (add-class (parent-element newval) "now-playing"))) - -(defclass/std track-display () - ((title-elem - thumb-elem - artist-elem - time-elem - duration-elem - play/pause-btn))) - -(defun get-audio-track (ctl audio) - (cdr (assoc audio (audio->track ctl)))) - -(defun get-next-audio-track (ctl &optional audio) - (with-slots (audio->track) ctl - (if (null audio) - (first audio->track) - (let ((pos - (position audio audio->track :key #'car))) - (assert pos () "Audio element ~a not found in this playlist control." audio) - (nth (1+ pos) audio->track))))) - -(defun stop-playback (ctl) - (with-slots (now-playing) ctl - (when now-playing - (pause-media now-playing) - (setf (media-position now-playing) 0 - now-playing nil - (text (play/pause-btn (track-display ctl))) "⏵")))) - -(defun pause-playback (ctl) - (when-let (audio (now-playing ctl)) - (pause-media audio) - (setf (text (play/pause-btn (track-display ctl))) "⏵"))) - -(defun start-playback (ctl) - (when-let (audio (now-playing ctl)) - (play-media audio) - (setf (text (play/pause-btn (track-display ctl))) - "⏸"))) - -(defun load-track-display (ctl) - (when-let (track (get-audio-track ctl (now-playing ctl))) - (with-slots - (title-elem thumb-elem artist-elem - time-elem duration-elem) - (track-display ctl) - (with-slots (title artist thumb-url duration) track - (setf (text title-elem) title - (text duration-elem) (secs-to-hms duration) - (text time-elem) (secs-to-hms 0) - (url-src thumb-elem) thumb-url))))) - -(defun initialize-playlist/ctl (body) - (let ((ctl (playlist/ctl body))) - (setf now-playing (car (first (audio->track ctl)))) - (load-track-display ctl))) - -(defun playlist/ctl (obj) - (connection-data-item obj "playlist/ctl")) - -(defun install-playlist/ctl (playlist obj) - (setf (connection-data-item obj "playlist/ctl") - (make-instance 'playlist/ctl :playlist playlist))) - -(defun install-track-list (list) - (let ((ctl (playlist/ctl list))) - (setf (track-list ctl) list))) - -(defun install-track-display (thumb title artist time dur play/pause) - (let ((ctl (playlist/ctl thumb))) - (setf (track-display ctl) - (make-instance 'track-display - :duration-elem dur - :time-elem time - :artist-elem artist - :thumb-elem thumb - :title-elem title - :play/pause-btn play/pause)))) - -(defun install-audio-track (audio track &optional (position -1)) - (when-let (ctl (playlist/ctl audio)) - (setf (audio->track ctl) - (insert-nth (cons audio track) position (audio->track ctl))))) - -(defun ctl/now-playing (elem) - (when-let (ctl (playlist/ctl elem)) - (now-playing ctl))) - -(defun ctl/pause (elem) - (when-let (ctl (playlist/ctl elem)) - (pause-playback ctl))) - -(defun ctl/stop (elem) - (when-let (ctl (playlist/ctl elem)) - (stop-playback ctl))) - -(defun ctl/play-audio (audio) - (when-let (ctl (playlist/ctl audio)) - (unless (eq audio (now-playing ctl)) - (stop-playback ctl) - (setf (now-playing ctl) audio) - (start-playback ctl) - (load-track-display ctl)))) - -(defun ctl/toggle-play (elem) - (when-let (ctl (playlist/ctl elem)) - (if (now-playing ctl) - (if (pausedp (now-playing ctl)) - (start-playback ctl) - (pause-playback ctl)) - (ctl/next-track elem)))) - -(defun ctl/next-track (elem) - (when-let (ctl (playlist/ctl elem)) - (let ((next - (get-next-audio-track ctl (now-playing ctl)))) - (stop-playback ctl) - (when next - (setf (now-playing ctl) (car next)) - (start-playback ctl) - (load-track-display ctl))))) - -(defun ctl/update-playback-time (audio) - (when-let (ctl (playlist/ctl audio)) - (setf (text (time-elem (track-display ctl))) - (secs-to-hms (media-position audio))))) - -(defun create-track-list-item (parent track) - (with-clog-create parent - (div (:bind view) - (p () - (span (:content (track-listing-line track))) - (span (:content " -- ")) - (span (:content (secs-to-hms (or (track-duration track) 0))))) - (audio (:source (media-url-path track) :controls nil :bind audio))) - (install-audio-track audio track) - (set-on-time-update - audio - 'ctl/update-playback-time) - (set-on-ended - audio - (alambda (ctl/next-track audio))) - (set-on-click - view - (alambda - (ctl/play-audio audio))))) +;; (defun create-track-form (parent playlist &rest args) +;; (declare (ignorable args)) +;; (with-clog-create parent +;; (div () +;; (section (:h3 :content "Add Track")) +;; (label (:content "Paste URL: " :bind url-label)) +;; (form-element (:text :bind url-input)) +;; (button (:content "Fetch Track" :bind submit-button)) +;; (div (:bind notice-area))) +;; (label-for url-label url-input) +;; (setf (place-holder url-input) "https://www.youtube.com/watch?v=dQw4w9WgXcQ") +;; (set-on-click +;; submit-button +;; (alambda +;; (let* ((url +;; (value url-input)) +;; (notice +;; (create-p notice-area :content (format nil "... Fetching ~a" url)))) +;; (setf (value url-input) "") +;; (add-fetch-track-job +;; url +;; (lambda (track) +;; (remove-from-dom notice) +;; (append-track playlist track) +;; (add-track-to-listing parent track)) +;; (lambda (err) +;; (remove-from-dom notice) +;; (format t "Error: ~a~%" err) +;; (alert (window (connection-body parent)) +;; (format nil "Error while fetching track at: ~a~%" +;; url))))))))) + -(defun create-track-listing (parent playlist &rest args) - (declare (ignorable args)) - (let ((list (create-ordered-list parent))) - (install-track-list list) - (dolist (track (playlist-tracks playlist)) - (with-clog-create list - (list-item () - (track-list-item (track))))))) - -(defun add-track-to-listing (elem track) - (with-slots (track-list) (playlist/ctl elem) - (with-clog-create track-list - (list-item () - (track-list-item (track)))))) - -(defun create-track-form (parent playlist &rest args) - (declare (ignorable args)) - (with-clog-create parent - (div () - (section (:h3 :content "Add Track")) - (label (:content "Paste URL: " :bind url-label)) - (form-element (:text :bind url-input)) - (button (:content "Fetch Track" :bind submit-button)) - (div (:bind notice-area))) - (label-for url-label url-input) - (setf (place-holder url-input) "https://www.youtube.com/watch?v=dQw4w9WgXcQ") - (set-on-click - submit-button - (alambda - (let* ((url - (value url-input)) - (notice - (create-p notice-area :content (format nil "... Fetching ~a" url)))) - (setf (value url-input) "") - (add-fetch-track-job - url - (lambda (track) - (remove-from-dom notice) - (append-track playlist track) - (add-track-to-listing parent track)) - (lambda (err) - (remove-from-dom notice) - (format t "Error: ~a~%" err) - (alert (window (connection-body parent)) - (format nil "Error while fetching track at: ~a~%" - url))))))))) - -(defun playlist-key-from-url (url) - (first (last (ppcre:split "/" (nth 4 (multiple-value-list (quri:parse-uri url))))))) - -(defun create-track-display (obj) - (with-clog-create obj - (div () - (section (:h3 :content "Now Playing")) - (img (:bind thumb-elem)) - (p (:bind title-elem)) - (p (:bind artist-elem :hidden t)) - (p () - (span (:bind time-elem)) - (span (:content "/")) - (span (:bind duration-elem))) - (button (:bind stop-button :content "⏹")) - (button (:bind next-button :content "⏭")) - (button (:bind pause/play-button :content "⏵"))) - (setf (height thumb-elem) 120) - (set-on-click stop-button 'ctl/stop) - (set-on-click next-button 'ctl/next-track) - (set-on-click - pause/play-button - #'ctl/toggle-play) - (install-track-display thumb-elem title-elem artist-elem time-elem duration-elem - pause/play-button))) - -(defun playlist-page (body) - (when-let* ((listid - (playlist-key-from-url (url (location body)))) - (playlist - (object-with-key listid))) - (install-playlist/ctl playlist body) - (with-clog-create body - (div () - (section (:h2 :content (format nil "~a -- ~a" - (playlist-title playlist) - (secs-to-hms (playlist-duration playlist))))) - (track-display ()) - (div () (track-listing (playlist))) - (track-form (playlist)))))) (defun user-page (body) (if-let (user (session-user body)) |