1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
;; 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))
(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.")
(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 ()
;; 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*))
;; ... and register all handlers.
;; 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))))))
;; 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)
|
