;;;(ql:quickload "cl-store") (ql:quickload "yason") (ql:quickload "cl-ppcre") (ql:quickload "unix-opts") (ql:quickload "ironclad") (ql:quickload "dexador") ;;; All records exist in this data structure ;;; nil on start and loaded in from file ;;; *records* represents as hash of months, ;;; where the key is the month stamp, eg 20210701 ;;; and the value is the monthly expenses hash (defvar *records* (make-hash-table :test 'equalp)) (defvar *api-config-path* "./auth.json") (defvar *api-url* NIL) (defvar *api-key* NIL) ;;; Used for input checking (mostly) (defvar *old-month-line-regex* (ppcre:create-scanner "^([A-Z][a-z]{1,})[0-9]{4}$")) (defvar *old-exp-line-regex* (ppcre:create-scanner "^([A-Z].*)\ -\ \\\$([0-9]{1,4}) - PAID")) (defvar *new-month-line-regex* (ppcre:create-scanner "20[0-9]{4}")) ;;; Taken from: https://gist.github.com/WetHat/a49e6f2140b401a190d45d31e052af8f ;;; Used for pretty printing output (defconstant +CELL-FORMATS+ '(:left "~vA" :center "~v:@<~A~>" :right "~v@A")) (defun format-table (stream data &key (column-label (loop for i from 1 to (length (car data)) collect (format nil "COL~D" i))) (column-align (loop for i from 1 to (length (car data)) collect :left))) (let* ((col-count (length column-label)) (strtable (cons column-label ; table header (loop for row in data ; table body with all cells as strings collect (loop for cell in row collect (if (stringp cell) cell ;else (format nil "~A" cell)))))) (col-widths (loop with widths = (make-array col-count :initial-element 0) for row in strtable do (loop for cell in row for i from 0 do (setf (aref widths i) (max (aref widths i) (length cell)))) finally (return widths)))) ;------------------------------------------------------------------------------------ ; splice in the header separator (setq strtable (nconc (list (car strtable) ; table header (loop for align in column-align ; generate separator for width across col-widths collect (case align (:left (format nil ":~v@{~A~:*~}" (1- width) "-")) (:right (format nil "~v@{~A~:*~}:" (1- width) "-")) (:center (format nil ":~v@{~A~:*~}:" (- width 2) "-"))))) (cdr strtable))) ; table body ;------------------------------------------------------------------------------------ ; Generate the formatted table (let ((row-fmt (format nil "| ~{~A~^ | ~} |~~%" ; compile the row format (loop for align in column-align collect (getf +CELL-FORMATS+ align)))) (widths (loop for w across col-widths collect w))) ; write each line to the given stream (dolist (row strtable) (apply #'format stream row-fmt (mapcan #'list widths row)))))) ;;; Used by "print-month" arg to validate ;;; the user provided a valid key (defun check-month (month-key) (if (stringp month-key) month-key (return-from check-month NIL)) (if (ppcre:scan *old-month-line-regex* month-key) month-key (if (ppcre:scan *new-month-line-regex* month-key) month-key (return-from check-month NIL)))) ;; Called like: (add-month '202107) (defun add-month (month-key) (if (check-month month-key) (if (not (gethash month-key *records*)) (progn (setf (gethash month-key *records*) (make-hash-table :test 'equalp)) month-key)))) (defun add-expense-to-month (expense value month) (if (gethash month *records*) (setf (gethash expense (gethash month *records*)) value) (progn (print (concatenate 'string "Adding" month)) (if (add-month month) (setf (gethash expense (gethash month *records*)) value) (print (concatenate 'string "Failed to add" month)))))) (opts:define-opts (:name :help :description "Print help text" :short #\h :long "help") (:name :print-month :description "Print records for given month. Must conform to either MonthYear or YYYYMM semantics." :short #\p :long "print-month" :arg-parser #'check-month) (:name :add-expense :description "Non interactive interface for recording an expense. Expects expense name as an argument, and requires -v|--value and -m|month" :short #\e :long "add-expense" :arg-parser #'identity) (:name :value :description "Used with -e|--add-expense. Must be an integer." :short #\v :long "value" :arg-parser #'parse-integer) (:name :month :description "Used with -e|--add-expense. Must be a valid month key." :short #\m :long "month" :arg-parser #'check-month) (:name :interactive-mode :description "Run in interactive mode" :short #\i :long "interactive")) ;; See: https://github.com/libre-man/unix-opts/blob/master/example/example.lisp (defmacro when-option ((options opt) &body body) `(let ((it (getf ,options ,opt))) (when it ,@body))) (defun reload () (load "~/Repos/fin-lisp/fin-lisp.lisp")) (defun parse-api-config (path) (let ((api-config-hash (yason:parse (uiop:read-file-string path))) (ret-tuple '())) ; I think this probably can be done in the let binding (push (gethash "token" api-config-hash) ret-tuple) (push (gethash "url" api-config-hash) ret-tuple) ret-tuple)) ;;;;;;;;;;;;;;;;;;;;;;;; ;;; Encryption stuff ;;; ;;;;;;;;;;;;;;;;;;;;;;;; ;;; See: https://www.cliki.net/Ironclad ;;; Return cipher when provided key ;;; Currently, this is 'insecure' as we are using a string ;;; coerced into a byte array as the key, aka a non-random secret. ;;; Should use twofish (defun get-cipher (key) (ironclad:make-cipher :blowfish :mode :ecb :key (ironclad:ascii-string-to-byte-array key))) (defun encrypt-records (key) (let* ((cipher (get-cipher key)) (content (ironclad:ascii-string-to-byte-array (with-output-to-string (json) (yason:encode *records* json))))) (ironclad:encrypt-in-place cipher content) (write-to-string (ironclad:octets-to-integer content)))) (defun decrypt-records (key enc-record-string) (let ((cipher (get-cipher key))) (let ((content (ironclad:integer-to-octets (parse-integer enc-record-string)))) (ironclad:decrypt-in-place cipher content) (coerce (mapcar #'code-char (coerce content 'list)) 'string)))) (defun download-records () (let* ((api-config (parse-api-config *api-config-path*)) (dl-records (yason:parse (dex:get (concatenate 'string (first api-config) "download") :headers (list (cons "X-Token" (second api-config))))))) dl-records)) (defun upload-records (enc-records-string) (let* ((api-config (parse-api-config *api-config-path*)) (result (dex:post (concatenate 'string (first api-config) "upload") :headers (list (cons "X-Token" (second api-config)) (cons "Content-Type" "application/json")) :content (concatenate 'string "{\"content\": \"" enc-records-string "\"}")))) result)) ;;; Serialization and communicating with the web API (defun push-records (key) "Upload records to remote server" (upload-records (encrypt-records key))) (defun get-records (key) "Get records from remote server" (setf *records* (yason:parse (decrypt-records key (gethash "content" (download-records)))))) ;;; Taken from practical common lisp (defun prompt-read (prompt) (format *query-io* "~a: " prompt) (force-output *query-io*) (read-line *query-io*)) (defun prompt-for-expense () (list (prompt-read "Enter expense name") (parse-integer (prompt-read "Enter expense value")))) ;;; Given key for *records* hash, ;;; print expenses/values for month (defun dump-month (month-key) (let ((month-hash) (exp-keys)) (setf month-hash (gethash month-key *records*)) (setf exp-keys (loop for key being the hash-keys of month-hash collect key)) (format t "~C" #\linefeed) (format t "~a~C" month-key #\linefeed) (dolist (exp-key exp-keys) (format t "~a : ~a~C" exp-key (gethash exp-key month-hash) #\linefeed)) (format t "~C" #\linefeed))) ;;; Given key for *records* hash, ;;; print expenses/values for month (defun dump-month-table (month-key) (let* ((month-hash (gethash month-key *records*)) (exp-keys (loop for key being the hash-keys of month-hash collect key)) (flist)) (dolist (exp-key exp-keys) (setq flist (append flist (list (list exp-key (gethash exp-key month-hash)))))) (format-table T flist :column-label '("Expense" "Amount")))) ;;; Dump all records. (defun dump-records () (let ((record-key-list (loop for key being the hash-keys of *records* collect key))) (dolist (month-key record-key-list) (dump-month month-key)))) (defmacro generic-handler (form error-string) `(handler-case ,form (error (e) (format t "Invalid input: ~a ~%" ,error-string) (values 0 e)))) ;; Util screen clearer (defun cls() (format t "~A[H~@*~A[J" #\escape)) (defun interactive-mode () (format t "~%") (format t "Available options:~%") (format t "1. Enter expense~%") (format t "2. Display month~%") (format t "3. Push records~%") (format t "4. Get records~%") (format t "5. Quit~%") (let ((answer (prompt-read "Select an option"))) (if (string= answer "1") (generic-handler (let ((month-input (prompt-read "Enter month")) (expense-input (prompt-for-expense))) (add-expense-to-month (first expense-input) (second expense-input) month-input)) "Invalid Input")) (if (string= answer "2") (generic-handler (dump-month-table (prompt-read "Enter month")) "Invalid month")) (if (string= answer "3") (generic-handler (push-records (prompt-read "Enter encryption key")) "Serialization error or invalid filename")) (if (string= answer "4") (generic-handler (get-records (prompt-read "Enter decryption key")) "Deserialization error or invalid filename")) (if (string= answer "5") (return-from interactive-mode nil))) (interactive-mode)) (defun display-help () (opts:describe :prefix "fin-lisp.lisp - Basic expense tracker in lisp" :usage-of "fin-lisp.lisp" :args "[FREE-ARGS]") (quit)) ;; Entry point (defun main () (if (= 1 (length sb-ext:*posix-argv*)) (interactive-mode)) (let ((matches (opts:get-opts))) ;;(format t "~a ~%" matches) (when-option (matches :help) (display-help)) (when-option (matches :print-month) (let ((key (prompt-read "Enter decryption key")) (month-key (destructuring-bind (&key print-month) matches print-month))) (get-records key) (dump-month-table month-key) (quit))) (when-option (matches :add-expense) ;; This is probably the wrong way to resolve the arguments (when-option (matches :value) (when-option (matches :month) (let ((key (prompt-read "Enter decryption key")) (name-value-month (destructuring-bind (&key add-expense value month) matches (list add-expense value month)))) (get-records key) (if (add-expense-to-month (first name-value-month) (second name-value-month) (third name-value-month)) (push-records key) (print "Invalid month input")))))) (when-option (matches :interactive-mode) (progn (interactive-mode) (quit))))) ;;; Can only be called from the REPL, ;;; used for importing according to the old schema (defun import-records (filename) (let ((old-file-lines (with-open-file (stream filename) (loop for line = (read-line stream nil) while line collect line))) (cur-mon) (cur-exp)) (loop for line in old-file-lines do (progn (if (ppcre:scan *old-month-line-regex* line) (setf cur-mon line)) (if (ppcre:scan *old-exp-line-regex* line) (progn (setf cur-exp (ppcre:register-groups-bind (first second) (*old-exp-line-regex* line) :sharedp t (list first second))) (print cur-exp) (if (gethash cur-mon *records*) (let ((innerhash (gethash cur-mon *records*))) (setf (gethash (first cur-exp) innerhash) (second cur-exp)))) (if (not (gethash cur-mon *records*)) (progn (add-month cur-mon) (let ((innerhash (gethash cur-mon *records*))) (setf (gethash (first cur-exp) innerhash) (second cur-exp))))))))))) (defun reset-records () "Used for debugging, just resets the *records* hash to NIL" (setf *records* (make-hash-table :test 'equal)))