(defpackage #:tempores.freshbooks (:use #:cl #:anaphora #:alexandria #:serapeum #:fwoar.lisputils #:tempores.parser) (:import-from #:tempores #:tempores) (:export #:tempores)) (in-package :tempores.freshbooks) (defvar *api-key*) (defvar *endpoint*) (defun init () (ubiquitous:restore 'tempores) (ubiquitous:value :freshbooks :api-key) (ubiquitous:value :freshbooks :endpoint)) (eval-when (:load-toplevel :compile-toplevel :execute) (xhtmlambda::def-element <::request) (xhtmlambda::def-element <::time_entry) (xhtmlambda::def-element <::project_id) (xhtmlambda::def-element <::task_id) (xhtmlambda::def-element <::hours) (xhtmlambda::def-element <::notes) (xhtmlambda::def-element <::date)) (defun post-to-endpoint (xml) (let ((drakma:*text-content-types* (acons "application" "xml" drakma:*text-content-types*))) (drakma:http-request *endpoint* :basic-authorization (list *api-key* "X") :method :post :content (with-output-to-string (s) (format s "~w" xml))))) (defun parsed-api-call (xml) (plump:parse (post-to-endpoint xml))) (defmacro define-api-call (name (&rest args) method-name &body elements) `(defun ,name ,args (parsed-api-call (<:request (:method ,method-name) ,@elements)))) (define-api-call create-time-entry (entry-spec) "time_entry.create" entry-spec) (define-api-call list-invoices () "invoice.list") (define-api-call list-projects () "project.list") (define-api-call list-tasks () "task.list") (define-api-call list-payments () "payment.list") (define-api-call list-clients () "client.list") (defgeneric slots-for (cls) (:method-combination append)) (defmacro define-simple-class (name (&rest supers) &body elements) (let ((schema-name (intern (string-join (list name "-SCHEMA")))) (schema-supers (loop for super in supers collect (intern (string-join (list (symbol-name super) "-schema")))))) `(eval-when (:compile-toplevel :load-toplevel :execute) (prog1 (defclass ,name ,supers ,(list* '(registry :initform (make-hash-table :test 'equal) :allocation :class) (loop for element in elements collect `(,element :initarg ,(make-keyword element) :initform nil)))) (defclass ,schema-name ,schema-supers ()) (defmethod slots-for append ((cls ,schema-name)) ',elements))))) (define-simple-class task () task_id name description billable rate) (define-simple-class project () project_id name description rate bill_method client_id hour_budget tasks staff) (tempores.macros:define-printer (task s) ((with-slots (task_id name) task (format s "~i~a (~a):" name task_id))) ((with-slots (task_id name) task (format s "~a (~a)" name task_id)))) (tempores.macros:define-printer (project s) ((with-slots (project_id name tasks) project (format s "~i~a (~a):~%~{~a~%~}" name project_id tasks))) ((with-slots (project_id name tasks) project (format s "~a (~a): ~a tasks" name project_id (length tasks))))) (defparameter *task-registry* (make-hash-table :test 'equal)) (defmethod initialize-instance :after ((self task) &key &allow-other-keys) (loop for slot in '(task_id name description billable rate) for node = (slot-value self slot) unless (null node) do (setf (slot-value self slot) (plump:text node)))) (defun register-task (task) (with-slots (task_id) task (setf (gethash task_id *task-registry*) task))) (defparameter *project-registry* (make-hash-table :test 'equal)) (defmethod initialize-instance :after ((self project) &key &allow-other-keys) (loop for slot in '(project_id name description rate bill_method client_id hour_budget) for node = (slot-value self slot) unless (null node) do (setf (slot-value self slot) (plump:text node))) (with-slots (tasks) self (setf tasks (loop for task across (lquery:$ (inline tasks) "> task") for task_id = (lquery:$1 (inline task) "task_id" (text)) for task-obj = (gethash task_id *task-registry*) unless task-obj do (setf task-obj (parse-task task)) collect task-obj)))) (defun register-project (project) (with-slots (name) project (setf (gethash name *project-registry*) project))) (defun parse-task (parsed-xml) (apply #'make-instance 'task (loop for slot in (slots-for (make-instance 'task-schema)) nconc (let ((slot-name (format nil "> ~(~a~)" slot))) (list (make-keyword slot) (lquery:$ (inline parsed-xml) slot-name (node))))))) (defun parse-project (parsed-xml) (apply #'make-instance 'project (loop for slot in (slots-for (make-instance 'project-schema)) nconc (let ((slot-name (format nil "> ~(~a~)" slot))) (list (make-keyword slot) (lquery:$ (inline parsed-xml) slot-name (node))))))) (defun get-project (name) (let ((projects (sort (map 'vector (alambda (cons (string-downcase it) it)) (hash-table-keys *project-registry*)) #'string< :key #'car)) (name (string-downcase name))) (gethash (cdr (find-if (alambda (string= it name :end1 (length name))) projects :key #'car)) *project-registry*))) (defun make-time-entry (project task date hours notes) (<:time_entry () (<:project_id () (parse-integer (slot-value (get-project project) 'project_id))) (<:task_id () (parse-integer task)) (<:date () (identity date)) (<:hours () (identity hours)) (<:notes () (identity notes)))) (defun get-task-by-name (name) (let ((tasks (mapcar (destructuring-lambda ((id . task)) (cons (slot-value task 'name) id)) (hash-table-alist *task-registry*)))) (cdr (assoc name tasks :test #'string-equal)))) (defun tempores-to-entries (tempores-log) (let ((task-id (get-task-by-name "General"))) (loop for entry in tempores-log for date = (tempores::date entry) for project = (tempores::client entry) for note = (tempores::memo entry) for hours = (tempores::duration entry) for fmt-date = (format nil "~:@{~2,'0d-~2,'0d-~2,'0d 00:00:00~}" (reverse (tempores.cli::unroll-date date))) collect (make-time-entry project task-id fmt-date hours note)))) (defun make-entry-updates () (let ((updates (tempores-to-entries (tempores::get-log #p"/home/edwlan/bucket/time.md")))) (loop for update in updates collect (<:request (:method "time_entry.create") update)))) (defun get-entry-data () (init) (setf *endpoint* (ubiquitous:value :freshbooks :endpoint)) (setf *api-key* (ubiquitous:value :freshbooks :api-key)) (let-each (:be *) (list-tasks) (lquery:$ * "task") (map 'list #'parse-task *) (mapcar #'register-task *)) (let-each (:be *) (list-projects) (lquery:$ * "project") (map 'list #'parse-project *) (mapcar #'register-project *)) (make-entry-updates)) (defun post-time-entries-main () (let-each (:be *) (get-entry-data) (mapcar #'parsed-api-call *)))