4 files changed, 72 insertions, 7 deletions

diff --git a/doc/guix.texi b/doc/guix.texi
index b2ff12dcb11..50eddc426e3 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -6591,6 +6591,21 @@ directory within the container.  If this is undesirable,
 be automatically shared and will change to the user's home directory
 within the container instead.  See also @option{--user}.
 
+@item --cwd=@var{directory}
+For containers, change to @var{directory} inside the container instead
+of the default location.  The default location is the current working
+directory when @option{--no-cwd} is not used, or the user's home
+directory when @option{--no-cwd} is used.  When @var{directory} is a
+relative file name, it is interpreted relative to the current working
+directory on the host.  Note that @option{--cwd} does not automatically
+share @var{directory}---you must ensure it is accessible via the default
+current directory sharing or explicit @option{--share}/@option{--expose}
+options.  For example:
+
+@example
+guix shell --container --cwd=/tmp --share=/tmp coreutils
+@end example
+
 @item --writable-root
 When using @option{--container}, this option makes the root file system
 writable (it is read-only by default).
@@ -7092,6 +7107,17 @@ directory within the container.  If this is undesirable,
 be automatically shared and will change to the user's home directory
 within the container instead.  See also @option{--user}.
 
+@item --cwd=@var{directory}
+For containers, change to @var{directory} inside the container instead
+of the default location.  The default location is the current working
+directory when @option{--no-cwd} is not used, or the user's home
+directory when @option{--no-cwd} is used.  When @var{directory} is a
+relative file name, it is interpreted relative to the current working
+directory on the host.  Note that @option{--cwd} does not automatically
+share @var{directory}---you must ensure it is accessible via the default
+current directory sharing or explicit @option{--share}/@option{--expose}
+options.
+
 @item --expose=@var{source}[=@var{target}]
 @itemx --share=@var{source}[=@var{target}]
 For containers, @option{--expose} (resp. @option{--share}) exposes the
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 86c8e31def9..8e5d76bce7d 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -123,6 +123,10 @@ shell'."
       --no-cwd           do not share current working directory with an
                          isolated container"))
   (display (G_ "
+      --cwd=DIR          change to DIRECTORY inside the container (default is
+                         current working directory--or $HOME if --no-cwd is
+                         used)"))
+  (display (G_ "
       --writable-root    make the container's root file system writable"))
 
   (display (G_ "
@@ -265,6 +269,9 @@ use '--preserve' instead~%"))
          (option '("no-cwd") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'no-cwd? #t result)))
+         (option '("cwd") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'cwd arg result)))
          (option '("writable-root") #f #f
                  (lambda (opt name arg result)
                    (alist-cons 'writable-root? #t result)))
@@ -743,7 +750,7 @@ regexps in WHITE-LIST."
 
 (define* (launch-environment/container #:key command bash user user-mappings
                                        profile manifest link-profile? network?
-                                       map-cwd? emulate-fhs? nesting?
+                                       map-cwd? cwd emulate-fhs? nesting?
                                        writable-root?
                                        (setup-hook #f)
                                        (symlinks '()) (white-list '()))
@@ -825,7 +832,7 @@ WHILE-LIST."
                                 (inputs->requisites
                                  (list (direct-store-path bash) profile)))))
     (return
-     (let* ((cwd      (getcwd))
+     (let* ((host-cwd (getcwd))                    ;actual current working directory
             (home     (getenv "HOME"))
             (uid      (if user 1000 (getuid)))
             (gid      (if user
@@ -857,6 +864,13 @@ WHILE-LIST."
                                          (name "overflow"))))
             (home-dir (password-entry-directory passwd))
             (logname  (password-entry-name passwd))
+            (container-cwd
+             (and cwd
+                  (override-user-dir
+                   user home
+                   (if (string-prefix? "/" cwd)
+                       cwd
+                       (string-append host-cwd "/" cwd)))))
             (environ  (filter (match-lambda
                                 ((variable . value)
                                  (find (cut regexp-exec <> variable)
@@ -873,8 +887,8 @@ WHILE-LIST."
                 ;; Share current working directory, unless asked not to.
                 (if map-cwd?
                     (list (file-system-mapping
-                           (source cwd)
-                           (target cwd)
+                           (source host-cwd)
+                           (target host-cwd)
                            (writable? #t)))
                     '())
                 ;; Add the user mappings *after* the current working directory
@@ -942,9 +956,10 @@ WHILE-LIST."
 
             ;; For convenience, start in the user's current working
             ;; directory or, if unmapped, the home directory.
-            (chdir (if map-cwd?
-                       (override-user-dir user home cwd)
-                       home-dir))
+            (chdir (or container-cwd    ; explicit --cwd takes precedence
+                       (and map-cwd?    ; otherwise, use current dir unless --no-cwd
+                            (override-user-dir user home host-cwd))
+                       home-dir))       ; fallback to home
 
             ;; Set environment variables that match WHITE-LIST.
             (for-each (match-lambda
@@ -1187,6 +1202,8 @@ command-line option processing with 'parse-command-line'."
         (leave (G_ "'--link-profile' cannot be used without '--container'~%")))
       (when user
         (leave (G_ "'--user' cannot be used without '--container'~%")))
+      (when (assoc-ref opts 'cwd)
+        (leave (G_ "'--cwd' cannot be used without '--container'~%")))
       (when no-cwd?
         (leave (G_ "--no-cwd cannot be used without '--container'~%")))
       (when writable-root?
@@ -1278,6 +1295,7 @@ when using '--container'; doing nothing~%"))
                                                   #:link-profile? link-prof?
                                                   #:network? network?
                                                   #:map-cwd? (not no-cwd?)
+                                                  #:cwd (assoc-ref opts 'cwd)
                                                   #:writable-root? writable-root?
                                                   #:emulate-fhs? emulate-fhs?
                                                   #:nesting? nesting?
diff --git a/tests/guix-environment-container.sh b/tests/guix-environment-container.sh
index 5b89f8383b6..8947a4ea1ba 100644
--- a/tests/guix-environment-container.sh
+++ b/tests/guix-environment-container.sh
@@ -186,6 +186,24 @@ HOME="$tmpdir" guix environment --bootstrap --container --user=foognu \
             -- /bin/sh -c 'test $(pwd) == "/home/foo" -a ! -d '"$tmpdir"
 )
 
+# '--cwd' is independent from sharing the host current working directory.
+(
+  cd "$tmpdir" \
+    && guix environment --bootstrap --container --no-cwd --cwd=/tmp \
+            --ad-hoc guile-bootstrap --pure \
+            -- /bin/sh -c 'test $(pwd) == "/tmp" -a ! -d '"$tmpdir"
+)
+
+# Relative '--cwd' is resolved against the host CWD and still honors '--user'.
+mkdir -p "$tmpdir/home/wd"
+home_dir="$(cd "$tmpdir/home"; pwd -P)"
+(
+  cd "$tmpdir/home/wd" \
+    && HOME="$home_dir" guix environment --bootstrap --container --user=foo \
+            --cwd=. --ad-hoc guile-bootstrap --pure \
+            -- /bin/sh -c 'test "$(pwd)" = "/home/foo/wd"'
+)
+
 # Check that the root file system is read-only by default...
 guix environment --bootstrap --container --ad-hoc guile-bootstrap \
      -- guile -c '(mkdir "/whatever")' && false
diff --git a/tests/guix-shell.sh b/tests/guix-shell.sh
index b2f820bf26d..4eb4a3196cd 100644
--- a/tests/guix-shell.sh
+++ b/tests/guix-shell.sh
@@ -35,6 +35,9 @@ guix shell --bootstrap --pure guile-bootstrap -- guile --version
 # '--symlink' can only be used with --container.
 guix shell --bootstrap guile-bootstrap -S /dummy=bin/guile && false
 
+# '--cwd' can only be used with --container.
+guix shell --cwd=/tmp -n hello && false
+
 # '--ad-hoc' is a thing of the past.
 guix shell --ad-hoc guile-bootstrap && false