hackityhackityhackity

7 files changed, 736 insertions, 169 deletions

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")
                ))