refactor(gemma): Move Gemma source into monorepo stucture

1 files changed, 192 insertions, 0 deletions

diff --git a/services/gemma/src/gemma.lisp b/services/gemma/src/gemma.lisp
new file mode 100644
index 000000000000..b8a20addd907
--- /dev/null
+++ b/services/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)