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