diff options
Diffstat (limited to 'services/gemma/src/gemma.lisp')
| -rw-r--r-- | services/gemma/src/gemma.lisp | 192 |
1 files changed, 0 insertions, 192 deletions
diff --git a/services/gemma/src/gemma.lisp b/services/gemma/src/gemma.lisp deleted file mode 100644 index b8a20addd907..000000000000 --- a/services/gemma/src/gemma.lisp +++ /dev/null @@ -1,192 +0,0 @@ -;; 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) |