I am writing a home-mbsync-service-type for guix home, which is almost complete. My knowledge of lisp is very limited, but I learned a lot by writing this service and couple of other small services, packages and scripts for guix.
I would like to get some feedback on the code quality and improvements that can be made etc, for this service and would like some help regarding one thing, that is remaining within this service.
Previously, when I wrote a home service for guix I followed how David had his services written, by serializing the configuration file manually. But since then I learnt that there is a built-it procedures/macros that can be used to serialize the generated configuration file.
While learning this serialization system for guix, I struggled a lot, especially with regards to gexp as along side guile scheme, I also had to learn concepts specific to guix. But now I have somewhat of an idea how gexp work.
Now with the service I am writing, I had to rename the field names that get put in the configuration file and I’m not sure how one would rename the field while serializing using the built-in serialization system.
But this is how I wrote mine,
(define-module (apoorv home services mbsync)
#:use-module (apoorv home utils)
#:use-module (gnu home services)
#:use-module (gnu home services mcron)
#:use-module (gnu home services shepherd)
#:use-module (gnu packages)
#:use-module (gnu packages gnome)
#:use-module (gnu packages mail)
#:use-module (gnu packages password-utils)
#:use-module (gnu services)
#:use-module (gnu services configuration)
#:use-module (guix gexp)
#:use-module (guix packages)
#:use-module (srfi srfi-1)
#:export (home-mbsync-service-type
home-mbsync-configuration
imap-account
imap-store
maildir-store
channel))
;; (define (serialize-string name value)
;; (let ((fields '((name . "IMAPAccount")
;; (host . "Host")
;; (user . "User")
;; (pass-cmd-package . "PassCmd")
;; (certificate-file . "CertificateFile")
;; (imap-store . "IMAPStore")
;; (maildir-store . "MaildirStore")
;; (path-to-mail-dir . "Path")
;; (path-to-inbox-dir . "Inbox")
;; (patterns . "Patterns"))))
;; (cond
;; ((eq? name 'name)
;; (string-append "IMAPAccount " value "\n"
;; "Account " value "\n"
;; "Channel " value "\n"))
;; ((eq? name 'imap-store)
;; (string-append "IMAPStore " value "\n"
;; "Far :" value ":\n"))
;; ((eq? name 'maildir-store)
;; (string-append "MaildirStore " value "\n"
;; "Near :" value ":\n"))
;; ((eq? name 'pass-cmd-package)
;; (let ((pass-cmd-args (imap-account-pass-cmd-args value)))
;; (string-append "PassCmd \"" value "/bin/" pass-cmd-args "\"\n")))
;; (else
;; (let ((mapped-name (assoc-ref fields name)))
;; (if mapped-name
;; (format #f "~a ~a~%" mapped-name value)
;; (format #f "~a ~a~%" name value)))))))
(define (serialize-string field-name value)
(format #f "~a ~a~%" field-name value))
(define (serialize-boolean field-name value)
(let ((value (if value "yes" "no")))
(format #f "~a ~a~%" field-name value)))
(define (serialize-symbol field-name value)
(format #f "~a ~a~%" field-name (symbol->string value)))
(define (serialize-number field-name value)
(format #f "~a ~a~%" field-name value))
(define (serialize-cmd field-name value)
(if (not (boolean? value))
(let ((cmd (car value))
(args (cdr value)))
#~(format #f "~a \"~a/bin/~a\"~%" '#$field-name #$(file-append cmd) #$args))
;; (string-append field-name (file-append cmd) "/bin/" args))
""))
(define-configuration all-stores
(path
(string #f)
"The location of the store in server's file system")
(max-size
(string "0")
"Messages largen than size will have only
a small placeholder message propagated into this store")
(map-inbox
(string "")
"Create a virtual mailbox (relative to path) which
aliases the inbox")
(flatten
(string "")
"Flatten the hierarchy within this store
by substituting the canonical hierarchy delimiter /
with delim")
(trash
(string #f)
"Specified a mailbox (relative to path) to copy deleted
messages to prior to expunging")
(trash-new-only
(boolean #f)
"When trashing. copy only not yet propagated messages")
(trash-remote-new
(boolean #f)
"When expunging the opposite store, copy not yet propagated
messages to this store's trash"))
(define-configuration maildir-store
(maildir-store
(string "local")
"Define the maildir store name, opening a section
for its parameters")
(alt-map
(boolean #f)
"Use the alternative UID storage scheme for mailboxes
in this store.")
(path-to-inbox-dir
(string "~/Maildir")
"The location of the inbox")
(path-to-mail-dir
(string "")
"Path to default mail directory")
(sub-folders
(symbol 'Verbatim)
"The on-disk folder naming style used for hierarchical
mailboxes"))
(define (serialize-maildir-store field-name value)
(let ((store (maildir-store-maildir-store value))
(alt-map (maildir-store-alt-map value))
(inbox-dir (maildir-store-path-to-inbox-dir value))
(mail-dir (maildir-store-path-to-mail-dir value))
(sub-folders (maildir-store-sub-folders value)))
(string-append "MaildirStore " store "\n"
(if alt-map
"AltMap yes \n"
"")
"Path " mail-dir "\n"
"Inbox " inbox-dir "\n"
"Subfolders " (symbol->string sub-folders) "\n"
"\n")))
(define-configuration channel
(channel
(string "")
"Define the channel name, opening a section for its
parameters")
(far-store
(string "")
"Specify the far side store to be connected
by this channel")
(near-store
(string "")
"Specify the near side store to be connected
by this channel")
(patterns
(string "")
"Instead of syncronizing only one mailbox pair,
syncronize all mailboxes that match the pattern(s)")
(max-size
(string "")
"Analogous to the homonymous option in the stores
section, but applies to Far and Near")
(max-messages
(number 0)
"Sets the maximum number of messages to keep in
each near side mailbox")
(expire-unread
(boolean #f)
"Selects whether unread messages should be affect by
MaxMessages")
(expire-side
(symbol 'Near)
"Selects on which side messages should be expired when
MaxMessages is configured")
(sync
(symbol 'Full)
"Select the syncronization operation(s) to perform")
(create
(symbol 'None)
"Automatically create missing mailboxes [on the
far/near side]")
(remove
(symbol 'None)
"Propagate mailbox deletions [to the far/near side]")
(expunge
(symbol 'None)
"Permanently remove all messages [on the far/near side]
which are marked for deletion")
(expunge-solo
(symbol 'None)
"Permanently remove all messages [on the far/near side]
which are both marked for deletion and have no corresponding
message in the opposite store")
(copy-arrival-date
(boolean #f)
"Selects whether their arrival time should be
propagated together with the messages")
(sync-state
(string "")
"Set the location of this channel's syncronization state files"))
(define (serialize-channel field-name value)
(let ((channel (channel-channel value))
(far-store (channel-far-store value))
(near-store (channel-near-store value))
(patterns (channel-patterns value))
(max-size (channel-max-size value))
(max-msg (channel-max-messages value))
(exp-unread (channel-expire-unread value))
(exp-side (channel-expire-side value))
(sync (channel-sync value))
(create (channel-create value))
(remove (channel-remove value))
(expunge (channel-expunge value))
(expunge-solo (channel-expunge-solo value))
(copy-arrival-date (channel-copy-arrival-date value))
(sync-state (channel-sync-state value)))
(string-append "Channel " channel "\n"
"Far " far-store "\n"
"Near " near-store "\n"
"Patterns " patterns "\n"
(if (not (string-null? max-size))
(string-append "MaxSize " max-size "\n")
"")
(if (> max-msg 0)
(string-append "MaxMessages " (number->string max-msg) "\n")
"")
(if exp-unread
"ExpiredUnread yes \n"
"")
(if (not (eq? exp-side 'Near))
(string-append "ExpireSide " (symbol->string exp-side) "\n")
"")
(if (not (eq? sync 'Full))
(string-append "Sync " (symbol->string sync) "\n")
"")
"Create " (symbol->string create) "\n"
(if (not (eq? remove 'None))
(string-append "Remove " (symbol->string remove) "\n")
"")
(if (not (eq? expunge 'None))
(string-append "Expunge " (symbol->string expunge) "\n")
"")
(if (not (eq? expunge-solo 'None))
(string-append "ExpungeSolo " (symbol->string expunge-solo) "\n")
"")
(if copy-arrival-date
"CopyArrivalDate yes \n"
"")
"SyncState " sync-state "\n"
"\n")))
(define-configuration imap-store
(imap-store
(string "")
"Define the IMAP4 store name, opening a section for its
parameters")
(account
(string "")
"Specify which IMAP4 account to use")
(use-namespace
(boolean #t)
"Selects whether the server's first personal NAMESPACE
should be prefixed to mailbox names")
(subscribed-only
(boolean #f)
"Selects whether to synchronize only mailboxes that
are subscribed to on the IMAP server"))
(define (serialize-imap-store field-name value)
(let ((account (imap-store-account value))
(store (imap-store-imap-store value))
(use-namespace (imap-store-use-namespace value))
(subscribed-only (imap-store-subscribed-only value)))
(string-append "IMAPStore " store "\n"
"Account " account "\n"
(if (not use-namespace)
"UseNamespace no \n"
"")
(if subscribed-only
"SubscribedOnly yes \n"
"")
"\n")))
(define (cmd? cmd)
(or (pair? cmd)
(boolean? cmd)))
(define-configuration imap-account
(account
(string "")
"Define the IMAP4 account name, opening a section for its
parameters")
(host
(string "")
"Specify the DNS name or IP address of the IMAP server")
(port
(number 143)
"Specify the TCP port number of the IMAP server")
(timeout
(number 20)
"Specify the connect and data timeout for the IMAP
server in seconds")
(user
(string "")
"Specify the login name on the IMAP server")
(user-cmd
(cmd #f)
"Specify a shell command to obtain a user rather than
specifying a user directly")
(pass
(string "")
"Specify the password for username on the IMAP server")
(pass-cmd
(cmd #f)
"Specify a shell command to obtain a password rather than
specifying a password directly")
(tunnel
(cmd #f)
"Specify a command to run to establish a connection rather
than opening a TCP socket")
(tls-type
(symbol 'None)
"Select the connection security/encryption method")
(system-certificates
(boolean #t)
"Whether the system's default CA (certificate authority)
certificate store should be used to verify certificate trust
chains")
(certificate-file
(string "/etc/ssl/certs/ca-certificates.crt")
"Location to the ssl certificate")
(imap-store
(imap-store #f)
"IMAP store configuration")
(maildir-store
(maildir-store #f)
"Maildir store configuration")
(channel
(channel #f)
"Channel configuration")
(extra-content
(list-of-strings '())
"Extra content appended as-is to the mbsync configuration file"
empty-serializer))
(define (list-of-imap-accounts? lst)
(every imap-account? lst))
(define (serialize-list-of-imap-accounts field-name value)
#~(string-join
(list
#$@(map
(lambda (val)
;; (serialize-configuration val imap-account-fields))
(let ((account (imap-account-account val))
(host (imap-account-host val))
(port (imap-account-port val))
(timeout (imap-account-timeout val))
(user (imap-account-user val))
(user-cmd (imap-account-user-cmd val))
(pass (imap-account-pass val))
(pass-cmd (imap-account-pass-cmd val))
(tunnel (imap-account-tunnel val))
(tls-type (imap-account-tls-type val))
(system-cert (imap-account-system-certificates val))
(cert-file (imap-account-certificate-file val))
(imap-store (imap-account-imap-store val))
(maildir-store (imap-account-maildir-store val))
(channel (imap-account-channel val)))
(string-append "IMAPAccount " account "\n"
"Host " host "\n"
(if (and (not (string-null? user))
(eq? user-cmd #f))
(string-append "User " user "\n")
"")
(if (and (string-null? user)
(not (eq? user-cmd #f)))
(serialize-cmd field-name user-cmd)
"")
(if (and (not (string-null? pass))
(eq? pass-cmd #f))
(string-append "Pass " pass "\n")
"")
;; (if (and (string-null? pass)
;; (not (eq? pass-cmd #f)))
;; (serialize-cmd field-name pass-cmd)
;; "")
(if (not (eq? tls-type 'None))
(string-append "TLSType " (symbol->string tls-type) "\n")
"")
(if (not system-cert)
"SystemCertificate no \n"
"")
"CertificateFile " cert-file "\n"
"\n"
(serialize-imap-store field-name imap-store)
(serialize-maildir-store field-name maildir-store)
(serialize-channel field-name channel))))
value))
"\n"))
(define-configuration home-mbsync-configuration
(mbsync
(file-like isync)
"Package to use for mbsync")
(accounts
(list-of-imap-accounts '())
"List of imap accounts"))
(define (home-mbsync-profile-service config)
(list
(home-mbsync-configuration-mbsync config)))
;; (define (mbsync-account-config config)
;; #~(string-append
;; "IMAPAccount " #$(imap-account-name config) "\n"
;; "Host " #$(imap-account-host config) "\n"
;; "User " #$(imap-account-user config) "\n"
;; "PassCmd \"" #$(imap-account-pass-cmd-package config) "/bin/" #$(imap-account-pass-cmd-args config) "\"\n"
;; "TLSType IMAPS\n"
;; "CertificateFile " #$(imap-account-certificate-file config) "\n"
;; "\n"
;; "IMAPStore " #$(imap-account-imap-store config) "\n"
;; "Account " #$(imap-account-name config) "\n"
;; "\n"
;; "MaildirStore " #$(imap-account-maildir-store config) "\n"
;; "Subfolders Verbatim\n"
;; "Path " #$(imap-account-path-to-mail-dir config) "\n"
;; "Inbox " #$(imap-account-path-to-inbox-dir config) "\n"
;; "\n"
;; "Channel " #$(imap-account-name config) "\n"
;; "Far :" #$(imap-account-imap-store config) ":\n"
;; "Near :" #$(imap-account-maildir-store config) ":\n"
;; "Patterns " #$(imap-account-patterns config) "\n"
;; "Create Both\n"
;; "SyncState *\n"
;; (string-join '#$(imap-account-extra-content config) "\n")))
;; (define (generate-mbsync-config-file config)
;; #~(string-join
;; (list
;; #$@(map mbsync-account-config (home-mbsync-configuration-accounts config))
;; "\n")))
(define (home-mbsync-files-service config)
`(("isync/mbsyncrc"
;; ,(mixed-text-file "mbsyncrc" (generate-mbsync-config-file config)))))
,(mixed-text-file
"mbsyncrc"
(serialize-configuration config home-mbsync-configuration-fields)))))
(define (home-mbsync-mcron-service config)
"Run 'mbsync -a' on a schedule and send a notification when done."
(list
#~(job '(next-hour (range 0 24 1))
(lambda ()
(and (zero? (status:exit-val
(system* #$(file-append (home-mbsync-configuration-mbsync config) "/bin/mbsync")
"-c" "/home/apoorv/.config/isync/mbsyncrc" "-a")))
(system* (string-append #$libnotify "/bin/notify-send") "Email" "Mailbox synced"))))))
(define home-mbsync-service-type
(service-type
(name 'home-mbsync)
(description "A service for running mbsync")
(extensions
(list (service-extension
home-profile-service-type
home-mbsync-profile-service)
(service-extension
home-xdg-configuration-files-service-type
home-mbsync-files-service)
(service-extension
home-mcron-service-type
home-mbsync-mcron-service)))
(default-value (home-mbsync-configuration))))
While writing this, I did had a lot discussion and help from people on the Guix (unofficial) matrix channel.
The usage of this service would look like this,
(service home-mbsync-service-type
(home-mbsync-configuration
(accounts
(list (imap-account
(account "gmail")
(host "imap.gmail.com")
(user "my_email@gmail.com")
(pass-cmd `(,password-store . "pass my_email_pass"))
(tls-type 'IMAPS)
(imap-store
(imap-store
(imap-store "gmail-remote")
(account "gmail")))
(maildir-store
(maildir-store
(maildir-store "gmail-local")
(path-to-mail-dir "~/.local/share/mail/gmail/")
(path-to-inbox-dir "~/.local/share/mail/gmail/inbox")))
(channel
(channel
(channel "gmail")
(far-store ":gmail-remote:")
(near-store ":gmail-local:")
(create 'Both)
(patterns "* ![Gmail]* \"[Gmail]/Sent Mail\" \"[Gmail]/Starred\" \"[Gmail]/All Mail\" \"[Gmail]/Trash\"")
(sync-state "*"))))))))
Not sure, but I have a feeling that this is not well written, perhaps there are some improvements that can be made.
Particularly, I don’t like that I have to do (imap-store (imap-store (imap-store and same for maildir-store and channel.
The part that I cannot figure out is,
;; (if (and (string-null? pass)
;; (not (eq? pass-cmd #f)))
;; (serialize-cmd field-name pass-cmd)
;; "")
I cannot figure out how would I serialize this cmd type, that is my own custom type. If I un-comment this, I get this error,
In procedure string-append: Wrong type (expecting string): #<gexp (format #f "~a \"~a/bin/~a\"~%" (quote #<gexp-input accounts:out>) #<gexp-input #<file-append #<package apoorv-password-store@1.7.4 nebula/packages/password-utils.scm:25 7fafd34c18f0> "">:out> #<gexp-input "pass my_email_pass":out>) apoorv/home/services/mbsync.scm:98:8 7fafcf7774b0>
Commenting this out, it works and I have no errors.
Now, I might be able to do something like,
#~(string-append "IMAPAccount " #$account "\n"
"Host " #$host "\n"
(if (and (not (string-null? #$user))
(eq? #$user-cmd #f))
(string-append "User " #$user "\n")
"")
(if (and (string-null? #$user)
(not (eq? #$user-cmd #f)))
#$(serialize-cmd field-name user-cmd)
"")
(if (and (not (string-null? #$pass))
(eq? #$pass-cmd #f))
(string-append "Pass " #$pass "\n")
"")
(if (and (string-null? #$pass)
(not (eq? #$pass-cmd #f)))
#$(serialize-cmd field-name pass-cmd)
"")
(if (not (eq? #$tls-type 'None))
(string-append "TLSType " (symbol->string #$tls-type) "\n")
"")
(if (not #$system-cert)
"SystemCertificate no \n"
"")
"CertificateFile " #$cert-file "\n"
"\n"
#$(serialize-imap-store field-name imap-store)
#$(serialize-maildir-store field-name maildir-store)
#$(serialize-channel field-name channel))))
but then, I have to add #$ to a every field and something causes this error,
building /gnu/store/na15a1kl544fy7flw6y3mbgsixdjsf9w-mbsyncrc.drv...
ice-9/read.scm:126:4: In procedure read-expr*:
/gnu/store/ihb24g8bshhml4ibw6xl1iv0w4va62fn-mbsyncrc-builder:1:461: Unknown # object: "#<"
builder for `/gnu/store/na15a1kl544fy7flw6y3mbgsixdjsf9w-mbsyncrc.drv' failed with exit code 1
build of /gnu/store/na15a1kl544fy7flw6y3mbgsixdjsf9w-mbsyncrc.drv failed
This is what the generated configuration file looks like (when it works),
IMAPAccount gmail
Host imap.gmail.com
User my_email@gmail.com
TLSType IMAPS
CertificateFile /etc/ssl/certs/ca-certificates.crt
IMAPStore gmail-remote
Account gmail
MaildirStore gmail-local
Path ~/.local/share/mail/gmail/
Inbox ~/.local/share/mail/gmail/inbox
Subfolders Verbatim
Channel gmail
Far :gmail-remote:
Near :gmail-local:
Patterns * ![Gmail]* "[Gmail]/Sent Mail" "[Gmail]/Starred" "[Gmail]/All Mail" "[Gmail]/Trash"
Create Both
SyncState *
)