From b68cf6250233f54886210f917bb26de414de818d Mon Sep 17 00:00:00 2001 From: colin Date: Sun, 26 Nov 2023 09:31:45 -0800 Subject: hackityhackityhackity --- src/config.lisp | 25 ++- src/downloader.lisp | 14 +- src/parenscript.lisp | 571 +++++++++++++++++++++++++++++++++++++++++++++++++++ src/session.lisp | 16 -- src/site.lisp | 211 +++++++++---------- src/vampire.lisp | 64 +++--- vampire.asd | 4 +- 7 files changed, 736 insertions(+), 169 deletions(-) create mode 100644 src/parenscript.lisp delete mode 100644 src/session.lisp diff --git a/src/config.lisp b/src/config.lisp index 5bdd4e8..33e294e 100644 --- a/src/config.lisp +++ b/src/config.lisp @@ -1,4 +1,3 @@ - (defpackage #:vampire.config (:use #:cl) (:import-from #:defclass-std #:defclass/std) @@ -8,21 +7,24 @@ #:swank-port* #:host* #:port* - #:downloader-threads*)) + #:downloader-threads* + #:yt-dlp* + #:use)) (in-package #:vampire.config) (defvar *config* nil) +(defun use (c) (setf *config* c)) + (defclass/std config () ((datastore-directory :ir :std #P"/srv/vampire/store/") (static-directory :ir :std #P"/srv/vampire/static/") (swank-port :std nil :doc "If set, swank is started on this port.") (host :std "0.0.0.0") - (port :ir :std 4919) + (port :ir :std 8989) (downloader-threads :ir :std 5) - (yt-dlp-path :std ())) - ) + (yt-dlp :std nil))) (defun static-directory* (&optional (config *config*)) (static-directory config)) @@ -38,3 +40,16 @@ (defun port* (&optional (config *config*)) (port config)) + +(defun downloader-threads* (&optional (config *config*)) + (downloader-threads config)) + +(defun yt-dlp* (&optional (config *config*)) + (yt-dlp config)) + +(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))) + + diff --git a/src/downloader.lisp b/src/downloader.lisp index 1e08ac6..7649103 100644 --- a/src/downloader.lisp +++ b/src/downloader.lisp @@ -13,12 +13,12 @@ (defvar *dl-cluster*) (defvar *media-directory*) -(defun start (config) +(defun start () (let ((media-dir - (merge-pathnames "media/" (static-directory config)))) + (merge-pathnames "media/" (config:static-directory*)))) (ensure-directories-exist media-dir) (setf *dl-cluster* (legion:make-cluster - (downloader-threads config) + (config:downloader-threads*) (lambda (job) (funcall job media-dir))))) (legion:start *dl-cluster*)) @@ -66,6 +66,10 @@ :duration dur :thumb-url url)))) +(defun find-downloader-tool () + (or (config:yt-dlp*) + (uiop:run-program "which yt-dlp" :output :string))) + (defun download-media (url media-dir) "Download media and create a new track from its audio source, moving the raw audio to the media-dir when done." @@ -75,8 +79,8 @@ (trackinfo-file (trackinfo-file tmpdir tmpname))) (uiop:run-program - (format nil "youtube-dl --format-sort aext --prefer-free-formats --playlist-end 1 --write-info-json -x -o \"~a/~a.%(ext)s\" '~a'" - tmpdir tmpname url)) + (format nil "~a --format-sort aext --prefer-free-formats --playlist-end 1 --write-info-json -x -o \"~a/~a.%(ext)s\" '~a'" + (find-downloader-tool) tmpdir tmpname url)) (let* ((info (trackinfo trackinfo-file)) (downloaded diff --git a/src/parenscript.lisp b/src/parenscript.lisp new file mode 100644 index 0000000..2fe098b --- /dev/null +++ b/src/parenscript.lisp @@ -0,0 +1,571 @@ +(defpackage #:vampire.parenscript + (:use #:cl #:parenscript) + (:local-nicknames (#:a #:alexandria-2)) + (:export + ;; convenience parenscript macros + #:@> + #:{} + #:let-slots + #:with-methods + #:with-object + + ;; data definition + #:defstruct + #:setf+ + #:defmethod + + ;; modularity macros + #:defmodule + #:export + #:export-struct + #:import-from + #:import-struct-from)) + +(in-package #:vampire.parenscript) + +(defun setf-name-of (name) + (read-from-string (format nil "__setf_~a" name))) + +;; NB: The following macro exists b/c ps:{} wasn't working for some reason +(defpsmacro {} (&rest args) + "A convenience macro for building object literals." + `(ps:create ,@args)) + +(defpsmacro @. (&rest args) + "A convenience macro aliasing ps:chain." + `(ps:chain ,@args)) + +(defpsmacro setf+ (place val) + (if (consp place) + (destructuring-bind (accessor object) place + `(,(setf-name-of accessor) ,val ,object)) + `(setf ,place ,val))) + + +(defpsmacro let-slots (slot-specs &rest body) + (if (consp slot-specs) + `(with-slots ,(caar slot-specs) ,(cadar slot-specs) + (let-slots ,(cdr slot-specs) ,@body)) + `(progn ,@body))) + + +(defpsmacro with-methods (methods object &rest body) + (let ((args (gensym "ARGS"))) + `(labels ,(mapcar #'(lambda (method) + `(,method (&rest ,args) + (apply (getprop ,object ',method) ,args))) + methods) + ,@body))) + +(defpsmacro with-object (object slots methods &rest body) + "A convenience macro that combines with-slots and with-methods a single call. +It departs from the ordinary calling order by putting the expression that +evaluates to the object first. + E.g. + +(with-object (@. gonna make a (cool-thing 1 2 3)) (slot1 slot2) (method1 method2) + .... do stuff) +" + `(let ((object ,object)) + (with-slots ,slots object + (with-methods ,methods object + ,@body)))) + +(defun constructor-name-of (name) (read-from-string (format nil "make-~a" name))) +(defun accessor-name-for (name slot) (read-from-string (format nil "~a-~a" name slot))) +(defun getf-accessor-name-for (name slot) + (read-from-string (format nil "__setf_~a-~a" name slot))) + +(defpsmacro defstruct (name &rest slots) + (let ((constructor + (a:symbolicate "-" name "-struct")) + (constructor-body + (cons 'ps:setf + (loop :for slot :in slots + :for slot-name := (if (consp slot) (first slot) slot) + :append `((@ this ,slot-name) ,slot-name))))) + `(progn + (defun ,constructor (&key ,@slots) + ,constructor-body + null)))) + +(defpsmacro defelems (&rest names) + "Used to define virtual DOM elements constructors en masse." + (unless (null names) + `(progn + (defun ,(car names) (props &rest children) + (elem ,(string-downcase (symbol-name (car names))) props children)) + (defelems ,@(cdr names))))) + + +(defpsmacro defmodule (name &rest body) + "Defines a unit of code, meant to encapsulate hidden state and functions. NAME +can be either a symbol or a list of symbols. In the latter case, the list +represents a module path to the module being defined." + (cond + ((symbolp name) + `(defvar ,name + ((lambda () + (let ((*exports* ({}))) + (progn ,@body) + *exports*))))) + + ((listp name) + `(setf (@ ,@name) + ((lambda () + (let ((*exports* ({}))) + (progn ,@body) + *exports*))))))) + + +(defpsmacro export (&rest names) + "To be called within the body a DEFMODULE. Exports NAMES from the containing +module. If a name is a SETF DEFUN, it will export the SETF version as well." + (let* ((name-exports + (loop for name in names collect + `(setf (@ *exports* ,name) ,name))) + (setf-names + (loop for name in names + collect (setf-name-of name))) + (setf-name-exports + (loop for name in setf-names + collect `(when (equal "function" (typeof ,name)) + (setf (@ *exports* ,name) ,name))))) + `(progn + ,@(nconc name-exports setf-name-exports)))) + + +(defpsmacro import-from (module-name &rest symbs) + "To be called from within the body of DEFMODULE. Imports names into the +current module. Each member of SYMBS can be either a symbol or a pair of +symbols. In the case of the example pair (EXTERNAL LOCAL) the EXTERNAL symbol +is bound to the LOCAL symbol. This lets you avoid name conflicts." + (let* ((imports + (mapcar + (lambda (s) + (let* ((local (if (symbolp s) s (cadr s))) + (foreign (if (symbolp s) s (car s)))) + (if (symbolp module-name) + `(progn + (defvar ,local (@ ,module-name ,foreign)) + (defvar ,(setf-name-of local) + (@ ,module-name ,(setf-name-of foreign)))) + `(progn + (defvar ,local (@ ,@(append module-name (list foreign)))) + (defvar ,(setf-name-of local) + (@ ,@(append module-name (list (setf-name-of foreign))))))))) + symbs))) + `(progn ,@imports))) + + + +(defvar *slummer-ps-lib* + '(progn + +;;; The core virtual DOM type and some utility functions + (defmodule *slummer* + + + (defun elem (tag &optional (properties ({})) (children ([]))) + "TAG is an html tag, PROPS is an object and CHILDREN is an array of elements + The whole structure represents a DOM tree fragment." + ({} tag tag + properties properties + ;; if children are not elems they are implicitly converted to strings + children (mapcar (lambda (child) + (if (not (@ child tag)) + (+ "" child) + child)) + children))) + + (defun elem-prop (el prop) + "A handy function to retrieve the property named PROP from the PROPERTIES +field of EL." + (getprop el 'properties prop)) + + (defun elems-diff? (el1 el2) + "Returns T if EL1 and EL2 are different enough to require re-rendering." + (or (not (equal (typeof el1) (typeof el2))) + (and (stringp el1) (not (equal el1 el2))) + (not (equal (@ el1 tag) (@ el2 tag))))) + + +;;; Checking Virtual DOM state and chainging the real DOM. + + (defun event-property? (prop) + "Returns T if PROP is the name of an event handler property. +E.g. 'onclick' or 'onkeydown'." + (chain prop (starts-with "on"))) + + (defun property->event (prop) + "Turns an event property name PROP into an event name. +E.g. (property->event :onclick) should return 'click'. Parenscript doesn't seem +to distinguish between keywords and strings." + (chain prop (slice 2))) + + (defun remove-property (node prop value) + "NODE is a real DOM element, PROP and VALUE are what is being removed." + (cond ((booleanp value) + (chain node (remove-attribute prop)) + (setf (getprop node prop) false)) + ((functionp value) + (chain node (remove-event-listener (property->event prop) value))) + (t + (chain node (remove-attribute prop))))) + + (defun realize-property (node prop value) + "NODE is a real DOM element, and PROP and VALUE are being added." + (cond ((event-property? prop) + (chain node (add-event-listener (property->event prop) value))) + ((booleanp value) + (when value (chain node (set-attribute prop value))) + (setf (getprop node prop) value)) + (t + (chain node (set-attribute prop value))))) + + ;; TODO figure out a good way to compare lambda values + (defun update-property (node prop old-val new-val) + "Handles changes in PROP's value on the real DOM element NODE." + (if (not new-val) + (remove-property node prop old-val) + (when (not (equal old-val new-val)) + (realize-property node prop new-val)))) + + (defun keys-for (&rest objects) + "A utility function for combining the keys of OBJECTS and returning them as +an array." + (let ((index ({})) + (keys (list))) + (dolist (ob objects) + (for-in (key ob) + (unless (getprop index key) + (setf (getprop index key) t) + (chain keys (push key))))) + keys)) + + + (defun realize-elem (el) + "The main DOM node builder. Takes an ELEM called El and returns a new DOM +node." + (if (stringp el) + (chain document (create-text-node el)) + (let ((new-node (chain document (create-element (@ el tag))))) + (for-in (prop (@ el properties)) + (realize-property new-node prop (elem-prop el prop))) + (dolist (child (@ el children)) + (chain new-node (append-child (realize-elem child)))) + new-node))) + + + (defun update-properties (node old-props new-props) + (dolist (prop (keys-for old-props new-props)) + (update-property node + prop + (getprop old-props prop) + (getprop new-props prop)))) + + + (defun update-elem (parent-node old-elem new-elem &optional (child-index 0)) + + (let ((child-node (getprop parent-node 'child-nodes child-index))) + (cond ((not old-elem) + ;; if there is no old element we just append a new one + (chain parent-node (append-child (realize-elem new-elem)))) + + ((not new-elem) + ;; if there is no new element we remove the node from the DOM + (chain parent-node (remove-child child-node))) + + ((elems-diff? new-elem old-elem) + ;; if the elements differ, we replace the child-node with fresh node + (chain parent-node + (replace-child (realize-elem new-elem) child-node))) + + ((not (stringp new-elem)) ; if we have a non-string node + ;; first we update the child node's properties + (update-properties child-node + (@ old-elem properties) + (@ new-elem properties)) + ;; then we recursively update the child node's own children + (let* ((new-length (@ new-elem children length)) + (old-length (@ old-elem children length)) + + (max-len (max new-length old-length))) + (dotimes (idx max-len) + (update-elem child-node + (getprop old-elem 'children (- max-len 1 idx)) + (getprop new-elem 'children (- max-len 1 idx)) + (- max-len 1 idx)))))))) + + + (defun query (arg) + "Query the DOM. If the query is in CSS id attribute notation, then a single +element is returned, otherwise an array of matches is returned." + (if (equal (elt arg 0) "#") + (@. document (query-selector arg)) + (@. -Array (from (@. document (query-selector-all arg)))))) + + (defun on (ob evt handler) + (let ((ob (if (stringp ob) (query ob) ob))) + (@. ob (add-event-listener evt handler)))) + + (defun attach-view (view attachment) + (setf (@. view attachment) + (if (stringp attachment) + (@. document (get-element-by-id attachment)) + attachment)) + (render-view view)) + + (defun render-view (view) + (let ((new-virtual (@. view (render)))) + (update-elem (@. view attachment) (@. view virtual) new-virtual) + (setf (@. view virtual) new-virtual))) + + (export elem render-view attach-view on query)) ; end defmodule *slummer* + + +;;; HTML builders for virtual DOM elements +;;; see https://developer.mozilla.org/en-US/docs/Web/HTML/Element + (defmodule (*slummer* *html*) + + (import-from *slummer* elem) + + (defelems + footer header h1 h2 h3 h4 h5 h6 nav section) + + ;; text content + (defelems + blockquote dd div dl dt figcaption figure hr li ol p pre ul) + + ;; inline text semantics + (defelems + a b br code em i q s small span strong sub sup time ) + + ;; multimedia + (defelems + audio img track video) + + ;; canvas + (defelems canvas) + + ;; forms + (defelems + button datalist fieldset form input label legend meter + optgroup option select textarea) + + (export + footer header h1 h2 h3 h4 h5 h6 nav section + blockquote dd div dl dt figcaption figure hr li ol p pre ul + a b br code em i q s small span strong sub sup time + audio img track video + canvas + button datalist fieldset form input label legend meter + optgroup option select textarea ) + +;;; Some Handy Utilities + + (defun list->ul (props ls &optional map-fn) + "Takes a PROPS object and a LS and produces a UL element. Optionally, +accepts a MAP-FN argument that should turn the members of LS into ELEMs" + (if (not map-fn) + (elem "ul" props ls) + (elem "ul" props (mapcar map-fn ls)))) + + (defun list->ol (props ls &optional map-fn) + (if (not map-fn) + (elem "ol" props ls) + (elem "ol" props (mapcar map-fn ls)))) + + + (export list->ul list->ol)) ; ends SLUMMER.HTML + + +;;; Odds and ends - Utilities. + (defmodule (*slummer* *util*) + "utility library" + (defun ->string (arg) + (+ "" arg)) + + (defun cons (x xs) + "XS is assumed to be a javascript array" + (@. xs (unshift x)) + xs) + + (defun list (&rest args) + args) + + (export ->string cons list)) ; end of SLUMMER.UTIL + +;;; Creating and selecting random values. + (defmodule (*slummer* *random*) + "Random operations" + + (defun pick (ary) + (elt ary (random (length ary)))) + + (defun pick-pop (ary) + (let* ((idx (random (length ary))) + (val (elt ary idx))) + (@. ary (slice idx 1)) + val)) + + (defun rand (&optional lo hi) + (cond ((not lo) (random)) + ((not hi) (random lo)) + (true + (+ lo (random (- hi lo)))))) + + (export pick pick-pop rand)) ; end of SLUMMER.RANDOM + + +;;; JSON Serialization + (defmodule (*slummer* *json*) + + (defun ->json (ob) + (@. *json* (stringify ob))) + + (defun parse (str) + (@. *json* (parse str))) + + (export ->json parse)) ; end of SLUMMER.JSON + + +;;; Basic graphics utilities + (defmodule (*slummer* *graphics*) + + (defstruct color (red 0) (green 0) (blue 0) (alpha 1.0)) + + (defun random-color () + (make-color :red (random 256) + :green (random 256) + :blue (random 256))) + + (defun color->string (color) + (with-slots (red blue green alpha) color + (+ "rgba(" red "," green "," blue "," alpha ")"))) + + + (export random-color color->string + make-color color-red color-green color-blue color-alpha)) ; end of SLUMMER.GRAPHICS + + + ;; Working with html5 canvas as a drawing surface, low level + (defmodule (*slummer* *graphics* *surface*) + "Canvas primitives" + + (defstruct surface context canvas) + + (defun new-surface (&optional dom-elem) + (let ((canvas + (cond ((null dom-elem) (@. document (create-element "canvas"))) + ((stringp dom-elem) (@. *slummer* (query dom-elem))) + (t from-dom)))) + (let ((surface (make-surface :canvas canvas + :context (@. canvas (get-context "2d"))))) + (disable-image-smoothing surface) + surface))) + + (macrolet + ((defaccessors (&rest specs) + (let ((expanded + (mapcan (lambda (spec) + (destructuring-bind (prop sub-prop) spec + (let ((dname (read-from-string (format nil "surface-~a" sub-prop)))) + (list + `(defun ,dname (surface) + (@. surface ,prop ,sub-prop)) + `(defun (setf ,dname) (newval surface) + (setf (@. surface ,prop ,sub-prop) newval)) + `(export ,dname))))) + specs))) + `(progn ,@expanded)))) + (defaccessors + (canvas height) + (canvas width) + (context fill-style) + (context line-style) + (context line-width) + (context line-cap) + (context line-join) + (context miter-limit) + (context font) + (context text-align) + (context text-baseline) + (context direction))) + + (macrolet + ((ctx-proxy (&rest names) + (cons 'progn + (mapcan (lambda (name) + (list `(defun ,name (surface &rest args) + (apply (ps:@ surface context ,name) args)) + `(export ,name))) + names)))) + (ctx-proxy fill-rect stroke-rect clear-rect + begin-path close-path stroke fill + move-to line-to arc arc-to + quadratic-curve-to bezier-curve-to + fill-text stroke-text + draw-image + save restore + translate rotate scale)) + + (defun disable-image-smoothing (surface) + (setf (@. surface context image-smoothing-enabled) false) + (setf (@. surface context moz-image-smoothing-enabled) false) + (setf (@. surface context webkit-image-smoothing-enabled) false) + (setf (@. surface context ms-image-smoothing-enabled) false)) + + (defun enable-image-smoothing (surface) + (setf (@. surface context image-smoothing-enabled) true) + (setf (@. surface context moz-image-smoothing-enabled) true) + (setf (@. surface context webkit-image-smoothing-enabled) true) + (setf (@. surface context ms-image-smoothing-enabled) true)) + + (defun clear-surface (surface &optional color) + (if color + (progn + (save surface) + (setf+ (surface-fill-style surface) color) + (fill-rect surface 0 0 (surface-width surface) (surface-height surface)) + (restore surface)) + (clear-rect surface 0 0 (surface-width surface) (surface-height surface)))) + + (export new-surface clear-surface + disable-image-smoothing enable-image-smoothing)) ;; end of (*slummer* *graphics* *surface*) + + (defmodule (*slummer* *net*) + "Some networking tools." + + (defun xhr (url &key + (method "GET") + (response-type "text") + payload + on-error + on-load) + "Make an XHR request to URL calling ON-LOAD on the response. The default + METHOD is the string \"GET\", and the default PAYLOAD is NIL." + (let ((req (ps:new (-X-M-L-Http-Request)))) + (setf (@. req response-type) response-type) + (when on-load + (let ((handler (lambda () (funcall on-load (@. req response))))) + (@. req (add-event-listener "load" handler)))) + (when on-error + (@. req (add-event-listener "error" on-error))) + (@. req (open method url)) + (@. req (send payload)))) + + (defun ws (url on-message &key hello) + "Creates a new WebSocket connection to URL and attaches the ON-MESSAGE + handler to handle incoming messages. Optionally send the HELLO message on + opening the connection. The URL should look like ws:://addr[:PORT]/other-stuff" + (let ((con (ps:new (-web-socket url)))) + (@. con (add-event-listener "message" on-message)) + (when hello + (@. con (add-event-listener "open" (lambda () (@. con (send hello)))))) + con)) + + (export xhr ws)) ; end defmodule slummer.net + + ;; the following two lines close the top-level defvar + )) diff --git a/src/session.lisp b/src/session.lisp deleted file mode 100644 index 9887581..0000000 --- a/src/session.lisp +++ /dev/null @@ -1,16 +0,0 @@ -;;;; session.lisp - -(in-package :vampire) - -;;; SESSION CLASS - -(defclass/bknr session (keyed) - ((user :std (error "Sessions must be associated with users.")))) - -(defun make-session (user) - (with-transaction () - (make-instance 'session :user user))) - - - - diff --git a/src/site.lisp b/src/site.lisp index 6b84c71..a21afa0 100644 --- a/src/site.lisp +++ b/src/site.lisp @@ -3,6 +3,7 @@ (:import-from #:spinneret #:with-html #:with-html-string) (:local-nicknames (#:lzb #:lazybones) + (#:client #:lazybones/client.parenscript) (#:json #:jonathan) (#:a #:alexandria-2) (#:util #:vampire.utilities) @@ -25,7 +26,8 @@ (path (&key (title "") params - (auth t) + (auth t auth-supplied-p) + notauth setup) &body body) "PATH is a LAYZBONES ENDPOINT path, and can contain variables. @@ -46,8 +48,9 @@ can do anything; e.g. setting headers. BODY is SPINNERET code defining the body (but not the header) of a page." `(defendpoint* :get ,path ,params () - (unless ,auth - (lzb:http-err 403)) + ,(when auth-supplied-p + `(unless ,auth + ,(if notauth notauth `(lzb:http-err 403)))) ,setup (with-html-string (:doctype) @@ -57,71 +60,9 @@ page." (:meta :name "viewport" :content "width=device-width, initial-scale=1.0") (:link :rel "stylesheet" :href "/css/theme.css")) (:body + (:script :src "/js/vampire-api.js" :defer t) ,@body)))) -(ps:defpsmacro defmodule (name &body definitions) - "Defines a javascript module called NAME. DEFINITIONS is a list of -defining forms that look like one of - -(DEFPRIVATE VAR EXPR) - -or - -(DEFPUBLIC VAR EXPR) - -Everything defined as DEFPRIVAGE is only accessible from within the -module. Anything named DEFPUBLIC can be accessed from outside the -module with a name like `name.var` in JS, or (ps:chain name var) in -parenscript. - -DEFPRIVATEs are all hoisted to the top of the module, and are defined -sequentially. - -E.g. - -(defmodule -arith - (defprivate local-adder (lambda (x y) (+ x y))) - (defprivate x-factor 10) - (defprivate local-mult (lambda (z) (* x-factor z))) - (defpublic adder local-adder) - (defpublic scale-up local-mult) - (defpublic update-scale-factor (lambda (x) (setf x-factor x)))) - -this would generate - -if ('undefined' === typeof Arith) { - var Arith = (function (module562) { - var localAdder = function (x, y) { - return x + y; - }; - var xFactor = 10; - var localMult = function (z) { - return xFactor * z; - }; - module562.adder = localAdder; - module562.scaleUp = localMult; - module562.updateScaleFactor = function (x) { - return xFactor = x; - }; - return module562; - })({ }); -}; -" - (let ((module (gensym "MODULE"))) - (multiple-value-bind (locals exports) - (loop :for (define name form) :in definitions - :do (assert (member define '(defpublic defprivate))) - :if (eq define 'defprivate) - :collect (list name form) :into locals - :else - :collect `(setf (ps:chain ,module ,name) ,form) :into exports - :finally (return (values locals exports))) - `(defvar ,name - ((lambda (,module) - (let* ,locals - ,@exports - ,module)) - (ps:create)))))) (defmacro two-columns (col1 col2) "A Two-Column Layout Macro" @@ -153,16 +94,16 @@ if ('undefined' === typeof Arith) { ;;; PLAYLIST PAGE (defun ps-prev-track () - (ps:ps (ps:chain -vampire (play-previous-track)))) + (ps:ps (ps:chain -vampire-control (play-previous-track)))) (defun ps-next-track () - (ps:ps (ps:chain -vampire (play-next-track)))) + (ps:ps (ps:chain -vampire-control (play-next-track)))) (defun ps-play/pause () - (ps:ps (ps:chain -vampire (toggle-playback)))) + (ps:ps (ps:chain -vampire-control (toggle-playback)))) -(defun ps-play-track (track) - (ps:ps (ps:chain -vampire (play-track (ps:lisp (model:key track)))))) +(defun ps-play-track (track-key) + (ps:ps (ps:chain -vampire-control (play-track (ps:lisp track-key))))) (defun previous-track-button () (with-html @@ -229,54 +170,24 @@ if ('undefined' === typeof Arith) { (defun playlist-control-app (playlist) (with-html - (:script - (:raw - (ps:ps - (defmodule -vampire - - (defprivate stop-media-playback - (lambda ())) - - (defprivate forward-one-track - (lambda ())) - - (defprivate back-one-track - (lambda ())) - - (defprivate start-media-playback - (lambda ())) - - (defprivate media-now-playing-p - (lambda ())) - - (defpublic play-next-track - (lambda () - (stop-media-playback) - (when (forward-one-track) - (start-media-playback)))) - - (defpublic play-previous-track - (lambda () - (stop-media-playback) - (when (back-one-track) - (start-media-playback)))) - - (defpublic toggle-playback - (lambda () - (if (media-now-playing-p) - (stop-media-playback) - (start-media-playback)))) + (:script))) + +(defparameter +vampire-session-cookie+ "SESSIONKEY") - (defpublic play-track - (lambda (key) - (stop-media-playback) - (set-track-to key) - (start-media-playback))) +(defun logged-in-p () + (a:when-let (token (lzb:response-cookie +vampire-session-cookie+)) + (model:lookup token))) - ;; moocow - )))))) +(defpage "/" + (:title "Vampire" + :auth (logged-in-p) + :notauth (lzb:http-redirect "/login")) + (:p "Welcome to vampire")) +(defpage "/login" + (:title "Vampire - Login") + (:p "Go ahead and log in")) (defpage "/playlist/:pl a-playlist:" (:title (playlist-title-string pl) @@ -298,3 +209,73 @@ if ('undefined' === typeof Arith) { '(div :background "#222222" :color "white")))) + +;;; JAVASCRIT + +(defendpoint* :get "/js/vampire-api.js" () () + "Serves a javascript module called 'VampireApi'" + (setf (lzb:response-header :content-type) "text/javascript") + (client:generate-js + (lzb:app 'vampire.api::vampire.api))) + +(defendpoint* :get "/js/vampire-util.js" () () + "Serves a javascript module called" + ) + +(defendpoint* :get "/js/vampire-app.js" () () + "Serves a javascript module called VampireApp." + (setf (lzb:response-header :content-type) "text/javascript") + (ps:ps + (defmodule -vampire-app + "vampire control app" + + (defprivate element + (lambda (id) + (ps:chain document (get-element-by-id id)))) + + (defprivate stop-media-playback + (lambda ())) + + (defprivate forward-one-track + (lambda ())) + + (defprivate back-one-track + (lambda ())) + + (defprivate start-media-playback + (lambda ())) + + (defprivate media-now-playing-p + (lambda ())) + + (defpublic play-next-track + (lambda () + (stop-media-playback) + (when (forward-one-track) + (start-media-playback)))) + + (defpublic play-previous-track + (lambda () + (stop-media-playback) + (when (back-one-track) + (start-media-playback)))) + + (defpublic toggle-playback + (lambda () + (if (media-now-playing-p) + (stop-media-playback) + (start-media-playback)))) + + (defpublic play-track + (lambda (key) + (stop-media-playback) + (set-track-to key) + (start-media-playback))) + + (defpublic load + (lambda () + (ps:chain -vampire-api + (get-session-playlist (ps:chain -vampire-client (get-session))) + (then )))) + ;; moocow + ))) diff --git a/src/vampire.lisp b/src/vampire.lisp index 52eb542..946ba77 100644 --- a/src/vampire.lisp +++ b/src/vampire.lisp @@ -1,46 +1,56 @@ ;;;; vampire.lisp -(in-package #:vampire) - -;;; SYSTEM CONFIG COMPONENT +(defpackage #:vampire + (:use #:cl) + (:local-nicknames (#:config #:vampire.config) + (#:downloader #:vampire.downloader) + (#:lzb #:lazybones) + (#:api #:vampire.api) + (#:site #:vampire.site))) -(defvar *config* nil) - -(defclass/std config () - ((datastore-directory :ir :std #P"/srv/vampire/store/") - (static-directory :ir :std #P"/srv/vampire/static/") - (swank-port :std nil :doc "If set, swank is started on this port.") - (host :std "0.0.0.0") - (port :ir :std 4919) - (downloader-threads :ir :std 5))) +(in-package #:vampire) -(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))) +(defvar *server* nil) ;;; STARTUP -(defun initialize-database (config) - (ensure-directories-exist (datastore-directory config)) +(defun initialize-database () + (ensure-directories-exist (config:datastore-directory*)) (make-instance 'bknr.datastore:mp-store - :directory (datastore-directory config) + :directory (config:datastore-directory*) :subsystems (list (make-instance 'bknr.datastore:store-object-subsystem)))) (defun start-vampire (config) - (setf *config* config) - (initialize-database config ) - (start-downloader-service config) - (when (swank-port config) - (swank:create-server :port (swank-port config) :dont-close t))) + (config:use config) + (initialize-database) + (downloader:start) + + (unless *server* + (setf *server* + (lzb:create-server + :port (config:port*) + :address (config:host*) + :domain "localhost"))) + + (lzb:install-app *server* 'api::vampire.api) + (lzb:install-app *server* 'site::vampire.site) + + (lzb:start-server *server*) + + (when (config:swank-port*) + (swank:create-server :port (config:swank-port*) :dont-close t))) (defun hacking-start () (start-vampire (make-instance - 'config - :static-directory (merge-pathnames "vampire-static/" (user-homedir-pathname)) - :datastore-directory (merge-pathnames "vampire-store/" (user-homedir-pathname))))) + 'config:config + + :static-directory + (merge-pathnames "vampire-static/" (user-homedir-pathname)) + + :datastore-directory + (merge-pathnames "vampire-store/" (user-homedir-pathname))))) diff --git a/vampire.asd b/vampire.asd index 152d2bb..2efc35d 100644 --- a/vampire.asd +++ b/vampire.asd @@ -8,6 +8,7 @@ :pathname "src/" :serial t :depends-on (#:lazybones/backend/hunchentoot + #:lazybones/client/parenscript #:spinneret #:lass #:parenscript @@ -30,8 +31,9 @@ (:file "model") (:file "mailbox") (:file "api") + (:file "parenscript") (:file "site") ; (:file "zipper") -; (:file "vampire") + (:file "vampire") ;(:file "run") )) -- cgit v1.2.3