diff options
Diffstat (limited to 'fun/gemma/src/gemma.lisp')
| -rw-r--r-- | fun/gemma/src/gemma.lisp | 192 |
1 files changed, 192 insertions, 0 deletions
diff --git a/fun/gemma/src/gemma.lisp b/fun/gemma/src/gemma.lisp new file mode 100644 index 000000000000..b8a20addd907 --- /dev/null +++ b/fun/gemma/src/gemma.lisp @@ -0,0 +1,192 @@ +;; Copyright (C) 2016-2017 Vincent Ambo <mail@tazj.in> +;; +;; This file is part of Gemma. +;; +;; Gemma is free software: you can redistribute it and/or modify it +;; under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +(defpackage gemma + (:use :cl + :local-time + :cl-json) + (:import-from :sb-posix :getenv) + (:shadowing-import-from :sb-posix :getcwd) + (:export :start-gemma :config :entrypoint)) +(in-package :gemma) + +;; TODO: Store an average of how many days it was between task +;; completions. Some of the current numbers are just guesses +;; anyways. + +(defmacro in-case-of (x &body body) + "Evaluate BODY if X is non-nil, binding the value of X to IT." + `(let ((it ,x)) + (when it ,@body))) + +;; Set default configuration parameters +(defvar *gemma-port* 4242 + "Port on which the Gemma web server listens.") + +(defvar *static-file-location* + (or (in-case-of (sb-posix:getenv "out") + (concatenate 'string it "/share/gemma/")) + "frontend/") + "Folder from which to serve static assets. If built inside of Nix, + the folder is concatenated with the output path at which the files + are expected to be.") + +(defun initialise-persistence (data-dir) + (defvar *p-tasks* + (cl-prevalence:make-prevalence-system data-dir) + "All tasks registered in this Gemma instance.") + + ;; Initialise database ID counter + (or (> (length (cl-prevalence:find-all-objects *p-tasks* 'task)) 0) + (cl-prevalence:tx-create-id-counter *p-tasks*))) + +(defun config (&key port data-dir) + "Configuration function for use in the Gemma configuration file." + + (in-package :gemma) + (in-case-of port (defparameter *gemma-port* it)) + (initialise-persistence (or data-dir "data/"))) + +;; +;; Define task management system +;; + +(defclass task () + ((id :reader id + :initarg :id) + + ;; (Unique) name of the task + (name :type symbol + :initarg :name + :accessor name-of) + + ;; Maximum completion interval + (days :type integer + :initarg :days + :accessor days-of) + + ;; Optional description + (description :type string + :initarg :description + :accessor description-of) + + ;; Last completion time + (done-at :type timestamp + :initarg :done-at + :accessor last-done-at))) + +(defmacro deftask (task-name days &optional description) + (unless (get-task task-name) + `(progn (cl-prevalence:tx-create-object + *p-tasks* + 'task + (quote ((name ,task-name) + (days ,days) + (description ,(or description "")) + (done-at ,(now))))) + (cl-prevalence:snapshot *p-tasks*)))) + +(defun get-task (name) + (cl-prevalence:find-object-with-slot *p-tasks* 'task 'name name)) + +(defun list-tasks () + (cl-prevalence:find-all-objects *p-tasks* 'task)) + +(defun days-remaining (task) + "Returns the number of days remaining before the supplied TASK reaches its +maximum interval." + (let* ((expires-at (timestamp+ (last-done-at task) + (days-of task) :day)) + (secs-until-expiry (timestamp-difference expires-at (now)))) + (round (/ secs-until-expiry 60 60 24)))) + +(defun sort-tasks (tasks) + "Sorts TASKS in descending order by number of days remaining." + (sort (copy-list tasks) + (lambda (t1 t2) (< (days-remaining t1) + (days-remaining t2))))) + +(defun complete-task (name &optional at) + "Mark the task with NAME as completed, either now or AT specified time." + (cl-prevalence:tx-change-object-slots *p-tasks* 'task + (id (get-task name)) + `((done-at ,(or at (now))))) + (cl-prevalence:snapshot *p-tasks*)) + +;; +;; Define web API +;; + +(defun response-for (task) + "Create a response object to be JSON encoded for TASK." + `((:name . ,(name-of task)) + (:description . ,(description-of task)) + (:remaining . ,(days-remaining task)))) + +(defun start-gemma () + (in-package :gemma) + + ;; Load configuration + (load (pathname (or (getenv "GEMMA_CONFIG") + "/etc/gemma/config.lisp"))) + + ;; Set up web server + (hunchentoot:start + (make-instance 'hunchentoot:easy-acceptor + :port *gemma-port* + :document-root *static-file-location*)) + + ;; Task listing handler + (hunchentoot:define-easy-handler + (get-tasks :uri "/tasks") () + + (setf (hunchentoot:content-type*) "application/json") + (setf (hunchentoot:header-out "Access-Control-Allow-Origin") "*") + (encode-json-to-string + ;; Construct a frontend-friendly representation of the tasks. + (mapcar #'response-for (sort-tasks (list-tasks))))) + + ;; Task completion handler + (hunchentoot:define-easy-handler + (complete-task-handler :uri "/complete") (task) + (setf (hunchentoot:content-type*) "application/json") + (let* ((key (find-symbol (camel-case-to-lisp task) "GEMMA"))) + (format t "Marking task ~A as completed" key) + (complete-task key) + (encode-json-to-string (response-for (get-task key)))))) + +(defun entrypoint () + "This function serves as the entrypoint for ASDF-built executables. + It joins the Hunchentoot server thread to keep the process running + for as long as the server is alive." + + (start-gemma) + (sb-thread:join-thread + (find-if (lambda (th) + (string= (sb-thread:thread-name th) + (format nil "hunchentoot-listener-*:~A" *gemma-port*))) + (sb-thread:list-all-threads)))) + +;; Experimentation / testing stuff + +(defun randomise-completion-times () + "Set some random completion timestamps for all tasks" + (mapcar + (lambda (task) + (complete-task (name-of task) + (timestamp- (now) + (random 14) + :day))) + (cl-prevalence:find-all-objects *p-tasks* 'task))) + +(defun clear-all-tasks () + (mapcar (lambda (task) (cl-prevalence:tx-delete-object *p-tasks* 'task (id task))) + (cl-prevalence:find-all-objects *p-tasks* 'task))) + +;; (randomise-completion-times) |