;;;; 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?list=~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)))) (create-audio ) (defun create-track-listing (parent playlist &rest args) (declare (ignorable args)) (dolist (track (playlist-tracks playlist)) (with-clog-create parent (div (:bind view) (section (:h4 :content (track-title track))) (img (:bind thumb)) (audio (:source (media-url-path track) :controls nil :bind audio))) (set-on-click view (alambda (play-media audio))) (if (track-thumb-url track) (setf (url-src thumb) (track-thumb-url track) (height thumb) "100px"))))) (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) (append-track playlist track) (reload (location (connection-body parent)))) (lambda (err) (remove-from-dom notice) (format t "Error: ~a~%" err) (alert (window (connection-body parent)) (format nil "Error whiel fetching track at: ~a~%" url))))))))) (defun playlist-page (body) (when-let* ((listid (form-data-item (form-get-data body) "list")) (playlist (object-with-key listid))) (with-clog-create body (div () (section (:h2 :content (playlist-title playlist))) (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)))))