From 527d9322e93c14685aaba61d49125483397cd948 Mon Sep 17 00:00:00 2001 From: "Dirk-Jan C. Binnema" Date: Sat, 31 May 2025 12:44:13 +0300 Subject: [PATCH] scm: new guile/scheme bindings This implements the new scm/guile bindings for mu, to replace the deprecated guile/ (at some point in the future). For now, we allow for creating a guile shell with mu support. --- mu/meson.build | 2 +- scm/meson.build | 58 +++++++ scm/mu-scm-contact.cc | 36 ++++ scm/mu-scm-contact.hh | 38 +++++ scm/mu-scm-shell.scm | 18 ++ scm/mu-scm-store.cc | 156 +++++++++++++++++ scm/mu-scm-store.hh | 30 ++++ scm/mu-scm.cc | 160 ++++++++++++++++++ scm/mu-scm.hh | 242 ++++++++++++++++++++++++++ scm/mu-scm.scm | 384 ++++++++++++++++++++++++++++++++++++++++++ 10 files changed, 1123 insertions(+), 1 deletion(-) create mode 100644 scm/meson.build create mode 100644 scm/mu-scm-contact.cc create mode 100644 scm/mu-scm-contact.hh create mode 100644 scm/mu-scm-shell.scm create mode 100644 scm/mu-scm-store.cc create mode 100644 scm/mu-scm-store.hh create mode 100644 scm/mu-scm.cc create mode 100644 scm/mu-scm.hh create mode 100644 scm/mu-scm.scm diff --git a/mu/meson.build b/mu/meson.build index 0ada1e5f..28dd00ed 100644 --- a/mu/meson.build +++ b/mu/meson.build @@ -34,7 +34,7 @@ mu = executable( 'mu-cmd-view.cc', 'mu-cmd.cc' ], - dependencies: [ glib_dep, gmime_dep, lib_mu_dep, thread_dep, config_h_dep ], + dependencies: [ glib_dep, gmime_dep, lib_mu_dep, mu_scm_dep, thread_dep, config_h_dep ], cpp_args: ['-DMU_SCRIPTS_DIR="'+ join_paths(datadir, 'mu', 'scripts') + '"'], install: true) # diff --git a/scm/meson.build b/scm/meson.build new file mode 100644 index 00000000..6681d5a7 --- /dev/null +++ b/scm/meson.build @@ -0,0 +1,58 @@ +## Copyright (C) 2025 Dirk-Jan C. Binnema +## +## 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, write to the Free Software Foundation, +## Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +mu_scm_dir=join_paths(datadir, 'mu', 'scm') +mu_scm_dir_arg='-DMU_SCM_DIR="' + mu_scm_dir + '"' + +lib_mu_scm=static_library( + 'mu-scm', + [ + 'mu-scm.cc', + 'mu-scm-contact.cc', + 'mu-scm-store.cc' + ], + dependencies: [ + guile_dep, + config_h_dep, + lib_mu_dep, + lib_mu_utils_dep, + lib_mu_message_dep], + install: false, + cpp_args: [mu_scm_dir_arg]) + +install_data(['mu-scm.scm', 'mu-scm-shell.scm'], install_dir : mu_scm_dir) + +# note: top-level meson.build defines a dummy replacement for this. +mu_scm_dep = declare_dependency( + link_with: lib_mu_scm, + dependencies: [guile_dep, lib_mu_dep, config_h_dep, thread_dep ], + include_directories: + include_directories(['.', '..'])) + +if makeinfo.found() + custom_target('mu_scm_info', + input: 'mu-scm.texi', + output: 'mu-scm.info', + install: true, + install_dir: infodir, + command: [makeinfo, + '-o', join_paths(meson.current_build_dir(), 'mu-scm.info'), + join_paths(meson.current_source_dir(), 'mu-scm.texi'), + '-I', join_paths(meson.current_build_dir(), '..')]) + if install_info.found() + infodir = join_paths(get_option('prefix') / get_option('infodir')) + meson.add_install_script(install_info_script, infodir, 'mu-scm.info') + endif +endif diff --git a/scm/mu-scm-contact.cc b/scm/mu-scm-contact.cc new file mode 100644 index 00000000..08fa3e0e --- /dev/null +++ b/scm/mu-scm-contact.cc @@ -0,0 +1,36 @@ +/* +** Copyright (C) 2025 Dirk-Jan C. Binnema +** +** 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, 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, write to the Free Software Foundation, +** Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +** +*/ + + +#include "mu-scm-contact.hh" + +using namespace Mu::Scm; + +SCM +Mu::Scm::to_scm(const Contact& contact) +{ + static SCM email{scm_from_utf8_symbol("email")}; + static SCM name{scm_from_utf8_symbol("name")}; + + SCM alist = scm_acons(email, to_scm(contact.email), SCM_EOL); + if (!contact.name.empty()) + alist = scm_acons(name, to_scm(contact.name), alist); + + return alist; +} diff --git a/scm/mu-scm-contact.hh b/scm/mu-scm-contact.hh new file mode 100644 index 00000000..9a5472db --- /dev/null +++ b/scm/mu-scm-contact.hh @@ -0,0 +1,38 @@ +/* +** Copyright (C) 2025 Dirk-Jan C. Binnema +** +** 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, 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, write to the Free Software Foundation, +** Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +** +*/ + +#ifndef MU_SCM_CONTACT_HH +#define MU_SCM_CONTACT_HH + +#include "message/mu-contact.hh" +#include "mu-scm.hh" + +namespace Mu::Scm { +/** + * Convert a Contact to an SCM + * + * @param contact a contact + * + * @return SCM + */ +SCM to_scm(const Contact& contact); + +} // Mu::Scm + +#endif /*MU_SCM_CONTACT_HH*/ diff --git a/scm/mu-scm-shell.scm b/scm/mu-scm-shell.scm new file mode 100644 index 00000000..0efe7f8f --- /dev/null +++ b/scm/mu-scm-shell.scm @@ -0,0 +1,18 @@ +;; Copyright (C) 2025 Dirk-Jan C. Binnema +;; +;; 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, 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, write to the Free Software Foundation, +;; Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +(display "Welcome to the mu shell!\n\n") +(use-modules (mu)) diff --git a/scm/mu-scm-store.cc b/scm/mu-scm-store.cc new file mode 100644 index 00000000..f11ef834 --- /dev/null +++ b/scm/mu-scm-store.cc @@ -0,0 +1,156 @@ +/* +** Copyright (C) 2025 Dirk-Jan C. Binnema +** +** 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, 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, write to the Free Software Foundation, +** Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +** +*/ + +#include "mu-scm-store.hh" +#include "mu-scm-contact.hh" + +using namespace Mu; +using namespace Mu::Scm; + +// types +namespace { +static SCM store_type; +static SCM default_store; +static bool initialized; +} + +static const Store& +to_store(SCM scm) +{ + scm_assert_foreign_object_type(store_type, scm); + return *reinterpret_cast(scm_foreign_object_ref(scm, 0)); +} + +static SCM +subr_mcount(SCM store_scm) +{ + return to_scm(to_store(store_scm).size()); +} + +static SCM +subr_cfind(SCM store_scm, SCM pattern_scm, SCM personal_scm, SCM after_scm, SCM max_results_scm) +{ + SCM contacts{SCM_EOL}; + const auto pattern{from_scm(pattern_scm)}; + const auto personal{from_scm(personal_scm)}; + const auto after{from_scm_with_default(after_scm, 0)}; + + // 0 means "unlimited" + const size_t maxnum = from_scm_with_default(max_results_scm, 0U); + + to_store(store_scm).contacts_cache().for_each( + [&](const auto& contact)->bool { + contacts = scm_append_x(scm_list_2(contacts, scm_list_1(to_scm(contact)))); + return true; + }, pattern, personal, after, maxnum); + return contacts; +} + +static Field::Id +to_sort_field_id(SCM field) +{ + if (scm_is_false(field)) + return Field::Id::Date; + + const auto sym{from_scm(scm_symbol_to_string(field))}; + if (const auto field_opt{field_from_name(sym)}; !field_opt) { + raise_error("invalid symbol", "mfind", + "expected sort-field symbol, but got {}", sym); + return Field::Id::Date; + } else + return field_opt->id; +} + +static SCM +subr_mfind(SCM store_scm, SCM query_scm, SCM related_scm, SCM skip_dups_scm, + SCM sort_field_scm, SCM reverse_scm, SCM max_results_scm) +{ + const auto& store{to_store(store_scm)}; + const auto query{from_scm(query_scm)}; + const auto related(from_scm(related_scm)); + const auto skip_dups(from_scm(skip_dups_scm)); + const auto reverse(from_scm(reverse_scm)); + + SCM_ASSERT_TYPE(scm_is_false(sort_field_scm) || scm_is_symbol(sort_field_scm), + sort_field_scm, SCM_ARG5, __func__, "symbol or #f"); + + const auto sort_field_id = to_sort_field_id(sort_field_scm); + + // 0 means "unlimited" + const size_t maxnum = from_scm_with_default(max_results_scm, 0U); + + // XXX date/reverse/maxnum + + const QueryFlags qflags = QueryFlags::SkipUnreadable | + (skip_dups ? QueryFlags::SkipDuplicates : QueryFlags::None) | + (related ? QueryFlags::IncludeRelated: QueryFlags::None ) | + (reverse ? QueryFlags::Descending : QueryFlags::None); + + SCM msgs{SCM_EOL}; + std::lock_guard lock{store.lock()}; + const auto qres = store.run_query(query, sort_field_id, qflags, maxnum); + + SCM_ASSERT(qres, query_scm, SCM_ARG1, __func__); + + for (const auto& mi: *qres) { + if (auto plist{mi.document()->get_data()}; plist.empty()) + continue; + else { + SCM scm_plist{scm_c_eval_string(("'" + plist).c_str())}; + msgs = scm_append_x(scm_list_2( msgs, scm_list_1(scm_plist))); + } + } + + return msgs; +} + +static void +init_subrs() +{ +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wcast-function-type" + scm_c_define_gsubr("store-mfind", 7/*req*/, 0/*opt*/, 0/*rst*/, + reinterpret_cast(subr_mfind)); + scm_c_define_gsubr("store-mcount", 1/*req*/, 0/*opt*/, 0/*rst*/, + reinterpret_cast(subr_mcount)); + scm_c_define_gsubr("store-cfind", 5/*req*/, 0/*opt*/, 0/*rst*/, + reinterpret_cast(subr_cfind)); +#pragma GCC diagnostic pop +} + + +void +Mu::Scm::init_store(const Store& store) +{ + if (initialized) + return; + + store_type = scm_make_foreign_object_type( + scm_from_utf8_symbol("store"), + scm_list_1 (scm_from_utf8_symbol("data")), + {}); // no finalizer + + default_store = scm_make_foreign_object_1( + store_type, const_cast(&store)); + scm_c_define("default-store-object", default_store); + + init_subrs(); + + initialized = true; +} diff --git a/scm/mu-scm-store.hh b/scm/mu-scm-store.hh new file mode 100644 index 00000000..41396ba8 --- /dev/null +++ b/scm/mu-scm-store.hh @@ -0,0 +1,30 @@ +/* +** Copyright (C) 2025 Dirk-Jan C. Binnema +** +** 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, 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, write to the Free Software Foundation, +** Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +** +*/ + +#ifndef MU_SCM_STORE_HH +#define MU_SCM_STORE_HH + +#include "lib/mu-store.hh" +#include "mu-scm.hh" + +namespace Mu::Scm { +void init_store(const Mu::Store& store); +} // Mu::Scm + +#endif /*MU_SCM_STORE_HH*/ diff --git a/scm/mu-scm.cc b/scm/mu-scm.cc new file mode 100644 index 00000000..10526e3f --- /dev/null +++ b/scm/mu-scm.cc @@ -0,0 +1,160 @@ +/* +** Copyright (C) 2025 Dirk-Jan C. Binnema +** +** 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, 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, write to the Free Software Foundation, +** Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +** +*/ + +#include "mu-scm.hh" + +#include +#include + +#include "mu-utils.hh" +#include "config.h" + +#include "mu-scm-contact.hh" +#include "mu-scm-store.hh" + +using namespace Mu; +using namespace Mu::Scm; + +namespace { +static const Mu::Scm::Config *config{}; +static SCM mu_mod; // The mu module +} + +/** + * Create a plist for the relevant configuration items + * + * @param opts + */ +static void +init_config (const Options& opts) +{ + scm_c_define("options", + alist_add( + SCM_EOL, + make_symbol("mu-home"), opts.muhome, + make_symbol("verbose"), opts.verbose, + make_symbol("debug"), opts.debug, + make_symbol("quiet"), opts.quiet)); +} + +static void +init_module_mu(void* _data) +{ + init_config(config->options); + init_store(config->store); +} + +static const Result +make_mu_scm_path(const std::string& fname) { + + const std::string dir = []() { + if (const char *altpath{::getenv("MU_SCM_DIR")}; altpath) + return altpath; + else + return MU_SCM_DIR; + }(); + + auto fpath{join_paths(dir, fname)}; + if (::access(fpath.c_str(), R_OK) != 0) + return Err(Error::Code::File, "cannot read {}: {}", + fpath, ::strerror(errno)); + else + return Ok(std::move(fpath)); +} + +namespace { +static std::string mu_scm_path; +static std::string mu_scm_shell_path; +} + + +static Result +prepare_run(const Mu::Scm::Config& conf) +{ + if (config) + return Err(Error{Error::Code::AccessDenied, + "already prepared"}); + config = &conf; + + // do a checks _before_ entering guile, so we get a bit more civilized + // error message. + + if (const auto path = make_mu_scm_path("mu-scm.scm"); path) + mu_scm_path = *path; + else + return Err(path.error()); + + if (const auto path = make_mu_scm_path("mu-scm-shell.scm"); path) + mu_scm_shell_path = *path; + else + return Err(path.error()); + + + if (config->options.scm.script_path) { + const auto path{config->options.scm.script_path->c_str()}; + if (const auto res = ::access(path, R_OK); res != 0) { + return Err(Error::Code::InvalidArgument, + "cannot read '{}': {}", path, ::strerror(errno)); + } + } + + return Ok(); +} + +Result +Mu::Scm::run(const Mu::Scm::Config& conf) { + + if (const auto res = prepare_run(conf); !res) + return Err(res.error()); + + scm_boot_guile(0, {}, [](void *data, int argc, char **argv) { + mu_mod = scm_c_define_module ("mu", init_module_mu, {}); + + std::vector args { + "mu", + "-l", mu_scm_path.c_str(), + }; + std::string cmd; + const auto opts{config->options.scm}; + // if a script-path was specified, run a script + if (opts.script_path) { + // XXX: couldn't get another combination of -l/-s/-e/-c to work + // a) invokes `main' with arguments, and + // b) exits (rather than drop to a shell) + // but, what works is to manually specify (main ....) + cmd = "(main " + quote(*opts.script_path); + for (const auto& scriptarg : opts.params) + cmd += " " + quote(scriptarg); + cmd += ")"; + for (const auto& arg: { + "-l", opts.script_path->c_str(), + "-c", cmd.c_str()}) + args.emplace_back(arg); + } else { + // otherwise, drop us into an interactive shell/repl (and + // shell spec) + args.emplace_back("-l"); + args.emplace_back(mu_scm_shell_path.c_str()); + } + /* ahem...*/ + scm_shell(std::size(args), const_cast(args.data())); + }, {}); // never returns. + + return Ok(); +} diff --git a/scm/mu-scm.hh b/scm/mu-scm.hh new file mode 100644 index 00000000..f015eaaf --- /dev/null +++ b/scm/mu-scm.hh @@ -0,0 +1,242 @@ +/* +** Copyright (C) 2025 Dirk-Jan C. Binnema +** +** 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, 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, write to the Free Software Foundation, +** Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. +** +*/ + + +#ifndef MU_SCM_HH +#define MU_SCM_HH + +#include +#include +#include + +#pragma GCC diagnostic push +#pragma GCC diagnostic ignored "-Wredundant-decls" +#include +#pragma GCC diagnostic pop + +#include "utils/mu-result.hh" +#include "mu/mu-options.hh" +#include "mu-store.hh" + +/** + * Namespace for the Scm (Guile) subsystem + * + */ +namespace Mu::Scm { + + /** + * Configuration object + * + */ + struct Config { + const Mu::Store& store; + const Options& options; + }; + + /** + * Start a guile shell + * + * Initialize the Scm sub-system, then start a shell or run a script, + * based on the configuration. + * + * @param conf a Config object + * + * @return Ok() or some error + */ + Result run(const Config& conf); + + /** + * Helpers + * + * @{*/ + + // https://www.open-std.org/jtc1/sc22/wg21/docs/papers/2022/p2593r0.html + template struct always_false : std::false_type {}; + + template constexpr bool is_char_array_v = + std::is_array_v && + std::is_same_v, char>; + + /** + * Make SCM symbol from string-like value + * + * @param val some value + * + * @return an SCM symbol + */ + template + SCM make_symbol(const T& val){ + using Type = std::remove_const_t; // *not* std::remove_const + if constexpr (std::is_same_v || + std::is_same_v) + return scm_from_utf8_symboln(val.data(), val.size()); + else if constexpr (is_char_array_v|| std::is_same_v) + return scm_from_utf8_symbol(val); + else { + static_assert(always_false::value, "source type not supported"); + return SCM_UNSPECIFIED; + } + } + + /** + * Get some C++ value from an SCM object, generically. + * + * @param ARG some SCM object + * + * @return C++ value + */ + template + T from_scm(SCM ARG) { + using Type = std::remove_const_t; // *not* std::remove_const + if constexpr (std::is_same_v) { + SCM_ASSERT(scm_string_p(ARG), ARG, SCM_ARG1, __func__); + auto str{scm_to_utf8_string(ARG)}; + std::string res{str}; + ::free(str); + return res; + } else if constexpr (std::is_same_v) { + SCM_ASSERT(scm_char_p(ARG), ARG, SCM_ARG1, __func__); + return scm_to_char(ARG); + } else if constexpr (std::is_same_v) { + SCM_ASSERT(scm_boolean_p(ARG), ARG, SCM_ARG1, __func__); + return scm_to_bool(ARG); + } else if constexpr (std::is_same_v) { + SCM_ASSERT(scm_is_signed_integer(ARG, std::numeric_limits::min(), + std::numeric_limits::max()), + ARG, SCM_ARG1, __func__); + return scm_to_int(ARG); + } else if constexpr (std::is_same_v) { + SCM_ASSERT(scm_is_unsigned_integer(ARG, std::numeric_limits::min(), + std::numeric_limits::max()), + ARG, SCM_ARG1, __func__); + return scm_to_uint(ARG); + } else if constexpr (std::is_same_v) { + return ARG; + } else { + static_assert(always_false::value, "target type not supported"); + return {}; + } + } + /** + * Like from_SCM, but if ARG is boolean false, return default value. + * + * @param ARG argument + * @param default_value default value + * + * @return value + */ + template + T from_scm_with_default(SCM ARG, const T default_value) { + return (scm_is_bool(ARG) && scm_is_false(ARG)) ? default_value : from_scm(ARG); + } + + + /** + * Get some SCM from a C++ value, generically. + * + * @param val some C++ object + * + * @return an SCM + */ + template + SCM to_scm(const T& val) { + using Type = std::remove_const_t; + if constexpr (std::is_same_v || + std::is_same_v) + return scm_from_utf8_stringn(val.data(), val.size()); + else if constexpr (is_char_array_v|| std::is_same_v) + return scm_from_utf8_string(val); + else if constexpr (std::is_same_v) + return scm_from_bool(val); + else if constexpr (std::is_same_v) + return scm_from_size_t(val); + else if constexpr (std::is_same_v) + return scm_from_int64(val); + else if constexpr (std::is_same_v) + return scm_from_uint64(val); + else if constexpr (std::is_same_v) + return val; + else { + static_assert(always_false::value, + "source type not supported"); + return SCM_UNSPECIFIED; + } + } + + // base case. + static inline SCM alist_add(SCM alist) { + return alist; + } + /** + * Add key-value pair to an alist + * + * This assumes that keys are unique ("acons") + * + * @param alist some alist + * @param key key + * @param val value + * @param keyvals... 0 or more key, value parmeters + * + * @return the updated alist + */ + template + static inline SCM alist_add(SCM alist, const Key& key, const Value& val, + KeyVals... keyvals) { + SCM res = scm_acons(to_scm(key), to_scm(val), alist); + return alist_add(res, std::forward(keyvals)...); + } + + /** + * Make an SCM error + * + * @param err name of the error + * @param subr function name + * @param frm... args format string + * + * @return an error (type) + */ + template + void raise_error(const std::string& err, + const std::string& subr, + fmt::format_string frm, T&&... args) noexcept { + static SCM mu_scm_error = scm_from_utf8_symbol("mu-scm-error"); + scm_error(mu_scm_error, + subr.c_str(), + fmt::format(frm, std::forward(args)...).c_str(), + SCM_BOOL_F, SCM_BOOL_F); + } + + /**@}*/ +} + + +/** + * SCM formatter, for use with fmt + * + * @param scm some object + * + * @return string representation of scm + */ +// static inline std::string format_as(SCM scm) { +// return Mu::Scm::from_scm(scm_object_to_string(scm, SCM_UNSPECIFIED)); +// } +// XXX doesn't work: +// "static assertion failed: Formatting of non-void pointers is disallowed" + +#endif /*MU_SCM_HH*/ diff --git a/scm/mu-scm.scm b/scm/mu-scm.scm new file mode 100644 index 00000000..44350daa --- /dev/null +++ b/scm/mu-scm.scm @@ -0,0 +1,384 @@ +;; Copyright (C) 2025 Dirk-Jan C. Binnema +;; +;; 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, 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, write to the Free Software Foundation, +;; Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. + +;; Note: this Scheme code depends on being loaded as part of "mu scm" +;; which does so automatically. It is not a general Guile module. + +(define-module (mu) + :use-module (oop goops) + :use-module (system foreign) + :use-module (ice-9 optargs) + #:export ( + ;; classes + + *default-store* + + mfind + mcount + cfind + + + sexp + + date + iso-date + last-change + + message-id + path + priority + subject + + language + size + + ;; message flags / predicates + flags + flag? + draft? + flagged? + passed? + replied? + seen? + trashed? + new? + signed? + encrypted? + attach? + unread? + list? + personal? + calendar? + + ;; contact fields + from + to + cc + bcc + + ;; helpers + iso-date->time-t + time-t->iso-date)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; some helpers for dealing with plists / alists +(define (plist-for-each func plist) + "Call FUNC for each key/value in the PLIST. +PLIST is a property-list with alternating key and value. +Stops when FUNC returns #f." + (when (and (not (null? plist)) + (func (car plist) (cadr plist))) + (plist-for-each func (cddr plist)))) + +(define (plist-find plist key) + "Find the value for the first occurrence of KEY in PLIST. +If not found, return #f." + (let ((val #f)) + (plist-for-each + (lambda (k v) + (if (eq? k key) + (begin + (set! val v) #f) + #t)) + plist) + val)) + +(define (decolonize-symbol sym) + "Remove :-prefix from symbol." + (let ((name (symbol->string sym))) + (if (string-prefix? ":" name) + (string->symbol (string-drop name 1)) + sym))) + +(define (plist->alist plist) + "Convert a plist into an alist." + (let ((alist '())) + (plist-for-each + (lambda (k v) + (set! alist + (append! alist + (list (cons (decolonize-symbol k) + v))))) + plist) + alist)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Message +;; +;; A is created from a message plist. + +;; In mu, we have store a plist sexp for each message in the database, +;; for use with mu4e. But, that very plist is useful here as well. +(define-class () + (plist #:init-keyword #:plist #:getter plist)) + +;; using the plist as-is makes for O(n) access to the various fields + +(define-method (find-field (message ) field) + (plist-find (plist message) field)) + +(define-method (sexp (message )) + "Get the s-expression (plist) for this MESSAGE. + +This is an internal data-structure, originally for use with mu4e, but useful +here as well. However, the precise details are not part of mu-scm API." + (plist message)) + +(define (emacs-time->epoch-secs lst) + "Convert emacs-style timestamp LST to a number of seconds since epoch. +If LST is #f, return #f." + (if lst + (+ (ash (car lst) 16) (cadr lst)) + #f)) + +;; Accessor for the fields + +(define-method (subject (message )) + "Get the subject for MESSAGE or #f if not found." + (find-field message ':subject)) + +(define-method (maildir (message )) + "Get the maildir for MESSAGE or #f if not found." + (find-field message ':maildir)) + +(define-method (message-id (message )) + "Get the message-id for MESSAGE or #f if not found." + (find-field message ':message-id)) + +(define-method (date (message )) + "Get the date for MESSAGE was sent. +This is the number of seconds since epoch; #f if not found." + (emacs-time->epoch-secs (find-field message ':date))) + +(define-method (last-change (message )) + "Get the date for the last change to MESSAGE. +This is the number of seconds since epoch; #f if not found." + (emacs-time->epoch-secs (find-field message ':changed))) + +(define-method (path (message )) + "Get the file-system path for MESSAGE. +A symbol, either 'high, 'low or 'normal, or #f if not found." + (find-field message ':path)) + +(define-method (priority (message )) + "Get the priority for MESSAGE. +A symbol, either 'high, 'low or 'normal, or #f if not found." + (find-field message ':priority)) + +(define-method (language (message )) + "Get the ISO-639-1 language code for the message as a symbol, if detected. +Return #f otherwise." + (let ((lang (find-field message ':language))) + (if lang + (string->symbol lang) + #f))) +;; if-let would be nice! + +(define-method (size (message )) + "Get the size of the message in bytes or #f if not available." + (find-field message ':size)) + +;; Flags. + +(define-method (flags (message )) + "Get the size of the message in bytes or #f if not available." + (find-field message ':flags)) + +(define-method (flag? (message ) flag) + "Does MESSAGE have FLAG?." + (let ((flags + (find-field message ':flags))) + (if flags + (if (member flag flags) #t #f) + #f))) + +(define-method (draft? (message )) + "Is MESSAGE a draft message?" + (flag? message 'draft)) + +(define-method (flagged? (message )) + "Is MESSAGE flagged?" + (flag? message 'flagged)) + +(define-method (passed? (message )) + "Has MESSAGE message been 'passed' (forwarded)?" + (flag? message 'passed)) + +(define-method (replied? (message )) + "Has MESSAGE been replied to?" + (flag? message 'replied)) + +(define-method (seen? (message )) + "Does MESSAGE been 'seen' (read)?" + (flag? message 'seen)) + +(define-method (trashed? (message )) + "Has MESSAGE been trashed?" + (flag? message 'trashed)) + +(define-method (new? (message )) + "Is MESSAGE new?" + (flag? message 'new)) + +(define-method (signed? (message )) + "Has MESSAGE been cryptographically signed?" + (flag? message 'signed)) + +(define-method (encrypted? (message )) + "Has MESSAGE been encrypted?" + (flag? message 'encrypted)) + +(define-method (attach? (message )) + "Does MESSAGE have an attachment?" + (flag? message 'attach)) + +(define-method (unread? (message )) + "Is MESSAGE unread?" + (flag? message 'unread)) + +(define-method (list? (message )) + "Is MESSAGE from some mailing-list?" + (flag? message 'list)) + +(define-method (personal? (message )) + "Is MESSAGE personal?" + (flag? message 'personal)) + +(define-method (calendar? (message )) + "Does MESSAGE have a calender invitation?" + (flag? message 'calendar)) + +(define-method (find-contact-field (message ) field) + "Get contact FIELD from MESSAGE as an alist. +Helper method " + (let ((cs (find-field message field))) + (if cs + (map plist->alist cs) + #f))) + +(define-method (from (message )) + "Get the sender (the From: field) for MESSAGE or #f if not found." + (find-contact-field message ':from)) + +(define-method (to (message )) + "Get the (intended) recipient for MESSAGE (the To: field) or #f if not found." + (find-contact-field message ':to)) + +(define-method (cc (message )) + "Get the (intended) carbon-copy recipient for MESSAGE (the Cc: field) or #f if +not found." + (find-contact-field message ':cc)) + +(define-method (bcc (message )) + "Get the (intended) blind carbon-copy recipient for MESSAGE (the Bcc: field) or +#f if not found." + (find-contact-field message ':bcc)) + +;; Store +;; +;; Note: we have a *default-store*, which is the store we opened during +;; startup; for now that's the only store supported, but we keep things +;; open. +;; +;; Since it's the default store, we'd like to call the methods without +;; explicitly using *default-store*; with GOOPS, we cannot pass a default for +;; that, nor can we use keyword arguments (I think?). So use define* for that. + +;; the 'store-object' is a foreign object wrapping a const Store*. +(define-class () + (store-object #:init-keyword #:store-object #:getter store-object)) + +;; not exported +(define-method (make-store store-object) + "Make a store from some STORE-OBJECT." + (make #:store-object store-object)) + +(define *default-store* + ;; default-store-object is defined in mu-scm-store.cc + (make-store default-store-object)) + +(define* (mfind query + #:key + (store *default-store*) + (related? #f) + (skip-dups? #f) + (sort-field 'date) + (reverse? #f) + (max-results #f)) + "Find messages matching some query. The query is mandatory, +the other (keyword) arguments are optional. + +(mfind QUERY + #:store *default-store*. Leave at default. + #:related? include related messages? Default: false + #:skip-dups? skip duplicates? Default: false + #:sort-field? field to sort by, a symbol. Default: date + #:reverse? sort in descending order (z-a) + #:max-results max. number of matches. Default: false (unlimited))." + (map (lambda (plist) + (make #:plist plist)) + (store-mfind (store-object store) query + related? skip-dups? sort-field reverse? max-results))) + +(define* (mcount + #:key + (store *default-store*)) + "Get the number of messages." + (store-mcount (store-object store))) + +(define* (cfind pattern + #:key + (store *default-store*) + (personal? #f) + (after #f) + (max-results #f)) + "Find contacts matching some regex pattern, similar to 'mu-cfind(1). +The pattern is mandatory; the other (keyword) arguments are optional. +(cfind PATTERN + #:store *default-store*. Leave at default. + #:personal? only include 'personal' contacts. Default: all + #:after only include contacts last seen time_t: Default all + #:max-results max. number of matches. Default: false (unlimited))." + (store-cfind (store-object store) pattern personal? after max-results)) + + +;;; Helpers + +(define* (iso-date->time-t isodate) + "Convert an ISO-8601 ISODATE to a number of seconds since epoch. + +ISODATE is a string with the strftime format \"%FT%T\", i.e., +yyyy-mm-ddThh:mm:ss or any prefix there of. The 'T', ':', '-' or any non-numeric +characters re optional. + +ISODATE is assumed to represent some UTC date." + (let* ((tmpl "00000101000000") + (isodate (string-filter char-numeric? isodate)) ;; filter out 'T' ':' '-' etc + (isodate ;; fill out isodate + (if (> (string-length tmpl) (string-length isodate)) + (string-append isodate (substring tmpl (string-length isodate))) + isodate))) + ;;(format #t "~a\n" isodate) + (car (mktime (car (strptime "%Y%m%d%H%M%S" isodate)) "Z")))) + +(define-method (time-t->iso-date time-t) + "Convert a time_t (second-since-epoch) value TIME-T to an ISO-8601 +string for the corresponding UTC time. + +If TIME-T is #f, return an empty string of the same length." + (if time-t + (strftime "%FT%T" (gmtime time-t)) + " "))