From patchwork Wed Feb 6 23:10:49 2019 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Ricardo Wurmus X-Patchwork-Id: 968 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 4200C16BCA; Wed, 6 Feb 2019 23:12:10 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.0 (2014-02-07) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00,T_DKIM_INVALID, URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.0 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTP id 6D35416BC8 for ; Wed, 6 Feb 2019 23:12:09 +0000 (GMT) Received: from localhost ([127.0.0.1]:59778 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1grWMS-0002SO-Kw for patchwork@mira.cbaines.net; Wed, 06 Feb 2019 18:12:08 -0500 Received: from eggs.gnu.org ([209.51.188.92]:47534) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1grWMN-0002Pq-SQ for guix-patches@gnu.org; Wed, 06 Feb 2019 18:12:05 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1grWMM-0006YI-Fi for guix-patches@gnu.org; Wed, 06 Feb 2019 18:12:03 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:37069) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1grWMM-0006Y2-9I for guix-patches@gnu.org; Wed, 06 Feb 2019 18:12:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1grWMM-00033S-0o for guix-patches@gnu.org; Wed, 06 Feb 2019 18:12:02 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#29951] [PATCH]: guix: Add wrap-script. References: <20180102204434.2716-1-rekado@elephly.net> In-Reply-To: <20180102204434.2716-1-rekado@elephly.net> Resent-From: Ricardo Wurmus Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Wed, 06 Feb 2019 23:12:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 29951 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 29951@debbugs.gnu.org Received: via spool by 29951-submit@debbugs.gnu.org id=B29951.154949468511689 (code B ref 29951); Wed, 06 Feb 2019 23:12:01 +0000 Received: (at 29951) by debbugs.gnu.org; 6 Feb 2019 23:11:25 +0000 Received: from localhost ([127.0.0.1]:36350 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1grWLi-00032R-Te for submit@debbugs.gnu.org; Wed, 06 Feb 2019 18:11:25 -0500 Received: from sender-of-o51.zoho.com ([135.84.80.216]:21043) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1grWLd-00032C-PQ for 29951@debbugs.gnu.org; Wed, 06 Feb 2019 18:11:19 -0500 ARC-Seal: i=1; a=rsa-sha256; t=1549494654; cv=none; d=zoho.com; s=zohoarc; b=eaCFTGTX3vPlIqBf3DKcI2vMJVwfi0o01iH9MLndJkZy/m6k1knrTEyCGEMcFPFRxLJ2WJu0wTOh89zOfnvyKGxukTnAAGaAs+c6EAnlIUlZi6QAG0M6DFKl6YAS1U6yEGKY9LPKvh/1MhCOSDBDq+/71lAeviTgLt6y1B7jUbQ= ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=zoho.com; s=zohoarc; t=1549494654; h=Content-Type:Date:From:MIME-Version:Message-ID:Subject:To:ARC-Authentication-Results; bh=3oz41+O7doxXU/cyYD3bjdHjmMhPLPXdk8T994AZ2IY=; b=nhWVKqPwmIz9+pLppjUwBFArObAevNEyeDg1qaa3S5Lx1Rx+1x1Ryd/YeG44yfnFVd/nOlXTqxAgu02K5PVPgBnti/h2gMnWNiZH0EcwC0Pdn09htQxecImMH0KLZ3/LZ6f3coPIYAzHQ1zGD9oOly7AfzqWe0ndg3rKmzSHaQg= ARC-Authentication-Results: i=1; mx.zoho.com; dkim=pass header.i=elephly.net; spf=pass smtp.mailfrom=rekado@elephly.net; dmarc=pass header.from= header.from= DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; t=1549494654; s=zoho; d=elephly.net; i=rekado@elephly.net; h=From:To:Subject:Date:Message-ID:MIME-Version:Content-Type; l=9354; bh=3oz41+O7doxXU/cyYD3bjdHjmMhPLPXdk8T994AZ2IY=; b=X1OMoOKQApTmoXdlIUyugY5Mf/qpvSAOc0XSL7yRQICSdAcvJbxz7s7pfpl7T91V E9agvKRAQLDZ//JVYvO1BUdDYAzdjFB47z8QODd44XQHf6u6AnBd3X4RbkIJjUE/vm5 ep29v5IkV7aHSNNMBAI/BAMkxhNyk9NRp2Iqyk28= Received: from localhost (p3E9E9403.dip0.t-ipconnect.de [62.158.148.3]) by mx.zohomail.com with SMTPS id 1549494653285686.1107214484396; Wed, 6 Feb 2019 15:10:53 -0800 (PST) User-agent: mu4e 1.0; emacs 26.1 From: Ricardo Wurmus X-URL: https://elephly.net X-PGP-Key: https://elephly.net/rekado.pubkey X-PGP-Fingerprint: BCA6 89B6 3655 3801 C3C6 2150 197A 5888 235F ACAC Date: Thu, 07 Feb 2019 00:10:49 +0100 Message-ID: <87d0o4fr7q.fsf@elephly.net> MIME-Version: 1.0 X-ZohoMailClient: External X-Zoho-Virus-Status: 1 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-detected-operating-system: by eggs.gnu.org: GNU/Linux 2.2.x-3.x [generic] X-Received-From: 209.51.188.43 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 Here’s a new version which raises a condition on errors, handles all shebangs (including those with arguments or with custom store prefix), and which allows the value for “guile” to be overridden. It comes with tests. It doesn’t apply automatically when “wrap-program” is used. It might be a good idea to call it automatically and fall back to “wrap-program” if the target is not a supported script. Comments are very welcome! From 8b0a19b35b6cad2347b68893bf751caec87b9df6 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Tue, 2 Jan 2018 21:43:07 +0100 Subject: [PATCH] guix: Add wrap-script. * guix/build/utils.scm (wrap-script): New procedure. (&wrap-error): New condition. (wrap-error?, wrap-error-program, wrap-error-type): New procedures. * tests/build-utils.scm ("wrap-script, simple case", "wrap-script, with encoding declaration", "wrap-script, raises condition"): New tests. --- guix/build/utils.scm | 125 ++++++++++++++++++++++++++++++++++++++++++ tests/build-utils.scm | 102 ++++++++++++++++++++++++++++++++++ 2 files changed, 227 insertions(+) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 55d34b67e..b7cd748d8 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2015, 2018 Mark H Weaver ;;; Copyright © 2018 Arun Isaac +;;; Copyright © 2018, 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -90,6 +91,11 @@ remove-store-references wrapper? wrap-program + wrap-script + + wrap-error? + wrap-error-program + wrap-error-type invoke invoke-error? @@ -1042,6 +1048,11 @@ known as `nuke-refs' in Nixpkgs." (put-u8 out (char->integer char)) result)))))) +(define-condition-type &wrap-error &error + wrap-error? + (program wrap-error-program) + (type wrap-error-type)) + (define (wrapper? prog) "Return #t if PROG is a wrapper as produced by 'wrap-program'." (and (file-exists? prog) @@ -1146,6 +1157,120 @@ with definitions for VARS." (chmod prog-tmp #o755) (rename-file prog-tmp prog)))) +(define wrap-script + (let ((interpreter-regex + (make-regexp + (string-append "^#! ?(/[^ ]+/bin/(" + (string-join '("python[^ ]*" + "Rscript" + "perl" + "ruby" + "bash" + "sh") "|") + "))( ?.*)"))) + (coding-line-regex + (make-regexp + ".*#.*coding[=:][[:space:]]*([-a-zA-Z_0-9.]+)"))) + (lambda* (prog #:key (guile (which "guile")) #:rest vars) + "Wrap the script PROG such that VARS are set first. The format of VARS +is the same as in the WRAP-PROGRAM procedure. This procedure differs from +WRAP-PROGRAM in that it does not create a separate shell script. Instead, +PROG is modified directly by prepending a Guile script, which is interpreted +as a comment in the script's language. + +Special encoding comments as supported by Python are recreated on the second +line. + +Note that this procedure can only be used once per file as Guile scripts are +not supported." + (define update-env + (match-lambda + ((var sep '= rest) + `(setenv ,var ,(string-join rest sep))) + ((var sep 'prefix rest) + `(let ((current (getenv ,var))) + (setenv ,var (if current + (string-append ,(string-join rest sep) + ,sep current) + ,(string-join rest sep))))) + ((var sep 'suffix rest) + `(let ((current (getenv ,var))) + (setenv ,var (if current + (string-append current ,sep + ,(string-join rest sep)) + ,(string-join rest sep))))) + ((var '= rest) + `(setenv ,var ,(string-join rest ":"))) + ((var 'prefix rest) + `(let ((current (getenv ,var))) + (setenv ,var (if current + (string-append ,(string-join rest ":") + ":" current) + ,(string-join rest ":"))))) + ((var 'suffix rest) + `(let ((current (getenv ,var))) + (setenv ,var (if current + (string-append current ":" + ,(string-join rest ":")) + ,(string-join rest ":"))))))) + (let-values (((interpreter args coding-line) + (call-with-ascii-input-file prog + (lambda (p) + (let ((first-match + (false-if-exception + (regexp-exec interpreter-regex (read-line p))))) + (values (and first-match (match:substring first-match 1)) + (and first-match (match:substring first-match 3)) + (false-if-exception + (and=> (regexp-exec coding-line-regex (read-line p)) + (lambda (m) (match:substring m 0)))))))))) + (if interpreter + (let* ((header (format #f "\ +#!~a --no-auto-compile +#!#; ~a +#\\-~s +#\\-~s +" + guile + (or coding-line "Guix wrapper") + (cons 'begin (map update-env + (match vars + ((#:guile _ . vars) vars) + (_ vars)))) + `(let ((cl (command-line))) + (apply execl ,interpreter + (car cl) + (cons (car cl) + (append + ',(string-split args #\space) + cl)))))) + (template (string-append prog ".XXXXXX")) + (out (mkstemp! template)) + (st (stat prog)) + (mode (stat:mode st))) + (with-throw-handler #t + (lambda () + (call-with-ascii-input-file prog + (lambda (p) + (format out header) + (dump-port p out) + (close out) + (chmod template mode) + (rename-file template prog) + (set-file-time prog st)))) + (lambda (key . args) + (format (current-error-port) + "wrap-script: ~a: error: ~a ~s~%" + prog key args) + (false-if-exception (delete-file template)) + (raise (condition + (&wrap-error (program prog) + (type key)))) + #f))) + (raise (condition + (&wrap-error (program prog) + (type 'no-interpreter-found))))))))) + ;;; ;;; Locales. diff --git a/tests/build-utils.scm b/tests/build-utils.scm index 7d49446f6..1c9084514 100644 --- a/tests/build-utils.scm +++ b/tests/build-utils.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2015, 2016 Ludovic Courtès +;;; Copyright © 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -122,4 +123,105 @@ (and (zero? (close-pipe pipe)) str)))))) +(let ((script-contents "\ +#!/anything/cabbage-bash-1.2.3/bin/sh + +echo hello world")) + + (test-equal "wrap-script, simple case" + (string-append + (format #f "\ +#!GUILE --no-auto-compile +#!#; Guix wrapper +#\\-~s +#\\-~s +" + '(begin (let ((current (getenv "GUIX_FOO"))) + (setenv "GUIX_FOO" + (if current + (string-append "/some/path:/some/other/path" + ":" current) + "/some/path:/some/other/path")))) + '(let ((cl (command-line))) + (apply execl "/anything/cabbage-bash-1.2.3/bin/sh" + (car cl) + (cons (car cl) + (append '("") cl))))) + script-contents) + (call-with-temporary-directory + (lambda (directory) + (let ((script-file-name (string-append directory "/foo"))) + (call-with-output-file script-file-name + (lambda (port) + (format port script-contents))) + (chmod script-file-name #o777) + + (mock ((guix build utils) which (const "GUILE")) + (wrap-script script-file-name + `("GUIX_FOO" prefix ("/some/path" + "/some/other/path")))) + (let ((str (call-with-input-file script-file-name get-string-all))) + (with-directory-excursion directory + (delete-file "foo")) + str)))))) + +(let ((script-contents "\ +#!/anything/cabbage-bash-1.2.3/bin/python3 -and -args +# vim:fileencoding=utf-8 +print('hello world')")) + + (test-equal "wrap-script, with encoding declaration" + (string-append + (format #f "\ +#!MYGUILE --no-auto-compile +#!#; # vim:fileencoding=utf-8 +#\\-~s +#\\-~s +" + '(begin (let ((current (getenv "GUIX_FOO"))) + (setenv "GUIX_FOO" + (if current + (string-append "/some/path:/some/other/path" + ":" current) + "/some/path:/some/other/path")))) + `(let ((cl (command-line))) + (apply execl "/anything/cabbage-bash-1.2.3/bin/python3" + (car cl) + (cons (car cl) + (append '("" "-and" "-args") cl))))) + script-contents) + (call-with-temporary-directory + (lambda (directory) + (let ((script-file-name (string-append directory "/foo"))) + (call-with-output-file script-file-name + (lambda (port) + (format port script-contents))) + (chmod script-file-name #o777) + + (wrap-script script-file-name + #:guile "MYGUILE" + `("GUIX_FOO" prefix ("/some/path" + "/some/other/path"))) + (let ((str (call-with-input-file script-file-name get-string-all))) + (with-directory-excursion directory + (delete-file "foo")) + str)))))) + +(test-assert "wrap-script, raises condition" + (call-with-temporary-directory + (lambda (directory) + (let ((script-file-name (string-append directory "/foo"))) + (call-with-output-file script-file-name + (lambda (port) + (format port "This is not a script"))) + (chmod script-file-name #o777) + (catch 'srfi-34 + (lambda () + (wrap-script script-file-name + #:guile "MYGUILE" + `("GUIX_FOO" prefix ("/some/path" + "/some/other/path")))) + (lambda (type obj) + (wrap-error? obj))))))) + (test-end) -- 2.20.1