path: root/src/model.lisp

;;;; model.lisp

(defpackage #:vampire.model
  (:use #:cl)
  (:local-nicknames
   (#:a #:alexandria-2)
   (#:util #:vampire.utilities)
   (#:config #:vampire.config))
  (:import-from #:defclass-std #:defclass/std)
  (:import-from #:bknr.datastore
                #:with-transaction
                #:store-object
                #:persistent-class
                #:store-objects-with-class
                #:store-object-id
                #:store-object-with-id
                #:delete-object)
  (:import-from #:bknr.indices
                #:string-unique-index
                #:hash-index
                #:hash-list-index)
  (:export
   #:model
   #:key
   #:lookup
   #:session
   #:playlist
   #:user
   #:track
   #:artist
   #:tracks
   #:title
   ;; queries (non-transactional)
   #:login-user
   #:can-edit-p
   #:playlists

   ;; transactions
   #:make-session
   #:use-invite-with-code
   #:new-playlist
   #:update-playlist-title
   #:update-playlist
   #:remove-track
   #:swap-tracks
   #:destroy-playlist
   #:add-editor
   #:remove-editor
   #:update-track-info
   #:append-track))

(in-package :vampire.model)

;;; UTILITIES

(defmacro defclass/bknr (name supers slotdefs &rest options)
  "Defines a class using defclass/std syntax. Ensures that the class
   is a sublcas of STORE-OBJECT with metaclass PERSISTENT-CLASS."
  (let* ((include-store-object-p
           (notany (lambda (c) (closer-mop:subclassp c 'store-object))
                   supers))
         (supers
           (if include-store-object-p
               `(store-object ,@supers)
               supers)))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (defclass/std ,name ,supers
         ,slotdefs
         (:metaclass persistent-class)
         ,@options))))



;;; CLASSES 

(defclass/bknr keyed ()
  ((key :r :std (util:nuid)
           :index-type string-unique-index
           :index-reader lookup)))

(defclass/bknr user (keyed)
  ((name :index-type string-unique-index
         :index-reader user-with-name
         :index-initargs (:test 'equalp))
   (playlists :std (list))
   (pwsalt :std (util:nuid))
   (pwhash)))

(defclass/bknr invite (keyed)
  ((maker :ri :std nil
              :index-type hash-index
              :index-reader invites-by-maker)
   (uses-remaining :std nil)))

(defclass/bknr session (keyed)
  ((user :std (error "Sessions must be associated with users."))))

(defun make-session (user)
  (with-transaction ()
    (make-instance 'session :user user)))

(defclass/bknr playlist (keyed)
  ((title  :std (util:default-name "playlist"))
   (tracks editors :std (list))
   (cover-image :std nil :doc "A url to the cover of this album.")
   (user :std (error "A USER is required to have created the content."))))

(defmethod initialize-instance :after ((pl playlist) &key)
  (pushnew pl (playlists (user pl)) :test #'eq))

(defclass/bknr track (keyed)
  ((source file title artist album thumb-url duration codec )
   (playlists :std (list)
              :doc "A list of playlists in which this track appears")))

(defun track-file (track)
  (with-slots (file) track
    (merge-pathnames
     (path:basename file)
     (merge-pathnames "media/" (config:static-directory*)))))

;;; MODEL OPERATIONS

(defun can-edit-p (user playlist)
  (or (eq (user playlist) user)
      (member user (editors playlist) :test #'eq)))

(defun invite-by-code (code)
  "Returns NIL if CODE is an invalid invite code. Returns the INVITE
   instance otherwise"
  (a:when-let (obj (lookup code))
    (and (typep obj 'invite)
         (or (null (uses-remaining obj))
             (plusp (uses-remaining obj)))
         obj)))

(defun user-with-key (key)
  (a:when-let (obj (lookup key))
    (when (typep obj 'user)
      obj)))

(defun login-user (username password)
  (a:when-let (user (user-with-name username))
    (with-slots (pwhash pwsalt) user
      (when (equalp pwhash (util:hash-string password pwsalt))
        user))))

(defun last-change (obj)
  (slot-value obj 'bknr.datastore::last-change))

(defun recent-playlists (&optional (count 10))
  (util:take count
             (sort (copy-seq (store-objects-with-class 'playlist))
                   #'>
                   :key #'last-change)))

(defun playlist-duration (pl)
  (reduce #'+
          (tracks pl)
          :key (lambda (tr) (or (duration tr) 0)) 
          :initial-value 0))

(defun track-with-source (source)
  (find source (store-objects-with-class 'track)
        :test #'string-equal :key 'source))

;;; TRANSACTIONS

(defun new-user (&key name password)
  (with-transaction ()
    (make-instance 'user :name name)))

(defun set-new-password (user pw)
  (with-transaction ()
    (setf (pwhash user)
          (util:hash-string pw (pwsalt user)))
    t))


(defun use-invite-with-code (code username password)
  "Redeems invite token CODE, updating it's associated INVITE instance
and creating a new user with USERNAME and PASSWORD. If everything goes
well then the USER instance is returned. If not, then NIL is returned,
indicating that the CODE was not associated with any known INVITE."
  (with-transaction ()
    (a:when-let (invite (invite-by-code code))
      (when (uses-remaining invite)
        (decf (uses-remaining invite))
        (unless (plusp (uses-remaining invite))
          (delete-object invite)))
      (let ((user (make-instance 'user :name username)))
        (setf (pwhash user)
              (util:hash-string password (pwsalt user)))
        user))))

(defun remove-editor (playlist editor)
  (with-transaction ()
    (setf (editors playlist)
          (delete editor (editors playlist)))))

(defun add-editor (playlist editor)
  (with-transaction ()
    (pushnew editor (editors playlist) :test #'eq)))

(defun destroy-invite (invite)
  (with-transaction ()
    (delete-object invite)))

(defun make-invite (user &optional uses)
  (with-transaction ()
    (make-instance 'invite :maker user :uses-remaining uses)))

(defun append-track (playlist track)
  (with-transaction ()
    (setf (tracks playlist) (nconc (tracks playlist) (list track)))
    (pushnew playlist (playlists track) :test #'eq)))

(defun remove-track (playlist track)
  (with-transaction ()
    (setf (tracks playlist) (delete track (tracks playlist))
          (playlists track) (delete playlist (playlists track)))))

(defun swap-tracks (pl n m)
  (unless (or (minusp (min m n))
              (>= (max m n) (length (tracks pl)) ))
    (with-transaction ()
      (setf (tracks pl)
            (util:nswap (tracks pl) n m)))))

(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 (file track) (namestring file))
      track)))

(defun new-playlist (user &key title)
  (with-transaction ()
    (make-instance 'playlist :title title :user user)))

(defun destroy-playlist (pl)
  (with-transaction ()
    (setf (playlists (user pl))
          (delete pl (playlists (user pl))))
    (delete-object pl)))

(defun update-playlist-title (playlist title)
  (with-transaction ()
    (setf (title playlist) title)))

(defun update-playlist (pl title tracks)
  (with-transaction ()
    (when title (setf (title pl) title))
    (when tracks (setf (tracks pl) tracks))
    pl))

(defun update-track-info (track new-artist new-album new-title)
  (with-transaction ()
    (with-slots (artist album title) track
      (setf artist (unless (equal "" new-artist) new-artist)
	    album (unless (equal "" new-album) new-album)
	    title (unless (equal "" new-title) new-title)))))


(defun playlist-cover-url (pl)
  (declare (ignore pl))
  "https://images5.fanpop.com/image/photos/31100000/Riker-star-trek-the-next-generation-31159197-1024-768.png")