397 lines
14 KiB
Scheme
Executable File
397 lines
14 KiB
Scheme
Executable File
#!/usr/bin/env -S csi -s
|
||
|
||
;; Copyright © 2024 Jaidyn Ann <jadedctrl@posteo.at>
|
||
;;
|
||
;; This program 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.
|
||
;;
|
||
;; This program is distributed in the hope that it will be useful,
|
||
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;; GNU General Public License for more details.
|
||
;;
|
||
;; You should have received a copy of the GNU General Public License
|
||
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
||
|
||
(import scheme
|
||
(chicken base)
|
||
(chicken condition)
|
||
(chicken file)
|
||
(chicken pathname)
|
||
(chicken process)
|
||
(chicken io)
|
||
(chicken repl)
|
||
(chicken process-context)
|
||
(chicken string)
|
||
(chicken time)
|
||
(srfi 1)
|
||
(srfi 4)
|
||
(srfi 13)
|
||
(srfi 18)
|
||
(prefix getopt-long getopt:)
|
||
(prefix nrepl nrepl:)
|
||
(prefix uri-common uri:)
|
||
(prefix vcarded vcard:)
|
||
qt-light)
|
||
|
||
|
||
(define *qt-app* #f) ;; The <qt-application> object.
|
||
(define *qt-win* #f) ;; The <qt-window> object.
|
||
(define *vcard-pathname* #f) ;; Path to current vCard file.
|
||
(define *vcard-alist* '()) ;; Parsed alist of current vCard file.
|
||
|
||
|
||
;; Start & run the application.
|
||
(define (init)
|
||
(let [(cli-args (parse-cli-args (command-line-arguments)))]
|
||
;; If --help, then print a usage message and quit.
|
||
(if (alist-ref 'help cli-args)
|
||
(cli-usage))
|
||
;; Otherwise, let’s get our threads started!
|
||
(let [(qt-thread (init-qt cli-args))
|
||
(nrepl-thread (init-nrepl cli-args))
|
||
(repl-thread (thread-start! repl))]
|
||
;; Wait for the QT program, even after stdin is closed off.
|
||
(thread-join! qt-thread))))
|
||
|
||
|
||
;; Set up some global variables (for easier live REPL use), prepare the QT app.
|
||
(define (init-qt cli-args)
|
||
(set! *qt-app* (qt:init))
|
||
(set! *qt-win* (create-window))
|
||
(qt:char-encoding 'utf8)
|
||
(init-window *qt-win*)
|
||
;; Kick off the QT thread, then open the cli free-arg vCard file, if provided.
|
||
;; That is, like `$ contact freeArgFile.vcf`.
|
||
(let [(qt-thread (thread-start! qt-loop))
|
||
(last-free-arg (condition-case (last (car cli-args)) (var () #f)))]
|
||
(when (string? last-free-arg)
|
||
(open-vcard-file *qt-win* last-free-arg #t))
|
||
qt-thread))
|
||
|
||
|
||
;; Kick off our remote TCP-accessible REPL, if the user enabled it at cli.
|
||
(define (init-nrepl cli-args)
|
||
(if (alist-ref 'repl cli-args)
|
||
(thread-start!
|
||
(lambda ()
|
||
(nrepl:nrepl (string->number (alist-ref 'repl cli-args)))))))
|
||
|
||
|
||
;; Print a “usage” help message, telling the user how to run the program.
|
||
(define (cli-usage)
|
||
(print "usage: " (pathname-file (program-name)) " [-h] [--repl PORT] [VCF_FILE]")
|
||
(print)
|
||
(print (pathname-file (program-name)) " is a simple contacts program for managing")
|
||
(print "vCard-format contacts.")
|
||
(print)
|
||
(print (getopt:usage cli-args-grammar))
|
||
(exit))
|
||
|
||
|
||
;; Parse out command-line args into an alist.
|
||
;; '("dad" "-h" "--repl=12" "mm") → '(("dad" "mm") (help #t) (repl 12))
|
||
(define (parse-cli-args args)
|
||
(handle-exceptions
|
||
exn
|
||
(and
|
||
(print ((condition-property-accessor 'exn 'message) exn))
|
||
'((help . #t)))
|
||
(getopt:getopt-long args cli-args-grammar)))
|
||
|
||
|
||
;; Definition of our command-line arguments, in getopt-long’s format.
|
||
(define cli-args-grammar
|
||
'((help "display this help message"
|
||
(single-char #\h))
|
||
(repl "start a TCP-accesible REPL at the given port"
|
||
(value #t))))
|
||
|
||
|
||
;; Loop through QT’s processing, again and again.
|
||
(define (qt-loop)
|
||
(qt:run #t)
|
||
(qt-loop))
|
||
|
||
|
||
;; Create the application window.
|
||
(define (create-window)
|
||
(qt:widget (window-contents)))
|
||
|
||
|
||
;; Return the UI’s XML, read from “contacts.ui”.
|
||
;; We could generate this XML ourselves, and write a nice s-expr front-end,
|
||
;; maybe… `o`
|
||
(define (window-contents)
|
||
(call-with-input-file
|
||
"rolladecks.ui"
|
||
(lambda (in-port) (read-string #f in-port))))
|
||
|
||
|
||
;; Initialize the window.
|
||
(define (init-window window)
|
||
;; Set the profile-picture label to a default theme icon.
|
||
(let [(default-profile-pic
|
||
(or (qt:theme-icon "person") (qt:theme-icon "contact-new")))]
|
||
(if default-profile-pic
|
||
(set! (qt:property (qt:find window "avatarLabel") "pixmap")
|
||
(qt:icon->pixmap default-profile-pic 100 100))))
|
||
;; Set the window’s title.
|
||
(set-window-title! window "New contact")
|
||
;; Now prepare callbacks and show the window.
|
||
(window-callbacks window)
|
||
(qt:show window))
|
||
|
||
|
||
;; Connect callback functions to widgets’ signals.
|
||
(define (window-callbacks window)
|
||
(menubar-callbacks window))
|
||
|
||
|
||
;; Connect callback functions to menubar items.
|
||
(define (menubar-callbacks window)
|
||
(let* [(menu-file-exit (qt:find window "actionQuit"))
|
||
(menu-file-save (qt:find window "actionSave"))
|
||
(menu-file-save-as (qt:find window "actionSaveAs"))
|
||
(menu-file-open (qt:find window "actionOpen"))
|
||
(menu-file-new (qt:find window "actionNew"))]
|
||
;; We connect to https://doc.qt.io/qt-6/qaction.html#triggered
|
||
;; Simply kill the program.
|
||
(when menu-file-exit
|
||
(qt:connect
|
||
menu-file-exit "triggered()"
|
||
(qt:receiver exit)))
|
||
;; If they try to Save, save!
|
||
(when menu-file-save
|
||
(qt:connect
|
||
menu-file-save "triggered()"
|
||
(qt:receiver
|
||
(lambda ()
|
||
(if *vcard-pathname*
|
||
(save-vcard-file window)
|
||
(save-vcard-file-as window))))))
|
||
;; If they try to Save As…, set the current vcard-path, then save!
|
||
(when menu-file-save-as
|
||
(qt:connect
|
||
menu-file-save-as "triggered()"
|
||
(qt:receiver
|
||
(lambda ()
|
||
(save-vcard-file-as window)))))
|
||
;; If they want a new contact, create a new, blank, window.
|
||
;; That is, a new process.
|
||
(when menu-file-new
|
||
(qt:connect
|
||
menu-file-new "triggered()"
|
||
(qt:receiver create-new-window)))
|
||
;; If they want to open a contact through the Open… dialogue, we should open
|
||
;; the contact in a new window.
|
||
(when menu-file-open
|
||
(qt:connect
|
||
menu-file-open "triggered()"
|
||
(qt:receiver
|
||
(lambda ()
|
||
(let* [(selected-file (qt:get-open-filename
|
||
"Select a contact file to open…"
|
||
(contacts-dir)))]
|
||
(if (not (string-null? selected-file))
|
||
(if *vcard-pathname*
|
||
(create-new-window selected-file)
|
||
(open-vcard-file window selected-file))))))))))
|
||
|
||
|
||
;; Executes a new instance of the program; optionally, with a contact-file’s
|
||
;; pathname as a new argument.
|
||
;; Functionally, opens a new contacts window.
|
||
(define (create-new-window . pathname)
|
||
(let* [(pathname (optional pathname #f))
|
||
(clean-cli-args
|
||
(drop-right (cdr (argv))
|
||
(length (command-line-arguments))))
|
||
(program-args
|
||
(if pathname
|
||
(append clean-cli-args (list pathname))
|
||
clean-cli-args))]
|
||
(process-run
|
||
(executable-pathname)
|
||
program-args)))
|
||
|
||
|
||
;; Parse a vCard file and populate the window’s forms with its contents.
|
||
(define (open-vcard-file window file . exit-on-fail?)
|
||
(set! *vcard-pathname* file)
|
||
(set-window-title! window (pathname-file file))
|
||
(thread-start!
|
||
(lambda ()
|
||
(condition-case
|
||
;; Parse the vCard, then populate the window’s fields.
|
||
(begin
|
||
(set! *vcard-alist*
|
||
(with-input-from-file file vcard:read-vcard))
|
||
(populate-window-with-vcard window *vcard-alist*))
|
||
;; … if that didn’t work out, complain to the user!
|
||
[(vcard)
|
||
(set! *vcard-pathname* #f)
|
||
(set! *vcard-alist* '())
|
||
(set-window-title! window "New contact")
|
||
(error-message "Parsing error"
|
||
(string-join
|
||
(list "This file doesn’t seem to be a valid vCard file."
|
||
"Please make sure you selected the right file, and take a look at it manually.")
|
||
"\n")
|
||
#f exit-on-fail?)]
|
||
;; … complain harder, harder!!
|
||
[exn (file)
|
||
(set! *vcard-pathname* #f)
|
||
(set! *vcard-alist* '())
|
||
(set-window-title! window "New contact")
|
||
(error-message "File error"
|
||
"Failed to open the file."
|
||
exn exit-on-fail?)]))))
|
||
|
||
|
||
;; Save the window contents to the currently-selected file-path in vCard format.
|
||
(define (save-vcard-file window)
|
||
(thread-start!
|
||
(lambda ()
|
||
(condition-case
|
||
(begin
|
||
(set! *vcard-alist* (populate-vcard-with-window window *vcard-alist*))
|
||
(call-with-output-file *vcard-pathname*
|
||
(lambda (out-port)
|
||
(vcard:write-vcard *vcard-alist*
|
||
out-port))))
|
||
[exn ()
|
||
(error-message
|
||
"Export error"
|
||
"Failed to save the file.\nTry saving to another location with “File→Save as…”."
|
||
exn)]))))
|
||
|
||
|
||
;; Save the window contents to a to-be-selected file-path in vCard format…
|
||
;; *if* the user saves them.
|
||
(define (save-vcard-file-as window)
|
||
(let [(new-path (qt:get-save-filename "Save contact as…" (contacts-dir)))]
|
||
(when (and (string? new-path) (not (string-null? new-path)))
|
||
(set! *vcard-pathname* new-path)
|
||
(save-vcard-file window))))
|
||
|
||
|
||
;; Simply map vCard property-names to their corresponding name in the window’s
|
||
;; fields.
|
||
(define property->formname-alist
|
||
'((FN . "nameLineEdit")
|
||
;; (ADR . "address")
|
||
(TEL . "homePhoneLineEdit")
|
||
(TEL . "workPhoneLineEdit")
|
||
(EMAIL . "eMailLineEdit")
|
||
(URL . "urlLineEdit")
|
||
(NICKNAME . "nicknameLineEdit")))
|
||
|
||
|
||
;; … and likewise, map window fields’ names to vCard properties.
|
||
(define formname-alist->property
|
||
(map (lambda (a) (cons (cdr a) (car a)))
|
||
property->formname-alist))
|
||
|
||
|
||
;; Given a parsed vCard in vcarded’s alist format, populate the window’s fields.
|
||
;; Here’s the format:
|
||
;; ((PROPERTY (ATTRIBUTES) VALUE)
|
||
;; (FN () "A. Dmytryshyn")
|
||
;; (ADR ("TYPE=home") ("" "" "1234 Abc.", "", "", "", "")))
|
||
(define (populate-window-with-vcard window vcard-alist)
|
||
(map (lambda (property)
|
||
(let* [(formname (alist-ref (car property) property->formname-alist))
|
||
(lineEditWidget (if formname (qt:find window formname) #f))]
|
||
(cond
|
||
[lineEditWidget
|
||
(set! (qt:property lineEditWidget "text")
|
||
(cond
|
||
[(string? (last property))
|
||
(last property)]
|
||
[(uri:uri? (last property))
|
||
(uri:uri->string (last property))]
|
||
[#t ""]))]
|
||
[(and (eq? (car property) 'PHOTO)
|
||
(list? (last property)))
|
||
(let* [(avatar (qt:find window "avatarLabel"))
|
||
(old-pixmap
|
||
(if avatar (qt:property avatar "pixmap")))
|
||
[new-pixmap
|
||
(if avatar (u8vector->pixmap (cadr (last property))))]]
|
||
(when avatar
|
||
(set! (qt:property avatar "pixmap") new-pixmap)))])))
|
||
vcard-alist)
|
||
(when (alist-ref 'FN vcard-alist)
|
||
(set-window-title! window (last (alist-ref 'FN vcard-alist)))))
|
||
|
||
|
||
;; Given a Contacts QT window, take its vCard lineEdit widgets and populate a
|
||
;; vcarded-style alist with their values.
|
||
;; Returns a vCard according the window’s textbox values.
|
||
(define (populate-vcard-with-window window vcard-alist)
|
||
(for-each
|
||
(lambda (lineEditName)
|
||
(let* [(widget (if lineEditName (qt:find window lineEditName) #f))
|
||
(widget-value (if widget (qt:property widget "text") #f))
|
||
(property-sym (alist-ref lineEditName formname-alist->property equal?))
|
||
(property-value (alist-ref property-sym vcard-alist))]
|
||
(when (and widget (not (string-null? widget-value)))
|
||
(set! vcard-alist
|
||
(alist-update property-sym
|
||
(list (if (list? property-value) (car property-value) '())
|
||
(qt:property widget "text"))
|
||
vcard-alist)))))
|
||
(map car formname-alist->property))
|
||
(vcard:normalize-vcard vcard-alist))
|
||
|
||
|
||
;; Display an error-message dialogue, optionally exiting after the user
|
||
;; dismisses it.
|
||
(define (error-message title description #!optional (exn #f) (exit-after-message? #f))
|
||
(let [(exn-message (if exn ((condition-property-accessor 'exn 'message) exn)
|
||
#f))]
|
||
(qt:message
|
||
(if exn-message
|
||
(string-concatenate (list description "\n“" exn-message "”"))
|
||
description)
|
||
title: title
|
||
type: 'critical)
|
||
(when exit-after-message? (exit))))
|
||
|
||
|
||
;; Guess the user’s contacts directory, as best we can.
|
||
(define (contacts-dir)
|
||
(let [(home (get-environment-variable "HOME"))]
|
||
(if home
|
||
(conc home "/Contacts")
|
||
"./")))
|
||
|
||
|
||
;; Set a QT window’s title, suffixing with the program name (Contact).
|
||
(define (set-window-title! window title)
|
||
(set! (qt:property window "windowTitle")
|
||
(string-concatenate (list title " - Contact"))))
|
||
|
||
|
||
;; Given a image bytevector (u8vector), create a corresponding pixmap.
|
||
(define (u8vector->pixmap vector)
|
||
(let* ([temp-file (write-temporary-file vector)]
|
||
[pixmap (qt:pixmap temp-file)])
|
||
(delete-file* temp-file)
|
||
pixmap))
|
||
|
||
|
||
;; Given a u8vector for file-contents, create a tempory file and write the
|
||
;; contents to it. Returns the pathname.
|
||
(define (write-temporary-file u8vector-contents)
|
||
(let [(temp-file (create-temporary-file))]
|
||
(with-output-to-file temp-file
|
||
(lambda () (map write-byte (u8vector->list u8vector-contents))))
|
||
temp-file))
|
||
|
||
|
||
(init)
|