tvl-depot/fun/gemma/src/gemma.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)