alx/mu4e
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

scm: new guile/scheme bindings

Browse Source 
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.
This commit is contained in:
Dirk-Jan C. Binnema
2025-05-31 12:44:13 +03:00
parent f9c24c7166
commit 527d9322e9
10 changed files with 1123 additions and 1 deletions
Download Patch File Download Diff File Expand all files Collapse all files

58
scm/meson.build Normal file
View File

@ -0,0 +1,58 @@
## Copyright (C) 2025 Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
##
## 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

36
scm/mu-scm-contact.cc Normal file
View File

@ -0,0 +1,36 @@
/*
** Copyright (C) 2025 Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
**
** 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;
}

38
scm/mu-scm-contact.hh Normal file
View File

@ -0,0 +1,38 @@
/*
** Copyright (C) 2025 Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
**
** 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*/

18
scm/mu-scm-shell.scm Normal file
View File

@ -0,0 +1,18 @@
;; Copyright (C) 2025 Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;;
;; 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))

156
scm/mu-scm-store.cc Normal file
View File

@ -0,0 +1,156 @@
/*
** Copyright (C) 2025 Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
**
** 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<Store*>(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<std::string>(pattern_scm)};
const auto personal{from_scm<bool>(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<std::string>(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<std::string>(query_scm)};
const auto related(from_scm<bool>(related_scm));
const auto skip_dups(from_scm<bool>(skip_dups_scm));
const auto reverse(from_scm<bool>(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<scm_t_subr>(subr_mfind));
scm_c_define_gsubr("store-mcount", 1/*req*/, 0/*opt*/, 0/*rst*/,
reinterpret_cast<scm_t_subr>(subr_mcount));
scm_c_define_gsubr("store-cfind", 5/*req*/, 0/*opt*/, 0/*rst*/,
reinterpret_cast<scm_t_subr>(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*>(&store));
scm_c_define("default-store-object", default_store);
init_subrs();
initialized = true;
}

30
scm/mu-scm-store.hh Normal file
View File

@ -0,0 +1,30 @@
/*
** Copyright (C) 2025 Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
**
** 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*/

160
scm/mu-scm.cc Normal file
View File

@ -0,0 +1,160 @@
/*
** Copyright (C) 2025 Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
**
** 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 <unistd.h>
#include <errno.h>
#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<std::string>
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<void>
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<void>
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<const char*> 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<char**>(args.data()));
}, {}); // never returns.
return Ok();
}

242
scm/mu-scm.hh Normal file
View File

@ -0,0 +1,242 @@
/*
** Copyright (C) 2025 Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
**
** 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 <string>
#include <string_view>
#include <type_traits>
#pragma GCC diagnostic push
#pragma GCC diagnostic ignored "-Wredundant-decls"
#include <libguile.h>
#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<void> run(const Config& conf);
/**
* Helpers
*
* @{*/
// https://www.open-std.org/jtc1/sc22/wg21/docs/papers/2022/p2593r0.html
template<typename T> struct always_false : std::false_type {};
template<typename T> constexpr bool is_char_array_v =
std::is_array_v<T> &&
std::is_same_v<std::remove_extent_t<T>, char>;
/**
* Make SCM symbol from string-like value
*
* @param val some value
*
* @return an SCM symbol
*/
template<typename T>
SCM make_symbol(const T& val){
using Type = std::remove_const_t<T>; // *not* std::remove_const
if constexpr (std::is_same_v<Type, std::string> ||
std::is_same_v<Type, std::string_view>)
return scm_from_utf8_symboln(val.data(), val.size());
else if constexpr (is_char_array_v<Type>|| std::is_same_v<Type, const char*>)
return scm_from_utf8_symbol(val);
else {
static_assert(always_false<Type>::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<typename T>
T from_scm(SCM ARG) {
using Type = std::remove_const_t<T>; // *not* std::remove_const
if constexpr (std::is_same_v<Type, std::string>) {
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<Type, char>) {
SCM_ASSERT(scm_char_p(ARG), ARG, SCM_ARG1, __func__);
return scm_to_char(ARG);
} else if constexpr (std::is_same_v<Type, bool>) {
SCM_ASSERT(scm_boolean_p(ARG), ARG, SCM_ARG1, __func__);
return scm_to_bool(ARG);
} else if constexpr (std::is_same_v<Type, int>) {
SCM_ASSERT(scm_is_signed_integer(ARG, std::numeric_limits<int>::min(),
std::numeric_limits<int>::max()),
ARG, SCM_ARG1, __func__);
return scm_to_int(ARG);
} else if constexpr (std::is_same_v<Type, uint>) {
SCM_ASSERT(scm_is_unsigned_integer(ARG, std::numeric_limits<uint>::min(),
std::numeric_limits<uint>::max()),
ARG, SCM_ARG1, __func__);
return scm_to_uint(ARG);
} else if constexpr (std::is_same_v<Type, SCM>) {
return ARG;
} else {
static_assert(always_false<Type>::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<typename T>
T from_scm_with_default(SCM ARG, const T default_value) {
return (scm_is_bool(ARG) && scm_is_false(ARG)) ? default_value : from_scm<T>(ARG);
}
/**
* Get some SCM from a C++ value, generically.
*
* @param val some C++ object
*
* @return an SCM
*/
template<typename T>
SCM to_scm(const T& val) {
using Type = std::remove_const_t<T>;
if constexpr (std::is_same_v<Type, std::string> ||
std::is_same_v<Type, std::string_view>)
return scm_from_utf8_stringn(val.data(), val.size());
else if constexpr (is_char_array_v<Type>|| std::is_same_v<Type, const char*>)
return scm_from_utf8_string(val);
else if constexpr (std::is_same_v<Type, bool>)
return scm_from_bool(val);
else if constexpr (std::is_same_v<Type, size_t>)
return scm_from_size_t(val);
else if constexpr (std::is_same_v<Type, int64_t>)
return scm_from_int64(val);
else if constexpr (std::is_same_v<Type, uint64_t>)
return scm_from_uint64(val);
else if constexpr (std::is_same_v<Type, SCM>)
return val;
else {
static_assert(always_false<Type>::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<typename Key, typename Value, typename... KeyVals>
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>(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<typename...T>
void raise_error(const std::string& err,
const std::string& subr,
fmt::format_string<T...> 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<T>(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<std::string>(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*/

384
scm/mu-scm.scm Normal file
View File

@ -0,0 +1,384 @@
;; Copyright (C) 2025 Dirk-Jan C. Binnema <djcb@djcbsoftware.nl>
;;
;; 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
<store>
*default-store*
mfind
mcount
cfind
<message>
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 <message> 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 <message> ()
(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 <message>) field)
(plist-find (plist message) field))
(define-method (sexp (message <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 <message>))
"Get the subject for MESSAGE or #f if not found."
(find-field message ':subject))
(define-method (maildir (message <message>))
"Get the maildir for MESSAGE or #f if not found."
(find-field message ':maildir))
(define-method (message-id (message <message>))
"Get the message-id for MESSAGE or #f if not found."
(find-field message ':message-id))
(define-method (date (message <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 <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 <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 <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 <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 <message>))
"Get the size of the message in bytes or #f if not available."
(find-field message ':size))
;; Flags.
(define-method (flags (message <message>))
"Get the size of the message in bytes or #f if not available."
(find-field message ':flags))
(define-method (flag? (message <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 <message>))
"Is MESSAGE a draft message?"
(flag? message 'draft))
(define-method (flagged? (message <message>))
"Is MESSAGE flagged?"
(flag? message 'flagged))
(define-method (passed? (message <message>))
"Has MESSAGE message been 'passed' (forwarded)?"
(flag? message 'passed))
(define-method (replied? (message <message>))
"Has MESSAGE been replied to?"
(flag? message 'replied))
(define-method (seen? (message <message>))
"Does MESSAGE been 'seen' (read)?"
(flag? message 'seen))
(define-method (trashed? (message <message>))
"Has MESSAGE been trashed?"
(flag? message 'trashed))
(define-method (new? (message <message>))
"Is MESSAGE new?"
(flag? message 'new))
(define-method (signed? (message <message>))
"Has MESSAGE been cryptographically signed?"
(flag? message 'signed))
(define-method (encrypted? (message <message>))
"Has MESSAGE been encrypted?"
(flag? message 'encrypted))
(define-method (attach? (message <message>))
"Does MESSAGE have an attachment?"
(flag? message 'attach))
(define-method (unread? (message <message>))
"Is MESSAGE unread?"
(flag? message 'unread))
(define-method (list? (message <message>))
"Is MESSAGE from some mailing-list?"
(flag? message 'list))
(define-method (personal? (message <message>))
"Is MESSAGE personal?"
(flag? message 'personal))
(define-method (calendar? (message <message>))
"Does MESSAGE have a calender invitation?"
(flag? message 'calendar))
(define-method (find-contact-field (message <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 <message>))
"Get the sender (the From: field) for MESSAGE or #f if not found."
(find-contact-field message ':from))
(define-method (to (message <message>))
"Get the (intended) recipient for MESSAGE (the To: field) or #f if not found."
(find-contact-field message ':to))
(define-method (cc (message <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 <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> ()
(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> #: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 <message> #: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))
" "))