path: root/vampire.lisp

;;;; vampire.lisp

(in-package #:vampire)

;;; SYSTEM CONFIG COMPONENT

(defvar *config* nil)

(defclass/std config ()
  ((datastore-directory :ir :std #P"/srv/parasite/store/")
   (static-directory :ir :std #P"/srv/parasite/static/")
   (port :ir :std 4919)
   (downloader-threads :ir :std 5)))

(defun config-from-file (path)
  "PATH should be a path to a file containing a PLIST suitable for
   passing as the keyword arguments to (MAKE-INSTANCE 'CONFIG ...)"
  (apply #'make-instance 'config (read-from-file path)))

;;; 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 "")
   (playlists :with :std (list))
   (pw pwhash :with)))

;;; 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

(defparameter +user-key+ "vampire.userkey")

(defun user-key (window)
  (jonathan:parse (storage-element window :local +user-key+)))

(defun (setf user-key) (val window)
  (setf (storage-element window :local +user-key+) (jonathan:to-json val)))

(defun session-user (clog-obj)
  (object-with-key (user-key (window (connection-body clog-obj)))))

(defun create-new-playlist-form (parent &rest args)
  (declare (ignorable args))
  (with-clog-create parent
      (div ()
           (section (:h2 :content "Create New Playlist"))
           (label (:content "Playlist Title:"))
           (form-element (:text :bind pl-title))
           (button (:content "Create" :bind btn)))
    (set-on-click
     btn
     (alambda
       (new-playlist (session-user parent) :title (value pl-title))
       (reload (location (connection-body parent)))))))

(defun url-to-playlist (pl location)
  (format nil "~a//~a/playlist/~a"
          (protocol location)
          (host location)
          (key pl)))

(defun create-playlist-listing (parent &rest args)
  (declare (ignorable args))
  (dolist (pl (user-playlists (session-user parent)))
    (let ((url
            (url-to-playlist pl (location (connection-body parent)))))
      (with-clog-create parent
          (div ()
               (section (:h4)
                        (a (:link url :content (playlist-title pl) :bind pl-link))))
        (set-on-click
         pl-link
         (alambda
           (setf (url (location (connection-body parent)))
                 url)))))))

(defun media-url-path (track)
  (format nil "/media/~a.~a"
          (pathname-name (track-file track))
          (pathname-type (track-file track))))

(defun track-listing-line (track)
  (with-slots (artist title) track
    (with-output-to-string (out)
      (when artist
        (princ artist out)
        (princ " - " out))
      (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-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)) 
    (with-clog-create body
        (div ()
             (p (:content (format nil "Welcome ~a" (user-name user))))
             (new-playlist-form ())
             (playlist-listing ())))
    (setf (url (location body)) "/")))

(defun login-page (body)
  (with-clog-create body
      (div ()
           (p (:content "LOGIN"))
           (form-element (:text :bind name))
           (button (:bind btn :content "Click here to log in")))
    (set-on-click
     btn
     (lambda (obj)
       (declare (ignore obj))
       (let ((u (new-user :name (value name))))
         (setf (user-key (window body)) (key u))
         (setf (url (location body)) "/"))))))

(defun main (body)
  (if (session-user body)
      (setf (url (location body)) "/user")
      (setf (url (location body)) "/login")))

;;; STARTUP

(defun initialize-database (config)
  (ensure-directories-exist (datastore-directory config))
  (make-instance
   'bknr.datastore:mp-store
   :directory (datastore-directory config)
   :subsystems (list (make-instance 'bknr.datastore:store-object-subsystem))))

(defun start (config)
  (setf *config* config)
  (initialize-database config )
  (start-downloader-service config)
  (initialize 'main
              :extended-routing t
              :static-root (static-directory config))
  (set-on-new-window 'user-page :path "/user")
  (set-on-new-window 'login-page :path "/login")
  (set-on-new-window 'playlist-page :path "/playlist")
  (open-browser))

(defun hacking-start ()
  (start (make-instance
          'config
          :static-directory (merge-pathnames "vampire-static/" (user-homedir-pathname))
          :datastore-directory (merge-pathnames "vampire-store/" (user-homedir-pathname)))))