2021-08-27 07:06:50 +00:00
|
|
|
|
;;; GNU Guix --- Functional package management for GNU
|
2022-11-30 06:06:50 +00:00
|
|
|
|
;;; Copyright © 2021, 2022 Andrew Tropin <andrew@trop.in>
|
2021-08-27 07:06:50 +00:00
|
|
|
|
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
|
|
|
|
|
;;;
|
|
|
|
|
;;; This file is part of GNU Guix.
|
|
|
|
|
;;;
|
|
|
|
|
;;; GNU Guix 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.
|
|
|
|
|
;;;
|
|
|
|
|
;;; GNU Guix 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
2021-10-04 23:09:41 +00:00
|
|
|
|
(define-module (gnu home services xdg)
|
2021-08-27 07:06:50 +00:00
|
|
|
|
#:use-module (gnu services configuration)
|
2021-10-09 13:51:25 +00:00
|
|
|
|
#:use-module (gnu home services)
|
2021-08-27 07:06:50 +00:00
|
|
|
|
#:use-module (gnu packages freedesktop)
|
2021-10-04 23:09:41 +00:00
|
|
|
|
#:use-module (gnu home services utils)
|
2021-08-27 07:06:50 +00:00
|
|
|
|
#:use-module (guix gexp)
|
2022-07-21 12:24:32 +00:00
|
|
|
|
#:use-module (guix modules)
|
2021-08-27 07:06:50 +00:00
|
|
|
|
#:use-module (guix records)
|
|
|
|
|
#:use-module (guix i18n)
|
|
|
|
|
#:use-module (guix diagnostics)
|
|
|
|
|
|
|
|
|
|
#:use-module (ice-9 match)
|
|
|
|
|
#:use-module (srfi srfi-1)
|
|
|
|
|
#:use-module (rnrs enums)
|
|
|
|
|
|
|
|
|
|
#:export (home-xdg-base-directories-service-type
|
|
|
|
|
home-xdg-base-directories-configuration
|
|
|
|
|
home-xdg-base-directories-configuration?
|
2022-11-30 06:06:50 +00:00
|
|
|
|
home-xdg-base-directories-configuration-cache-home
|
|
|
|
|
home-xdg-base-directories-configuration-config-home
|
|
|
|
|
home-xdg-base-directories-configuration-data-home
|
|
|
|
|
home-xdg-base-directories-configuration-state-home
|
|
|
|
|
home-xdg-base-directories-configuration-log-home
|
|
|
|
|
home-xdg-base-directories-configuration-runtime-dir
|
2021-08-27 07:06:50 +00:00
|
|
|
|
|
|
|
|
|
home-xdg-user-directories-service-type
|
|
|
|
|
home-xdg-user-directories-configuration
|
|
|
|
|
home-xdg-user-directories-configuration?
|
2022-11-30 06:06:50 +00:00
|
|
|
|
home-xdg-user-directories-configuration-desktop
|
|
|
|
|
home-xdg-user-directories-configuration-documents
|
|
|
|
|
home-xdg-user-directories-configuration-download
|
|
|
|
|
home-xdg-user-directories-configuration-music
|
|
|
|
|
home-xdg-user-directories-configuration-pictures
|
|
|
|
|
home-xdg-user-directories-configuration-publicshare
|
|
|
|
|
home-xdg-user-directories-configuration-templates
|
|
|
|
|
home-xdg-user-directories-configuration-videos
|
2021-08-27 07:06:50 +00:00
|
|
|
|
|
|
|
|
|
xdg-desktop-action
|
|
|
|
|
xdg-desktop-entry
|
|
|
|
|
home-xdg-mime-applications-service-type
|
|
|
|
|
home-xdg-mime-applications-configuration))
|
|
|
|
|
|
|
|
|
|
;;; Commentary:
|
|
|
|
|
;;
|
|
|
|
|
;; This module contains services related to XDG directories and
|
|
|
|
|
;; applications.
|
|
|
|
|
;;
|
|
|
|
|
;; - XDG base directories
|
|
|
|
|
;; - XDG user directories
|
|
|
|
|
;; - XDG MIME applications
|
|
|
|
|
;;
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; XDG base directories.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define (serialize-path field-name val) "")
|
|
|
|
|
(define path? string?)
|
|
|
|
|
|
|
|
|
|
(define-configuration home-xdg-base-directories-configuration
|
|
|
|
|
(cache-home
|
|
|
|
|
(path "$HOME/.cache")
|
|
|
|
|
"Base directory for programs to store user-specific non-essential
|
|
|
|
|
(cached) data. Files in this directory can be deleted anytime without
|
|
|
|
|
loss of important data.")
|
|
|
|
|
(config-home
|
|
|
|
|
(path "$HOME/.config")
|
|
|
|
|
"Base directory for programs to store configuration files.
|
|
|
|
|
Some programs store here log or state files, but it's not desired,
|
|
|
|
|
this directory should contain static configurations.")
|
|
|
|
|
(data-home
|
|
|
|
|
(path "$HOME/.local/share")
|
|
|
|
|
"Base directory for programs to store architecture independent
|
|
|
|
|
read-only shared data, analogus to @file{/usr/share}, but for user.")
|
|
|
|
|
(runtime-dir
|
|
|
|
|
(path "${XDG_RUNTIME_DIR:-/run/user/$UID}")
|
|
|
|
|
"Base directory for programs to store user-specific runtime files,
|
|
|
|
|
like sockets.")
|
|
|
|
|
(log-home
|
|
|
|
|
(path "$HOME/.local/var/log")
|
|
|
|
|
"Base directory for programs to store log files, analogus to
|
|
|
|
|
@file{/var/log}, but for user. It is not a part of XDG Base Directory
|
|
|
|
|
Specification, but helps to make implementation of home services more
|
|
|
|
|
consistent.")
|
|
|
|
|
(state-home
|
|
|
|
|
(path "$HOME/.local/var/lib")
|
|
|
|
|
"Base directory for programs to store state files, like databases,
|
|
|
|
|
analogus to @file{/var/lib}, but for user. It is not a part of XDG
|
|
|
|
|
Base Directory Specification, but helps to make implementation of home
|
|
|
|
|
services more consistent."))
|
|
|
|
|
|
|
|
|
|
(define (home-xdg-base-directories-environment-variables-service config)
|
|
|
|
|
(map
|
|
|
|
|
(lambda (field)
|
|
|
|
|
(cons (format
|
|
|
|
|
#f "XDG_~a"
|
|
|
|
|
(object->snake-case-string (configuration-field-name field) 'upper))
|
|
|
|
|
((configuration-field-getter field) config)))
|
|
|
|
|
home-xdg-base-directories-configuration-fields))
|
|
|
|
|
|
|
|
|
|
(define (ensure-xdg-base-dirs-on-activation config)
|
|
|
|
|
#~(map (lambda (xdg-base-dir-variable)
|
2022-07-21 12:24:32 +00:00
|
|
|
|
((@ (guix build utils) mkdir-p)
|
2021-08-27 07:06:50 +00:00
|
|
|
|
(getenv
|
|
|
|
|
xdg-base-dir-variable)))
|
2022-08-02 05:00:21 +00:00
|
|
|
|
'#$(filter-map
|
|
|
|
|
(lambda (field)
|
|
|
|
|
(let ((variable
|
|
|
|
|
(string-append
|
|
|
|
|
"XDG_"
|
|
|
|
|
(object->snake-case-string
|
|
|
|
|
(configuration-field-name field) 'upper))))
|
|
|
|
|
;; XDG_RUNTIME_DIR shouldn't be created during activation
|
|
|
|
|
;; and will be provided by elogind or other service.
|
|
|
|
|
(and (not (string=? "XDG_RUNTIME_DIR" variable))
|
|
|
|
|
variable)))
|
|
|
|
|
home-xdg-base-directories-configuration-fields)))
|
2021-08-27 07:06:50 +00:00
|
|
|
|
|
|
|
|
|
(define (last-extension-or-cfg config extensions)
|
|
|
|
|
"Picks configuration value from last provided extension. If there
|
|
|
|
|
are no extensions use configuration instead."
|
|
|
|
|
(or (and (not (null? extensions)) (last extensions)) config))
|
|
|
|
|
|
|
|
|
|
(define home-xdg-base-directories-service-type
|
|
|
|
|
(service-type (name 'home-xdg-base-directories)
|
|
|
|
|
(extensions
|
|
|
|
|
(list (service-extension
|
|
|
|
|
home-environment-variables-service-type
|
|
|
|
|
home-xdg-base-directories-environment-variables-service)
|
|
|
|
|
(service-extension
|
|
|
|
|
home-activation-service-type
|
|
|
|
|
ensure-xdg-base-dirs-on-activation)))
|
|
|
|
|
(default-value (home-xdg-base-directories-configuration))
|
|
|
|
|
(compose identity)
|
|
|
|
|
(extend last-extension-or-cfg)
|
|
|
|
|
(description "Configure XDG base directories. This
|
|
|
|
|
service introduces two additional variables @env{XDG_STATE_HOME},
|
|
|
|
|
@env{XDG_LOG_HOME}. They are not a part of XDG specification, at
|
2021-11-15 01:37:54 +00:00
|
|
|
|
least yet, but are convenient to have, it improves the consistency
|
2021-08-27 07:06:50 +00:00
|
|
|
|
between different home services. The services of this service-type is
|
|
|
|
|
instantiated by default, to provide non-default value, extend the
|
|
|
|
|
service-type (using @code{simple-service} for example).")))
|
|
|
|
|
|
|
|
|
|
(define (generate-home-xdg-base-directories-documentation)
|
|
|
|
|
(generate-documentation
|
|
|
|
|
`((home-xdg-base-directories-configuration
|
|
|
|
|
,home-xdg-base-directories-configuration-fields))
|
|
|
|
|
'home-xdg-base-directories-configuration))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; XDG user directories.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define (serialize-string field-name val)
|
|
|
|
|
;; The path has to be quoted
|
|
|
|
|
(format #f "XDG_~a_DIR=\"~a\"\n"
|
|
|
|
|
(object->snake-case-string field-name 'upper) val))
|
|
|
|
|
|
|
|
|
|
(define-configuration home-xdg-user-directories-configuration
|
|
|
|
|
(desktop
|
|
|
|
|
(string "$HOME/Desktop")
|
|
|
|
|
"Default ``desktop'' directory, this is what you see on your
|
|
|
|
|
desktop when using a desktop environment,
|
|
|
|
|
e.g. GNOME (@pxref{XWindow,,,guix.info}).")
|
|
|
|
|
(documents
|
|
|
|
|
(string "$HOME/Documents")
|
|
|
|
|
"Default directory to put documents like PDFs.")
|
|
|
|
|
(download
|
|
|
|
|
(string "$HOME/Downloads")
|
|
|
|
|
"Default directory downloaded files, this is where your Web-broser
|
|
|
|
|
will put downloaded files in.")
|
|
|
|
|
(music
|
|
|
|
|
(string "$HOME/Music")
|
|
|
|
|
"Default directory for audio files.")
|
|
|
|
|
(pictures
|
|
|
|
|
(string "$HOME/Pictures")
|
|
|
|
|
"Default directory for pictures and images.")
|
|
|
|
|
(publicshare
|
|
|
|
|
(string "$HOME/Public")
|
|
|
|
|
"Default directory for shared files, which can be accessed by other
|
|
|
|
|
users on local machine or via network.")
|
|
|
|
|
(templates
|
|
|
|
|
(string "$HOME/Templates")
|
|
|
|
|
"Default directory for templates. They can be used by graphical
|
|
|
|
|
file manager or other apps for creating new files with some
|
|
|
|
|
pre-populated content.")
|
|
|
|
|
(videos
|
|
|
|
|
(string "$HOME/Videos")
|
|
|
|
|
"Default directory for videos."))
|
|
|
|
|
|
|
|
|
|
(define (home-xdg-user-directories-files-service config)
|
2022-02-11 12:34:46 +00:00
|
|
|
|
`(("user-dirs.conf"
|
2021-08-27 07:06:50 +00:00
|
|
|
|
,(mixed-text-file
|
|
|
|
|
"user-dirs.conf"
|
|
|
|
|
"enabled=False\n"))
|
2022-02-11 12:34:46 +00:00
|
|
|
|
("user-dirs.dirs"
|
2021-08-27 07:06:50 +00:00
|
|
|
|
,(mixed-text-file
|
|
|
|
|
"user-dirs.dirs"
|
|
|
|
|
(serialize-configuration
|
|
|
|
|
config
|
|
|
|
|
home-xdg-user-directories-configuration-fields)))))
|
|
|
|
|
|
|
|
|
|
(define (home-xdg-user-directories-activation-service config)
|
|
|
|
|
(let ((dirs (map (lambda (field)
|
|
|
|
|
((configuration-field-getter field) config))
|
|
|
|
|
home-xdg-user-directories-configuration-fields)))
|
|
|
|
|
#~(let ((ensure-dir
|
|
|
|
|
(lambda (path)
|
2022-07-21 12:24:32 +00:00
|
|
|
|
((@ (guix build utils) mkdir-p)
|
|
|
|
|
((@ (ice-9 string-fun) string-replace-substring)
|
2021-08-27 07:06:50 +00:00
|
|
|
|
path "$HOME" (getenv "HOME"))))))
|
|
|
|
|
(display "Creating XDG user directories...")
|
|
|
|
|
(map ensure-dir '#$dirs)
|
|
|
|
|
(display " done\n"))))
|
|
|
|
|
|
|
|
|
|
(define home-xdg-user-directories-service-type
|
|
|
|
|
(service-type (name 'home-xdg-user-directories)
|
|
|
|
|
(extensions
|
|
|
|
|
(list (service-extension
|
2022-02-11 12:34:46 +00:00
|
|
|
|
home-xdg-configuration-files-service-type
|
2021-08-27 07:06:50 +00:00
|
|
|
|
home-xdg-user-directories-files-service)
|
|
|
|
|
(service-extension
|
|
|
|
|
home-activation-service-type
|
|
|
|
|
home-xdg-user-directories-activation-service)))
|
|
|
|
|
(default-value (home-xdg-user-directories-configuration))
|
2022-12-19 11:02:20 +00:00
|
|
|
|
(compose identity)
|
|
|
|
|
(extend last-extension-or-cfg)
|
2021-08-27 07:06:50 +00:00
|
|
|
|
(description "Configure XDG user directories. To
|
|
|
|
|
disable a directory, point it to the $HOME.")))
|
|
|
|
|
|
|
|
|
|
(define (generate-home-xdg-user-directories-documentation)
|
|
|
|
|
(generate-documentation
|
|
|
|
|
`((home-xdg-user-directories-configuration
|
|
|
|
|
,home-xdg-user-directories-configuration-fields))
|
|
|
|
|
'home-xdg-user-directories-configuration))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; XDG MIME applications.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
;; Example config
|
|
|
|
|
;;
|
|
|
|
|
;; (home-xdg-mime-applications-configuration
|
|
|
|
|
;; (added '((x-scheme-handler/magnet . torrent.desktop)))
|
|
|
|
|
;; (default '((inode/directory . file.desktop)))
|
|
|
|
|
;; (removed '((inode/directory . thunar.desktop)))
|
|
|
|
|
;; (desktop-entries
|
|
|
|
|
;; (list (xdg-desktop-entry
|
|
|
|
|
;; (file "file")
|
|
|
|
|
;; (name "File manager")
|
|
|
|
|
;; (type 'application)
|
|
|
|
|
;; (config
|
|
|
|
|
;; '((exec . "emacsclient -c -a emacs %u"))))
|
|
|
|
|
;; (xdg-desktop-entry
|
|
|
|
|
;; (file "text")
|
|
|
|
|
;; (name "Text editor")
|
|
|
|
|
;; (type 'application)
|
|
|
|
|
;; (config
|
|
|
|
|
;; '((exec . "emacsclient -c -a emacs %u")))
|
|
|
|
|
;; (actions
|
|
|
|
|
;; (list (xdg-desktop-action
|
|
|
|
|
;; (action 'create)
|
|
|
|
|
;; (name "Create an action")
|
|
|
|
|
;; (config
|
|
|
|
|
;; '((exec . "echo hi"))))))))))
|
|
|
|
|
|
|
|
|
|
;; See
|
|
|
|
|
;; <https://specifications.freedesktop.org/shared-mime-info-spec/shared-mime-info-spec-latest.html>
|
|
|
|
|
;; <https://specifications.freedesktop.org/mime-apps-spec/mime-apps-spec-latest.html>
|
|
|
|
|
|
|
|
|
|
(define (serialize-alist field-name val)
|
|
|
|
|
(define (serialize-mimelist-entry key val)
|
|
|
|
|
(let ((val (cond
|
|
|
|
|
((list? val)
|
|
|
|
|
(string-join (map maybe-object->string val) ";"))
|
|
|
|
|
((or (string? val) (symbol? val))
|
|
|
|
|
val)
|
|
|
|
|
(else (raise (formatted-message
|
|
|
|
|
(G_ "\
|
|
|
|
|
The value of an XDG MIME entry must be a list, string or symbol, was given ~a")
|
|
|
|
|
val))))))
|
|
|
|
|
(format #f "~a=~a\n" key val)))
|
|
|
|
|
|
|
|
|
|
(define (merge-duplicates alist acc)
|
|
|
|
|
"Merge values that have the same key.
|
|
|
|
|
|
|
|
|
|
@example
|
|
|
|
|
(merge-duplicates '((key1 . value1)
|
2021-09-28 09:30:55 +00:00
|
|
|
|
(key2 . value2)
|
|
|
|
|
(key1 . value3)
|
|
|
|
|
(key1 . value4)) '())
|
2021-08-27 07:06:50 +00:00
|
|
|
|
|
|
|
|
|
@result{} ((key1 . (value4 value3 value1)) (key2 . value2))
|
|
|
|
|
@end example"
|
|
|
|
|
(cond
|
|
|
|
|
((null? alist) acc)
|
|
|
|
|
(else (let* ((head (first alist))
|
|
|
|
|
(tail (cdr alist))
|
|
|
|
|
(key (first head))
|
|
|
|
|
(value (cdr head))
|
2021-09-28 09:30:55 +00:00
|
|
|
|
(duplicate? (assoc key acc))
|
|
|
|
|
(ensure-list (lambda (x)
|
|
|
|
|
(if (list? x) x (list x)))))
|
2021-08-27 07:06:50 +00:00
|
|
|
|
(if duplicate?
|
|
|
|
|
;; XXX: This will change the order of things,
|
|
|
|
|
;; though, it shouldn't be a problem for XDG MIME.
|
|
|
|
|
(merge-duplicates
|
|
|
|
|
tail
|
|
|
|
|
(alist-cons key
|
2021-09-28 09:30:55 +00:00
|
|
|
|
(cons value (ensure-list (cdr duplicate?)))
|
2021-08-27 07:06:50 +00:00
|
|
|
|
(alist-delete key acc)))
|
|
|
|
|
(merge-duplicates tail (cons head acc)))))))
|
|
|
|
|
|
|
|
|
|
(string-append (if (equal? field-name 'default)
|
|
|
|
|
"\n[Default Applications]\n"
|
|
|
|
|
(format #f "\n[~a Associations]\n"
|
|
|
|
|
(string-capitalize (symbol->string field-name))))
|
|
|
|
|
(generic-serialize-alist string-append
|
|
|
|
|
serialize-mimelist-entry
|
|
|
|
|
(merge-duplicates val '()))))
|
|
|
|
|
|
|
|
|
|
(define xdg-desktop-types (make-enumeration
|
|
|
|
|
'(application
|
|
|
|
|
link
|
|
|
|
|
directory)))
|
|
|
|
|
|
|
|
|
|
(define (xdg-desktop-type? type)
|
|
|
|
|
(unless (enum-set-member? type xdg-desktop-types)
|
|
|
|
|
(raise (formatted-message
|
|
|
|
|
(G_ "XDG desktop type must be of of ~a, was given: ~a")
|
|
|
|
|
(list->human-readable-list (enum-set->list xdg-desktop-types))
|
|
|
|
|
type))))
|
|
|
|
|
|
|
|
|
|
;; TODO: Add proper docs for this
|
|
|
|
|
;; XXX: 'define-configuration' require that fields have a default
|
|
|
|
|
;; value.
|
|
|
|
|
(define-record-type* <xdg-desktop-action>
|
|
|
|
|
xdg-desktop-action make-xdg-desktop-action
|
|
|
|
|
xdg-desktop-action?
|
|
|
|
|
(action xdg-desktop-action-action) ; symbol
|
|
|
|
|
(name xdg-desktop-action-name) ; string
|
|
|
|
|
(config xdg-desktop-action-config ; alist
|
|
|
|
|
(default '())))
|
|
|
|
|
|
|
|
|
|
(define-record-type* <xdg-desktop-entry>
|
|
|
|
|
xdg-desktop-entry make-xdg-desktop-entry
|
|
|
|
|
xdg-desktop-entry?
|
|
|
|
|
;; ".desktop" will automatically be added
|
|
|
|
|
(file xdg-desktop-entry-file) ; string
|
|
|
|
|
(name xdg-desktop-entry-name) ; string
|
|
|
|
|
(type xdg-desktop-entry-type) ; xdg-desktop-type
|
|
|
|
|
(config xdg-desktop-entry-config ; alist
|
|
|
|
|
(default '()))
|
|
|
|
|
(actions xdg-desktop-entry-actions ; list of <xdg-desktop-action>
|
|
|
|
|
(default '())))
|
|
|
|
|
|
|
|
|
|
(define desktop-entries? (list-of xdg-desktop-entry?))
|
|
|
|
|
(define (serialize-desktop-entries field-name val) "")
|
|
|
|
|
|
|
|
|
|
(define (serialize-xdg-desktop-entry entry)
|
|
|
|
|
"Return a tuple of the file name for ENTRY and the serialized
|
|
|
|
|
configuration."
|
|
|
|
|
(define (format-config key val)
|
|
|
|
|
(let ((val (cond
|
|
|
|
|
((list? val)
|
|
|
|
|
(string-join (map maybe-object->string val) ";"))
|
|
|
|
|
((boolean? val)
|
|
|
|
|
(if val "true" "false"))
|
|
|
|
|
(else val)))
|
|
|
|
|
(key (string-capitalize (maybe-object->string key))))
|
|
|
|
|
(list (if (string-suffix? key "?")
|
|
|
|
|
(string-drop-right key (- (string-length key) 1))
|
|
|
|
|
key)
|
|
|
|
|
"=" val "\n")))
|
|
|
|
|
|
|
|
|
|
(define (serialize-alist config)
|
2022-03-01 05:04:27 +00:00
|
|
|
|
(generic-serialize-alist append format-config config))
|
2021-08-27 07:06:50 +00:00
|
|
|
|
|
2022-11-19 16:37:24 +00:00
|
|
|
|
(define (serialize-xdg-desktop-action desktop-action)
|
|
|
|
|
(match-record desktop-action <xdg-desktop-action>
|
|
|
|
|
(action name config)
|
|
|
|
|
`(,(format #f "[Desktop Action ~a]\n"
|
|
|
|
|
(string-capitalize (maybe-object->string action)))
|
|
|
|
|
,(format #f "Name=~a\n" name)
|
|
|
|
|
,@(serialize-alist config))))
|
|
|
|
|
|
|
|
|
|
(match-record entry <xdg-desktop-entry>
|
|
|
|
|
(file name type config actions)
|
|
|
|
|
(list (if (string-suffix? file ".desktop")
|
|
|
|
|
file
|
|
|
|
|
(string-append file ".desktop"))
|
|
|
|
|
`("[Desktop Entry]\n"
|
|
|
|
|
,(format #f "Name=~a\n" name)
|
|
|
|
|
,(format #f "Type=~a\n"
|
|
|
|
|
(string-capitalize (symbol->string type)))
|
|
|
|
|
,@(serialize-alist config)
|
|
|
|
|
,@(append-map serialize-xdg-desktop-action actions)))))
|
2021-08-27 07:06:50 +00:00
|
|
|
|
|
|
|
|
|
(define-configuration home-xdg-mime-applications-configuration
|
|
|
|
|
(added
|
|
|
|
|
(alist '())
|
|
|
|
|
"An association list of MIME types and desktop entries which indicate
|
|
|
|
|
that the application should used to open the specified MIME type. The
|
|
|
|
|
value has to be string, symbol, or list of strings or symbols, this
|
|
|
|
|
applies to the `@code{default}', and `@code{removed}' fields as well.")
|
|
|
|
|
(default
|
|
|
|
|
(alist '())
|
|
|
|
|
"An association list of MIME types and desktop entries which indicate
|
|
|
|
|
that the application should be the default for opening the specified
|
|
|
|
|
MIME type.")
|
|
|
|
|
(removed
|
|
|
|
|
(alist '())
|
|
|
|
|
"An association list of MIME types and desktop entries which indicate
|
|
|
|
|
that the application cannot open the specified MIME type.")
|
|
|
|
|
(desktop-entries
|
|
|
|
|
(desktop-entries '())
|
|
|
|
|
"A list of XDG desktop entries to create. See
|
|
|
|
|
@code{xdg-desktop-entry}."))
|
|
|
|
|
|
2022-02-11 12:34:46 +00:00
|
|
|
|
(define (home-xdg-mime-applications-files config)
|
2021-08-27 07:06:50 +00:00
|
|
|
|
(define (add-xdg-desktop-entry-file entry)
|
|
|
|
|
(let ((file (first entry))
|
|
|
|
|
(config (second entry)))
|
2022-03-29 09:47:39 +00:00
|
|
|
|
;; TODO: Use xdg-data-files instead of home-files here
|
|
|
|
|
(list (format #f "applications/~a" file)
|
2021-08-27 07:06:50 +00:00
|
|
|
|
(apply mixed-text-file
|
|
|
|
|
(format #f "xdg-desktop-~a-entry" file)
|
|
|
|
|
config))))
|
2022-02-11 12:34:46 +00:00
|
|
|
|
(map (compose add-xdg-desktop-entry-file serialize-xdg-desktop-entry)
|
|
|
|
|
(home-xdg-mime-applications-configuration-desktop-entries config)))
|
2021-08-27 07:06:50 +00:00
|
|
|
|
|
2022-02-11 12:34:46 +00:00
|
|
|
|
(define (home-xdg-mime-applications-xdg-files config)
|
|
|
|
|
`(("mimeapps.list"
|
|
|
|
|
,(mixed-text-file
|
|
|
|
|
"xdg-mime-appplications"
|
|
|
|
|
(serialize-configuration
|
|
|
|
|
config
|
|
|
|
|
home-xdg-mime-applications-configuration-fields)))))
|
2021-08-27 07:06:50 +00:00
|
|
|
|
|
|
|
|
|
(define (home-xdg-mime-applications-extension old-config extension-configs)
|
|
|
|
|
(define (extract-fields config)
|
|
|
|
|
;; return '(added default removed desktop-entries)
|
|
|
|
|
(list (home-xdg-mime-applications-configuration-added config)
|
|
|
|
|
(home-xdg-mime-applications-configuration-default config)
|
|
|
|
|
(home-xdg-mime-applications-configuration-removed config)
|
|
|
|
|
(home-xdg-mime-applications-configuration-desktop-entries config)))
|
|
|
|
|
|
|
|
|
|
(define (append-configs elem acc)
|
|
|
|
|
(list (append (first elem) (first acc))
|
|
|
|
|
(append (second elem) (second acc))
|
|
|
|
|
(append (third elem) (third acc))
|
|
|
|
|
(append (fourth elem) (fourth acc))))
|
|
|
|
|
|
|
|
|
|
;; TODO: Implement procedure to check for duplicates without
|
|
|
|
|
;; sacrificing performance.
|
|
|
|
|
;;
|
|
|
|
|
;; Combine all the alists from 'added', 'default' and 'removed'
|
|
|
|
|
;; into one big alist.
|
|
|
|
|
(let ((folded-configs (fold append-configs
|
|
|
|
|
(extract-fields old-config)
|
|
|
|
|
(map extract-fields extension-configs))))
|
|
|
|
|
(home-xdg-mime-applications-configuration
|
|
|
|
|
(added (first folded-configs))
|
|
|
|
|
(default (second folded-configs))
|
|
|
|
|
(removed (third folded-configs))
|
|
|
|
|
(desktop-entries (fourth folded-configs)))))
|
|
|
|
|
|
|
|
|
|
(define home-xdg-mime-applications-service-type
|
|
|
|
|
(service-type (name 'home-xdg-mime-applications)
|
|
|
|
|
(extensions
|
|
|
|
|
(list (service-extension
|
2022-03-29 09:47:39 +00:00
|
|
|
|
home-xdg-data-files-service-type
|
2022-02-11 12:34:46 +00:00
|
|
|
|
home-xdg-mime-applications-files)
|
|
|
|
|
(service-extension
|
|
|
|
|
home-xdg-configuration-files-service-type
|
|
|
|
|
home-xdg-mime-applications-xdg-files)))
|
2021-08-27 07:06:50 +00:00
|
|
|
|
(compose identity)
|
|
|
|
|
(extend home-xdg-mime-applications-extension)
|
|
|
|
|
(default-value (home-xdg-mime-applications-configuration))
|
|
|
|
|
(description
|
|
|
|
|
"Configure XDG MIME applications, and XDG desktop entries.")))
|