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