code:
/* GNU Guix --- Functional package management for GNU
   Copyright (C) 2020 Ludovic Courtès <ludo@gnu.org>

   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/>.  */

/* This file implements part of the GNU ld.so audit interface.  It is used by
   the "fakechroot" engine of the 'guix pack -RR' wrappers to make sure the
   loader looks for shared objects under the "fake" root directory.  */

#define _GNU_SOURCE 1

#include <link.h>

#include <error.h>
#include <stdlib.h>
#include <string.h>
#include <assert.h>

/* The pseudo root directory and store that we are relocating to.  */
static const char *root_directory;
static char *store;

/* The original store, "/gnu/store" by default.  */
static const char original_store[] = "@STORE_DIRECTORY@";

/* Like 'malloc', but abort if 'malloc' returns NULL.  */
static void *
xmalloc (size_t size)
{
  void *result = malloc (size);
  assert (result != NULL);
  return result;
}

unsigned int
la_version (unsigned int v)
{
  if (v != LAV_CURRENT)
    error (1, 0, "cannot handle interface version %u", v);

  root_directory = getenv ("FAKECHROOT_BASE");
  if (root_directory == NULL)
    error (1, 0, "'FAKECHROOT_BASE' is not set");

  store = xmalloc (strlen (root_directory) + sizeof original_store);
  strcpy (store, root_directory);
  strcat (store, original_store);

  return v;
}

/* Return NAME, a shared object file name, relocated under STORE.  This
   function is called by the loader whenever it looks for a shared object.  */
char *
la_objsearch (const char *name, uintptr_t *cookie, unsigned int flag)
{
  char *result;

  if (strncmp (name, original_store,
	       sizeof original_store - 1) == 0)
    {
      size_t len = strlen (name) - sizeof original_store
	+ strlen (store) + 1;
      result = xmalloc (len);
      strcpy (result, store);
      strcat (result, name + sizeof original_store - 1);
    }
  else
    result = strdup (name);

  return result;
}

license: mit


code:
/* GNU Guix --- Functional package management for GNU
   Copyright (C) 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>

   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/>.  */

/* Make the given @WRAPPED_PROGRAM@ relocatable by executing it in a separate
   mount namespace where the store is mounted in its right place.

   We would happily do that in Scheme using 'call-with-container'.  However,
   this very program needs to be relocatable, so it needs to be statically
   linked, which complicates things (Guile's modules can hardly be "linked"
   into a single executable.)  */

#define _GNU_SOURCE
#include <stdlib.h>
#include <stdio.h>
#include <unistd.h>
#include <sched.h>
#include <sys/mount.h>
#include <errno.h>
#include <libgen.h>
#include <limits.h>
#include <string.h>
#include <assert.h>
#include <sys/stat.h>
#include <sys/types.h>
#include <sys/wait.h>
#include <fcntl.h>
#include <dirent.h>
#include <sys/syscall.h>

/* Whether we're building the ld.so/libfakechroot wrapper.  */
#define HAVE_EXEC_WITH_LOADER						\
  (defined PROGRAM_INTERPRETER) && (defined LOADER_AUDIT_MODULE)	\
  && (defined FAKECHROOT_LIBRARY)

/* The original store, "/gnu/store" by default.  */
static const char original_store[] = "@STORE_DIRECTORY@";

/* Like 'malloc', but abort if 'malloc' returns NULL.  */
static void *
xmalloc (size_t size)
{
  void *result = malloc (size);
  assert (result != NULL);
  return result;
}

/* Concatenate DIRECTORY, a slash, and FILE.  Return the result, which the
   caller must eventually free.  */
static char *
concat (const char *directory, const char *file)
{
  char *result = xmalloc (strlen (directory) + 2 + strlen (file));

  strcpy (result, directory);
  strcat (result, "/");
  strcat (result, file);
  return result;
}

static void
mkdir_p (const char *directory)
{
  if (strcmp (directory, "/") != 0)
    {
      char *parent = dirname (strdupa (directory));
      mkdir_p (parent);
      int err = mkdir (directory, 0700);
      if (err < 0 && errno != EEXIST)
	assert_perror (errno);
    }
}

static void
rm_rf (const char *directory)
{
  DIR *stream = opendir (directory);

  for (struct dirent *entry = readdir (stream);
       entry != NULL;
       entry = readdir (stream))
    {
      if (strcmp (entry->d_name, ".") == 0
	  || strcmp (entry->d_name, "..") == 0)
	continue;

      char *full = concat (directory, entry->d_name);

      int err = unlink (full);
      if (err < 0)
	{
	  if (errno == EISDIR)
	    /* Recurse (we expect a shallow directory structure so there's
	       little risk of stack overflow.)  */
	    rm_rf (full);
	  else
	    assert_perror (errno);
	}

      free (full);
    }

  closedir (stream);

  int err = rmdir (directory);
  if (err < 0 && errno != ENOENT)
    assert_perror (errno);
}

/* Make TARGET a bind-mount of SOURCE.  Take into account ENTRY's type, which
   corresponds to SOURCE.  */
static int
bind_mount (const char *source, const struct dirent *entry,
	    const char *target)
{
  if (entry->d_type == DT_DIR)
    {
      int err = mkdir (target, 0700);
      if (err != 0)
	return err;
    }
  else
    close (open (target, O_WRONLY | O_CREAT));

  return mount (source, target, "none",
		MS_BIND | MS_REC | MS_RDONLY, NULL);
}

#if HAVE_EXEC_WITH_LOADER

/* Make TARGET a symlink to SOURCE.  */
static int
make_symlink (const char *source, const struct dirent *entry,
	      const char *target)
{
  return symlink (source, target);
}

#endif

/* Mirror with FIRMLINK all the top-level entries in SOURCE to TARGET.  */
static void
mirror_directory (const char *source, const char *target,
		  int (* firmlink) (const char *, const struct dirent *,
				    const char *))
{
  DIR *stream = opendir (source);

  for (struct dirent *entry = readdir (stream);
       entry != NULL;
       entry = readdir (stream))
    {
      /* XXX: Some file systems may not report a useful 'd_type'.  Ignore them
	 for now.  */
      assert (entry->d_type != DT_UNKNOWN);

      if (strcmp (entry->d_name, ".") == 0
	  || strcmp (entry->d_name, "..") == 0)
	continue;

      char *abs_source = concat (source, entry->d_name);
      char *new_entry = concat (target, entry->d_name);

      if (entry->d_type == DT_LNK)
	{
	  char target[PATH_MAX];

	  ssize_t result = readlink (abs_source, target, sizeof target - 1);
	  if (result > 0)
	    {
	      target[result] = '\0';
	      int err = symlink (target, new_entry);
	      if (err < 0)
		assert_perror (errno);
	    }
	}
      else
	{
	  /* Create the mount point.  */
	  int err = firmlink (abs_source, entry, new_entry);

	  /* It used to be that only directories could be bind-mounted.  Thus,
	     keep going if we fail to bind-mount a non-directory entry.
	     That's OK because regular files in the root file system are
	     usually uninteresting.  */
	  if (err != 0 && entry->d_type != DT_DIR)
	    assert_perror (errno);

	  free (new_entry);
	  free (abs_source);
	}
    }

  closedir (stream);
}

/* Write the user/group ID map for PID to FILE, mapping ID to itself.  See
   user_namespaces(7).  */
static void
write_id_map (pid_t pid, const char *file, int id)
{
  char id_map_file[100];
  snprintf (id_map_file, sizeof id_map_file, "/proc/%d/%s", pid, file);

  char id_map[100];

  /* Map root and the current user.  */
  int len = snprintf (id_map, sizeof id_map, "%d %d 1\n", id, id);
  int fd = open (id_map_file, O_WRONLY);
  if (fd < 0)
    assert_perror (errno);

  int n = write (fd, id_map, len);
  if (n < 0)
    assert_perror (errno);

  close (fd);
}

/* Disallow setgroups(2) for PID.  */
static void
disallow_setgroups (pid_t pid)
{
  char file[100];

  snprintf (file, sizeof file, "/proc/%d/setgroups", pid);

  int fd = open (file, O_WRONLY);
  if (fd < 0)
    assert_perror (errno);

  int err = write (fd, "deny", 5);
  if (err < 0)
    assert_perror (errno);

  close (fd);
}

/* Run the wrapper program in a separate mount user namespace.  Return only
   upon failure.  */
static void
exec_in_user_namespace (const char *store, int argc, char *argv[])
{
  /* Spawn @WRAPPED_PROGRAM@ in a separate namespace where STORE is
     bind-mounted in the right place.  */
  int err;
  char *new_root = mkdtemp (strdup ("/tmp/guix-exec-XXXXXX"));
  char *new_store = concat (new_root, original_store);
  char *cwd = get_current_dir_name ();

  /* Create a child with separate namespaces and set up bind-mounts from
     there.  That way, bind-mounts automatically disappear when the child
     exits, which simplifies cleanup for the parent.  Note: clone is more
     convenient than fork + unshare since the parent can directly write
     the child uid_map/gid_map files.  */
  pid_t child = syscall (SYS_clone, SIGCHLD | CLONE_NEWNS | CLONE_NEWUSER,
			 NULL, NULL, NULL);
  switch (child)
    {
    case 0:
      /* Note: Due to <https://bugzilla.kernel.org/show_bug.cgi?id=183461>
	 we cannot make NEW_ROOT a tmpfs (which would have saved the need
	 for 'rm_rf'.)  */
      mirror_directory ("/", new_root, bind_mount);
      mkdir_p (new_store);
      err = mount (store, new_store, "none", MS_BIND | MS_REC | MS_RDONLY,
		   NULL);
      if (err < 0)
	assert_perror (errno);

      chdir (new_root);
      err = chroot (new_root);
      if (err < 0)
	assert_perror (errno);

      /* Change back to where we were before chroot'ing.  */
      chdir (cwd);

      int err = execv ("@WRAPPED_PROGRAM@", argv);
      if (err < 0)
	assert_perror (errno);
      break;

    case -1:
      /* Failure: user namespaces not supported.  */
      fprintf (stderr, "%s: error: 'clone' failed: %m\n", argv[0]);
      rm_rf (new_root);
      break;

    default:
      {
	/* Map the current user/group ID in the child's namespace (the
	   default is to get the "overflow UID", i.e., the UID of
	   "nobody").  We must first disallow 'setgroups' for that
	   process.  */
	disallow_setgroups (child);
	write_id_map (child, "uid_map", getuid ());
	write_id_map (child, "gid_map", getgid ());

	int status;
	waitpid (child, &status, 0);
	chdir ("/");			  /* avoid EBUSY */
	rm_rf (new_root);
	free (new_root);

	if (WIFEXITED (status))
	  exit (WEXITSTATUS (status));
	else
	  /* Abnormal termination cannot really be reproduced, so exit
	     with 255.  */
	  exit (255);
      }
    }
}

#ifdef PROOT_PROGRAM

/* Execute the wrapped program with PRoot, passing it ARGC and ARGV, and
   "bind-mounting" STORE in the right place.  */
static void
exec_with_proot (const char *store, int argc, char *argv[])
{
  int proot_specific_argc = 4;
  int proot_argc = argc + proot_specific_argc;
  char *proot_argv[proot_argc + 1], *proot;
  char bind_spec[strlen (store) + 1 + sizeof original_store];

  strcpy (bind_spec, store);
  strcat (bind_spec, ":");
  strcat (bind_spec, original_store);

  proot = concat (store, PROOT_PROGRAM);

  proot_argv[0] = proot;
  proot_argv[1] = "-b";
  proot_argv[2] = bind_spec;
  proot_argv[3] = "@WRAPPED_PROGRAM@";

  for (int i = 0; i < argc; i++)
    proot_argv[i + proot_specific_argc] = argv[i + 1];

  proot_argv[proot_argc] = NULL;

  /* Seccomp support seems to invariably lead to segfaults; disable it by
     default.  */
  setenv ("PROOT_NO_SECCOMP", "1", 0);

  int err = execv (proot, proot_argv);
  if (err < 0)
    assert_perror (errno);
}

#endif

#if HAVE_EXEC_WITH_LOADER

/* Traverse PATH, a NULL-terminated string array, and return a colon-separated
   search path where each item of PATH has been relocated to STORE.  The
   result is malloc'd.  */
static char *
relocated_search_path (const char *path[], const char *store)
{
  char *new_path;
  size_t size = 0;

  for (size_t i = 0; path[i] != NULL; i++)
    size += strlen (store) + strlen (path[i]) + 1;  /* upper bound */

  new_path = xmalloc (size + 1);
  new_path[0] = '\0';

  for (size_t i = 0; path[i] != NULL; i++)
    {
      if (strncmp (path[i], original_store,
		   sizeof original_store - 1) == 0)
	{
	  strcat (new_path, store);
	  strcat (new_path, path[i] + sizeof original_store - 1);
	}
      else
	strcat (new_path, path[i]);	  /* possibly $ORIGIN */

      strcat (new_path, ":");
    }

  new_path[strlen (new_path) - 1] = '\0'; /* Remove trailing colon.  */

  return new_path;
}

/* Concatenate PATH1 and PATH2 with a colon in between.  The result is
   potentially malloc'd.  */
static char *
concat_paths (const char *path1, const char *path2)
{
  if (path1[0] == '\0')
    return (char *) path2;
  else
    {
      char *result = xmalloc (strlen (path1) + strlen (path2) + 2);
      strcpy (result, path1);
      strcat (result, ":");
      strcat (result, path2);
      return result;
    }
}

/* Execute the wrapped program by invoking the loader (ld.so) directly,
   passing it the audit module and preloading libfakechroot.so.  */
static void
exec_with_loader (const char *store, int argc, char *argv[])
{
  static const char *audit_library_path[] = LOADER_AUDIT_RUNPATH;
  char *loader = concat (store,
			 PROGRAM_INTERPRETER + sizeof original_store);
  size_t loader_specific_argc = 8;
  size_t loader_argc = argc + loader_specific_argc;
  char *loader_argv[loader_argc + 1];
  loader_argv[0] = argv[0];
  loader_argv[1] = "--audit";
  loader_argv[2] = concat (store,
			   LOADER_AUDIT_MODULE + sizeof original_store);

  /* The audit module depends on libc.so and libgcc_s.so so honor
     AUDIT_LIBRARY_PATH.  Additionally, honor $LD_LIBRARY_PATH if set.  */
  loader_argv[3] = "--library-path";
  loader_argv[4] =
    concat_paths (getenv ("LD_LIBRARY_PATH") ?: "",
		  relocated_search_path (audit_library_path, store));

  loader_argv[5] = "--preload";
  loader_argv[6] = concat (store,
			   FAKECHROOT_LIBRARY + sizeof original_store);
  loader_argv[7] = concat (store,
			   "@WRAPPED_PROGRAM@" + sizeof original_store);

  for (size_t i = 0; i < argc; i++)
    loader_argv[i + loader_specific_argc] = argv[i + 1];

  loader_argv[loader_argc] = NULL;

  /* Set up the root directory.  */
  int err;
  char *new_root = mkdtemp (strdup ("/tmp/guix-exec-XXXXXX"));
  mirror_directory ("/", new_root, make_symlink);

  /* 'mirror_directory' created a symlink for the ancestor of ORIGINAL_STORE,
     typically "/gnu".  Remove that entry so we can create NEW_STORE
     below.  */
  const char *slash = strchr (original_store + 1, '/');
  const char *top = slash != NULL
    ? strndupa (original_store, slash - original_store)
    : original_store;
  char *new_store_top = concat (new_root, top);
  unlink (new_store_top);

  /* Now create the store under NEW_ROOT.  */
  char *new_store = concat (new_root, original_store);
  char *new_store_parent = dirname (strdup (new_store));
  mkdir_p (new_store_parent);
  err = symlink (store, new_store);
  if (err < 0)
    assert_perror (errno);

#ifdef GCONV_DIRECTORY
  /* Tell libc where to find its gconv modules.  This is necessary because
     gconv uses non-interposable 'open' calls.  */
  char *gconv_path = concat (store,
			     GCONV_DIRECTORY + sizeof original_store);
  setenv ("GCONV_PATH", gconv_path, 1);
  free (gconv_path);
#endif

  setenv ("FAKECHROOT_BASE", new_root, 1);

  pid_t child = fork ();
  switch (child)
    {
    case 0:
      err = execv (loader, loader_argv);
      if (err < 0)
	assert_perror (errno);
      exit (EXIT_FAILURE);
      break;

    case -1:
      assert_perror (errno);
      exit (EXIT_FAILURE);
      break;

    default:
      {
  	int status;
	waitpid (child, &status, 0);
	chdir ("/");			  /* avoid EBUSY */
	rm_rf (new_root);
	free (new_root);

	close (2);			/* flushing stderr should be silent */

	if (WIFEXITED (status))
	  exit (WEXITSTATUS (status));
	else
	  /* Abnormal termination cannot really be reproduced, so exit
	     with 255.  */
	  exit (255);
      }
    }
}

#endif

/* Execution engines.  */

struct engine
{
  const char *name;
  void (* exec) (const char *, int, char **);
};

static void
buffer_stderr (void)
{
  static char stderr_buffer[4096];
  setvbuf (stderr, stderr_buffer, _IOFBF, sizeof stderr_buffer);
}

/* The default engine: choose a robust method.  */
static void
exec_default (const char *store, int argc, char *argv[])
{
  /* Buffer stderr so that nothing's displayed if 'exec_in_user_namespace'
     fails but 'exec_with_proot' works.  */
  buffer_stderr ();

  exec_in_user_namespace (store, argc, argv);
#ifdef PROOT_PROGRAM
  exec_with_proot (store, argc, argv);
#endif
}

/* The "performance" engine: choose performance over robustness.  */
static void
exec_performance (const char *store, int argc, char *argv[])
{
  buffer_stderr ();

  exec_in_user_namespace (store, argc, argv);
#if HAVE_EXEC_WITH_LOADER
  exec_with_loader (store, argc, argv);
#endif
}

/* List of supported engines.  */
static const struct engine engines[] =
  {
   { "default", exec_default },
   { "performance", exec_performance },
   { "userns", exec_in_user_namespace },
#ifdef PROOT_PROGRAM
   { "proot", exec_with_proot },
#endif
#if HAVE_EXEC_WITH_LOADER
   { "fakechroot", exec_with_loader },
#endif
   { NULL, NULL }
  };

/* Return the "execution engine" to use.  */
static const struct engine *
execution_engine (void)
{
  const char *str = getenv ("GUIX_EXECUTION_ENGINE");

  if (str == NULL)
    str = "default";

 try:
  for (const struct engine *engine = engines;
       engine->name != NULL;
       engine++)
    {
      if (strcmp (engine->name, str) == 0)
	return engine;
    }

  fprintf (stderr, "%s: unsupported Guix execution engine; ignoring\n",
	   str);
  str = "default";
  goto try;
}

int
main (int argc, char *argv[])
{
  ssize_t size;
  char self[PATH_MAX];
  size = readlink ("/proc/self/exe", self, sizeof self - 1);
  assert (size > 0);

  /* SELF is something like "/home/ludo/.local/gnu/store/…-foo/bin/ls" and we
     want to extract "/home/ludo/.local/gnu/store".  */
  size_t index = strlen (self)
    - strlen ("@WRAPPED_PROGRAM@") + strlen (original_store);
  char *store = strdup (self);
  store[index] = '\0';

  struct stat statbuf;

  /* If STORE is already at the "right" place, we can execute
     @WRAPPED_PROGRAM@ right away.  This is not just an optimization: it's
     needed when running one of these wrappers from within an unshare'd
     namespace, because 'unshare' fails with EPERM in that context.  */
  if (strcmp (store, original_store) != 0
      && lstat ("@WRAPPED_PROGRAM@", &statbuf) != 0)
    {
      const struct engine *engine = execution_engine ();
      engine->exec (store, argc, argv);

      /* If we reach this point, that's because ENGINE failed to do the
	 job.  */
      fprintf (stderr, "\
This may be because \"user namespaces\" are not supported on this system.\n\
Consequently, we cannot run '@WRAPPED_PROGRAM@',\n\
unless you move it to the '@STORE_DIRECTORY@' directory.\n\
\n\
Please refer to the 'guix pack' documentation for more information.\n");
      return EXIT_FAILURE;
    }

  /* The executable is available under @STORE_DIRECTORY@, so we can now
     execute it.  */
  int err = execv ("@WRAPPED_PROGRAM@", argv);
  if (err < 0)
    assert_perror (errno);

  return EXIT_FAILURE;
}


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2013, 2014, 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
;;;
;;; 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/>.

(define-module (gnu packages avahi)
  #:use-module ((guix licenses) #:select (lgpl2.1+))
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix build-system gnu)
  #:use-module (gnu packages)
  #:use-module (gnu packages dbm)
  #:use-module (gnu packages gettext)
  #:use-module (gnu packages glib)
  #:use-module (gnu packages libdaemon)
  #:use-module (gnu packages libevent)
  #:use-module (gnu packages linux)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages xml))

(define-public avahi
  (package
    (name "avahi")
    (version "0.8")
    (home-page "https://avahi.org")
    (source (origin
             (method url-fetch)
             (uri (string-append home-page "/download/avahi-"
                                 version ".tar.gz"))
             (sha256
              (base32
               "1npdixwxxn3s9q1f365x9n9rc5xgfz39hxf23faqvlrklgbhj0q6"))
             (patches (search-patches "avahi-localstatedir.patch"))
             (modules '((guix build utils)))
             (snippet
              '(begin
                 ;; Fix version constraint in the avahi-libevent pkg-config file.
                 ;; This can be removed for Avahi versions > 0.8.
                 (substitute* "avahi-libevent.pc.in"
                   (("libevent-2\\.1\\.5")
                    "libevent >= 2.1.5"))
                 #t))))
    (build-system gnu-build-system)
    (arguments
     '(#:configure-flags '("--with-distro=none"
                           "--disable-static"
                           "--localstatedir=/var" ; for the DBus socket
                           "--disable-python"
                           "--disable-mono"
                           "--disable-doxygen-doc"
                           "--disable-xmltoman"
                           "--enable-tests"
                           "--disable-qt4" "--disable-qt5"
                           "--disable-gtk" "--disable-gtk3"
                           "--enable-compat-libdns_sd")))
    (inputs
     `(("dbus" ,dbus)
       ("expat" ,expat)
       ("gdbm" ,gdbm)
       ("glib" ,glib)
       ("libcap" ,libcap)            ;to enable chroot support in avahi-daemon
       ("libdaemon" ,libdaemon)
       ("libevent" ,libevent)))
    (native-inputs
     `(("gettext" ,gettext-minimal)
       ("glib" ,glib "bin")
       ("pkg-config" ,pkg-config)))
    (synopsis "Implementation of mDNS/DNS-SD protocols")
    (description
     "Avahi is a system which facilitates service discovery on a local
network.  It is an implementation of the mDNS (for \"Multicast DNS\") and
DNS-SD (for \"DNS-Based Service Discovery\") protocols.")
    (license lgpl2.1+)))

(define-public nss-mdns
  (package
    (name "nss-mdns")
    (version "0.14.1")
    (home-page "https://github.com/lathiat/nss-mdns")
    (source (origin
              (method url-fetch)
              (uri (string-append home-page "/releases/download/v" version "/"
                                  name "-" version ".tar.gz"))
              (sha256
               (base32
                "134wdr0n9cm5ab4g6dwq76lvzqns9dcylr470i2xxjimnw0l22d2"))))
    (build-system gnu-build-system)
    (arguments
     ;; The Avahi daemon socket is expected by 'configure.ac' to be at
     ;; "$(localstatedir)/run/avahi-daemon/socket", but nowadays it lives in
     ;; /run/avahi-daemon/socket.  Remove the "$(localstatedir)" bit.
     '(#:configure-flags '("AVAHI_SOCKET=/run/avahi-daemon/socket")))
    (synopsis "Multicast DNS Name Service Switch (@dfn{NSS}) plug-in")
    (description
     "Nss-mdns is a plug-in for the GNU C Library's Name Service Switch
(@dfn{NSS}) that resolves host names via multicast DNS (@dfn{mDNS}).  It is
most often used in home and other small networks without a local name server,
to resolve host names in the @samp{.local} top-level domain.")
    (license lgpl2.1+)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2016 Manolis Fragkiskos Ragkousis <manolis837@gmail.com>
;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2016 David Thompson <davet@gnu.org>
;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2018 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2020 Marius Bakke <mbakke@fastmail.com>
;;;
;;; 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/>.

(define-module (gnu packages avr)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix utils)
  #:use-module (guix download)
  #:use-module (guix git-download)
  #:use-module (guix packages)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system trivial)
  #:use-module (gnu packages)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages cross-base)
  #:use-module (gnu packages flashing-tools)
  #:use-module (gnu packages gcc)
  #:use-module (gnu packages vim))

(define-public avr-binutils
  (package
    (inherit (cross-binutils "avr"))
    (name "avr-binutils")))

(define-public avr-gcc-4.9
  (let ((xgcc (cross-gcc "avr" #:xgcc gcc-4.9 #:xbinutils avr-binutils)))
    (package
      (inherit xgcc)
      (name "avr-gcc")
      (arguments
       (substitute-keyword-arguments (package-arguments xgcc)
         ((#:phases phases)
          `(modify-phases ,phases
             (add-after 'set-paths 'augment-CPLUS_INCLUDE_PATH
               (lambda* (#:key inputs #:allow-other-keys)
                 (let ((gcc (assoc-ref inputs  "gcc")))
                   ;; Remove the default compiler from CPLUS_INCLUDE_PATH to
                   ;; prevent header conflict with the GCC from native-inputs.
                   (setenv "CPLUS_INCLUDE_PATH"
                           (string-join
                            (delete (string-append gcc "/include/c++")
                                    (string-split (getenv "CPLUS_INCLUDE_PATH")
                                                  #\:))
                            ":"))
                   (format #t
                           "environment variable `CPLUS_INCLUDE_PATH' changed to ~a~%"
                           (getenv "CPLUS_INCLUDE_PATH"))
                   #t)))
             ;; Without a working multilib build, the resulting GCC lacks
             ;; support for nearly every AVR chip.
             (add-after 'unpack 'fix-genmultilib
               (lambda _
                 ;; patch-shebang doesn't work here because there are actually
                 ;; several scripts inside this script, each with a #!/bin/sh
                 ;; that needs patching.
                 (substitute* "gcc/genmultilib"
                   (("#!/bin/sh") (string-append "#!" (which "sh"))))
                 #t))))
         ((#:configure-flags flags)
          `(delete "--disable-multilib" ,flags))))
      (native-search-paths
       (list (search-path-specification
              (variable "CROSS_C_INCLUDE_PATH")
              (files '("avr/include")))
             (search-path-specification
              (variable "CROSS_CPLUS_INCLUDE_PATH")
              (files '("avr/include")))
             (search-path-specification
              (variable "CROSS_OBJC_INCLUDE_PATH")
              (files '("avr/include")))
             (search-path-specification
              (variable "CROSS_OBJCPLUS_INCLUDE_PATH")
              (files '("avr/include")))
             (search-path-specification
              (variable "CROSS_LIBRARY_PATH")
              (files '("avr/lib")))))
      (native-inputs
       `(("gcc@5" ,gcc-5)
         ,@(package-native-inputs xgcc))))))

(define-public avr-gcc-5
  (package
    (inherit avr-gcc-4.9)
    (version (package-version gcc-5))
    (source (origin
              (inherit (package-source gcc-5))
              (patches (append (origin-patches (package-source gcc-5))
                               (search-patches "gcc-cross-environment-variables.patch")))))))

(define (avr-libc avr-gcc)
  (package
    (name "avr-libc")
    (version "2.0.0")
    (source (origin
              (method url-fetch)
              (uri (string-append "mirror://savannah//avr-libc/avr-libc-"
                                  version ".tar.bz2"))
              (sha256
               (base32
                "15svr2fx8j6prql2il2fc0ppwlv50rpmyckaxx38d3gxxv97zpdj"))))
    (build-system gnu-build-system)
    (arguments
     '(#:out-of-source? #t
       #:configure-flags '("--host=avr")
       #:phases
       (modify-phases %standard-phases
         (add-before 'unpack 'fix-cpath
           (lambda _
             ;; C_INCLUDE_PATH and CPATH pose issues for cross-building,
             ;; leading to failures when building avr-libc on 64-bit systems.
             ;; Simply unsetting them allows the build to succeed because it
             ;; doesn't try to use any of the native system's headers.
             (unsetenv "C_INCLUDE_PATH")
             (unsetenv "CPATH")
             #t)))))
    (native-inputs `(("avr-binutils" ,avr-binutils)
                     ("avr-gcc" ,avr-gcc)))
    (home-page "https://www.nongnu.org/avr-libc/")
    (synopsis "The AVR C Library")
    (description
     "AVR Libc is a project whose goal is to provide a high quality C library
for use with GCC on Atmel AVR microcontrollers.")
    (license
     (license:non-copyleft "http://www.nongnu.org/avr-libc/LICENSE.txt"))))

(define (avr-toolchain avr-gcc)
  ;; avr-libc checks the compiler version and passes "--enable-device-lib" for avr-gcc > 5.1.0.
  ;; It wouldn't install the library for atmega32u4 etc if we didn't use the corret avr-gcc.
  (let ((avr-libc (avr-libc avr-gcc)))
    (package
      (name "avr-toolchain")
      (version (package-version avr-gcc))
      (source #f)
      (build-system trivial-build-system)
      (arguments '(#:builder (begin (mkdir %output) #t)))
      (propagated-inputs
       `(("avrdude" ,avrdude)
         ("binutils" ,avr-binutils)
         ("gcc" ,avr-gcc)
         ("libc" ,avr-libc)))
      (synopsis "Complete GCC tool chain for AVR microcontroller development")
      (description "This package provides a complete GCC tool chain for AVR
microcontroller development.  This includes the GCC AVR cross compiler and
avrdude for firmware flashing.  The supported programming languages are C and
C++.")
      (home-page (package-home-page avr-libc))
      (license (package-license avr-gcc)))))

(define-public avr-toolchain-4.9 (avr-toolchain avr-gcc-4.9))
(define-public avr-toolchain-5 (avr-toolchain avr-gcc-5))

(define-public microscheme
  (package
    (name "microscheme")
    (version "0.9.3")
    (source
     (origin
       (method git-fetch)
       (uri (git-reference
             (url "https://github.com/ryansuchocki/microscheme")
             (commit (string-append "v" version))))
       (sha256
        (base32 "1r3ng4pw1s9yy1h5rafra1rq19d3vmb5pzbpcz1913wz22qdd976"))
       (file-name (git-file-name name version))))
    (build-system gnu-build-system)
    (arguments
     `(#:parallel-build? #f             ; fails to build otherwise
       #:tests? #f                      ; no tests
       #:phases
       (modify-phases %standard-phases
         (delete 'configure))
       #:make-flags
       (list (string-append "PREFIX=" (assoc-ref %outputs "out")))))
    (native-inputs
     `(("unzip" ,unzip)
       ("xxd" ,xxd)))
    (home-page "https://github.com/ryansuchocki/microscheme/")
    (synopsis "Scheme subset for Atmel microcontrollers")
    (description
     "Microscheme, or @code{(ms)} for short, is a functional programming
language for the Arduino, and for Atmel 8-bit AVR microcontrollers in general.
Microscheme is a subset of Scheme, in the sense that every valid @code{(ms)}
program is also a valid Scheme program (with the exception of Arduino
hardware-specific primitives).  The @code{(ms)} compiler performs function
inlining, and features an aggressive tree-shaker, eliminating unused top-level
definitions.  Microscheme has a robust @dfn{Foreign Function Interface} (FFI)
meaning that C code may be invoked directly from (ms) programs.")
    (license license:expat)))


code:
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016, 2017, 2019 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; 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/>.

(define-module (gnu packages axoloti)
  #:use-module (guix utils)
  #:use-module (guix packages)
  #:use-module (guix download)
  #:use-module (guix git-download)
  #:use-module ((guix licenses) #:prefix license:)
  #:use-module (guix build-system gnu)
  #:use-module (guix build-system ant)
  #:use-module (gnu packages)
  #:use-module (gnu packages base)
  #:use-module (gnu packages compression)
  #:use-module (gnu packages cross-base)
  #:use-module (gnu packages embedded)
  #:use-module (gnu packages flashing-tools)
  #:use-module (gnu packages java)
  #:use-module (gnu packages java-graphics)
  #:use-module (gnu packages libusb)
  #:use-module (gnu packages pkg-config)
  #:use-module (gnu packages textutils)
  #:use-module (gnu packages version-control)
  #:use-module (gnu packages xml))

(define libusb-for-axoloti
  (package (inherit libusb)
    (name "axoloti-libusb")
    (version (package-version libusb))
    (source
     (origin
       (inherit (package-source libusb))
       (patches (list (search-patch "libusb-for-axoloti.patch")))))))

(define dfu-util-for-axoloti
  (package (inherit dfu-util)
    (name "axoloti-dfu-util")
    (version "0.8")
    (source
     (origin
       (method url-fetch)
       (uri (string-append "http://dfu-util.sourceforge.net/releases/"
                           "dfu-util-" version ".tar.gz"))
       (sha256
        (base32
         "0n7h08avlzin04j93m6hkq9id6hxjiiix7ff9gc2n89aw6dxxjsm"))))
    (inputs
     `(("libusb" ,libusb-for-axoloti)))))

(define-public axoloti-runtime
  (package
    (name "axoloti-runtime")
    (version "1.0.12-2")
    (source
     (origin
       (method git-fetch)
       (uri (git-reference
             (url "https://github.com/axoloti/axoloti")
             (commit version)))
       (file-name (git-file-name name version))
       (sha256
        (base32 "1qffis277wshldr3i939b0r2x3a2mlr53samxqmr2nk1sfm2b4w9"))
       (modules '((guix build utils)))
       (snippet
        '(begin
           ;; Remove pre-built Java binaries.
           (delete-file-recursively "lib/")
           #t))))
    (build-system gnu-build-system)
    (arguments
     `(#:tests? #f ; no check target
       #:modules ((guix build gnu-build-system)
                  (guix build utils)
                  (srfi srfi-1)
                  (srfi srfi-26)
                  (ice-9 match)
                  (ice-9 regex))
       #:imported-modules ((guix build syscalls)
                           ,@%gnu-build-system-modules)
       #:phases
       (modify-phases %standard-phases
         (add-after 'unpack 'patch-paths
           (lambda* (#:key inputs #:allow-other-keys)
             ;; prepare ChibiOS
             (invoke "unzip" "-o" (assoc-ref inputs "chibios"))
             (invoke "mv" "ChibiOS_2.6.9" "chibios")
             (with-directory-excursion "chibios/ext"
               (invoke "unzip" "-o" "fatfs-0.9-patched.zip"))

             ;; Remove source of non-determinism in ChibiOS
             (substitute* "chibios/os/various/shell.c"
               (("#ifdef __DATE__") "#if 0"))

             ;; Patch shell paths
             (substitute* '("src/main/java/qcmds/QCmdCompileFirmware.java"
                            "src/main/java/qcmds/QCmdCompilePatch.java"
                            "src/main/java/qcmds/QCmdFlashDFU.java")
               (("/bin/sh") (which "sh")))

             ;; Override cross compiler base name
             (substitute* "firmware/Makefile.patch"
               (("arm-none-eabi-(gcc|g\\+\\+|objcopy|objdump)" tool)
                (which tool)))

             ;; Hardcode full path to compiler tools
             (substitute* '("firmware/Makefile"
                            "firmware/flasher/Makefile"
                            "firmware/mounter/Makefile")
               (("TRGT =.*")
                (string-append "TRGT = "
                               (assoc-ref inputs "cross-toolchain")
                               "/bin/arm-none-eabi-\n")))

             ;; Hardcode path to "make"
             (substitute* '("firmware/compile_firmware_linux.sh"
                            "firmware/compile_patch_linux.sh")
               (("make") (which "make")))

             ;; Hardcode path to "dfu-util"
             (substitute* "platform_linux/upload_fw_dfu.sh"
               (("-f \"\\$\\{platformdir\\}/bin/dfu-util\"") "-z \"\"")
               (("\\./dfu-util") (which "dfu-util")))
             #t))
         (delete 'configure)
         (replace 'build
           ;; Build Axoloti firmware with cross-compiler
           (lambda* (#:key inputs #:allow-other-keys)
             (let* ((toolchain (assoc-ref inputs "cross-toolchain"))
                    (headers   (string-append
                                toolchain
                                "/arm-none-eabi/include:"
                                toolchain
                                "/arm-none-eabi/include/arm-none-eabi/armv7e-m")))
               (setenv "CROSS_CPATH" headers)
               (setenv "CROSS_CPLUS_INCLUDE_PATH" headers)
               (setenv "CROSS_LIBRARY_PATH"
                       (string-append toolchain
                                      "/arm-none-eabi/lib")))
             (with-directory-excursion "platform_linux"
               (invoke "sh" "compile_firmware.sh"))))
         (replace 'install
           (lambda* (#:key inputs outputs #:allow-other-keys)
             (let* ((out   (assoc-ref outputs "out"))
                    (share (string-append out "/share/axoloti/"))
                    (doc   (string-append share "doc"))
                    (dir   (getcwd))
                    (pats  '("/doc/[^/]+$"
                             "/patches/[^/]+/[^/]+$"
                             "/objects/[^/]+/[^/]+$"
                             "/firmware/.+"
                             "/chibios/[^/]+$"
                             "/chibios/boards/ST_STM32F4_DISCOVERY/[^/]+$"
                             "/chibios/(ext|os|docs)/.+"
                             "/CMSIS/[^/]+/[^/]+$"
                             "/patch/[^/]+/[^/]+$"
                             "/[^/]+\\.txt$"))
                    (pattern (string-append
                              "(" (string-join
                                   (map (cut string-append dir <>)
                                        pats)
                                   "|") ")"))
                    (files   (find-files dir
                                         (lambda (file stat)
                                           (and (eq? 'regular (stat:type stat))
                                                (string-match pattern file))))))
               (for-each (lambda (file)
                           (install-file file
                                         (string-append
                                          share
                                          (regexp-substitute
                                           #f
                                           (string-match dir (dirname file))
                                           'pre  'post))))
                         files)
               #t))))))
    (inputs
     `(("chibios"
        ,(origin
           (method url-fetch)
           (uri "mirror://sourceforge/chibios/ChibiOS%20GPL3/Version%202.6.9/ChibiOS_2.6.9.zip")
           (sha256
            (base32
             "0lb5s8pkj80mqhsy47mmq0lqk34s2a2m3xagzihalvabwd0frhlj"))))
       ;; for compiling patches
       ("make" ,gnu-make)
       ;; for compiling firmware
       ("cross-toolchain" ,arm-none-eabi-nano-toolchain-4.9)
       ;; for uploading compiled patches and firmware
       ("dfu-util" ,dfu-util-for-axoloti)))
    (native-inputs
     `(("unzip" ,unzip)))
    (home-page "http://www.axoloti.com/")
    (synopsis "Audio development environment for the Axoloti core board")
    (description
     "The Axoloti patcher offers a “patcher” environment similar to Pure Data
for sketching digital audio algorithms.  The patches run on a standalone
powerful microcontroller board: Axoloti Core.  This package provides the
runtime.")
    (license license:gpl3+)))

(define-public axoloti-patcher
  (package (inherit axoloti-runtime)
    (name "axoloti-patcher")
    (version (package-version axoloti-runtime))
    (arguments
     `(#:tests? #f ; no check target
       #:modules ((guix build gnu-build-system)
                  ((guix build ant-build-system) #:prefix ant:)
                  (guix build utils)
                  (srfi srfi-1)
                  (srfi srfi-26)
                  (ice-9 match)
                  (ice-9 regex)
                  (sxml simple)
                  (sxml xpath)
                  (sxml transform))
       #:imported-modules ((guix build ant-build-system)
                           (guix build syscalls)
                           ,@%gnu-build-system-modules)
       #:phases
       (modify-phases %standard-phases
         (add-after 'unpack 'make-git-checkout-writable
           (lambda _
             (for-each make-file-writable (find-files "."))
             #t))
         (delete 'configure)
         (replace 'build
           (lambda* (#:key inputs #:allow-other-keys)
             (setenv "JAVA_HOME" (assoc-ref inputs "icedtea"))
             ;; We want to use our own jar files instead of the pre-built
             ;; stuff in lib.  So we replace the zipfileset tags in the
             ;; build.xml with new ones that reference our jars.
             (let* ((build.xml (with-input-from-file "build.xml"
                                 (lambda _
                                   (xml->sxml #:trim-whitespace? #t))))
                    (jars      (append-map (match-lambda
                                             (((? (cut string-prefix? "java-" <>)
                                                  label) . directory)
                                              (find-files directory "\\.jar$"))
                                             (_ '()))
                                           inputs))
                    (classpath (string-join jars ":"))
                    (fileset   (map (lambda (jar)
                                      `(zipfileset (@ (excludes "META-INF/*.SF")
                                                      (src ,jar))))
                                    jars)))
               (call-with-output-file "build.xml"
                 (lambda (port)
                   (sxml->xml
                    (pre-post-order
                     build.xml
                     `(;; Remove all zipfileset tags from the "jar" tree and
                       ;; inject our own tags.
                       (jar . ,(lambda (tag . kids)
                                 `(jar ,@(append-map
                                          (filter (lambda (e)
                                                    (not (eq? 'zipfileset (car e)))))
                                          kids)
                                       ,@fileset)))
                       ;; Skip the "bundle" target (and the "-post-jar" target
                       ;; that depends on it), because we don't need it and it
                       ;; confuses sxml->xml.
                       (target . ,(lambda (tag . kids)
                                    (let ((name ((sxpath '(name *text*))
                                                 (car kids))))
                                      (if (or (member "bundle" name)
                                              (member "-post-jar" name))
                                          '() ; skip
                                          `(,tag ,@kids)))))
                       (*default*  . ,(lambda (tag . kids) `(,tag ,@kids)))
                       (*text*     . ,(lambda (_ txt)
                                        (match txt
                                          ;; Remove timestamp.
                                          ("${TODAY}" "(unknown)")
                                          (_ txt))))))
                    port)))

               ;; Build it!
               (invoke "ant"
                       (string-append "-Djavac.classpath=" classpath)
                       "-Dbuild.runtime=true"
                       "-Dbuild.time=01/01/1970 00:00:00"
                       "-Djavac.source=1.7"
                       "-Djavac.target=1.7"
                       (string-append "-Dtag.short.version="
                                      ,version)))))
         (replace 'install
           (lambda* (#:key inputs outputs #:allow-other-keys)
             (let* ((out   (assoc-ref outputs "out"))
                    (share (string-append out "/share/axoloti/")))
               (install-file "dist/Axoloti.jar" share)

               ;; We do this to ensure that this package retains references to
               ;; other Java packages' jar files.
               (install-file "build.xml" share)

               ;; Create a launcher script
               (mkdir (string-append out "/bin"))
               (let ((target (string-append out "/bin/Axoloti")))
                 (with-output-to-file target
                   (lambda ()
                     (let* ((dir       (string-append (assoc-ref outputs "out")
                                                      "/share/axoloti"))
                            (runtime   (string-append (assoc-ref inputs "axoloti-runtime")
                                                      "/share/axoloti"))
                            (toolchain (assoc-ref inputs "cross-toolchain"))
                            (includes  (string-append
                                        toolchain
                                        "/arm-none-eabi/include:"
                                        toolchain
                                        "/arm-none-eabi/include/arm-none-eabi/armv7e-m")))
                       (display
                        (string-append "#!" (which "sh") "\n"
                                       "export CROSS_CPATH=" includes "\n"
                                       "export CROSS_CPLUS_INCLUDE_PATH=" includes "\n"
                                       "export CROSS_LIBRARY_PATH="
                                       toolchain "/arm-none-eabi/lib" "\n"
                                       (which "java")
                                       " -Daxoloti_release=" runtime
                                       " -Daxoloti_runtime=" runtime
                                       " -jar " dir "/Axoloti.jar")))))
                 (chmod target #o555))
               #t)))
         (add-after 'install 'strip-jar-timestamps
           (assoc-ref ant:%standard-phases 'strip-jar-timestamps)))))
    (inputs
     `(("icedtea" ,icedtea "jdk")
       ("cross-toolchain" ,arm-none-eabi-nano-toolchain-4.9)
       ("java-simple-xml" ,java-simple-xml)
       ("java-rsyntaxtextarea" ,java-rsyntaxtextarea)
       ("java-usb4java" ,java-usb4java)
       ("java-jsch" ,java-jsch)
       ("java-slf4j-api" ,java-slf4j-api)
       ("java-jgit" ,java-jgit-4.2)
       ("axoloti-runtime" ,axoloti-runtime)))
    (native-inputs
     `(("ant" ,ant)
       ("zip" ,zip) ; for repacking the jar
       ("unzip" ,unzip)))
    (description
     "The Axoloti patcher offers a “patcher” environment similar to Pure Data
for sketching digital audio algorithms.  The patches run on a standalone
powerful microcontroller board: Axoloti Core.  This package provides the
patcher application.")))

(define-public axoloti-patcher-next
  (package
    (name "axoloti-patcher-next")
    (version "2.0.0")
    (source
     (origin
       (method git-fetch)
       (uri (git-reference
             (url "https://github.com/axoloti/axoloti")
             (commit version)))
       (file-name (git-file-name name version))
       (sha256
        (base32 "022p993wf9l9mp6vg94x592vfqd1k1sjrq5f6x45h5r16qy6bdzh"))
       (modules '((guix build utils)))
       (snippet
        '(begin
           ;; Remove pre-built Java binaries.
           (delete-file-recursively "lib/")
           #t))))
    (build-system gnu-build-system)
    (arguments
     `(#:tests? #f ; there's a Java test which is run as part of the Java build.
       #:modules ((guix build gnu-build-system)
                  ((guix build ant-build-system) #:prefix ant:)
                  (guix build utils)
                  (srfi srfi-1)
                  (srfi srfi-26)
                  (ice-9 match)
                  (ice-9 regex)
                  (sxml simple)
                  (sxml xpath)
                  (sxml transform))
       #:imported-modules ((guix build ant-build-system)
                           (guix build syscalls)
                           ,@%gnu-build-system-modules)
       #:phases
       (modify-phases %standard-phases
         (add-after 'unpack 'make-git-checkout-writable
           (lambda* (#:key inputs #:allow-other-keys)
             (copy-recursively (assoc-ref inputs "elfloader")
                               "firmware/elfloader")
             (for-each make-file-writable (find-files "."))
             #t))
         (add-after 'unpack 'patch-paths
           (lambda* (#:key inputs #:allow-other-keys)
             ;; prepare ChibiOS
             (invoke "7z" "x" (assoc-ref inputs "chibios"))
             (with-directory-excursion "ChibiOS_19.1.3/ext"
               (invoke "7z" "x" "fatfs-0.13_patched.7z"))

             ;; Hardcode full path to compiler tools
             (substitute*
                 '("ChibiOS_19.1.3/os/common/startup/ARMCMx/compilers/GCC/mk/arm-none-eabi.mk"
                   "env/arm-none-eabi.mk")
               (("TRGT =.*")
                (string-append "TRGT = "
                               (assoc-ref inputs "cross-toolchain")
                               "/bin/arm-none-eabi-\n")))

             ;; Hardcode path to "make"
             (substitute* "src/main/java/axoloti/shell/ShellTask.java"
               (("return \"make\"")
                (string-append "return \"" (which "make") "\"")))

             ;; Hardcode path to "dfu-util"
             (substitute* "src/main/java/axoloti/shell/UploadFirmwareDFU.java"
               (("Axoloti.getReleaseDir\\(\\) \\+ \"/platform_.+/bin/dfu-util\"")
                (string-append "\"" (which "dfu-util") "\"")))
             #t))
         (delete 'configure)
         (replace 'build
           ;; Build Axoloti firmware with cross-compiler
           (lambda* (#:key inputs #:allow-other-keys)
             (let* ((toolchain (assoc-ref inputs "cross-toolchain"))
                    (headers   (string-append
                                toolchain
                                "/arm-none-eabi/include:"
                                toolchain
                                "/arm-none-eabi/include/arm-none-eabi/armv7e-m")))
               (setenv "CROSS_CPATH" headers)
               (setenv "CROSS_CPLUS_INCLUDE_PATH" headers)
               (setenv "CROSS_LIBRARY_PATH"
                       (string-append toolchain
                                      "/arm-none-eabi/lib")))
             (with-directory-excursion "platform_linux"
               (invoke "sh" "compile_firmware.sh"))))
         (add-after 'build 'build-patcher
           (lambda* (#:key inputs outputs #:allow-other-keys)
             (setenv "JAVA_HOME" (assoc-ref inputs "jdk"))
             ;; We want to use our own jar files instead of the pre-built
             ;; stuff in lib.  So we replace the zipfileset tags in the
             ;; build.xml with new ones that reference our jars.
             (let* ((build.xml (with-input-from-file "build.xml"
                                 (lambda _
                                   (xml->sxml #:trim-whitespace? #t))))
                    (jars      (append-map (match-lambda
                                             (((? (cut string-prefix? "java-" <>)
                                                  label) . directory)
                                              (find-files directory "\\.jar$"))
                                             (_ '()))
                                           inputs))
                    (classpath (string-join jars ":"))
                    (fileset   (map (lambda (jar)
                                      `(zipfileset (@ (excludes "META-INF/*.SF")
                                                      (src ,jar))))
                                    jars)))
               (call-with-output-file "build.xml"
                 (lambda (port)
                   (sxml->xml
                    (pre-post-order
                     build.xml
                     `( ;; Remove all zipfileset tags from the "jar" tree and
                       ;; inject our own tags.
                       (jar . ,(lambda (tag . kids)
                                 `(jar ,@(append-map
                                          (filter (lambda (e)
                                                    (not (eq? 'zipfileset (car e)))))
                                          kids)
                                       ,@fileset)))
                       ;; Skip the "bundle" target (and the "-post-jar" target
                       ;; that depends on it), because we don't need it and it
                       ;; confuses sxml->xml.
                       (target . ,(lambda (tag . kids)
                                    (let ((name ((sxpath '(name *text*))
                                                 (car kids))))
                                      (if (or (member "bundle" name)
                                              (member "-post-jar" name))
                                          '() ; skip
                                          `(,tag ,@kids)))))
                       (*default*  . ,(lambda (tag . kids) `(,tag ,@kids)))
                       (*text*     . ,(lambda (_ txt)
                                        (match txt
                                          ;; Remove timestamp.
                                          ("${TODAY}" "(unknown)")
                                          (_ txt))))))
                    port)))

               ;; Build it!
               (invoke "ant"
                       (string-append "-Djavac.classpath=" classpath)
                       "-Dbuilt_by=guix"
                       "-Dbuild.time=01/01/1970 00:00:00"
                       "-Djavac.source=1.8"
                       "-Djavac.target=1.8"
                       (string-append "-Dshort.version="
                                      ,version)
                       ;; TODO: this is the output of:
                       ;; git describe --long --tags --dirty --always
                       (string-append "-Dbuild.version="
                                      ,version "-0-g88b60feb")))))
         (replace 'install
           (lambda* (#:key inputs outputs #:allow-other-keys)
             (let* ((out   (assoc-ref outputs "out"))
                    (share (string-append out "/share/axoloti/")))

               ;; TODO: don't copy *everything* from these directories.
               (for-each (lambda (dir)
                           (copy-recursively dir (string-append share "/" dir)))
                         '("api"
                           "archive"
                           "doc"
                           "env"
                           "firmware"
                           "nbproject"
                           "platform_linux"))
               (install-file "dist/Axoloti.jar" share)

               ;; Install old firmware
               (let ((target (string-append share "/old_firmware/"))
                     (old-firmware
                      (string-append (assoc-ref inputs "axoloti-runtime")
                                     "/share/axoloti/firmware/")))
                 (mkdir-p target)
                 (install-file (string-append old-firmware
                                              "flasher/flasher_build/flasher.bin")
                               target)
                 ;; TODO: the old file differs from the file that is included
                 ;; in this repository as the old firmware.
                 (install-file (string-append old-firmware
                                              "build/axoloti.bin")
                               target))

               ;; We do this to ensure that this package retains references to
               ;; other Java packages' jar files.
               (install-file "build.xml" share)

               ;; Create a launcher script
               (mkdir (string-append out "/bin"))
               (let ((target (string-append out "/bin/Axoloti")))
                 (with-output-to-file target
                   (lambda ()
                     (let* ((dir       (string-append (assoc-ref outputs "out")
                                                      "/share/axoloti"))
                            (toolchain (assoc-ref inputs "cross-toolchain"))
                            (includes  (string-append
                                        toolchain
                                        "/arm-none-eabi/include:"
                                        toolchain
                                        "/arm-none-eabi/include/arm-none-eabi/armv7e-m")))
                       (display
                        (string-append "#!" (which "sh") "\n"
                                       "export CROSS_CPATH=" includes "\n"
                                       "export CROSS_CPLUS_INCLUDE_PATH=" includes "\n"
                                       "export CROSS_LIBRARY_PATH="
                                       toolchain "/arm-none-eabi/lib" "\n"
                                       (which "java")

                                       ;; Renderer arguments
                                       " -Xbootclasspath/a:"
                                       (assoc-ref inputs "java-marlin-renderer")
                                       "/lib/marlin.jar"
                                       " -Dsun.java2d.renderer=org.marlin.pisces.MarlinRenderingEngine"
                                       " -Daxoloti_release=" share
                                       " -jar " dir "/Axoloti.jar")))))
                 (chmod target #o555))
               #t)))
         (add-after 'install 'strip-jar-timestamps
           (assoc-ref ant:%standard-phases 'strip-jar-timestamps)))))
    (inputs
     `(("jdk" ,icedtea "jdk")
       ("cross-toolchain" ,arm-none-eabi-nano-toolchain-7-2018-q2-update)
       ;; for compiling patches
       ("make" ,gnu-make)
       ;; for uploading compiled patches and firmware
       ("dfu-util" ,dfu-util-for-axoloti)
       ;; for org/apache/commons/lang3/tuple/ImmutablePair
       ("java-commons-lang3" ,java-commons-lang3)
       ("java-jgit" ,java-jgit-4.2)
       ("java-jsch" ,java-jsch)
       ("java-marlin-renderer" ,java-marlin-renderer)
       ("java-piccolo2d-core" ,java-piccolo2d-core)
       ("java-piccolo2d-extras" ,java-piccolo2d-extras)
       ("java-rsyntaxtextarea" ,java-rsyntaxtextarea)
       ("java-simple-xml" ,java-simple-xml)
       ("java-slf4j-api" ,java-slf4j-api)
       ("java-usb4java" ,java-usb4java)))
    (native-inputs
     `(("ant" ,ant)
       ("axoloti-runtime" ,axoloti-runtime) ; for old firmware
       ("java-junit" ,java-junit)
       ("java-hamcrest-core" ,java-hamcrest-core)
       ("p7zip" ,p7zip)
       ("zip" ,zip)                     ; for repacking the jar
       ("elfloader"
        ,(let ((commit "d0f93acac6577a069b8739bf42c9500e9a862988"))
           (origin
             (method git-fetch)
             (uri (git-reference
                   (url "https://github.com/JohannesTaelman/elfloader")
                   (commit commit)))
             (file-name (git-file-name "elfloader" commit))
             (sha256
              (base32
               "0zsy6w784amfq4vr1qnx8xvy70v33gvffz1vljllwppdc8s3khmn")))))
       ("chibios"
        ,(origin
           (method url-fetch)
           (uri "http://rwthaachen.dl.osdn.jp/chibios/70739/ChibiOS_19.1.3.7z")
           (sha256
            (base32
             "1090alqp1z1bhj1z8ls04a350kbs8hsjcpkfddbprds73zbnnpk9"))))))
    (home-page "http://www.axoloti.com/")
    (synopsis "Audio development environment for the Axoloti core board")
    (description
     "The Axoloti patcher offers a “patcher” environment similar to Pure Data
for sketching digital audio algorithms.  The patches run on a standalone
powerful microcontroller board: Axoloti Core.")
    (license (list license:gpl3+     ; the whole project and GUI
                   license:bsd-3)))) ; the elfloader