From patchwork Tue Apr 19 23:31:47 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Philip McGrath X-Patchwork-Id: 38677 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id CC34227BBEA; Wed, 20 Apr 2022 00:34:34 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,SPF_HELO_PASS autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 9F5DF27BBE9 for ; Wed, 20 Apr 2022 00:34:32 +0100 (BST) Received: from localhost ([::1]:42216 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1ngxMd-0004BS-OJ for patchwork@mira.cbaines.net; Tue, 19 Apr 2022 19:34:31 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:41290) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1ngxMC-0003b2-DL for guix-patches@gnu.org; Tue, 19 Apr 2022 19:34:04 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:50567) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1ngxMA-0001wy-IR for guix-patches@gnu.org; Tue, 19 Apr 2022 19:34:04 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1ngxMA-00061P-Ff for guix-patches@gnu.org; Tue, 19 Apr 2022 19:34:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#55030] [PATCH 03/30] guix: Add elm-build-system and 'guix import elm'. Resent-From: Philip McGrath Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Tue, 19 Apr 2022 23:34:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 55030 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 55030@debbugs.gnu.org Cc: Philip McGrath Received: via spool by 55030-submit@debbugs.gnu.org id=B55030.165041119722955 (code B ref 55030); Tue, 19 Apr 2022 23:34:02 +0000 Received: (at 55030) by debbugs.gnu.org; 19 Apr 2022 23:33:17 +0000 Received: from localhost ([127.0.0.1]:44430 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ngxLJ-0005xq-NE for submit@debbugs.gnu.org; Tue, 19 Apr 2022 19:33:17 -0400 Received: from mail-vs1-f54.google.com ([209.85.217.54]:44590) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1ngxLG-0005xL-Sb for 55030@debbugs.gnu.org; Tue, 19 Apr 2022 19:33:08 -0400 Received: by mail-vs1-f54.google.com with SMTP id m14so24206vsp.11 for <55030@debbugs.gnu.org>; Tue, 19 Apr 2022 16:33:06 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=philipmcgrath.com; s=google; h=from:to:cc:subject:date:message-id:in-reply-to:references :mime-version:content-transfer-encoding; bh=ClT6VxzBawlVoWwfFdTZsDzbgMRfs+XG8m5rmLhBlMI=; b=a7YqO3kHyAzC86v1RiUu6IBPzjWW+Xe1Hqy+Jyo/NDuuQUHmqrBkeT1MpRi4lpXwgF Hhk/T/pLoBR6BpVRcd2Sy5mz3zz0LDdjmVuzZnFO/F4zMB7M/b+3yDRMJ1XlM1RdpQUA oTJa8AcHymUBwZQCwgicUzBZPTKzhAURI/nmrQ7T6DtHc3oW2AnhTgnom57fWsgHDQW1 MypobVN195rscsM8ORsrCjd4373bjtUQh6gGa1C+U3aQ6iE3sLySgIk5kYWRSarYML1e ig34JvY7ceyTZvO6KyCF0d6FNbjNxEyqjc8yt0WgKyljApzCyl46clbRgla+hva5JjpO A6Ow== X-Google-DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=1e100.net; s=20210112; h=x-gm-message-state:from:to:cc:subject:date:message-id:in-reply-to :references:mime-version:content-transfer-encoding; bh=ClT6VxzBawlVoWwfFdTZsDzbgMRfs+XG8m5rmLhBlMI=; b=Wc+0VIMwXAWVp1y/dsXueRuLol0/Ua4/qDfjbg6FhJ1zG7yIsFW+LuB7zhCRiKDqpF VHRoPd5VbpShLacOfHFWg8M1gKV+6xy1+bdqAg94W69mUKOw0Qt/WQtJ02NCQEjCLJPI WFJ2P3wMIW3c41md8u+5ZgSwryMELEWz2Jklh5c94PBFOsRJBhBAR5oTuElM3CFU1Kd8 3pwYiyv1Knk4tOhySZuYw07fM49Fmr9D5ac1gPd0etpwuSNtHJt1BfKup2bx1T2uOcA7 bp/wUzZcDsvtzEGtn7/ECXRuACg4nn1hpbV9PAaBbva6+TLCxhRKApY/UFY8nUu2MhB7 KRLw== X-Gm-Message-State: AOAM532uIoc/wnTzJxAKHEU6w96qxwG16/oTonAjyh0zyEKs1LS+W5dM vHeWgPMXAX+c8Gz8asoucRfb+5Qa1Gtqo5rD X-Google-Smtp-Source: ABdhPJwJyPw2e0uB5WUD/iIZuyFKC9fRLMdhrE3J5Lc5PrDogXt/r2jRa7NRWAUpXdxIafsYvw+OcA== X-Received: by 2002:a05:6102:20e:b0:32a:25f9:7bfc with SMTP id z14-20020a056102020e00b0032a25f97bfcmr5136213vsp.82.1650411180815; Tue, 19 Apr 2022 16:33:00 -0700 (PDT) Received: from localhost (c-73-125-98-51.hsd1.fl.comcast.net. [73.125.98.51]) by smtp.gmail.com with UTF8SMTPSA id v13-20020ab0678d000000b0035ce198a740sm175800uar.5.2022.04.19.16.32.59 (version=TLS1_3 cipher=TLS_AES_128_GCM_SHA256 bits=128/128); Tue, 19 Apr 2022 16:32:59 -0700 (PDT) From: Philip McGrath Date: Tue, 19 Apr 2022 19:31:47 -0400 Message-Id: <20220419233214.275789-3-philip@philipmcgrath.com> X-Mailer: git-send-email 2.32.0 In-Reply-To: <20220419233214.275789-1-philip@philipmcgrath.com> References: <20220419232736.272970-1-philip@philipmcgrath.com> <20220419233214.275789-1-philip@philipmcgrath.com> MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: "Guix-patches" X-getmail-retrieved-from-mailbox: Patches * gnu/packages/patches/elm-offline-package-registry.scm: New file. * gnu/local.mk (dist_patch_DATA): Add it. * gnu/packages/elm.scm (elm): Use it. * guix/build-system/elm.scm, guix/build/elm-build-system.scm, guix/import/elm.scm, guix/scripts/import/elm.scm: New files. * guix/scripts/import.scm (importers): Add "elm". --- gnu/local.mk | 1 + gnu/packages/elm.scm | 8 +- .../elm-offline-package-registry.patch | 71 ++++ guix/build-system/elm.scm | 144 +++++++ guix/build/elm-build-system.scm | 380 ++++++++++++++++++ guix/import/elm.scm | 148 +++++++ guix/scripts/import.scm | 3 +- guix/scripts/import/elm.scm | 107 +++++ 8 files changed, 859 insertions(+), 3 deletions(-) create mode 100644 gnu/packages/patches/elm-offline-package-registry.patch create mode 100644 guix/build-system/elm.scm create mode 100644 guix/build/elm-build-system.scm create mode 100644 guix/import/elm.scm create mode 100644 guix/scripts/import/elm.scm diff --git a/gnu/local.mk b/gnu/local.mk index 2af4d018ba..6f02f0a6fd 100644 --- a/gnu/local.mk +++ b/gnu/local.mk @@ -1024,6 +1024,7 @@ dist_patch_DATA = \ %D%/packages/patches/einstein-build.patch \ %D%/packages/patches/elfutils-tests-ptrace.patch \ %D%/packages/patches/elixir-path-length.patch \ + %D%/packages/patches/elm-offline-package-registry.patch \ %D%/packages/patches/elm-reactor-static-files.patch \ %D%/packages/patches/elogind-revert-polkit-detection.patch \ %D%/packages/patches/emacs-exec-path.patch \ diff --git a/gnu/packages/elm.scm b/gnu/packages/elm.scm index be2e4ebcbd..22c1db5942 100644 --- a/gnu/packages/elm.scm +++ b/gnu/packages/elm.scm @@ -25,6 +25,7 @@ (define-module (gnu packages elm) #:use-module (gnu packages haskell-xyz) #:use-module (gnu packages haskell-web) #:use-module (guix build-system haskell) + #:use-module (guix build-system elm) #:use-module (guix gexp) #:use-module (guix git-download) #:use-module ((guix licenses) #:prefix license:) @@ -37,6 +38,8 @@ (define-module (gnu packages elm) ;; also want to be able to enable it once we can build it. We patch Elm to ;; instead look for the files on disk relative to the executable and to have ;; `elm reactor` exit with a useful error message if they aren't there. +(define %reactor-root-base + "share/elm/reactor-") (define-public elm (package (name "elm") @@ -51,13 +54,14 @@ (define-public elm (sha256 (base32 "1rdg3xp3js9xadclk3cdypkscm5wahgsfmm4ldcw3xswzhw6ri8w")) (patches - (search-patches "elm-reactor-static-files.patch")))) + (search-patches "elm-reactor-static-files.patch" + "elm-offline-package-registry.patch")))) (build-system haskell-build-system) (arguments (list #:configure-flags #~(list (string-append "--ghc-option=-DGUIX_REACTOR_STATIC_REL_ROOT=" - "\"../share/elm/reactor-" + "\"../" #$%reactor-root-base #$(package-version this-package) "\"")) #:phases diff --git a/gnu/packages/patches/elm-offline-package-registry.patch b/gnu/packages/patches/elm-offline-package-registry.patch new file mode 100644 index 0000000000..761ec69878 --- /dev/null +++ b/gnu/packages/patches/elm-offline-package-registry.patch @@ -0,0 +1,71 @@ +From 06563409e6f2b1cca7bc1b27e31efd07a7569da8 Mon Sep 17 00:00:00 2001 +From: Philip McGrath +Date: Thu, 14 Apr 2022 22:41:04 -0400 +Subject: [PATCH] minimal support for offline builds + +Normally, Elm performs HTTP requests before building to obtain or +update its list of all registed packages and their versions. +This is problematic in the Guix build environment. + +This patch causes Elm to check if the `GUIX_ELM_OFFLINE_REGISTRY_FILE` +is set and, if so, to use the contents of the file it specifies as +though it were the response from +https://package.elm-lang.org/all-packages. + +This patch does not attempt to add more general support for offline +builds. In particular, it does not attempt to support incremental +updates to the package registry cache file. See also discussion at +https://discourse.elm-lang.org/t/private-package-tool-spec/6779/25. +--- + builder/src/Deps/Registry.hs | 25 +++++++++++++++++++++---- + 1 file changed, 21 insertions(+), 4 deletions(-) + +diff --git a/builder/src/Deps/Registry.hs b/builder/src/Deps/Registry.hs +index 8d7def98..70cf3622 100644 +--- a/builder/src/Deps/Registry.hs ++++ b/builder/src/Deps/Registry.hs +@@ -18,6 +18,8 @@ import Control.Monad (liftM2) + import Data.Binary (Binary, get, put) + import qualified Data.List as List + import qualified Data.Map.Strict as Map ++import System.Environment as Env ++import qualified Data.ByteString as BS + + import qualified Deps.Website as Website + import qualified Elm.Package as Pkg +@@ -190,13 +192,28 @@ getVersions' name (Registry _ versions) = + post :: Http.Manager -> String -> D.Decoder x a -> (a -> IO b) -> IO (Either Exit.RegistryProblem b) + post manager path decoder callback = + let +- url = Website.route path [] +- in +- Http.post manager url [] Exit.RP_Http $ +- \body -> ++ mkBodyCallback url body = + case D.fromByteString decoder body of + Right a -> Right <$> callback a + Left _ -> return $ Left $ Exit.RP_Data url body ++ postOnline url cb = ++ Http.post manager url [] Exit.RP_Http cb ++ performPost f url = ++ f url (mkBodyCallback url) ++ in ++ do ++ maybeFile <- Env.lookupEnv "GUIX_ELM_OFFLINE_REGISTRY_FILE" ++ case (path, maybeFile) of ++ ( "/all-packages", Just file ) -> ++ performPost postOffline file ++ ( _, _ ) -> ++ -- don't know how to handle other endpoints yet ++ performPost postOnline (Website.route path []) ++ ++postOffline :: String -> (BS.ByteString -> IO a) -> IO a ++postOffline file callback = do ++ body <- BS.readFile file ++ callback body + + + +-- +2.32.0 + diff --git a/guix/build-system/elm.scm b/guix/build-system/elm.scm new file mode 100644 index 0000000000..bf77df6519 --- /dev/null +++ b/guix/build-system/elm.scm @@ -0,0 +1,144 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Philip McGrath +;;; +;;; 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 . + +(define-module (guix build-system elm) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix gexp) + #:use-module (guix monads) + #:use-module (guix search-paths) + #:use-module (guix git-download) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:export (elm->package-name + elm-package-origin + %elm-build-system-modules + %elm-default-modules + elm-build + elm-build-system)) + +(define (elm->package-name name) + "Given the NAME of an Elm package, return a Guix-style package name." + (let ((converted + (string-join (string-split (string-downcase name) #\/) "-"))) + (if (string-prefix? "elm-" converted) + converted + (string-append "elm-" converted)))) + +(define (elm-package-origin name version hash) + "Return an origin for the Elm package NAME at the given VERSION with sha256 +checksum HASH." + ;; elm requires this very specific repository structure and tagging regime + (origin + (method git-fetch) + (uri (git-reference + (url (string-append "https://github.com/" name)) + (commit version))) + (file-name (git-file-name (elm->package-name name) version)) + (sha256 hash))) + +(define %elm-build-system-modules + ;; Build-side modules imported by default. + `((guix build elm-build-system) + (guix build json) + (guix build union) + ,@%gnu-build-system-modules)) + +(define %elm-default-modules + ;; Modules in scope in the build-side environment. + '((guix build elm-build-system) + (guix build utils) + (guix build json) + (guix build union))) + +(define (default-elm) + "Return the default Elm package for builds." + ;; Lazily resolve the binding to avoid a circular dependency. + (let ((elm (resolve-interface '(gnu packages elm)))) + (module-ref elm 'elm))) + +(define* (lower name + #:key source inputs native-inputs outputs system target + (implicit-elm-package-inputs? #t) + (elm (default-elm)) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME." + (define private-keywords + '(#:target #:implicit-elm-package-inputs? #:elm #:inputs #:native-inputs)) + (cond + (target + ;; Cross-compilation is not yet supported. It should be easy, though, + ;; since the build products are all platform-independent. + #f) + (else + (bag + (name name) + (system system) + (host-inputs + `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ("elm" ,elm) + ;; TODO: probably don't need most of (standard-packages) + ,@(standard-packages))) + (outputs outputs) + (build elm-build) + (arguments (strip-keyword-arguments private-keywords arguments)))))) + +(define* (elm-build name inputs + #:key + source + (tests? #t) + (phases '%standard-phases) + (outputs '("out")) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %elm-build-system-modules) + (modules %elm-default-modules)) + "Build SOURCE using ELM." + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (elm-build #:name #$name + #:source #+source + #:system #$system + #:tests? #$tests? + #:phases #$phases + #:outputs #$(outputs->gexp outputs) + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:inputs #$(input-tuples->gexp inputs))))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:guile-for-build guile))) + +(define elm-build-system + (build-system + (name 'elm) + (description "The Elm build system") + (lower lower))) diff --git a/guix/build/elm-build-system.scm b/guix/build/elm-build-system.scm new file mode 100644 index 0000000000..b47b16973d --- /dev/null +++ b/guix/build/elm-build-system.scm @@ -0,0 +1,380 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Philip McGrath +;;; +;;; 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 . + +(define-module (guix build elm-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (guix build json) + #:use-module (guix build union) + #:use-module (ice-9 ftw) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) + #:export (%standard-phases + patch-application-dependencies + patch-json-string-escapes + read-offline-registry->vhash + elm-build)) + +;; COMMENTARY: +;; +;; Elm draws a sharp distinction between "projects" with `{"type":"package"}` +;; vs. `{"type":"application"}` in the "elm.json" file: see +;; and +;; . +;; For now, `elm-build-system` is designed for "package"s: packaging +;; "application"s requires ad-hoc replacements for some phases---but see +;; `patch-application-dependencies`, which helps to work around a known issue +;; discussed below. It would be nice to add more streamlined support for +;; "application"s one we have more experience building them in Guix. For +;; example, we could incorporate the `uglifyjs` advice from +;; . +;; +;; We want building an Elm "package" to produce: +;; +;; - a "docs.json" file with extracted documentation; and +;; +;; - an "artifacts.dat" file with compilation results for use in building +;; "package"s and "application"s. +;; +;; Unfortunately, there isn't an entry point to the Elm compiler that builds +;; those files directly. Building with `elm make` does something different, +;; more oriented toward development, testing, and building "application"s. We +;; work around this limitation by staging the "package" we're building as +;; though it were already installed in ELM_HOME, generating a trivial Elm +;; "application" that depends on the "package", and building the +;; "application", which causes the files for the "package" to be built. +;; +;; Much of the ceremony involved is to avoid using `elm` in ways that would +;; make it try to do network IO beyond the bare minimum functionality for +;; which we've patched a replacement into our `elm`. On the other hand, we +;; get to take advantage of the very regular structure required of Elm +;; packages. +;; +;; *Known issue:* Elm itself supports multiple versions of "package"s +;; coexisting simultaneously under ELM_HOME, but we do not support this yet. +;; Sometimes, parallel versions coexisting causes `elm` to try to write to +;; built "artifacts.dat" files. For now, two workarounds are possible: +;; +;; - Use `patch-application-dependencies` to rewrite an "application"'s +;; "elm.json" file to refer to the versions of its inputs actually +;; packaged in Guix. +;; +;; - Use a Guix package transformation to rewrite your "application"'s +;; dependencies recursively, so that only one version of each Elm +;; "package" is included in your "application"'s build environment. +;; +;; Patching `elm` more extensively---perhaps adding an `elm guix` +;; subcommand`---might let us address these issues more directly. +;; +;; CODE: +;; + +(define %essential-elm-packages + ;; elm/json isn't essential in a fundamental sense, + ;; but it's required for a {"type":"application"}, + ;; which we are generating to trigger the build + '("elm/core" "elm/json")) + +(define* (target-elm-version #:optional elm) + "Return the version of ELM or whichever 'elm' is in $PATH. +Return #false if it cannot be determined." + (let* ((pipe (open-pipe* OPEN_READ + (or elm "elm") + "--version")) + (line (read-line pipe))) + (and (zero? (close-pipe pipe)) + (string? line) + line))) + +(define* (prepare-elm-home #:key native-inputs inputs #:allow-other-keys) + "Set the ELM_HOME environment variable and populate the indicated directory +with the union of the Elm \"package\" inputs. Also, set GUIX_ELM_VERSION to +the version of the Elm compiler in use." + (let* ((elm (search-input-file (or native-inputs inputs) "/bin/elm")) + (elm-version (target-elm-version elm))) + (setenv "GUIX_ELM_VERSION" elm-version) + (mkdir "../elm-home") + (with-directory-excursion "../elm-home" + (union-build elm-version + (search-path-as-list + (list (string-append "share/elm/" elm-version)) + (map cdr inputs)) + #:create-all-directories? #t) + (setenv "ELM_HOME" (getcwd))))) + +(define* (stage #:key native-inputs inputs #:allow-other-keys) + "Extract the installable files from the Elm \"package\" into a staging +directory and link it into the ELM_HOME tree. Also, set GUIX_ELM_PKG_NAME and +GUIX_ELM_PKG_VERSION to the name and version, respectively, of the Elm package +being built, as defined in its \"elm.json\" file." + (let* ((elm-version (getenv "GUIX_ELM_VERSION")) + (elm-home (getenv "ELM_HOME")) + (info (match (call-with-input-file "elm.json" read-json) + (('@ . alist) alist))) + (name (assoc-ref info "name")) + (version (assoc-ref info "version")) + (rel-dir (string-append elm-version "/packages/" name "/" version)) + (staged-dir (string-append elm-home "/../staged/" rel-dir))) + (setenv "GUIX_ELM_PKG_NAME" name) + (setenv "GUIX_ELM_PKG_VERSION" version) + (mkdir-p staged-dir) + (mkdir-p (string-append elm-home "/" (dirname rel-dir))) + (symlink staged-dir + (string-append elm-home "/" rel-dir)) + (copy-recursively "src" (string-append staged-dir "/src")) + (install-file "elm.json" staged-dir) + (install-file "README.md" staged-dir) + (when (file-exists? "LICENSE") + (install-file "LICENSE" staged-dir)))) + +(define (patch-json-string-escapes file) + "Work around a bug in the Elm compiler's JSON parser by attempting to +replace REVERSE-SOLIDUS--SOLIDUS escape sequences in FILE with unescaped +SOLIDUS characters." + ;; https://github.com/elm/compiler/issues/2255 + (substitute* file + (("\\\\/") + "/"))) + +(define (directory-list dir) + "Like DIRECTORY-LIST from 'racket/base': lists the contents of DIR, not +including the special \".\" and \"..\" entries." + (scandir dir (lambda (f) + (not (member f '("." "..")))))) + +(define* (make-offline-registry-file #:key inputs #:allow-other-keys) + "Generate an \"offline-package-registry.json\" file and sets +GUIX_ELM_OFFLINE_REGISTRY_FILE to its path, cooperating with a patch to `elm` +to avoid attempting to download a list of all published Elm package names and +versions from the internet." + (let* ((elm-home (getenv "ELM_HOME")) + (elm-version (getenv "GUIX_ELM_VERSION")) + (registry-file + (string-append elm-home "/../offline-package-registry.json")) + (registry-alist + ;; here, we don't need to look up entries, so we build the + ;; alist directly, rather than using a vhash + (with-directory-excursion + (string-append elm-home "/" elm-version "/packages") + (append-map (lambda (org) + (with-directory-excursion org + (map (lambda (repo) + (cons (string-append org "/" repo) + (directory-list repo))) + (directory-list ".")))) + (directory-list "."))))) + (call-with-output-file registry-file + (lambda (out) + (write-json `(@ ,@registry-alist) out))) + (patch-json-string-escapes registry-file) + (setenv "GUIX_ELM_OFFLINE_REGISTRY_FILE" registry-file))) + +(define (read-offline-registry->vhash) + "Return a vhash mapping Elm \"package\" names to lists of available version +strings." + (alist->vhash + (match (call-with-input-file (getenv "GUIX_ELM_OFFLINE_REGISTRY_FILE") + read-json) + (('@ . alist) alist)))) + +(define (find-indirect-dependencies registry-vhash root-pkg root-version) + "Return the recursive dependencies of ROOT-PKG, an Elm \"package\" name, at +version ROOT-VERSION as an alist mapping Elm \"package\" names to (single) +versions. The resulting alist will not include entries for +%ESSENTIAL-ELM-PACKAGES or for ROOT-PKG itself. The REGISTRY-VHASH is used in +conjunction with the ELM_HOME environment variable to find dependencies." + (with-directory-excursion + (string-append (getenv "ELM_HOME") + "/" (getenv "GUIX_ELM_VERSION") + "/packages") + (define (get-dependencies pkg version acc) + (let* ((elm-json-alist + (match (call-with-input-file + (string-append pkg "/" version "/elm.json") + read-json) + (('@ . alist) alist))) + (deps-alist + (match (assoc-ref elm-json-alist "dependencies") + (('@ . alist) alist))) + (deps-names + (filter-map (match-lambda + ((name . range) + (and (not (member name %essential-elm-packages)) + name))) + deps-alist))) + (fold register-dependency acc deps-names))) + (define (register-dependency pkg acc) + ;; Using vhash-cons unconditionally would add duplicate entries, + ;; which would then cause problems when we must emit JSON. + ;; Plus, we can avoid needlessly duplicating work. + (if (vhash-assoc pkg acc) + acc + (match (vhash-assoc pkg registry-vhash) + ((_ version . _) + ;; in the rare case that multiple versions are present, + ;; just picking an arbitrary one seems to work well enough for now + (get-dependencies pkg version (vhash-cons pkg version acc)))))) + (vlist->list + (get-dependencies root-pkg root-version vlist-null)))) + +(define* (patch-application-dependencies #:key inputs #:allow-other-keys) + "Rewrites the \"elm.json\" file in the working directory---which must be of +`\"type\":\"application\"`, not `\"type\":\"package\"`---to refer to the +dependency versions actually provided via Guix. The +GUIX_ELM_OFFLINE_REGISTRY_FILE environment variable is used to find available +versions." + (let* ((registry-vhash (read-offline-registry->vhash)) + (rewrite-dep-version + (match-lambda + ((name . _) + (cons name (match (vhash-assoc name registry-vhash) + ((_ version) ;; no dot + version)))))) + (rewrite-direct/indirect + (match-lambda + ;; a little checking to avoid confusing misuse with "package" + ;; project dependencies, which have a different shape + (((and key (or "direct" "indirect")) + '@ . alist) + `(,key @ ,@(map rewrite-dep-version alist))))) + (rewrite-json-section + (match-lambda + (((and key (or "dependencies" "test-dependencies")) + '@ . alist) + `(,key @ ,@(map rewrite-direct/indirect alist))) + ((k . v) + (cons k v)))) + (rewrite-elm-json + (match-lambda + (('@ . alist) + `(@ ,@(map rewrite-json-section alist)))))) + (with-atomic-file-replacement "elm.json" + (lambda (in out) + (write-json (rewrite-elm-json (read-json in)) + out))) + (patch-json-string-escapes "elm.json"))) + +(define* (configure #:key native-inputs inputs #:allow-other-keys) + "Generate a trivial Elm \"application\" with a direct dependency on the Elm +\"package\" currently being built." + (let* ((info (match (call-with-input-file "elm.json" read-json) + (('@ . alist) alist))) + (name (getenv "GUIX_ELM_PKG_NAME")) + (version (getenv "GUIX_ELM_PKG_VERSION")) + (elm-home (getenv "ELM_HOME")) + (registry-vhash (read-offline-registry->vhash)) + (app-dir (string-append elm-home "/../fake-app"))) + (mkdir-p (string-append app-dir "/src")) + (with-directory-excursion app-dir + (call-with-output-file "elm.json" + (lambda (out) + (write-json + `(@ ("type" . "application") + ("source-directories" "src") ;; intentionally no dot + ("elm-version" . ,(getenv "GUIX_ELM_VERSION")) + ("dependencies" + @ ("direct" + @ ,@(map (lambda (pkg) + (match (vhash-assoc pkg registry-vhash) + ((_ pkg-version . _) + (cons pkg + (if (equal? pkg name) + version + pkg-version))))) + (if (member name %essential-elm-packages) + %essential-elm-packages + (cons name %essential-elm-packages)))) + ("indirect" + @ ,@(if (member name %essential-elm-packages) + '() + (find-indirect-dependencies registry-vhash + name + version)))) + ("test-dependencies" + @ ("direct" @) + ("indirect" @))) + out))) + (patch-json-string-escapes "elm.json") + (with-output-to-file "src/Main.elm" + ;; the most trivial possible elm program + (lambda () + (display "module Main exposing (..) +main : Program () () () +main = Platform.worker + { init = \\_ -> ( (), Cmd.none ) + , update = \\_ -> \\_ -> ( (), Cmd.none ) + , subscriptions = \\_ -> Sub.none }")))))) + +(define* (build #:key native-inputs inputs #:allow-other-keys) + "Run `elm make` to build the Elm \"application\" generated by CONFIGURE." + (with-directory-excursion (string-append (getenv "ELM_HOME") "/../fake-app") + (invoke (search-input-file (or native-inputs inputs) "/bin/elm") + "make" + "src/Main.elm"))) + +(define* (check #:key tests? #:allow-other-keys) + "Does nothing, because the `elm-test` executable has not yet been packaged +for Guix." + (when tests? + (display "elm-test has not yet been packaged for Guix\n"))) + +(define* (install #:key outputs #:allow-other-keys) + "Installs the contents of the directory generated by STAGE, including any +files added by BUILD, to the Guix package output." + (copy-recursively + (string-append (getenv "ELM_HOME") "/../staged") + (string-append (assoc-ref outputs "out") "/share/elm"))) + +(define* (validate-compiled #:key outputs #:allow-other-keys) + "Checks that the files \"artifacts.dat\" and \"docs.json\" have been +installed." + (let ((base (string-append "/share/elm/" + (getenv "GUIX_ELM_VERSION") + "/packages/" + (getenv "GUIX_ELM_PKG_NAME") + "/" + (getenv "GUIX_ELM_PKG_VERSION"))) + (expected '("artifacts.dat" "docs.json"))) + (for-each (lambda (name) + (search-input-file outputs (string-append base "/" name))) + expected))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (add-after 'unpack 'prepare-elm-home prepare-elm-home) + (delete 'bootstrap) + (add-after 'patch-source-shebangs 'stage stage) + (add-after 'stage 'make-offline-registry-file make-offline-registry-file) + (replace 'configure configure) + (delete 'patch-generated-file-shebangs) + (replace 'build build) + (replace 'check check) + (replace 'install install) + (add-before 'validate-documentation-location 'validate-compiled + validate-compiled))) + +(define* (elm-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Builds the given Elm project, applying all of the PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) diff --git a/guix/import/elm.scm b/guix/import/elm.scm new file mode 100644 index 0000000000..ef0a31207c --- /dev/null +++ b/guix/import/elm.scm @@ -0,0 +1,148 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Philip McGrath +;;; +;;; 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 . + +(define-module (guix import elm) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) + #:use-module (guix utils) + #:use-module (guix base32) + #:use-module (guix hash) + #:use-module (guix memoization) + #:use-module (guix diagnostics) + #:use-module (guix i18n) + #:use-module ((guix ui) #:select (display-hint)) + #:use-module ((guix build utils) + #:select ((package-name->name+version + . hyphen-package-name->name+version) + find-files + invoke)) + #:use-module (guix import utils) + #:use-module (guix git) + #:use-module (guix import json) + #:autoload (gcrypt hash) (hash-algorithm sha256) + #:use-module (json) + #:use-module (guix packages) + #:use-module (guix upstream) + #:use-module ((guix licenses) #:prefix license:) + #:use-module (guix build-system elm) + #:export (elm-recursive-import + elm->guix-package)) + +(define elm-package-registry + ;; It is much nicer to fetch this small (< 40 KB gzipped) + ;; file once than to do many HTTP requests. + (mlambda () + "Fetch the Elm package registry, represented as a vhash mapping package +names to lists of available versions, sorted from latest to oldest." + (let ((url "https://package.elm-lang.org/all-packages")) + (cond + ((json-fetch url) + => (lambda (alist) + (fold (lambda (entry vh) + (match entry + ((name . vec) + (vhash-cons name + (sort (vector->list vec) version>?) + vh)))) + vlist-null + alist))) + (else + (raise (formatted-message + (G_ "error downloading Elm package registry from ~a") + url))))))) + +(define (make-elm-package-sexp name version) + "Return two values: the `package' s-expression for the Elm package with the +given NAME and VERSION, and a list of Elm packages it depends on." + (define-values (checkout _commit _relation) + ;; Elm requires that packages use this very specific format + (update-cached-checkout (string-append "https://github.com/" name) + #:ref `(tag . ,version))) + (define info + (call-with-input-file (string-append checkout "/elm.json") + json->scm)) + (define (get-deps key) + (cond + ((assoc-ref info key) + => (cut map car <>)) + (else + '()))) + (define dependencies + (get-deps "dependencies")) + (define test-dependencies + (get-deps "test-dependencies")) + (values + `(package + (name ,(elm->package-name name)) + (version ,version) + (source (elm-package-origin + ,name + version ;; no , + (base32 + ,(bytevector->nix-base32-string + (file-hash* checkout + #:algorithm (hash-algorithm sha256) + #:recursive? #t))))) + (build-system elm-build-system) + ,@(maybe-propagated-inputs (map elm->package-name dependencies)) + ,@(maybe-inputs (map elm->package-name test-dependencies)) + (home-page ,(string-append "https://package.elm-lang.org/packages/" + name "/" version)) + (synopsis ,(assoc-ref info "summary")) + (description + ;; Try to use the first paragraph of README.md (which Elm requires), + ;; or fall back to summary otherwise. + ,(beautify-description + (match (chunk-lines (call-with-input-file + (string-append checkout "/README.md") + read-lines)) + ((_ par . _) + (string-join par " ")) + (_ + (assoc-ref info "summary"))))) + (license ,(spdx-string->license (assoc-ref info "license"))) + ;; so we know where the "/" goes + (properties '((upstream-name . ,name)))) + (append dependencies test-dependencies))) + +(define elm->guix-package + (memoize + (lambda* (package-name #:key repo version) + "Fetch the metadata for PACKAGE-NAME, an Elm package registered at +package.elm.org, and return two values: the `package' s-expression +corresponding to that package (or #f on failure) and a list of Elm +dependencies.." + (cond + ((vhash-assoc package-name (elm-package-registry)) + => (match-lambda + ((_found latest . _versions) + (make-elm-package-sexp package-name (or version latest))))) + (else + (values #f '())))))) + +(define* (elm-recursive-import package-name #:optional version) + (recursive-import package-name + #:version version + #:repo->guix-package elm->guix-package + #:guix-name elm->package-name)) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 40fa6759ae..fa79f3211e 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -5,6 +5,7 @@ ;;; Copyright © 2019 Ricardo Wurmus ;;; Copyright © 2021 Simon Tournier ;;; Copyright © 2021 Xinglu Chen +;;; Copyright © 2022 Philip McGrath ;;; ;;; This file is part of GNU Guix. ;;; @@ -80,7 +81,7 @@ (define %standard-import-options '()) (define importers '("gnu" "pypi" "cpan" "hackage" "stackage" "egg" "elpa" "gem" "go" "cran" "crate" "texlive" "json" "opam" - "minetest")) + "minetest" "elm")) (define (resolve-importer name) (let ((module (resolve-interface diff --git a/guix/scripts/import/elm.scm b/guix/scripts/import/elm.scm new file mode 100644 index 0000000000..68dcbf1070 --- /dev/null +++ b/guix/scripts/import/elm.scm @@ -0,0 +1,107 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Philip McGrath +;;; +;;; 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 . + +(define-module (guix scripts import elm) + #:use-module (guix ui) + #:use-module (guix utils) + #:use-module (guix scripts) + #:use-module (guix import elm) + #:use-module (guix scripts import) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-37) + #:use-module (srfi srfi-71) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (guix-import-elm)) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + '()) + +(define (show-help) + (display (G_ "Usage: guix import elm PACKAGE-NAME + +Import and convert the Elm package PACKAGE-NAME. Optionally, a version +can be specified after the arobas (@) character.\n")) + (display (G_ " + -h, --help display this help and exit")) + (display (G_ " + -r, --recursive import packages recursively")) + (display (G_ " + -V, --version display version information and exit")) + (newline) + (show-bug-report-information)) + +(define %options + ;; Specification of the command-line options. + (cons* (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version-and-exit "guix import elm"))) + (option '(#\r "recursive") #f #f + (lambda (opt name arg result) + (alist-cons 'recursive #t result))) + %standard-import-options)) + + +;;; +;;; Entry point. +;;; + +(define (guix-import-elm . args) + (define (parse-options) + ;; Return the alist of option values. + (parse-command-line args %options (list %default-options) + #:build-options? #f)) + + (let* ((opts (parse-options)) + (args (filter-map (match-lambda + (('argument . value) + value) + (_ #f)) + (reverse opts)))) + (match args + ((spec) + (with-error-handling + (let ((name version (package-name->name+version spec))) + (if (assoc-ref opts 'recursive) + ;; Recursive import + (map (match-lambda + ((and ('package ('name name) . rest) pkg) + `(define-public ,(string->symbol name) + ,pkg)) + (_ #f)) + (elm-recursive-import name version)) + ;; Single import + (let ((sexp (elm->guix-package name #:version version))) + (unless sexp + (leave (G_ "failed to download meta-data for package '~a'~%") + name)) + sexp))))) + (() + (leave (G_ "too few arguments~%"))) + ((many ...) + (leave (G_ "too many arguments~%"))))))