initial commit

10 files changed, 461 insertions, 0 deletions

diff --git a/service/auth-service.lisp b/service/auth-service.lisp
new file mode 100644
index 0000000..6cbc134
--- /dev/null
+++ b/service/auth-service.lisp
@@ -0,0 +1,21 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:music-dispensary)
+
+;; ========================================================================== ;;
+
+(defclass auth-service (rest-service)
+  ()
+  (:documentation ""))
+
+(defmethod initialize-instance :after ((auth-service auth-service) &key)
+  (when (not (string= (session-value :permissions) "admin"))
+    (setf (location auth-service) "home")
+    (setf (errormsg auth-service) "You are not authorized to access this resource.")))
+
+(defmacro with-auth ((instance form-class) &body body)
+  `(let ((,instance (make-instance ',form-class)))
+     (when (null (errormsg ,instance))
+       ,@body)
+     (objects-to-json `(,,instance))))
diff --git a/service/base-service.lisp b/service/base-service.lisp
new file mode 100644
index 0000000..a3f77b0
--- /dev/null
+++ b/service/base-service.lisp
@@ -0,0 +1,10 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:music-dispensary)
+
+;; ========================================================================== ;;
+
+(defclass base-service ()
+  ()
+  (:documentation ""))
diff --git a/service/browse.lisp b/service/browse.lisp
new file mode 100644
index 0000000..1d310f5
--- /dev/null
+++ b/service/browse.lisp
@@ -0,0 +1,217 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:music-dispensary)
+
+;; ========================================================================== ;;
+
+(defparameter *papersizes* '((:name "letter" :size "(8.5 x 11.0 in)")
+                             (:name "arch a" :size "(9.0 x 12.0 in)")
+                             (:name "ledger" :size "(17.0 x 11.0 in)")
+                             (:name "a4" :size "(210 x 297 mm)")
+                             (:name "a10" :size "(26 x 37 mm)")
+                             (:name "a9" :size "(37 x 52 mm)")
+                             (:name "a8" :size "(52 x 74 mm)")
+                             (:name "a7" :size "(74 x 105 mm)")
+                             (:name "a6" :size "(105 x 148 mm)")
+                             (:name "a5" :size "(148 x 210 mm)")
+                             (:name "a3" :size "(297 x 420 mm)")
+                             (:name "a2" :size "(420 x 594 mm)")
+                             (:name "a1" :size "(594 x 841 mm)")
+                             (:name "a0" :size "(841 x 1189 mm)")
+                             (:name "b10" :size "(31 x 44 mm)")
+                             (:name "b9" :size "(44 x 62 mm)")
+                             (:name "b8" :size "(62 x 88 mm)")
+                             (:name "b7" :size "(88 x 125 mm)")
+                             (:name "b6" :size "(125 x 176 mm)")
+                             (:name "b5" :size "(176 x 250 mm)")
+                             (:name "b4" :size "(250 x 353 mm)")
+                             (:name "b3" :size "(353 x 500 mm)")
+                             (:name "b2" :size "(500 x 707 mm)")
+                             (:name "b1" :size "(707 x 1000 mm)")
+                             (:name "b0" :size "(1000 x 1414 mm)")
+                             (:name "4a0" :size "(1682 x 2378 mm)")
+                             (:name "2a0" :size "(1189 x 1682 mm)")
+                             (:name "c10" :size "(28 x 40 mm)")
+                             (:name "c9" :size "(40 x 57 mm)")
+                             (:name "c8" :size "(57 x 81 mm)")
+                             (:name "c7" :size "(81 x 114 mm)")
+                             (:name "c6" :size "(114 x 162 mm)")
+                             (:name "c5" :size "(162 x 229 mm)")
+                             (:name "c4" :size "(229 x 324 mm)")
+                             (:name "c3" :size "(324 x 458 mm)")
+                             (:name "c2" :size "(458 x 648 mm)")
+                             (:name "c1" :size "(648 x 917 mm)")
+                             (:name "c0" :size "(917 x 1297 mm)")
+                             (:name "junior-legal" :size "(8.0 x 5.0 in)")
+                             (:name "legal" :size "(8.5 x 14.0 in)")
+                             (:name "tabloid" :size "(11.0 x 17.0 in)")
+                             (:name "11x17" :size "(11.0 x 17.0 in)")
+                             (:name "17x11" :size "(17.0 x 11.0 in)")
+                             (:name "government-letter" :size "(8 x 10.5 in)")
+                             (:name "government-legal" :size "(8.5 x 13.0 in)")
+                             (:name "philippine-legal" :size "(8.5 x 13.0 in)")
+                             (:name "ansi a" :size "(8.5 x 11.0 in)")
+                             (:name "ansi b" :size "(17.0 x 11.0 in)")
+                             (:name "ansi c" :size "(17.0 x 22.0 in)")
+                             (:name "ansi d" :size "(22.0 x 34.0 in)")
+                             (:name "ansi e" :size "(34.0 x 44.0 in)")
+                             (:name "engineering f" :size "(28.0 x 40.0 in)")
+                             (:name "arch b" :size "(12.0 x 18.0 in)")
+                             (:name "arch c" :size "(18.0 x 24.0 in)")
+                             (:name "arch d" :size "(24.0 x 36.0 in)")
+                             (:name "arch e" :size "(36.0 x 48.0 in)")
+                             (:name "arch e1" :size "(30.0 x 42.0 in)")
+                             (:name "statement" :size "(5.5 x 8.5 in)")
+                             (:name "half letter" :size "(5.5 x 8.5 in)")
+                             (:name "quarto" :size "(8.0 x 10.0 in)")
+                             (:name "octavo" :size "(6.75 x 10.5 in)")
+                             (:name "executive" :size "(7.25 x 10.5 in)")
+                             (:name "monarch" :size "(7.25 x 10.5 in)")
+                             (:name "foolscap" :size "(8.27 x 13.0 in)")
+                             (:name "folio" :size "(8.27 x 13.0 in)")
+                             (:name "super-b" :size "(13.0 x 19.0 in)")
+                             (:name "post" :size "(15.5 x 19.5 in)")
+                             (:name "crown" :size "(15.0 x 20.0 in)")
+                             (:name "large post" :size "(16.5 x 21.0 in)")
+                             (:name "demy" :size "(17.5 x 22.5 in)")
+                             (:name "medium" :size "(18.0 x 23.0 in)")
+                             (:name "broadsheet" :size "(18.0 x 24.0 in)")
+                             (:name "royal" :size "(20.0 x 25.0 in)")
+                             (:name "elephant" :size "(23.0 x 28.0 in)")
+                             (:name "double demy" :size "(22.5 x 35.0 in)")
+                             (:name "quad demy" :size "(35.0 x 45.0 in)")
+                             (:name "atlas" :size "(26.0 x 34.0 in)")
+                             (:name "imperial" :size "(22.0 x 30.0 in)")
+                             (:name "antiquarian" :size "(31.0 x 53.0 in)")
+                             (:name "pa0" :size "(840 x 1120 mm)")
+                             (:name "pa1" :size "(560 x 840 mm)")
+                             (:name "pa2" :size "(420 x 560 mm)")
+                             (:name "pa3" :size "(280 x 420 mm)")
+                             (:name "pa4" :size "(210 x 280 mm)")
+                             (:name "pa5" :size "(140 x 210 mm)")
+                             (:name "pa6" :size "(105 x 140 mm)")
+                             (:name "pa7" :size "(70 x 105 mm)")
+                             (:name "pa8" :size "(52 x 70 mm)")
+                             (:name "pa9" :size "(35 x 52 mm)")
+                             (:name "pa10" :size "(26 x 35 mm)")
+                             (:name "f4" :size "(210 x 330 mm)")
+                             (:name "a8landscape" :size "(74 x 52 mm)")))
+
+;; ========================================================================== ;;
+;; browse
+
+(defclass browse (rest-service)
+  ((instructions :initarg :instructions
+                 :initform nil
+                 :accessor instructions))
+  (:documentation ""))
+
+(defmethod initialize-instance :after ((browse browse) &key)
+  (setf (instructions browse) "Use the file browser to find a LilyPond file (ending in .ly). Select a paper size. Then click \"Generate PDF\" to create a PDF of the music for download.<br/>Or select a PDF and download it as-is."))
+
+(defun browse-json ()
+  (objects-to-json `(,(make-instance 'browse))))
+
+;; ========================================================================== ;;
+;; browse-browser
+
+(defclass browse-browser (rest-service)
+  ((location-p :initarg :location-p
+               :initform nil
+               :accessor location-p)
+   (relative-path :initarg :relative-path
+                  :initform nil
+                  :accessor relative-path)
+   (nodes :initarg :nodes
+         :initform nil
+         :accessor nodes))
+  (:documentation ""))
+
+(defclass node (base-service)
+  ((node-type :initarg :node-type
+              :initform nil
+              :accessor node-type)
+   (path :initarg :path
+         :initform nil
+         :accessor path))
+  (:documentation ""))
+
+(defun browse-browser-json (relative-path node)
+  (let ((file-browser (or (session-value :file-browser)
+                          (make-instance 'file-browser
+                                         :document-root (make-webapp-path "music-dispensary/static/lilypond/")
+                                         :mime-extensions (mime-extensions *webapp*))))
+        (browse-browser (make-instance 'browse-browser)))
+    (setf (relative-path file-browser) (if (null-or-empty-p relative-path) nil relative-path))
+    (update-relative-path file-browser (if (null-or-empty-p node) nil node))
+    (setf (session-value :file-browser) file-browser)
+    (setf (relative-path browse-browser) (relative-path file-browser))
+    (setf (nodes browse-browser) (mapcar (lambda (node)
+                                           (make-instance 'node
+                                                          :node-type (car node)
+                                                          :path (cdr node)))
+                                         (directory-list file-browser)))
+    (objects-to-json `(,browse-browser))))
+
+;; ========================================================================== ;;
+;; browse-papersize
+
+(defclass browse-papersize (rest-service)
+  ((papersizes :initarg :papersizes
+               :initform nil
+               :accessor papersizes))
+  (:documentation ""))
+
+(defclass papersize (base-service)
+  ((name :initarg :name
+         :initform nil
+         :accessor name)
+   (size :initarg :size
+         :initform nil
+         :accessor size))
+  (:documentation ""))
+
+(defmethod initialize-instance :after ((browse-papersize browse-papersize) &key)
+  (setf (papersizes browse-papersize) (mapcar (lambda (x)
+                                                (make-instance 'papersize
+                                                               :name (getf x :name)
+                                                               :size (getf x :size)))
+                                              *papersizes*)))
+
+(defun browse-papersize-json ()
+  (objects-to-json `(,(make-instance 'browse-papersize))))
+
+;; ========================================================================== ;;
+;; browse-generate
+
+(defclass browse-generate (rest-service)
+  ((url :initarg :url
+        :initform nil
+        :accessor url))
+  (:documentation ""))
+
+(defun browse-generate-json (file papersize)
+  (let ((file-browser (session-value :file-browser))
+        (url nil))
+    (if (match-it ".*\.pdf$" file)
+        (setf url (format nil
+                          "/static/lilypond/~a/~a"
+                          (relative-path file-browser)
+                          file))
+        (let* ((output-file (format nil
+                                    "~a_~a"
+                                    (ppcre:regex-replace-all "\.ly" file "")
+                                    (ppcre:regex-replace-all " " papersize "_")))
+               (lilypond-command (format nil
+                                         "pushd '~a' >/dev/null ; lilypond -d 'paper-size=\"~a\"' -o ~a ~a ; popd >/dev/null"
+                                         (absolute-path file-browser)
+                                         papersize
+                                         output-file
+                                         file)))
+          (shell-wrapper lilypond-command)
+          (setf url (format nil
+                            "/static/lilypond/~a/~a"
+                            (relative-path file-browser)
+                            (format nil "~a.pdf" output-file)))))
+    (objects-to-json `(,(make-instance 'browse-generate :url url)))))
diff --git a/service/generic-form.lisp b/service/generic-form.lisp
new file mode 100644
index 0000000..96adc07
--- /dev/null
+++ b/service/generic-form.lisp
@@ -0,0 +1,45 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:music-dispensary)
+
+;; ========================================================================== ;;
+
+(defclass generic-form (rest-service)
+  ((name :initarg :name
+         :initform nil
+         :accessor name)
+   (http-method :initarg :http-method
+                :initform "POST"
+                :accessor http-method)
+   (action :initarg :action
+           :initform nil
+           :accessor action)
+   (form-fields :initarg :form-fields
+                :initform nil
+                :accessor form-fields))
+  (:documentation ""))
+
+(defclass form-field (base-service)
+  ((name :initarg :name
+         :initform nil
+         :accessor name)
+   (label :initarg :label
+          :initform nil
+          :accessor label)
+   (field-type :initarg :field-type
+               :initform nil
+               :accessor field-type))
+  (:documentation ""))
+
+(defmacro define-generic-form-constructor ((form-class name action) fields)
+  `(defmethod initialize-instance :after ((,form-class ,form-class) &key)
+     (setf (name ,form-class) ,name)
+     (setf (action ,form-class) ,action)
+     (setf (form-fields ,form-class)
+           (mapcar (lambda (form)
+                     (make-instance 'form-field
+                                    :name (getf form :name)
+                                    :label (getf form :label)
+                                    :field-type (getf form :field-type)))
+                   ,fields))))
diff --git a/service/home.lisp b/service/home.lisp
new file mode 100644
index 0000000..8166722
--- /dev/null
+++ b/service/home.lisp
@@ -0,0 +1,18 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:music-dispensary)
+
+;; ========================================================================== ;;
+
+(defclass home (rest-service)
+  ((content :initarg :content
+            :initform nil
+            :accessor content))
+  (:documentation ""))
+
+(defmethod initialize-instance :after ((home home) &key)
+  (setf (content home) (concatenate 'string "Welcome to the " (title *webapp*) "! You can browse for a LilyPond file of a piece of music you are interested in, select a paper size, and " (title *webapp*) " will generate a PDF of the music for you.")))
+
+(defun home-json ()
+  (objects-to-json `(,(make-instance 'home))))
diff --git a/service/login-authenticate.lisp b/service/login-authenticate.lisp
new file mode 100644
index 0000000..7ef038f
--- /dev/null
+++ b/service/login-authenticate.lisp
@@ -0,0 +1,24 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:music-dispensary)
+
+;; ========================================================================== ;;
+
+(defclass login-authenticate (rest-service)
+  ((location-p :initarg :location-p
+               :initform nil
+               :accessor location-p))
+  (:documentation ""))
+
+(defmethod initialize-instance :after ((login-authenticate login-authenticate) &key auth-result)
+  (if auth-result
+      (setf (message login-authenticate) "Successfully logged in.")
+      (setf (errormsg login-authenticate) "Login failed.")))
+
+(defun login-authenticate-json (dn password)
+  (let ((auth-result nil))
+    (when (check-ldap-password (ldap *webapp*) dn password)
+      (setf (session-value :permissions) "admin")
+      (setf auth-result t))
+    (objects-to-json `(,(make-instance 'login-authenticate :auth-result auth-result)))))
diff --git a/service/login.lisp b/service/login.lisp
new file mode 100644
index 0000000..082cda5
--- /dev/null
+++ b/service/login.lisp
@@ -0,0 +1,18 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:music-dispensary)
+
+;; ========================================================================== ;;
+
+(defclass login (generic-form)
+  ()
+  (:documentation ""))
+
+(define-generic-form-constructor (login "login-form" "/login/authenticate")
+    '((:name "username" :label "Username" :field-type "text")
+      (:name "password" :label "Password" :field-type "password")
+      (:name "submit" :label "Login" :field-type "button")))
+
+(defun login-json ()
+  (objects-to-json `(,(make-instance 'login))))
diff --git a/service/logout.lisp b/service/logout.lisp
new file mode 100644
index 0000000..68dd9d0
--- /dev/null
+++ b/service/logout.lisp
@@ -0,0 +1,19 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:music-dispensary)
+
+;; ========================================================================== ;;
+
+(defclass logout (rest-service)
+  ((location-p :initarg :location-p
+               :initform nil
+               :accessor location-p))
+  (:documentation ""))
+
+(defmethod initialize-instance :after ((logout logout) &key)
+  (setf (message logout) "You are now logged out."))
+
+(defun logout-json ()
+  (setf (session-value :permissions) "anonymous")
+  (objects-to-json `(,(make-instance 'logout))))
diff --git a/service/menu.lisp b/service/menu.lisp
new file mode 100644
index 0000000..130d4dc
--- /dev/null
+++ b/service/menu.lisp
@@ -0,0 +1,56 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:music-dispensary)
+
+;; ========================================================================== ;;
+
+(defparameter *menu-config* '((:id "a_menu_home" :label "Home" :url "/home" :handler "/home" :permission "t")
+                              (:id "a_menu_browse" :label "Browse Music" :url "/browse" :handler "/browse" :permission "anonymous")
+                              (:id "a_menu_login" :label "Login as Admin" :url "/login" :handler "/login" :permission "anonymous")
+                              (:id "a_menu_logout" :label "Logout" :url "/logout" :handler "/logout" :permission "admin")))
+
+(defclass menuitem ()
+  ((id :initarg :id
+       :initform nil
+       :accessor id)
+   (label :initarg :label
+          :initform nil
+          :accessor label)
+   (url :initarg :url
+        :initform nil
+        :accessor url)
+   (handler :initarg :handler
+            :initform nil
+            :accessor handler)
+   (permissions :initarg :permissions
+                :initform nil
+                :accessor permissions)
+   (children :initarg :children
+             :initform nil
+             :accessor children))
+  (:documentation ""))
+  
+(defclass menu (base-service)
+  ((menuitems :initarg :menuitems
+              :initform nil
+              :accessor menuitems))
+  (:documentation ""))
+
+(defmethod initialize-instance :after ((menu menu) &key)
+  (setf (menuitems menu)
+            (mapcar (lambda (x)
+                      (make-instance 'menuitem
+                                     :id (getf x :id)
+                                     :label (getf x :label)
+                                     :url (getf x :url)
+                                     :handler (getf x :handler)))
+                    (remove-if 'null (mapcar (lambda (x)
+                                               (when (find-if (lambda (y)
+                                                                (string= (getf x :permission) y))
+                                                              `("t" ,(session-value :permissions)))
+                                                 x))
+                                             *menu-config*)))))
+
+(defun menu-json ()
+  (objects-to-json `(,(make-instance 'menu))))
diff --git a/service/rest-service.lisp b/service/rest-service.lisp
new file mode 100644
index 0000000..4041da0
--- /dev/null
+++ b/service/rest-service.lisp
@@ -0,0 +1,33 @@
+;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+(declaim (optimize (speed 0) (safety 3) (debug 3)))
+
+(in-package #:music-dispensary)
+
+;; ========================================================================== ;;
+
+(defclass rest-service (base-service)
+  ((location :initarg :location
+             :initform nil
+             :accessor location)
+   (location-p :initarg :location-p
+               :initform t
+               :accessor location-p)
+   (errormsg :initarg :errormsg
+             :initform nil
+             :accessor errormsg)
+   (message :initarg :message
+            :initform nil
+            :accessor message))
+  (:documentation ""))
+
+(defmethod initialize-instance :after ((rest-service rest-service) &key)
+  (when (and (location-p rest-service) (null (location rest-service)))
+    (setf (location rest-service) (type-to-path rest-service))
+    (setf (session-value :location) (location rest-service))))
+
+(defun location-json ()
+  (let ((location (if (session-value :location) (session-value :location) "/home")))
+  (format nil "{\"location\":\"~a\"}" location)))
+
+(defun type-to-path (rest-type)
+  (concatenate 'string "/" (ppcre:regex-replace "-" (string-downcase (type-of rest-type)) "/")))