;; 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)
