diff options
| author | ckonstanski <ckonstanski@pippiandcarlos.com> | 2018-02-06 21:42:54 -0700 |
|---|---|---|
| committer | ckonstanski <ckonstanski@pippiandcarlos.com> | 2018-02-06 21:42:54 -0700 |
| commit | 142166df54eda65925921799a4bb3e7f6cdaba48 (patch) | |
| tree | 5dc70e16bd6719079651925b5c5769211a3bf27e | |
initial commit
32 files changed, 1741 insertions, 0 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..696753b --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +*~ +*swp +*.fasl diff --git a/condition/condition.lisp b/condition/condition.lisp new file mode 100644 index 0000000..9c2c25b --- /dev/null +++ b/condition/condition.lisp @@ -0,0 +1,9 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:music-dispensary) + +;; ========================================================================== ;; + +(define-condition handled-error (error) + ((text :initarg :text :reader text))) diff --git a/core/coreutils.lisp b/core/coreutils.lisp new file mode 100644 index 0000000..591168f --- /dev/null +++ b/core/coreutils.lisp @@ -0,0 +1,84 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(defpackage #:music-dispensary + (:use #:cl #:cl-log #:hunchentoot) + (:export #:music-dispensary)) + +(in-package #:music-dispensary) + +;; ========================================================================== ;; + +(defparameter *server-root* (namestring (asdf:system-relative-pathname (intern (package-name *package*)) "./")) + "The location of the web server root on the filesystem.") + +;; ========================================================================== ;; + +(defmacro with-gensyms (syms &body body) + `(let ,(mapcar #'(lambda (s) + `(,s (gensym))) + syms) + ,@body)) + +(defmacro once-only ((&rest names) &body body) + (let ((gensyms (loop for n in names collect (gensym)))) + `(let (,@(loop for g in gensyms collect `(,g (gensym)))) + `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) + ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) + ,@body))))) + +(defun logger (output) + "Logs output to the cl-log log file." + (log-message :info (format nil "~a: ~a" (net.telent.date:universal-time-to-rfc2822-date (get-universal-time)) output))) + +(defmacro add-to-list (output-list &rest value-to-add) + "Wraps the SETF...APPEND idiom in a smaller package." + `(setf ,output-list (append ,output-list ,@value-to-add))) + +(defun match-it (regex field) + "Wraps a PCRE search in a smaller package." + (cl-ppcre:all-matches-as-strings regex field)) + +(defun map-slot-names (instance) + "Returns a list of the names of all the slots of any class instance +using reflection. The returned values are symbols. Only works with +SBCL. Implementations for other lisps welcome." + #+sbcl + (mapcar #'sb-mop:slot-definition-name + (sb-mop:class-slots (class-of instance)))) + +(defun make-document-root-path (document-root relative-path) + "Makes a relative filesystem path into a full one, using +`document-root' as the base." + (concatenate 'string document-root relative-path)) + +(defun make-server-path (relative-path) + "Makes a relative filesystem path into a full one, using +`*server-root*' as the base." + (make-document-root-path *server-root* relative-path)) + +(defun null-or-empty-p (sequence) + (or (null sequence) (equal (length sequence) 0))) + +(defun shell-wrapper (command) + "Calls a shell command and returns the output as a list, where each +atom of the list is a string that contains one line of the output." + (let ((output (make-array '(0) :element-type 'character :fill-pointer 0 :adjustable t))) + (with-output-to-string (stream output) + (uffi:run-shell-command command :output stream)) + (loop for line in (ppcre:split #\Newline output) + collect line))) + +(defun reduce-to-char-separated-string (mylist char) + (format nil "~a" (reduce (lambda (&optional x y) + (cond ((and x y) (format nil "~a~a~a" x char y)) + ((and x (not y)) (format nil "~a" x)) + ((and (not x) y) (format nil "~a" y)) + (t ""))) + mylist))) + +(defun reduce-to-comma-separated-string (mylist) + (reduce-to-char-separated-string mylist ",")) + +(defun reduce-to-newline-separated-string (mylist) + (reduce-to-char-separated-string mylist #\Newline)) diff --git a/core/html.lisp b/core/html.lisp new file mode 100644 index 0000000..f5c5304 --- /dev/null +++ b/core/html.lisp @@ -0,0 +1,324 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +;; Lifted directly from araneida. + +(in-package :music-dispensary) + +;;; XXX fix this, it's not correct +(defun html-reserved-p (c) + (member c '(#\< #\" #\> #\&))) + +(defun html-escape (html-string) + (apply #'concatenate 'string + (loop for c across html-string + if (html-reserved-p c) + collect (format nil "&#~A;" (char-code c)) + else if (eql c #\Newline) collect "<br>" + else collect (string c)))) + +(defun s. (&rest args) + "Concatenate ARGS as strings" + (declare (optimize (speed 3))) + (let ((*print-pretty* nil)) + (with-output-to-string (out) + (dolist (arg args) + (princ arg out))))) + +(defun html-escape-tag (tag attrs content) + (declare (ignore tag attrs)) + (s. (mapcar #'html-escape content))) + +(setf (get 'escape 'html-converter) #'html-escape-tag) +(setf (get 'null 'html-converter) #'princ-to-string) + +(macrolet ((html-attr-body () + `(with-output-to-string (o) + (loop for (att val . rest) on attr by #'cddr do + (cond + #+parenscript((and (symbolp att) (equal (symbol-name 'css) (symbol-name att))) + (progn + (princ " " o) + (princ "style=\"" o) + (princ (val-printer (parenscript::css-inline-func val)) o) + (princ "\"" o))) + ((symbolp att) + (progn + (princ " " o) + (princ (symbol-name att) o) + (princ "=\"" o) + (princ (val-printer val) o) + (princ "\"" o))) + (t + (error "attribute ~S is not a symbol in attribute list ~S" att attr))))))) + (defun html-attr (attr) + (macrolet ((val-printer (val) + val)) + (html-attr-body))) + (defun html-attr-escaped (attr) + (macrolet ((val-printer (val) + `(html-escape ,val))) + (html-attr-body)))) + +(defun empty-element-p (tag) + (member (intern (symbol-name tag) #.*package*) '())) + +(defmacro defhtmltag (tag (attributes-var content-var) &body body) + "Define a custom HTML tag +Useful for custom phrases, or even special constructs. + +Example: +(defhtmltag coffee (attr content) + (declare (ignore attr content)) + \"c|_|\") + +So, saying +(span \"Nice hot \" (coffee)) + +Would produce: +<span>Nice hot c|_|</span> + +More in-depth use would be something such as: +(even-odd-list + (li \"one\") + (li \"two\") + (li \"three\")) + +Turning into: +(ul + ((li :class \"odd\") \"one\") + ((li :class \"even\") \"two\") + ((li :class \"odd\") \"odd\")) + +Your custom tag is expected to return either a string or +an html construct like you'd pass to HTML-STREAM." + (with-gensyms (throw-away) + `(setf (get ',tag :html-converter) + (lambda (,throw-away ,attributes-var ,content-var) + (declare (ignore ,throw-away)) + (funcall + (lambda (,attributes-var ,content-var) + ,@body) + ,attributes-var ,content-var))))) + +(defun htmlp (html) + "Returns t if html is a legal HTML list. +NB: HTML and friends print out a superset of legal html lists. + +'(ul (li \"yes\") (li \"no\")) is legal +3 is not + +But HTML will print both of them" + (and (consp html) + (not (stringp (car html))))) + +(defmacro destructure-html ((tag-sym attrs-sym content-sym) html &body body) + "Destructure an HTML construct. +(destructure-html (tag attrs content) '((span :class \"strange\") \"A strange span!\") + (format t \"<~A ~{~A~}>~{~A~}</~A>\" tag attrs content tag)) +If the construct is invalid, it will cause an error" + (once-only (html) + `(if (htmlp ,html) + (let ((,tag-sym (if (consp (car ,html)) + (caar ,html) + (car ,html))) + (,attrs-sym (if (consp (car ,html)) + (cdar ,html) + nil)) + (,content-sym (cdr ,html))) + ,@body)))) + +; I admit, this is a rather goofy way to write this. There's just so much code they have in common +; and this lets me modify them rather easily. +(macrolet ((html-body () + `(ret-block + (cond ((htmlp things) + (destructure-html (tag attrs content) things + (let ((special-effect (get tag :html-converter))) + (if special-effect + (if (not (functionp special-effect)) + (error "Tag ~A has :html-converter set, but NOT as a function." tag) + (call-self stream (funcall special-effect tag attrs content) inline-elements)) + (cond ((equal (symbol-name 'comment) (symbol-name tag)) + (printing + (format-out "<!-- ~{~A ~}~%" attrs) + (iter-list (c content) + (call-self stream c inline-elements)) + (format-out " -->~%"))) + #+parenscript + ((equal (symbol-name 'css) (symbol-name tag)) + (printing + (format-out "<style type=\"text/css\">~%") + (format-out "<!--~%") + (iter-list (c content) + (format-out (parenscript::css-rule-to-string (parenscript::make-css-rule (car c) (cdr c))))) + (format-out "~%-->") + (format-out "</style>"))) + #+parenscript + ((equal (symbol-name 'js-script) (symbol-name tag)) + (printing + (format-out "<script type=\"text/javascript\">~%") + (format-out "// <![CDATA[~%") + (format-out (parenscript:js* (cons 'progn content))) + (format-out "~%// ]]>~%"))) + ((not (empty-element-p tag)) + (printing + (format-out "<~A~A>" (symbol-name tag) (attr-printer attrs)) + (iter-list (c content) + (call-self stream c inline-elements)) + (format-out "</~A>~:[~;~%~]" + (symbol-name tag) + (not (member tag inline-elements))))) + (t + (format-out "<~A~A>" (symbol-name tag) (attr-printer attrs)))))))) + ((consp things) + (iter-list (thing things) (format-out "~A" thing))) + ((functionp things) + (call-function things stream)) + ((keywordp things) + (format-out "<~A>" (symbol-name things))) + (t + (format-out "~A" (thing-printer things))))))) + + ;; stream forms first + (macrolet ((ret-block (output-block) + `(progn + ,output-block + t)) + (iter-list ((item list) func) + `(dolist (,item ,list) + ,func)) + (printing (&body list) + `(progn + ,@list)) + (format-out (&rest args) + `(format stream ,@args)) + (call-function (things stream) + `(funcall ,things ,stream))) + + (defun html-stream (stream things &optional inline-elements) + "Format supplied argument as HTML. Argument may be a string +\(returned unchanged\) or a list of \(tag content\) where tag may be +\(tagname attrs\). \(\(a :href \"/ \"\) \"home\"\) is formatted as +you'd expect it to be. INLINE-ELEMENTS is a list of elements not to +print a newline after. Returns T unless broken, so can be the last +form in a handler For special effects, set the HTML-CONVERTER property +of a symbol for a tag to a function. It will be called with arguments +\(TAG ATTRS CONTENT\) and should return a string to be interpolated at +that point." + (declare (optimize (speed 3)) + (type stream stream)) + (macrolet ((attr-printer (attrs) + `(html-attr ,attrs)) + (call-self (stream things &optional inline-elements) + `(html-stream ,stream ,things ,inline-elements)) + (thing-printer (things) + `(princ-to-string things))) + (html-body))) + + (defun html-escaped-stream (stream things &optional inline-elements) + "Format supplied argument as HTML, escaping properly. +Just like html-stream except certain things are now html-escaped. +Content - in '\(p \"foo\"\) \"foo\" is the content - is escaped, as +well as the values of attributes. Please note that this CAN result in +double escaping if calling code also escapes. For special effects, +set the HTML-CONVERTER property of a symbol for a tag to a function. +It will be called with arguments \(TAG ATTRS CONTENT\) and should +return a string to be interpolated at that point. NB that the attrs +and content will be passed in *unescaped*" + (declare (optimize (speed 3)) + (type stream stream)) + (macrolet ((attr-printer (attrs) + `(html-attr-escaped ,attrs)) + (call-self (stream things &optional inline-elements) + `(html-escaped-stream ,stream ,things ,inline-elements)) + (thing-printer (things) + `(html-escape (princ-to-string ,things)))) + (html-body)))) + + ;; now for the string forms + (macrolet ((ret-block (output-block) + output-block) + (iter-list ((item list) func) + `(apply #'concatenate 'string (mapcar (lambda (,item) ,func) ,list))) + (printing (&body list) + `(concatenate 'string + ,@list)) + (format-out (&rest args) + `(format nil ,@args)) + (call-function (things stream) + (declare (ignore stream)) + `(funcall ,things))) + + (defun html (things &optional inline-elements) + "Format supplied argument as HTML. Argument may be a string +\(returned unchanged\) or a list of \(tag content\) where tag may be +\(tagname attrs\). \(\(a :href \"/\"\) \"home\"\) is formatted as +you'd expect it to be. For special effects, set the HTML-CONVERTER +property of a symbol for a tag to a function. It will be called with +arguments \(TAG ATTRS CONTENT\) and should return a string to be +interpolated at that point." + (declare (optimize (speed 3))) + (macrolet ((attr-printer (attrs) + `(html-attr ,attrs)) + (call-self (stream things &optional inline-elements) + `(html ,things ,inline-elements)) + (thing-printer (things) + `(princ-to-string ,things))) + (html-body))))) + +(defun html5 (things &optional inline-elements) + (format nil "<!DOCTYPE html>~%~a" (html things inline-elements))) + +#|| +(search-html-tree '((string> ht :element) t (= p :element)) '((html) ((body) ((p) "foo") ((p) "bar") ((div :title "titl") "blah")))) +||# + +(defun search-html-tree (search-terms tree) + (labels ((node-matches (term tree) + (or (eql term t) + (destructuring-bind (op content name) term + (let ((r-op (if (eql op '=) 'equal op))) + (if (eql name :element) + (funcall r-op content (caar tree)) + (funcall r-op content (getf (cdar tree) name)))))))) + (cond ((eql (cdr search-terms) nil) + (and (node-matches (car search-terms) tree) tree)) + ((null tree) nil) + ((node-matches (car search-terms) tree) + (remove-if #'null + (mapcar (lambda (tr) + (search-html-tree (cdr search-terms) tr)) + (cdr tree))))))) + + +#+parenscript +(defmacro css-file (request &rest rules) + "Sends CSS as a file in response to request, as specified by rules. + For example: + (defmethod handle-request-response ((handler my-handler) method request) + (css-file request + (* :border \"1px solid black\") + (div.bl0rg :font-family \"serif\") + ((\"a:active\" \"a:hoover\") :color \"black\" :size \"200%\"))) + See the documentation for Parenscript for more info on the CSS rules themselves." + `(progn + (request-send-headers ,request :content-type "text/css") + ,@(mapcar (lambda (rule) + `(princ (parenscript::css-rule-to-string (parenscript::css-rule ,@rule)) (request-stream ,request))) + rules) + t)) + +#+parenscript +(defmacro js-file (request &rest body) + "Sends Javascript as a file in response to request, as specified by the javascript body. + For example: + (defmethod handle-request-response ((handler my-handler) method request) + (js-file request + (defun hello () + (alert \"Hello, World!\")))) + See the documentation for Parenscript for more info on how to do Javascript." + `(progn + (request-send-headers ,request :content-type "text/javascript") + (princ (parenscript:js ,@body) (request-stream ,request)) + t)) diff --git a/file/file-browser.lisp b/file/file-browser.lisp new file mode 100644 index 0000000..4694374 --- /dev/null +++ b/file/file-browser.lisp @@ -0,0 +1,72 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:music-dispensary) + +;; ========================================================================== ;; + +(defclass file-browser () + ((document-root :initarg :document-root + :initform nil + :accessor document-root + :documentation "The highest level directory that the +user is allowed to navigate to. Ends in a slash.") + (relative-path :initarg :relative-path + :initform nil + :accessor relative-path + :documentation "Add this to `document-root' +to get to the current directory, whose contents are to be +displayed.") + (mime-extensions :initarg :mime-extensions + :initform nil + :accessor mime-extensions + :documentation "A list of MIME file extensions +that, if not `nil', will limit directory listings to show only those +files that contain these extensions.") + (nodes :initarg :nodes + :initform () + :accessor nodes + :documentation "The nodes of the current directory. A list +of dotted pairs in the form '(([:directory|:file|:symlink] . <node-name>)).")) + (:documentation "Used for directory-browsing. Keeps track of +directory-navigating state in the `user-session'.")) + +(defmethod absolute-path ((file-browser file-browser)) + (ppcre:regex-replace-all "//" + (format nil "~a/~a" (or (document-root file-browser) "") (or (relative-path file-browser) "")) + "/")) + +(defmethod update-relative-path ((file-browser file-browser) node) + (when (not (null-or-empty-p node)) + (if (equal node "..") + (if (null-or-empty-p (relative-path file-browser)) + (setf (relative-path file-browser) "") + (setf (relative-path file-browser) (let ((path-list (nreverse (remove-if 'null-or-empty-p (ppcre:split "/" (relative-path file-browser))))) + (new-path "")) + (pop path-list) + (loop for path-part in (nreverse path-list) do + (setf new-path (format nil "~a~a/" new-path path-part))) + (ppcre:regex-replace-all "/$" new-path "")))) + (if (null-or-empty-p (relative-path file-browser)) + (setf (relative-path file-browser) node) + (setf (relative-path file-browser) (format nil "~a/~a" (relative-path file-browser) node)))))) + +(defmethod directory-list ((file-browser file-browser)) + (labels ((finder (type) + (remove-if 'null (mapcar (lambda (line) + (when (not (or (equal line "."))) + (let ((item (ppcre:regex-replace-all "\\./" line ""))) + (when (or (null (mime-extensions file-browser)) + (equal type "d") + (remove-if-not (lambda (x) + (match-it (format nil "~a$" x) item)) + (mime-extensions file-browser))) + (cons (cond ((equal type "d") :directory) + ((equal type "f") :file) + ((equal type "l") :symlink)) + item))))) + (shell-wrapper (format nil + "pushd '~a' >/dev/null ; find -maxdepth 1 -type ~a | sort ; popd >/dev/null" + (absolute-path file-browser) + type)))))) + (setf (nodes file-browser) (remove-if 'null (append `((:directory . "..")) (finder "d") (finder "f") (finder "l")))))) diff --git a/file/file-utils.lisp b/file/file-utils.lisp new file mode 100644 index 0000000..604a20f --- /dev/null +++ b/file/file-utils.lisp @@ -0,0 +1,28 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:music-dispensary) + +;; ========================================================================== ;; + +(defun mkdir (path) + (uffi:run-shell-command (format nil "mkdir -p ~a" path))) + +(defun file-exists-p (file-path) + (equal (car (shell-wrapper (format nil "if test -f '~a'; then echo 0; else echo 1; fi" file-path))) "0")) + +(defun directory-p (absolute-path) + (if (car (shell-wrapper (format nil "file '~a' |grep 'directory'" absolute-path))) t nil)) + +(defun symlink-p (absolute-path) + (if (car (shell-wrapper (format nil "file '~a' |grep 'symbolic link'" absolute-path))) t nil)) + +(defun file-p (absolute-path) + (if (or (directory-p absolute-path) (symlink-p absolute-path)) nil t)) + +(defun find-files (working-dir base-dir pattern) + (shell-wrapper (format nil + "pushd ~a >/dev/null 2>&1 ; find ~a -iname '~a' ; popd >/dev/null 2>&1" + working-dir + base-dir + pattern))) diff --git a/file/generics.lisp b/file/generics.lisp new file mode 100644 index 0000000..a4dea2f --- /dev/null +++ b/file/generics.lisp @@ -0,0 +1,17 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:music-dispensary) + +;; ========================================================================== ;; + +(defgeneric absolute-path (file-browser) + (:documentation "Returns the absolute path of `file-browser'.")) + +(defgeneric update-relative-path (file-browser node) + (:documentation "Updates `relative-path' of `file-browser' by adding +a `node' to it. If `node' is '..', `relative-path' is reduced a +level.")) + +(defgeneric directory-list (file-browser) + (:documentation "")) diff --git a/json/json-utils.lisp b/json/json-utils.lisp new file mode 100644 index 0000000..7ebe3bf --- /dev/null +++ b/json/json-utils.lisp @@ -0,0 +1,76 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:music-dispensary) + +;; ========================================================================== ;; + +(defun json-to-object (object-type json-obj) + (remove-if-not (lambda (x) + (let ((found-value nil)) + (loop for slot in (map-slot-names x) do + (when (slot-value x slot) + (setf found-value t))) + found-value)) + (mapcar (lambda (obj) + (let ((object (make-instance object-type))) + (loop for slot in (map-slot-names object) do + (let ((symb (intern (symbol-name slot) :keyword))) + (setf (slot-value object slot) + (cdr (find-if (lambda (param) (eq (car param) symb)) obj))))) + object)) + json-obj))) + +;; ========================================================================== ;; + +(defun objects-to-json (list-of-objects &optional (explicit-encoder-p nil)) + (labels ((objectp (object) + (not (eq () (remove-if 'null (mapcar (lambda (superclass) + (eq (class-name superclass) 'base-service)) + (sb-mop:class-direct-superclasses (class-of object))))))) + (list-of-lists-p (object) + (and (listp object) + (find-if (lambda (y) (not (null y))) + (mapcar (lambda (x) + (listp x)) + object)))) + (list-of-objects-p (object) + (and (listp object) + (find-if (lambda (y) (not (null y))) + (mapcar (lambda (x) + (objectp x)) + object)))) + (map-slots (object) + (remove-if 'null (mapcar (lambda (slot) + (let ((symb (intern (symbol-name slot) :keyword)) + (value (slot-value object slot))) + (when value + (cons symb (cond ((or (equal value (json:json-bool t)) + (equal value (json:json-bool nil))) + value) + ((list-of-lists-p value) + (listify value)) + ((list-of-objects-p value) + (if explicit-encoder-p + (error "Can't do list-of-objects with the explicit encoder.") + (listify value))) + ((listp value) + (map 'vector #'identity value)) + ((objectp value) + (if explicit-encoder-p + (cons :object (map-slots value)) + (map-slots value))) + (t + value)))))) + (map-slot-names object)))) + (listify (list-of-objects) + (mapcar (lambda (object) + (map-slots object)) + list-of-objects))) + (let ((listobj (listify list-of-objects))) + (reduce-to-comma-separated-string (mapcar (lambda (alist) + (if explicit-encoder-p + (json:with-explicit-encoder + (json:encode-json-to-string (cons :object alist))) + (json:encode-json-alist-to-string alist))) + listobj))))) diff --git a/music-dispensary.asd b/music-dispensary.asd new file mode 100644 index 0000000..7b38838 --- /dev/null +++ b/music-dispensary.asd @@ -0,0 +1,66 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:cl) + +;; ========================================================================== ;; + +(defpackage #:music-dispensary-system (:use #:cl #:asdf)) +(in-package #:music-dispensary-system) + +(defmacro do-defsystem (&key name version maintainer author description long-description depends-on components) + `(defsystem ,name + :name ,name + :version ,version + :maintainer ,maintainer + :author ,author + :description ,description + :long-description ,long-description + :depends-on ,(eval depends-on) + :components ,components)) + +(defparameter *asdf-packages* '(net-telent-date cl-ppcre uffi hunchentoot cl-log ironclad cl-json)) + +(loop for pkg in *asdf-packages* do + (ql:quickload (symbol-name pkg))) + +(do-defsystem :name "music-dispensary" + :version "1" + :maintainer "Carlos Konstanski <ckonstanski@pippiandcarlos.com>" + :author "Carlos Konstanski <ckonstanski@pippiandcarlos.com>" + :description "music-dispensary" + :long-description "music-dispensary is a webapp that lets the user select a lilypond file and a paper size and uses those imputs generate the resulting PDF." + :depends-on *asdf-packages* + :components ((:module core + :components ((:file "coreutils") + (:file "html" :depends-on ("coreutils")))) + (:module condition + :depends-on (core) + :components ((:file "condition"))) + (:module file + :depends-on (condition) + :components ((:file "file-utils") + (:file "generics") + (:file "file-browser" :depends-on ("generics" "file-utils")))) + (:module json + :depends-on (condition) + :components ((:file "json-utils"))) + (:module service + :depends-on (json) + :components ((:file "base-service") + (:file "rest-service" :depends-on ("base-service")) + (:file "auth-service" :depends-on ("rest-service")) + (:file "generic-form" :depends-on ("rest-service")) + (:file "menu" :depends-on ("base-service")) + (:file "home" :depends-on ("rest-service")) + (:file "login" :depends-on ("generic-form")) + (:file "login-authenticate" :depends-on ("rest-service")) + (:file "logout" :depends-on ("rest-service")) + (:file "browse" :depends-on ("rest-service")) + )) + (:module webapps + :depends-on (service) + :components ((:file "webapp-loader") + (:module music-dispensary + :depends-on ("webapp-loader") + :components ((:file "site"))))))) 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)) "/"))) diff --git a/webapps/music-dispensary/clojurescript/music-dispensary/.gitignore b/webapps/music-dispensary/clojurescript/music-dispensary/.gitignore new file mode 100644 index 0000000..c754477 --- /dev/null +++ b/webapps/music-dispensary/clojurescript/music-dispensary/.gitignore @@ -0,0 +1,14 @@ +target +classes +resources +checkouts +pom.xml +pom.xml.asc +*.jar +*.class +.lein-* +.nrepl-port +.hgignore +.hg +profiles.clj +figwheel_server.log diff --git a/webapps/music-dispensary/clojurescript/music-dispensary/README.md b/webapps/music-dispensary/clojurescript/music-dispensary/README.md new file mode 100644 index 0000000..2de33dd --- /dev/null +++ b/webapps/music-dispensary/clojurescript/music-dispensary/README.md @@ -0,0 +1,14 @@ +# music-dispensary + +A Clojure library designed to ... well, that part is up to you. + +## Usage + +FIXME + +## License + +Copyright © 2017 FIXME + +Distributed under the Eclipse Public License either version 1.0 or (at +your option) any later version. diff --git a/webapps/music-dispensary/clojurescript/music-dispensary/project.clj b/webapps/music-dispensary/clojurescript/music-dispensary/project.clj new file mode 100644 index 0000000..e904105 --- /dev/null +++ b/webapps/music-dispensary/clojurescript/music-dispensary/project.clj @@ -0,0 +1,13 @@ +(defproject music-dispensary "0.1.0-SNAPSHOT" + :description "An LDAP adminitration utility written in SBCL on the + server-side and ClojureScript on the client-side. This is the + client-side component." + :url "FIXME" + :license "public domain" + :dependencies [[org.clojure/clojure "LATEST"] + [org.clojure/clojurescript "LATEST"] + [cljs-ajax "LATEST"] + [prismatic/dommy "LATEST"] + [hiccups "LATEST"]] + :plugins [[lein-cljsbuild "LATEST"]] + :clean-targets ^{:protect false} [:target-path "out" "resources/public/cljs"]) diff --git a/webapps/music-dispensary/clojurescript/music-dispensary/src/core.cljs b/webapps/music-dispensary/clojurescript/music-dispensary/src/core.cljs new file mode 100644 index 0000000..d640d1b --- /dev/null +++ b/webapps/music-dispensary/clojurescript/music-dispensary/src/core.cljs @@ -0,0 +1,330 @@ +(ns music-dispensary.core + (:require-macros [hiccups.core :as hiccups :refer [html]]) + (:require [ajax.core :refer [GET POST]] + [dommy.core :as dommy] + [hiccups.runtime :as hiccupsrt])) + +;; ========================================================================== ;; +;; declarations + +(enable-console-print!) + +(declare template-message) +(declare maybe-error) +(declare maybe-message) +(declare notifications) +(declare auth-notifications) +(declare template-generic-form) +(declare template-menu) +(declare handler-menu) +(declare render-menu) +(declare template-home) +(declare handler-home) +(declare render-home) +(declare handler-login) +(declare render-login) +(declare handler-login-authenticate) +(declare render-login-authenticate) +(declare handler-logout) +(declare render-logout) +(declare template-browse) +(declare handler-browse) +(declare render-browse) +(declare on-browse-browser-node-clicked) +(declare template-browse-browser) +(declare handler-browse-browser) +(declare render-browse-browser) +(declare on-browse-papersize-clicked) +(declare template-browse-papersize) +(declare handler-browse-papersize) +(declare render-browse-papersize) +(declare handler-browse-generate) +(declare render-browse-generate) +(declare on-menu-clicked) +(declare handler-location) +(declare goto-location) + +;; ========================================================================== ;; +;; notifications + +(hiccups/defhtml template-error [errormsg] + [:div {:class "alert alert-danger"} errormsg]) + +(hiccups/defhtml template-message [message] + [:div {:class "alert alert-success"} message]) + +(defn maybe-error [jsonobj] + (cond (get jsonobj "errormsg") + (dommy/set-html! (dommy/sel1 :#errormsg) + (template-error (get jsonobj "errormsg"))) + :else + (dommy/set-html! (dommy/sel1 :#errormsg) ""))) + +(defn maybe-message [jsonobj] + (cond (get jsonobj "message") + (dommy/set-html! (dommy/sel1 :#message) + (template-message (get jsonobj "message"))) + :else + (dommy/set-html! (dommy/sel1 :#message) ""))) + +(defn notifications [jsonobj] + (maybe-error jsonobj) + (maybe-message jsonobj)) + +(defn auth-notifications [jsonobj] + (when (get jsonobj "errormsg") + (render-home) + (render-menu))) + +;; ========================================================================== ;; +;; forms + +(hiccups/defhtml template-generic-form + ([jsonobj] + (template-generic-form jsonobj "on_menu_clicked")) + ([jsonobj onclick] + [:form {:name (get jsonobj "name") + :id (get jsonobj "name") + :class "form-horizontal" + :method (get jsonobj "httpMethod")} + (for [form-field (get jsonobj "formFields")] + (cond (= (get form-field "fieldType") "button") + [:div {:class "col-sm-offset-2 col-sm-10"} + [:button {:name (get form-field "name") + :id (get form-field "name") + :type (get form-field "fieldType") + :class "btn btn-primary" + :data-dismiss "modal" + :onclick (str (clojure.string/replace (namespace ::x) "-" "_") "." onclick "('" (get jsonobj "action") "')")} + (get form-field "label")]] + :else + [:div {:class "form-group"} + [:label {:for (get form-field "name") + :class "control-label col-sm-2"} + (get form-field "label")] + [:div {:class "col-sm-10"} + [:input {:name (get form-field "name") + :id (get form-field "name") + :type (get form-field "fieldType") + :class "form-control"}]]]))])) + +;; ========================================================================== ;; +;; menu + +(hiccups/defhtml template-menu [menuitems] + [:div {:class "row"} + (for [menuitem menuitems] + [:div {:class "col-lg-3"} + [:a {:class "menuitem" + :id (get menuitem "id") + :onclick (str (clojure.string/replace (namespace ::x) "-" "_") ".on_menu_clicked('" (get menuitem "handler") "')")} + (get menuitem "label")]])]) + +(defn handler-menu [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (dommy/set-html! (dommy/sel1 :#menu) (template-menu (get jsonobj "menuitems"))))) + +(defn render-menu [] + (GET "/menu" {:handler handler-menu})) + +;; ========================================================================== ;; +;; home + +(hiccups/defhtml template-home [jsonobj] + [:p {:align "center"} (get jsonobj "content")]) + +(defn handler-home [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (dommy/set-html! (dommy/sel1 :#body) (template-home jsonobj)))) + +(defn render-home [] + (GET "/home" {:handler handler-home})) + +;; ========================================================================== ;; +;; login + +(defn handler-login [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (notifications jsonobj) + (dommy/set-html! (dommy/sel1 :#body) (template-generic-form jsonobj)))) + +(defn render-login [] + (GET "/login" {:handler handler-login})) + +;; ========================================================================== ;; +;; login-authenticate + +(defn handler-login-authenticate [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (cond (get jsonobj "errormsg") + (render-login) + (get jsonobj "message") + (render-home)) + (render-menu) + (notifications jsonobj))) + +(defn render-login-authenticate [] + (POST "/login/authenticate" {:format :raw + :params {:username (dommy/value (dommy/sel1 :#username)) + :password (dommy/value (dommy/sel1 :#password))} + :handler handler-login-authenticate})) + +;; ========================================================================== ;; +;; logout + +(defn handler-logout [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (render-home) + (render-menu) + (notifications jsonobj))) + +(defn render-logout [] + (GET "/logout" {:handler handler-logout})) + +;; ========================================================================== ;; +;; browse + +(hiccups/defhtml template-browse [jsonobj] + [:p {:align "center"} (get jsonobj "instructions")] + [:div {:class "row"} + [:div {:class "col-lg-6"} + [:div {:id "browser"}]] + [:div {:class "col-lg-6"} + [:div {:id "papersize"}]]]) + +(defn handler-browse [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (dommy/set-html! (dommy/sel1 :#body) (template-browse jsonobj)) + (render-browse-browser) + (render-browse-papersize))) + +(defn render-browse [] + (GET "/browse" {:handler handler-browse})) + +;; ========================================================================== ;; +;; browse-browser + +(defn on-browse-browser-node-clicked [node] + (dommy/set-value! (dommy/sel1 :#node) node) + (cond (clojure.string/ends-with? node ".ly") + (do + (dommy/set-value! (dommy/sel1 :#file) node) + (dommy/set-style! (dommy/sel1 :#generate) :display "inline")) + (clojure.string/ends-with? node ".pdf") + (render-browse-generate node) + :else + (render-browse-browser))) + +(hiccups/defhtml template-browse-browser [jsonobj] + [:form {:name "browse-browser-form" + :id "browse-browser-form"} + [:input {:type "hidden" + :name "relative-path" + :id "relative-path" + :value (get jsonobj "relativePath")}] + [:input {:type "hidden" + :name "node" + :id "node" + :value ""}]] + (for [node (get jsonobj "nodes")] + [:p + [:img {:src (str "static/images/" (cond (= (get node "nodeType") "directory") "folder-icon.jpg" :else "file-icon.jpg"))}] + " " + [:a {:style "cursor:pointer; cursor:hand;" + :onclick (str (clojure.string/replace (namespace ::x) "-" "_") ".on_browse_browser_node_clicked('" (get node "path") "')")} + (cond (= (get node "path") "..") [:i "Up one level"] :else (get node "path"))]])) + +(defn handler-browse-browser [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (dommy/set-html! (dommy/sel1 :#browser) (template-browse-browser jsonobj)))) + +(defn render-browse-browser [] + (POST "/browse/browser" {:format :raw + :params {:relative-path (cond (dommy/sel1 :#relative-path) (dommy/value (dommy/sel1 :#relative-path)) :else "") + :node (cond (dommy/sel1 :#node) (dommy/value (dommy/sel1 :#node)) :else "")} + :handler handler-browse-browser})) + +;; ========================================================================== ;; +;; browse-papersize + +(defn on-browse-papersize-clicked [] + (let [jquery (js* "$")] + (dommy/set-style! (dommy/sel1 :#generate) :display "none") + (render-browse-generate (dommy/value (dommy/sel1 :#file)) (.val (jquery "#papersize :selected"))))) + +(hiccups/defhtml template-browse-papersize [jsonobj] + [:form {:name "browse-papersize-form" + :id "browse-papersize-form" + :class "form-horizontal"} + [:div {:class "form-group"} + [:label {:for "papersize" + :class "control-label"} + "The file you selected"] + [:input {:type "text" + :name "file" + :id "file" + :value "" + :class "form-control" + :readonly "readonly"}]] + [:div {:class "form-group"} + [:label {:for "papersize" + :class "control-label"} + "Select a paper size"] + [:select {:name "papersize" + :id "papersize" + :class "form-control"} + (for [papersize (get jsonobj "papersizes")] + [:option {:value (get papersize "name")} (str (get papersize "name") " " (get papersize "size"))])]] + [:div {:class "form-group"} + [:button {:type "button" + :name "generate" + :id "generate" + :data-dismiss "modal" + :style "display:none;" + :onclick (str (clojure.string/replace (namespace ::x) "-" "_") ".on_browse_papersize_clicked()")} + "Generate PDF"]]]) + +(defn handler-browse-papersize [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (dommy/set-html! (dommy/sel1 :#papersize) (template-browse-papersize jsonobj)))) + +(defn render-browse-papersize [] + (GET "/browse/papersize" {:handler handler-browse-papersize})) + +;; ========================================================================== ;; +;; browse-generate + +(defn handler-browse-generate [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (.open js/window (get jsonobj "url")))) + +(defn render-browse-generate + ([node] + (POST "/browse/generate" {:format :raw + :params {:file node :papersize ""} + :handler handler-browse-generate})) + ([node papersize] + (POST "/browse/generate" {:format :raw + :params {:file node :papersize papersize} + :handler handler-browse-generate}))) + +;; ========================================================================== ;; +;; location + +(defn on-menu-clicked [handler] + (cond (= handler "/home") (render-home) + (= handler "/login") (render-login) + (= handler "/login/authenticate") (render-login-authenticate) + (= handler "/logout") (render-logout) + (= handler "/browse") (render-browse))) + +(defn handler-location [response] + (let [jsonobj (js->clj (js/JSON.parse response))] + (on-menu-clicked (get jsonobj "location")) + (render-menu) + (notifications jsonobj))) + +(defn goto-location [] + (GET "/location" {:handler handler-location})) + +(set! (.-onload js/window) goto-location) diff --git a/webapps/music-dispensary/conf/.gitignore b/webapps/music-dispensary/conf/.gitignore new file mode 100644 index 0000000..14fa7a6 --- /dev/null +++ b/webapps/music-dispensary/conf/.gitignore @@ -0,0 +1 @@ +options.lisp diff --git a/webapps/music-dispensary/conf/options.lisp.example b/webapps/music-dispensary/conf/options.lisp.example new file mode 100644 index 0000000..dc3678c --- /dev/null +++ b/webapps/music-dispensary/conf/options.lisp.example @@ -0,0 +1,6 @@ +((:name "music-dispensary" + :url "music-dispensary.tld" + :document-root "music-dispensary" + :title "music-dispensary" + :meta-description "music-dispensary" + :mime-extensions ("ly" "pdf"))) diff --git a/webapps/music-dispensary/site.lisp b/webapps/music-dispensary/site.lisp new file mode 100644 index 0000000..f74236c --- /dev/null +++ b/webapps/music-dispensary/site.lisp @@ -0,0 +1,76 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:music-dispensary) + +;; ========================================================================== ;; + +(defmacro .base () + `(html5 + `(html + (head + ((meta :name "viewport" :content "width=device-width, initial-scale=1")) + ((meta :charset "utf-8")) + ((title) ,(title *webapp*)) + ,@(mapcar (lambda (css) + `((link :rel "stylesheet" :href ,css))) + '("https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/css/bootstrap.min.css"))) + ,@(mapcar (lambda (js) + `((script :type "text/javascript" :src ,js))) + '("https://ajax.googleapis.com/ajax/libs/jquery/3.2.0/jquery.min.js" + "https://maxcdn.bootstrapcdn.com/bootstrap/3.3.7/js/bootstrap.min.js" + "/static/js/cljs/main.js")) + (body + ((div :class "container-fluid") + ((div :class "page-header") + ((h2 :align "center") ,(title *webapp*))) + ((div :id "menu" :class "well")) + ((div :id "errormsg")) + ((div :id "message")) + ((div :id "body"))))))) + +;; ========================================================================== ;; + +(defmacro .location () + `(location-json)) + +(defmacro .home () + `(home-json)) + +(defmacro .menu () + `(menu-json)) + +(defmacro .login () + `(login-json)) + +(defmacro .login-authenticate () + `(login-authenticate-json username password)) + +(defmacro .logout () + `(logout-json)) + +(defmacro .browse () + `(browse-json)) + +(defmacro .browse-browser () + `(browse-browser-json relative-path node)) + +(defmacro .browse-papersize () + `(browse-papersize-json)) + +(defmacro .browse-generate () + `(browse-generate-json file papersize)) + +;; ========================================================================== ;; + +(define-endpoint :get "/" () .base) +(define-endpoint :get "/location" () .location) +(define-endpoint :get "/home" () .home) +(define-endpoint :get "/menu" () .menu) +(define-endpoint :get "/login" () .login) +(define-endpoint :post "/login/authenticate" ((username :parameter-type 'string) (password :parameter-type 'string)) .login-authenticate) +(define-endpoint :get "/logout" () .logout) +(define-endpoint :get "/browse" () .browse) +(define-endpoint :post "/browse/browser" ((relative-path :parameter-type 'string) (node :parameter-type 'string)) .browse-browser) +(define-endpoint :get "/browse/papersize" () .browse-papersize) +(define-endpoint :post "/browse/generate" ((file :parameter-type 'string) (papersize :parameter-type 'string)) .browse-generate) diff --git a/webapps/music-dispensary/static/images/edit-delete.png b/webapps/music-dispensary/static/images/edit-delete.png Binary files differnew file mode 100644 index 0000000..b0de61d --- /dev/null +++ b/webapps/music-dispensary/static/images/edit-delete.png diff --git a/webapps/music-dispensary/static/images/file-icon.jpg b/webapps/music-dispensary/static/images/file-icon.jpg Binary files differnew file mode 100644 index 0000000..c6a2d9a --- /dev/null +++ b/webapps/music-dispensary/static/images/file-icon.jpg diff --git a/webapps/music-dispensary/static/images/folder-icon.jpg b/webapps/music-dispensary/static/images/folder-icon.jpg Binary files differnew file mode 100644 index 0000000..ed417be --- /dev/null +++ b/webapps/music-dispensary/static/images/folder-icon.jpg diff --git a/webapps/music-dispensary/static/js/cljs b/webapps/music-dispensary/static/js/cljs new file mode 120000 index 0000000..55fd981 --- /dev/null +++ b/webapps/music-dispensary/static/js/cljs @@ -0,0 +1 @@ +../../clojurescript/music-dispensary/resources/public/cljs
\ No newline at end of file diff --git a/webapps/music-dispensary/static/lilypond b/webapps/music-dispensary/static/lilypond new file mode 120000 index 0000000..34af233 --- /dev/null +++ b/webapps/music-dispensary/static/lilypond @@ -0,0 +1 @@ +/home/ckonstanski/Musik/lilypond
\ No newline at end of file diff --git a/webapps/webapp-loader.lisp b/webapps/webapp-loader.lisp new file mode 100644 index 0000000..679344e --- /dev/null +++ b/webapps/webapp-loader.lisp @@ -0,0 +1,145 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +(declaim (optimize (speed 0) (safety 3) (debug 3))) + +(in-package #:music-dispensary) + +(defvar *acceptor* nil) +(defvar *dispatch-table* '(#'dispatch-easy-handlers #'default-dispatcher)) +(defvar *webapps* (make-hash-table :test 'equal)) +(defvar *webapp* nil) +(defparameter *port* 3007) +(defparameter *session-timeout* 14400) + +(defclass webapp () + ((name :initarg :name + :initform nil + :accessor name + :documentation "The name of the webapp as used in the code. A +string used as the key to any webapp config lookup.") + (url :initarg :url + :initform nil + :accessor url + :documentation "The domain portion of the URL to the +root of the webapp.") + (document-root :initarg :document-root + :initform nil + :accessor document-root + :documentation "The absolute filesystem path to +the webapp's top-level directory, which is inside the webapps +folder.") + (title :initarg :title + :initform nil + :accessor title + :documentation "The default title that shows up in +the browser title bar.") + (meta-description :initarg :meta-description + :initform nil + :accessor meta-description + :documentation "The text that goes into the META DESCRIPTION +tag, and anywhere else we want to put this text so that it will show +up in Google.") + (mime-extensions :initarg :mime-extensions + :initform nil + :accessor mime-extensions)) + (:documentation "")) + +(defgeneric get-site-file-path (webapp) + (:documentation "Builds a full filesystem path to a webapp's site +file.")) + +(defmethod get-site-file-path ((webapp webapp)) + (format nil "~a/site" (document-root webapp))) + +(defgeneric get-pages-file-paths (webapp) + (:documentation "")) + +(defmethod get-pages-file-paths ((webapp webapp)) + (mapcar (lambda (pages-file) + (ppcre:regex-replace-all "\\.lisp$" (format nil "~a" pages-file) "")) + (remove-if (lambda (x) (equal x "shared")) + (shell-wrapper (format nil "find '~a' -maxdepth 1 -type f -iname 'pages*.lisp' |sort" (document-root webapp)))))) + +(defun make-webapp-path (relative-path) + "Makes an absolute filesystem path to a location in the webapps +folder." + (concatenate 'string *server-root* "webapps/" relative-path)) + +(defun get-options-files () + (mapcar (lambda (webapp-directory) + (format nil "~a/conf/options.lisp" webapp-directory)) + (remove-if (lambda (x) (or (match-it "webapps/$" x) + (match-it "webapps/shared$" x) + (match-it "webapps/CVS$" x) + (match-it "webapps/\\.$" x) + (match-it "webapps/\\.\\.$" x))) + (shell-wrapper (format nil "find '~a' -maxdepth 1 -type d |sort" (make-webapp-path "")))))) + +(defun set-webapp (webapp) + "Sets a `webapp' object in `*webapps*'. The lookup key is the +webapp name. If a webapp already exists under this key, it gets +overwritten with the new one." + (setf (gethash (name webapp) *webapps*) webapp)) + +(defun get-webapp (key) + "Gets the webapp object." + (gethash key *webapps*)) + +(defun generate-sessionid () + "Generates a unique random string to seed the +`*session-secret*'. The string is a SHA256 hash." + (let ((entropic-value (make-array '(32) :element-type '(unsigned-byte 8)))) + (with-open-file (urandom-file "/dev/urandom" :direction :input :element-type '(unsigned-byte 8)) + (loop for i from 0 to 31 do + (setf (elt entropic-value i) (read-byte urandom-file)))) + (let ((digest (ironclad:make-digest 'ironclad:sha256))) + (ironclad:update-digest digest entropic-value) + (ironclad:byte-array-to-hex-string (ironclad:produce-digest digest))))) + +(defun populate-webapps () + (loop for options-file in (get-options-files) do + (with-open-file (input options-file :direction :input) + (let* ((form (car (read input)))) + (set-webapp (make-instance 'webapp + :name (getf form :name) + :url (getf form :url) + :document-root (make-webapp-path (getf form :document-root)) + :title (getf form :title) + :meta-description (getf form :meta-description) + :mime-extensions (getf form :mime-extensions))))))) + +(defun music-dispensary () + "Call this to start the server." + (when (null *acceptor*) + (let ((package (string-downcase (package-name *package*)))) + (populate-webapps) + (setf (log-manager) (make-instance 'log-manager :message-class 'formatted-message)) + (start-messenger 'text-file-messenger :filename (format nil "/var/log/lisp/~a.log" package)) + (setf *session-secret* (generate-sessionid)) + (populate-webapps) + (setf *acceptor* (start (make-instance 'easy-acceptor + :port *port* + :document-root (make-server-path (format nil "webapps/~a/" package)) + :name (format nil "~a-acceptor" package))))))) + +(defmacro with-request-wrapper (uri page-function) + ;; Assigning package outside the backquote is necessary because + ;; *package* resolves incorrectly to common-lisp-user inside the + ;; backquote. + (let ((package (string-downcase (package-name *package*)))) + `(let ((*webapp* (get-webapp ,package))) + (logger (format nil "Page request URI: [~a]" ,uri)) + (unless *session* + (start-session) + (setf (session-max-time *session*) *session-timeout*) + (setf (session-value :permissions) "anonymous")) + (,page-function)))) + +(defmacro define-endpoint (request-type uri var-list page-function) + "Does the grunt work of creating an `easy-handler' for each page you +wish to publish." + (let ((name (gensym))) + `(progn + (logger (format nil "Publishing page. URL = [~a]" ,uri)) + (define-easy-handler (,name :uri ,uri :default-request-type ,request-type) + ,var-list + (with-request-wrapper ,uri ,page-function))))) |
