192 lines
6.1 KiB
Common Lisp
192 lines
6.1 KiB
Common Lisp
;; Copyright (C) 2016-2020 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 :main))
|
|
(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 *gemma-acceptor* nil
|
|
"Hunchentoot acceptor for Gemma's web server.")
|
|
|
|
(defvar *static-file-location* "frontend/"
|
|
"Folder from which to serve static assets. If built inside of Nix,
|
|
the path is injected during the build.")
|
|
|
|
(defvar *p-tasks* nil
|
|
"All tasks registered in this Gemma instance.")
|
|
|
|
(defun initialise-persistence (data-dir)
|
|
(setq *p-tasks* (cl-prevalence:make-prevalence-system data-dir))
|
|
|
|
;; 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
|
|
(setq *gemma-acceptor* (make-instance 'hunchentoot:easy-acceptor
|
|
:port *gemma-port*
|
|
:document-root *static-file-location*))
|
|
(hunchentoot:start *gemma-acceptor*)
|
|
|
|
;; 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 main ()
|
|
"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)
|