hacking hacking hacking on the site

6 files changed, 197 insertions, 78 deletions

diff --git a/src/api.lisp b/src/api.lisp
index 022a9ad..0fa8702 100644
--- a/src/api.lisp
+++ b/src/api.lisp
@@ -6,6 +6,7 @@
    (#:lzb #:lazybones)
    (#:json #:jonathan)
    (#:a #:alexandria-2)
+   (#:control #:vampire.control)
    (#:util #:vampire.utilities)
    (#:model #:vampire.model)
    (#:downloader #:vampire.downloader)
@@ -21,56 +22,22 @@
   :prefix "/api"
   :content-type "application/json")
 
-;;; SPECIALS
+;;; SPECIALS & PARAMETERS
 
 (defvar *session* nil
   "Bound per session by code expanded from SESSION-EDNPOINT")
 
-;;; MACROS
+(defparameter +api-token-key+ :|apiToken|)
 
-(defmacro define-model-lookup (class)
-  "Defines a function called A-CLASS. These functions can be referenced
-in endpoint pathname specifications and in parameter lists to parse
-and bind parameters to model objects. 
+;;; MACROS
 
-Any failures result in an HTTP 404."
-  (let ((name (a:symbolicate :a- class)))
-    `(defun ,name (key)
-       (let ((,class (model:lookup key )))
-         (unless (typep ,class ',class )
-           (lzb:http-err 404
-                         (format nil "No ~a with id ~a"
-                                 ',class key)))))))
 
 (defmacro defendpoint/session (method path body-vars &body code)
   (let ((full-path
-          (concatenate 'string "/session/:*session* a-session:" path)))
+          (concatenate 'string "/session/:*session* control:a-session:" path)))
     `(defendpoint* ,method ,full-path () (:body-vars ,body-vars) ,@code)))
 
 
-;;; ARGUMENT VALIDATORS
-
-(defparameter +api-token-key+ :|apiToken|)
-
-(define-model-lookup model:session)
-(define-model-lookup model:playlist)
-(define-model-lookup model:user)
-(define-model-lookup model:track)
-
-(defun an-int (str)
-  (let ((int (parse-integer str :junk-allowed t)))
-    (unless int
-      (lzb:http-err
-       400
-       (format nil "Expected an integer, but got ~s" str)))
-    int))
-
-(defun check-title (title)
-  "Validates a string meant to be the title of something. Titles should
-be non-empty strings."
-  (unless (util:legible-line-p title)
-    (lzb:http-err 406 "Invalid Title")))
-
 ;;; PERMISSIONS CHECKS
 
 (defun check-can-edit (playlist)
@@ -103,17 +70,20 @@ The JSON body must contain properties \"code\", \"username\", and
 
 ;;; PLAYLIST ENDPOINTS
 
-(defendpoint/session :get "/playlist/:pl a-playlist:" ()
+(defendpoint/session 
+    :get "/playlist/:pl control:a-playlist:" ()
   "Return a PLAYLIST identified by its key."
   (json:to-json pl))
 
-(defendpoint/session :post "/playlist" (title)
+(defendpoint/session
+    :post "/playlist" (title)
   "Create a new playlist. The request body must contain the field \"title\"."
-  (check-title title)
+  (control:check-title title)
   (json:to-json
    (model:new-playlist (model:user *session*) :title title)))
 
-(defendpoint/session :patch "/playlist/:pl a-playlist:" (title trackids)
+(defendpoint/session
+    :patch "/playlist/:pl control:a-playlist:" (title trackids)
   "Update a playlist with fields in the request body. 
 
 Fields include \"title\" and \"trackIds\". All fields are optional.
@@ -122,12 +92,13 @@ If title is provided it is validated. If trackIds is provided, each of
 its members is validated, returning ao 404 if no track can be found
 witht he given id."
   (check-can-edit pl)
-  (when title (check-title title))
-  (let ((tracks (mapcar #'a-track trackids)))
+  (when title (control:check-title title))
+  (let ((tracks (mapcar #'control:a-track trackids)))
     (model:update-playlist pl title tracks))
   "true")
 
-(defendpoint/session :post "/add-track/:pl a-playlist:" (url)
+(defendpoint/session
+    :post "/add-track/:pl control:a-playlist:" (url)
   (check-can-edit pl)
   (let ((user (model:user *session*)))  ; need to capture lexically
                                         ; b/c of closures below
@@ -141,7 +112,7 @@ witht he given id."
        (logger:logerror (list :error e :url url))
        (mail:send user (list :|fetchError| url))))))
 
-(defendpoint/session :delete "/playlist/:pl a-playlist:" ()
+(defendpoint/session :delete "/playlist/:pl control:a-playlist:" ()
   "Owners can delete their playlists."
   (check-ownership pl)
   (model:destroy-playlist pl)
@@ -149,13 +120,15 @@ witht he given id."
 
 ;;; USER ENDPOINTS
 
-(defendpoint/session :patch "/user/:u a-user:/add-playlist/:pl a-playlist:" ()
+(defendpoint/session
+    :patch "/user/:u control:a-user:/add-playlist/:pl control:a-playlist:" ()
   "Owners can add collaborators to their playlists"
   (check-ownership pl)
   (model:add-editor pl u)
   "true")
 
-(defendpoint/session :patch "/user/:u a-user:/remove-playlist/:pl a-playlist:" ()
+(defendpoint/session
+    :patch "/user/:u control:a-user:/remove-playlist/:pl control:a-playlist:" ()
   "Owners can remove collaborators from their playlists"
   (check-ownership pl)
   (model:remove-editor pl u)
@@ -163,18 +136,21 @@ witht he given id."
 
 ;;; TRACK ENDPOINTS
 
-(defendpoint/session :get "/track/:tr a-track:" ()
+(defendpoint/session
+    :get "/track/:tr control:a-track:" ()
   "Fetch the metadata related to a particular track"
   (json:to-json tr))
 
-(defendpoint/session :patch "/track/:tr a-track:" (title artist album)
+(defendpoint/session
+    :patch "/track/:tr control:a-track:" (title artist album)
   "Any logged in user can edit track metadata"
   (model:update-track-info tr  (or artist "") (or album "") (or title ""))
   "true")
 
 ;;; MAILBOX ENDPOINTS
 
-(defendpoint/session :get "/notifications" ()
+(defendpoint/session
+    :get "/notifications" ()
   "Get the messages, if any, for the user session."
   (mail:deliver (model:user *session*)))
 
diff --git a/src/control.lisp b/src/control.lisp
new file mode 100644
index 0000000..359b812
--- /dev/null
+++ b/src/control.lisp
@@ -0,0 +1,60 @@
+
+(defpackage #:vampire.control
+  (:use #:cl)
+  (:documentation "Some utilities interfacing the model with HTTP interfaces")
+  (:local-nicknames
+   (#:a #:alexandria-2)
+   (#:utils #:vampire.utilities)
+   (#:model #:vampire.model)
+   (#:lzb #:lazybones))
+  (:export
+   #:check-title
+   #:a-session
+   #:a-model
+   #:a-playlist
+   #:a-user
+   #:a-track
+   #:an-int))
+
+(in-package #:vampire.control)
+
+
+(defun check-title (title)
+  "Validates a string meant to be the title of something. Titles should
+be non-empty strings."
+  (unless (utils:legible-line-p title)
+    (lzb:http-err 406 "Invalid Title")))
+
+(defmacro define-model-lookup (class)
+  "Defines a function called A-CLASS. These functions can be referenced
+in endpoint pathname specifications and in parameter lists to parse
+and bind parameters to model objects. 
+
+Any failures result in an HTTP 404."
+  (let* ((article (if (find (elt (symbol-name class) 0)
+                            "aeioAEIO") ; U is a consonant when beginning a word
+                      :an- :a-))
+         (name (a:symbolicate article class))
+         (instance (gensym "INSTANCE"))
+         (key (gensym "KEY")))
+    `(defun ,name (,key)
+       (let ((,instance (model:lookup ,key)))
+         (if (typep ,instance ',class )
+             ,instance
+             (lzb:http-err 404
+                           (format nil "No ~a with id ~a"
+                                   ',class ,key)))))))
+
+(define-model-lookup model:session)
+(define-model-lookup model:playlist)
+(define-model-lookup model:user)
+(define-model-lookup model:track)
+
+(defun an-int (str)
+  (let ((int (parse-integer str :junk-allowed t)))
+    (unless int
+      (lzb:http-err
+       400
+       (format nil "Expected an integer, but got ~s" str)))
+    int))
+
diff --git a/src/model.lisp b/src/model.lisp
index 00edde2..ed26d9b 100644
--- a/src/model.lisp
+++ b/src/model.lisp
@@ -260,3 +260,5 @@ indicating that the CODE was not associated with any known INVITE."
       (setf artist (unless (equal "" new-artist) new-artist)
 	    album (unless (equal "" new-album) new-album)
 	    title (unless (equal "" new-title) new-title)))))
+
+
diff --git a/src/site.lisp b/src/site.lisp
index e793bc3..3977ffd 100644
--- a/src/site.lisp
+++ b/src/site.lisp
@@ -7,6 +7,7 @@
    (#:json #:jonathan)
    (#:a #:alexandria-2)
    (#:util #:vampire.utilities)
+   (#:control #:vampire.control)
    (#:model #:vampire.model)
    (#:api #:vampire.api))
   (:use #:cl))
@@ -65,7 +66,7 @@ page."
 (defmacro defpage/session
     (path (&key (title "") params setup) &body body)
   `(defpage ,path (:title ,title :params ,params :setup ,setup
-                   :auth (logged-in-p) :notauth (lzb:http-redirect "/login"))
+                   :auth (browser-session) :notauth (lzb:http-redirect "/login"))
      (header)
      ,@body))
 
@@ -218,11 +219,15 @@ path we're visiting"
 
 (defparameter +vampire-session-cookie+ "SESSIONKEY")
 
-(defun logged-in-p ()
-  (print 'logged-in-p)
-  (a:when-let (token (print (lzb:request-cookie +vampire-session-cookie+)))
-    (model:lookup token)))
+(defun browser-session ()
+  (a:when-let* ((token (lzb:request-cookie +vampire-session-cookie+))
+                (session (model:lookup token)))
+    (when (typep session 'model:session)
+      session)))
 
+(defun session-user ()
+  (a:when-let (session (browser-session))
+    (model:user session)))
 
 
 (defun header ()
@@ -233,7 +238,7 @@ path we're visiting"
             (:div :class "right vsep-container"
                   (:a :class "vsep-item" :href "/about" "about")
                   (:a :class "vsep-item" :href "/logout" "logout"))
-            (:h1 "⹋ V̷ · ̷A̷ · ̷M̷ · ̷P̷ · ̷I̷ · ̷R̷ · ̷E̷ ⹋")))
+            (:h1 "⹋ V̷ † ̷A̷ ⸸ ̷M̷ † ̷P̷ ⸸ ̷I̷ † ̷R̷ ⸸ ̷E̷ ⹋")))
      (:hgroup
       (:nav
        (:div :class "navbar"
@@ -243,7 +248,7 @@ path we're visiting"
 
 
 (defendpoint* :get "/" () ()
-  (if (logged-in-p)
+  (if (browser-session)
       (lzb:http-redirect "/you")
       (lzb:http-redirect "/login")))
 
@@ -273,14 +278,70 @@ the biggest threat we've ever had and we need to meet the moment,\"
 she said. Further reading: Nvidia CEO Says US Will Take Years To
 Achieve Chip Independence")))
 
+(defun playlist-page-url (pl)
+  (format nil "/playlist/~a/~a"
+          (model:key pl)
+          (url-rewrite:url-encode (model:title pl))))
+
+#+off
+(defun playlist-card (pl)
+  (with-html
+    (:div :class "card"
+          (:img :src (model::cover-image pl))
+          (:a :href (playlist-page-url pl)
+              (model:title pl)))))
+
+(defun playlist-card (pl)
+  (with-html
+    (:a
+     :href (playlist-page-url pl)
+     :class "card"
+     (:img :src (model::cover-image pl))
+     (:span 
+         (model:title pl)))))
+
+(defun user-playlists (lists)
+  (with-html
+    (:h2 "Your Playlists")
+    (:div
+     :class "playlists"
+     (dolist (pl lists)
+       (playlist-card pl)))))
+
+(defun make-playlist-form ()
+  (with-html
+    (:h2 "Create a Playlist")
+    (form :class "center" :button "Create" :method "POST" :action "/playlist"
+      (input "title" "Playlist Title"))))
+
+(defendpoint* :post "/playlist" ()
+  (:auth #'browser-session :body-vars (title))
+  (control:check-title title)
+  (let ((pl (model:new-playlist (session-user) :title title)))
+    (lzb:http-redirect (playlist-page-url pl))))
+
+(defun invites-control ()
+  (with-html
+    (:h2 "Invite Friends")
+    (:div
+     (:p "Invites go here"))))
+
+
+(defun password-reset-link ()
+  (with-html
+    (:div
+     (:a :href "/reset-password" "Reset Password"))))
+
 (defpage/session "/you" (:title "Vampire ~ Your Stuff")
   (:div 
    (row
-     (col (gibberish)))
-   (row
-     (col (gibberish))
-     (col (gibberish))
-     )))
+     (col
+       (user-playlists
+        (print (model:playlists (session-user)))))
+     (col
+       (make-playlist-form)
+       (invites-control)
+       (password-reset-link)))))
 
 (defpage/session "/us" (:title "Vampire ~ Our Playlists")
   (:div :class "container"))
@@ -319,18 +380,9 @@ Achieve Chip Independence")))
           (input "password" "Choose a Passwrod" "password"))))
 
 
-
-
-(defpage "/playlist/:pl a-playlist:"
-    (:title (playlist-title-string pl)
-     :auth (can-view-playlist-p pl))
-  (two-columns
-   (:div
-    (playlist-title-view pl)
-    (playlist-tracks-view pl))
-   (:div
-    (now-playing-view pl)))
-  (playlist-control-app pl))
+(defpage/session "/playlist/:pl control:a-playlist:/:title:"
+    (:title (model:title pl))
+  (:h1 (model:title pl)))
 
 ;;; CSS
 
@@ -378,6 +430,10 @@ Achieve Chip Independence")))
        :float left
        :width 100%
        :text-align center))
+
+     (.center
+      :margin auto
+      :max-width 80%)
      
      (.navbar
       :width 100%
@@ -397,12 +453,31 @@ Achieve Chip Independence")))
        :color #(active-color)))
 
      (.row
-      :display flex
-      :justify-content space-between)
+      :display flex)
 
      (.col
       :flex 1)
 
+     (.playlists
+      :display flex
+      :justify-content space-around
+      :flex-wrap wrap
+      :width 100%)
+     
+     (.card
+      :margin #(padding)
+      :border 1px solid #(fringe-color)
+      :width 200px
+      :height 200px
+      :display block)
+     
+     ((:or h1 h2)
+      :width 80%
+      :margin-left auto
+      :margin-right auto
+      :text-align center
+      :border-bottom 1px dotted #(fringe-color))
+
      (:media "(max-width: 650px)"
       (.navbar
        (a
diff --git a/src/utilities.lisp b/src/utilities.lisp
index 7494934..1ede246 100644
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -16,7 +16,8 @@
            #:jsonify-symbol
            #:whitespace-p
            #:newline-p
-           #:legible-line-p))
+           #:legible-line-p
+           #:check-title))
 
 (in-package #:vampire.utilities)
 
@@ -157,3 +158,7 @@
   (and (stringp s)
        (plusp (count-if #'alphanumericp s))
        (zerop (count-if #'newline-p s))))
+
+
+
+
diff --git a/vampire.asd b/vampire.asd
index 2efc35d..c190c3b 100644
--- a/vampire.asd
+++ b/vampire.asd
@@ -29,6 +29,7 @@
                (:file "config")
                (:file "downloader")
                (:file "model")
+               (:file "control")
                (:file "mailbox")
                (:file "api")
                (:file "parenscript")