rolladeck/rolladeck.scm

#!/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 “rolladeck.ui”.
;; We could generate this XML ourselves, and write a nice s-expr front-end,
;; maybe… `o`
(define (window-contents)
  (call-with-input-file
      "rolladeck.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)