[bug#29951] [PATCH] WIP guix: Add wrap-script.

[bug#29951] [PATCH] WIP guix: Add wrap-script.

[Ricardo Wurmus]

* guix/build/utils.scm (wrap-script): New procedure.
---
 guix/build/utils.scm | 101 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 101 insertions(+)

diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 7391307c8..a2efcb31c 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -84,6 +85,7 @@
             fold-port-matches
             remove-store-references
             wrap-program
+            wrap-script
             invoke
 
             locale-category->string))
@@ -1068,6 +1070,105 @@ with definitions for VARS."
         (chmod prog-tmp #o755)
         (rename-file prog-tmp prog))))
 
+(define wrap-script
+  (let ((interpreter-regex
+         (make-regexp
+          (string-append "^#! ?(/bin/sh|/gnu/store/[^/]+/bin/("
+                         (string-join '("python[^ ]*"
+                                        "Rscript"
+                                        "perl"
+                                        "ruby"
+                                        "bash"
+                                        "sh") "|")
+                         ") ?.*)")))
+        (coding-line-regex
+         (make-regexp
+          ".*#.*coding[=:][[:space:]]*([-[a-zA-Z_0-9].]+)")))
+    (lambda* (prog #: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 coding-line)
+                    (call-with-ascii-input-file prog
+                      (lambda (p)
+                        (values (false-if-exception
+                                 (and=> (regexp-exec interpreter-regex (read-line p))
+                                        (lambda (m) (match:substring m 1))))
+                                (false-if-exception
+                                 (and=> (regexp-exec coding-line-regex (read-line p))
+                                        (lambda (m) (match:substring m 0)))))))))
+        (when interpreter
+          (let* ((header (format #f "\
+#!~a --no-auto-compile
+#!#; ~a
+#\\-~s
+#\\-~s
+"
+                                 (which "guile")
+                                 (or coding-line "Guix wrapper")
+                                 (cons 'begin (map update-env vars))
+                                 `(apply execl ,interpreter
+                                         (car (command-line))
+                                         (command-line))))
+                 (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))
+                #f))))))))
+
 \f
 ;;;
 ;;; Locales.
-- 
2.15.0

[bug#29951] [PATCH] WIP guix: Add wrap-script.

[Hartmut Goebel]

This code is over-changeling my scheme knowledge :-) Thus just a few
comments:


> +                                (false-if-exception
> +                                 (and=> (regexp-exec coding-line-regex (read-line p))
> +                                        (lambda (m) (match:substring m 0)))))))))

When using emacs, this line can also contain other local variable
definitions. What about keeping the whole line?

> +        (when interpreter
> +          (let* ((header (format #f "\
> +#!~a --no-auto-compile
> +#!#; ~a
> +#\\-~s
> +#\\-~s
> +"
> +                                 (which "guile")
> +                                 (or coding-line "Guix wrapper")
> +                                 (cons 'begin (map update-env vars))
> +                                 `(apply execl ,interpreter
> +                                         (car (command-line))
> +                                         (command-line))))

Does this take care of proper quoting the string-values?

> +                (call-with-ascii-input-file prog

Does this work if the file contains non-ascii characters, e.g. \xf0
(assuming "ascii" means 0-127 only)?


-- 
Regards
Hartmut Goebel

| Hartmut Goebel          | h.goebel@crazy-compilers.com               |
| www.crazy-compilers.com | compilers which you thought are impossible |

[bug#29951] [PATCH] WIP guix: Add wrap-script.

[Ricardo Wurmus]

Hi Hartmut,

>> +                                (false-if-exception
>> +                                 (and=> (regexp-exec coding-line-regex (read-line p))
>> +                                        (lambda (m) (match:substring m 0)))))))))
>
> When using emacs, this line can also contain other local variable
> definitions. What about keeping the whole line?

The purpose here was just to retain the coding comment, because it is
interpreted by Python itself to set the file encoding.  Other values are
not used by Python to make any such decisions.

Since these modified files are only generated in a build phase to modify
the *execution* environment (and the unchanged files are available via
“guix build -S”), I think that it is reasonable to assume that users
won’t be interested in editing these files directly, so hints to the
editor don’t need to be preserved.

I find it a little cleaner to keep this coding-line preservation as
restricted as possible, but maybe you are right and it would be safer to
just copy the whole line when the coding regex matches.

>> +        (when interpreter
>> +          (let* ((header (format #f "\
>> +#!~a --no-auto-compile
>> +#!#; ~a
>> +#\\-~s
>> +#\\-~s
>> +"
>> +                                 (which "guile")
>> +                                 (or coding-line "Guix wrapper")
>> +                                 (cons 'begin (map update-env vars))
>> +                                 `(apply execl ,interpreter
>> +                                         (car (command-line))
>> +                                         (command-line))))
>
> Does this take care of proper quoting the string-values?

What string values do you refer to?  We first generate an S-expression
(where we don’t need to take care of escaping things anyway) and then
format it as a string (with “format” and the “~s” format string), and
then we print that S-expression-as-a-string into a file.

I ran this on an actual Python file in the store.  This is the original
file, which I copied to “/tmp/test-python”:

--8<---------------cut here---------------start------------->8---
#!/gnu/store/iyy9w0hcxv4dg9q92d4g023vvz50r5bq-python-3.5.3/bin/python3.5
import sys
from lib2to3.main import main

sys.exit(main("lib2to3.fixes"))
--8<---------------cut here---------------end--------------->8---

This is the code in the REPL:

--8<---------------cut here---------------start------------->8---
,use (guix build utils)
scheme@(guile-user)> (wrap-script "/tmp/test-python"
                                  '("PYTHONPATH" ":" prefix ("/foo/bar:whatever"))
                                  '("FOOBAR" ":" suffix ("/to/me")))
scheme@(guile-user)>
--8<---------------cut here---------------end--------------->8---

This is the result in “/tmp/test-python”:

--8<---------------cut here---------------start------------->8---
#!/home/rekado/.guix-profile/bin/guile --no-auto-compile
#!#; Guix wrapper
#\-(begin (let ((current (getenv "PYTHONPATH"))) (setenv "PYTHONPATH" (if current (string-append "/foo/bar:whatever" ":" current) "/foo/bar:whatever"))) (let ((current (getenv "FOOBAR"))) (setenv "FOOBAR" (if current (string-append current ":" "/to/me") "/to/me"))))
#\-(apply execl "/gnu/store/iyy9w0hcxv4dg9q92d4g023vvz50r5bq-python-3.5.3/bin/python3.5" (car (command-line)) (command-line))
#!/gnu/store/iyy9w0hcxv4dg9q92d4g023vvz50r5bq-python-3.5.3/bin/python3.5
import sys
from lib2to3.main import main

sys.exit(main("lib2to3.fixes"))
--8<---------------cut here---------------end--------------->8---

>
>> +                (call-with-ascii-input-file prog
>
> Does this work if the file contains non-ascii characters, e.g. \xf0
> (assuming "ascii" means 0-127 only)?

“call-with-ascii-input-file” opens the file as a binary, so it reads the
file as a series of bytes.  This seems fine when reading only the
shebang (which is ASCII only) and when trying to match the coding regex
on the second line.

--
Ricardo

GPG: BCA6 89B6 3655 3801 C3C6  2150 197A 5888 235F ACAC
https://elephly.net

[bug#29951] [PATCH] WIP guix: Add wrap-script.

[Hartmut Goebel]

[-- Attachment #1: Type: text/plain, Size: 852 bytes --]

Am 05.01.2018 um 09:19 schrieb Ricardo Wurmus:

Thanks for your reply.

>> Does this take care of proper quoting the string-values?
> What string values do you refer to?  We first generate an S-expression
> (where we don’t need to take care of escaping things anyway) and then
> format it as a string (with “format” and the “~s” format string), and
> then we print that S-expression-as-a-string into a file.

I mean the values of the environment variables to be set, whcih might
contain double-quotes or backslashes.

But I understand that these values are calculated within guile anyway
and ~s takes care of proper quoting. So this is fine. Thanks for
elaborating.

-- 
Regards
Hartmut Goebel

| Hartmut Goebel          | h.goebel@crazy-compilers.com               |
| www.crazy-compilers.com | compilers which you thought are impossible |


[-- Attachment #2: Type: text/html, Size: 1550 bytes --]

[bug#29951] [PATCH] WIP guix: Add wrap-script.

[Chris Marusich]

[-- Attachment #1: Type: text/plain, Size: 1157 bytes --]

Ricardo Wurmus <rekado@elephly.net> writes:

> This is the result in “/tmp/test-python”:
>
> #!/home/rekado/.guix-profile/bin/guile --no-auto-compile
> #!#; Guix wrapper
> #\-(begin (let ((current (getenv "PYTHONPATH"))) (setenv "PYTHONPATH" (if current (string-append "/foo/bar:whatever" ":" current) "/foo/bar:whatever"))) (let ((current (getenv "FOOBAR"))) (setenv "FOOBAR" (if current (string-append current ":" "/to/me") "/to/me"))))
> #\-(apply execl "/gnu/store/iyy9w0hcxv4dg9q92d4g023vvz50r5bq-python-3.5.3/bin/python3.5" (car (command-line)) (command-line))
> #!/gnu/store/iyy9w0hcxv4dg9q92d4g023vvz50r5bq-python-3.5.3/bin/python3.5
> import sys
> from lib2to3.main import main
>
> sys.exit(main("lib2to3.fixes"))

I understand that the part beginning with #! and ending with !# are a
block comment in scheme, so they will be ignored by Guile, and that
"Guix wrapper" shows up after a ;, so it will also be considered a
comment by Guile, but I don't understand why the lines following that
need to begin with #\-.  I also don't understand why Guile doesn't
complain about it.  Why do the lines begin with #\-?

-- 
Chris

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#29951] [PATCH] WIP guix: Add wrap-script.

[Ricardo Wurmus]

Hi Chris,

> Ricardo Wurmus <rekado@elephly.net> writes:
>
>> This is the result in “/tmp/test-python”:
>>
>> #!/home/rekado/.guix-profile/bin/guile --no-auto-compile
>> #!#; Guix wrapper
>> #\-(begin (let ((current (getenv "PYTHONPATH"))) (setenv "PYTHONPATH" (if current (string-append "/foo/bar:whatever" ":" current) "/foo/bar:whatever"))) (let ((current (getenv "FOOBAR"))) (setenv "FOOBAR" (if current (string-append current ":" "/to/me") "/to/me"))))
>> #\-(apply execl "/gnu/store/iyy9w0hcxv4dg9q92d4g023vvz50r5bq-python-3.5.3/bin/python3.5" (car (command-line)) (command-line))
>> #!/gnu/store/iyy9w0hcxv4dg9q92d4g023vvz50r5bq-python-3.5.3/bin/python3.5
>> import sys
>> from lib2to3.main import main
>>
>> sys.exit(main("lib2to3.fixes"))
>
> I understand that the part beginning with #! and ending with !# are a
> block comment in scheme, so they will be ignored by Guile, and that
> "Guix wrapper" shows up after a ;, so it will also be considered a
> comment by Guile, but I don't understand why the lines following that
> need to begin with #\-.  I also don't understand why Guile doesn't
> complain about it.  Why do the lines begin with #\-?

#\- is Guile syntax for the character “-”.  To ensure that the target
language ignores these lines they must start with “#”.  In Guile,
however, we cannot just use “#” on its own.  The “#” in Guile is the
start of a reader macro.  We don’t really want a reader macro at the
beginning of each line, though – we just want to move on and get to the
expression.

So we use “#\-”, which evaluates to the character “-”.  It is valid in
Scheme to write code that evaluates to something and then ignore that
value.  Here’s an example:

   10
   23
   #\a
   #\b
   5
   (display "hello")

Guile would evaluate the numbers and characters one after the other, and
none of them would have any effect on the final expression that displays
“hello”.

In the wrapper we do the same kind of thing.  This line:

#\-(begin (let …) …)

is really just two Scheme values: a single arbitrary character and the
S-expression that we care about.  We only care about the side-effects of
evaluating the S-expression.

A language that uses “#” to mark comments, on the other hand, would
simply ignore the whole line.  The result is that we can use Guile to
set environment variables and then hand over execution to the target
language interpreter, which would run in the new environment.

The advantage of this approach is: we don’t have to rename wrapped
scripts any more (“.foo-real”), which makes for prettier usage messages
(“Usage: foo -v” instead of “Usage: .foo-real -v”) and avoids problems
when an application checks its own name to determine what actions it
should take.

--
Ricardo

[bug#29951] [PATCH] WIP guix: Add wrap-script.

[Chris Marusich]

[-- Attachment #1: Type: text/plain, Size: 798 bytes --]

Hi Ricardo,

Thank you for taking the time to explain it!

Ricardo Wurmus <rekado@elephly.net> writes:

> [...]  This line:
>
> #\-(begin (let …) …)
>
> is really just two Scheme values: a single arbitrary character and the
> S-expression that we care about.  We only care about the side-effects of
> evaluating the S-expression.

I understand now.  We're reading the hyphen symbol, and not doing
anything with it.  Got it!

> The advantage of this approach is: we don’t have to rename wrapped
> scripts any more (“.foo-real”), which makes for prettier usage messages
> (“Usage: foo -v” instead of “Usage: .foo-real -v”) and avoids problems
> when an application checks its own name to determine what actions it
> should take.

Sounds great!

-- 
Chris

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]

[bug#29951] [PATCH] WIP guix: Add wrap-script.

[Ludovic Courtès]

Hi!

Ricardo Wurmus <rekado@elephly.net> skribis:

> * guix/build/utils.scm (wrap-script): New procedure.

[...]

> +(define wrap-script
> +  (let ((interpreter-regex
> +         (make-regexp
> +          (string-append "^#! ?(/bin/sh|/gnu/store/[^/]+/bin/("
> +                         (string-join '("python[^ ]*"
> +                                        "Rscript"
> +                                        "perl"
> +                                        "ruby"
> +                                        "bash"
> +                                        "sh") "|")
> +                         ") ?.*)")))
> +        (coding-line-regex
> +         (make-regexp
> +          ".*#.*coding[=:][[:space:]]*([-[a-zA-Z_0-9].]+)")))
> +    (lambda* (prog #: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."

Nice!

> +      (let-values (((interpreter coding-line)
> +                    (call-with-ascii-input-file prog
> +                      (lambda (p)
> +                        (values (false-if-exception
> +                                 (and=> (regexp-exec interpreter-regex (read-line p))
> +                                        (lambda (m) (match:substring m 1))))
> +                                (false-if-exception
> +                                 (and=> (regexp-exec coding-line-regex (read-line p))
> +                                        (lambda (m) (match:substring m 0)))))))))

‘false-if-exception’ is problematic because it can hide errors.  Could
you narrow that down to the exception type of interest?  Or is there a
risk of random decoding errors and the likes when passed a binary file?

> +        (when interpreter

Should it return #t on success and #f on failure?  Or just thrown an
exception on failure?

> +                                 (which "guile")

Let’s add #:guile defaulting to (which "guile").

I wonder if ‘wrap-program’ could automatically call ‘wrap-script’ when
appropriate so that users don’t have to choose by themselves.  WDYT?

Thanks!

Ludo’.

[bug#29951] [PATCH] WIP guix: Add wrap-script.

[Jelle Licht]

[-- Attachment #1: Type: text/plain, Size: 1339 bytes --]

2018-01-02 21:44 GMT+01:00 Ricardo Wurmus <rekado@elephly.net>:

> * guix/build/utils.scm (wrap-script): New procedure.
> ---
>  guix/build/utils.scm | 101 ++++++++++++++++++++++++++++++
> +++++++++++++++++++++
>  1 file changed, 101 insertions(+)
>
> diff --git a/guix/build/utils.scm b/guix/build/utils.scm
> index 7391307c8..a2efcb31c 100644
> --- a/guix/build/utils.scm
> +++ b/guix/build/utils.scm
> @@ -3,6 +3,7 @@
>  ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
>  ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
>  ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
> +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
>  ;;;
>  ;;; This file is part of GNU Guix.
>  ;;;
> @@ -84,6 +85,7 @@
>              fold-port-matches
>              remove-store-references
>              wrap-program
> +            wrap-script
>              invoke
>
>              locale-category->string))
> @@ -1068,6 +1070,105 @@ with definitions for VARS."
>          (chmod prog-tmp #o755)
>

[...]

>      (rename-file prog-tmp prog))))
>
> +(define wrap-script
> +  (let ((interpreter-regex
> +         (make-regexp
> +          (string-append "^#! ?(/bin/sh|/gnu/store/[^/]+/bin/("
>

Won't this be an issue for people using a customized store location?

[snipped]
>

[-- Attachment #2: Type: text/html, Size: 2292 bytes --]

[bug#29951] [PATCH] WIP guix: Add wrap-script.

[Ricardo Wurmus]

Jelle Licht <jlicht@fsfe.org> writes:

> 2018-01-02 21:44 GMT+01:00 Ricardo Wurmus <rekado@elephly.net>:
>
>> * guix/build/utils.scm (wrap-script): New procedure.
>> ---
[…]
>>
>> +(define wrap-script
>> +  (let ((interpreter-regex
>> +         (make-regexp
>> +          (string-append "^#! ?(/bin/sh|/gnu/store/[^/]+/bin/("
>>
>
> Won't this be an issue for people using a customized store location?

Yes.  I suppose we could change this to use the actual store prefix.

--
Ricardo

[bug#29951] [PATCH] WIP guix: Add wrap-script.

[Nils Gillmann]

Jelle Licht transcribed 4.1K bytes:
> 2018-01-02 21:44 GMT+01:00 Ricardo Wurmus <rekado@elephly.net>:
> 
> > * guix/build/utils.scm (wrap-script): New procedure.
> > ---
> >  guix/build/utils.scm | 101 ++++++++++++++++++++++++++++++
> > +++++++++++++++++++++
> >  1 file changed, 101 insertions(+)
> >
> > diff --git a/guix/build/utils.scm b/guix/build/utils.scm
> > index 7391307c8..a2efcb31c 100644
> > --- a/guix/build/utils.scm
> > +++ b/guix/build/utils.scm
> > @@ -3,6 +3,7 @@
> >  ;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
> >  ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
> >  ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
> > +;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
> >  ;;;
> >  ;;; This file is part of GNU Guix.
> >  ;;;
> > @@ -84,6 +85,7 @@
> >              fold-port-matches
> >              remove-store-references
> >              wrap-program
> > +            wrap-script
> >              invoke
> >
> >              locale-category->string))
> > @@ -1068,6 +1070,105 @@ with definitions for VARS."
> >          (chmod prog-tmp #o755)
> >
> 
> [...]
> 
> >      (rename-file prog-tmp prog))))
> >
> > +(define wrap-script
> > +  (let ((interpreter-regex
> > +         (make-regexp
> > +          (string-append "^#! ?(/bin/sh|/gnu/store/[^/]+/bin/("
> >
> 
> Won't this be an issue for people using a customized store location?

Can't we make this substitutable at configure time?

> [snipped]
> >

[bug#29951] [PATCH]: guix: Add wrap-script.

[Ricardo Wurmus]

[-- Attachment #1: Type: text/plain, Size: 478 bytes --]

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!

-- 
Ricardo



[-- Attachment #2: 0001-guix-Add-wrap-script.patch --]
[-- Type: text/x-patch, Size: 12100 bytes --]

From 8b0a19b35b6cad2347b68893bf751caec87b9df6 Mon Sep 17 00:00:00 2001
From: Ricardo Wurmus <rekado@elephly.net>
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 <nikita@karetnikov.org>
 ;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; 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)))))))))
+
 \f
 ;;;
 ;;; 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 <ludo@gnu.org>
+;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
 ;;;
 ;;; 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

bug#29951: [PATCH]: guix: Add wrap-script.

[Ricardo Wurmus]

Ricardo Wurmus <rekado@elephly.net> writes:

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

I have pushed this to core-updates with commit
0fb9a8df429a7b9f40610ff15baaff0d8e31e8cf

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

It still doesn’t do this.  To use it you have to opt in and use
“wrap-script” instead of “wrap-program”.

Comments are still welcome!

--
Ricardo