summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-02-08 23:23:35 +0100
committerLudovic Courtès <ludo@gnu.org>2016-02-08 23:46:46 +0100
commitf2e4805b7e80e31cc23b22a9f082b74d0547fc5f (patch)
treedc5f33a21349769edf725adbce5f8d60194bed94
parent423eef362b71e400dd028d29b9706e35cdb171d4 (diff)
Add (guix build bournish) and use it in the initrd.
* guix/build/bournish.scm: New file. * Makefile.am (MODULES): Add it. * gnu/system/linux-initrd.scm (base-initrd): Add (guix build bournish) and use it.
-rw-r--r--Makefile.am1
-rw-r--r--gnu/system/linux-initrd.scm4
-rw-r--r--guix/build/bournish.scm172
3 files changed, 176 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am
index 9620e600d1..9beeb9d564 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -98,6 +98,7 @@ MODULES = \
guix/build/gremlin.scm \
guix/build/emacs-utils.scm \
guix/build/graft.scm \
+ guix/build/bournish.scm \
guix/search-paths.scm \
guix/packages.scm \
guix/import/utils.scm \
diff --git a/gnu/system/linux-initrd.scm b/gnu/system/linux-initrd.scm
index f6bd84f02e..8ca74104fb 100644
--- a/gnu/system/linux-initrd.scm
+++ b/gnu/system/linux-initrd.scm
@@ -227,6 +227,7 @@ loaded at boot time in the order in which they appear."
#~(begin
(use-modules (gnu build linux-boot)
(guix build utils)
+ (guix build bournish) ;add the 'bournish' meta-command
(srfi srfi-26))
(with-output-to-port (%make-void-port "w")
@@ -242,7 +243,8 @@ loaded at boot time in the order in which they appear."
#:qemu-guest-networking? #$qemu-networking?
#:volatile-root? '#$volatile-root?))
#:name "base-initrd"
- #:modules '((guix build utils)
+ #:modules '((guix build bournish)
+ (guix build utils)
(guix build syscalls)
(gnu build linux-boot)
(gnu build linux-modules)
diff --git a/guix/build/bournish.scm b/guix/build/bournish.scm
new file mode 100644
index 0000000000..4022796658
--- /dev/null
+++ b/guix/build/bournish.scm
@@ -0,0 +1,172 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build bournish)
+ #:use-module (system base language)
+ #:use-module (system base compile)
+ #:use-module (system repl command)
+ #:use-module (system repl common)
+ #:use-module (ice-9 rdelim)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 ftw)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:export (%bournish-language))
+
+;;; Commentary:
+;;;
+;;; This is a super minimal Bourne-like shell language for Guile. It is meant
+;;; to be used at the REPL as a rescue shell. In a way, this is to Guile what
+;;; eshell is to Emacs.
+;;;
+;;; Code:
+
+(define (expand-variable str)
+ "Return STR or code to obtain the value of the environment variable STR
+refers to."
+ ;; XXX: No support for "${VAR}".
+ (if (string-prefix? "$" str)
+ `(or (getenv ,(string-drop str 1)) "")
+ str))
+
+(define* (display-tabulated lst
+ #:key (columns 3)
+ (column-width (/ 78 columns)))
+ "Display the list of string LST in COLUMNS columns of COLUMN-WIDTH
+characters."
+ (define len (length lst))
+ (define pad
+ (if (zero? (modulo len columns))
+ 0
+ columns))
+ (define items-per-column
+ (quotient (+ len pad) columns))
+ (define items (list->vector lst))
+
+ (let loop ((indexes (unfold (cut >= <> columns)
+ (cut * <> items-per-column)
+ 1+
+ 0)))
+ (unless (>= (first indexes) items-per-column)
+ (for-each (lambda (index)
+ (let ((item (if (< index len)
+ (vector-ref items index)
+ "")))
+ (display (string-pad-right item column-width))))
+ indexes)
+ (newline)
+ (loop (map 1+ indexes)))))
+
+(define ls-command-implementation
+ ;; Run-time support procedure.
+ (case-lambda
+ (()
+ (display-tabulated (scandir ".")))
+ (files
+ (let ((files (filter (lambda (file)
+ (catch 'system-error
+ (lambda ()
+ (lstat file))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (format (current-error-port) "~a: ~a~%"
+ file (strerror errno))
+ #f))))
+ files)))
+ (display-tabulated files)))))
+
+(define (ls-command . files)
+ `((@@ (guix build bournish) ls-command-implementation) ,@files))
+
+(define (which-command program)
+ `(search-path ((@@ (guix build bournish) executable-path))
+ ,program))
+
+(define (cat-command file)
+ `(call-with-input-file ,file
+ (lambda (port)
+ ((@ (guix build utils) dump-port) port (current-output-port))
+ *unspecified*)))
+
+(define (help-command . _)
+ (display "\
+Hello, this is Bournish, a minimal Bourne-like shell in Guile!
+
+The shell is good enough to navigate the file system and run commands but not
+much beyond that. It is meant to be used as a rescue shell in the initial RAM
+disk and is probably not very useful apart from that. It has a few built-in
+commands such as 'ls' and 'cd'; it lacks globbing, pipes---everything.\n"))
+
+(define %not-colon (char-set-complement (char-set #\:)))
+(define (executable-path)
+ "Return the search path for programs as a list."
+ (match (getenv "PATH")
+ (#f '())
+ (str (string-tokenize str %not-colon))))
+
+(define %commands
+ ;; Built-in commands.
+ `(("echo" ,(lambda strings `(list ,@strings)))
+ ("cd" ,(lambda (dir) `(chdir ,dir)))
+ ("pwd" ,(lambda () `(getcwd)))
+ ("rm" ,(lambda (file) `(delete-file ,file)))
+ ("cp" ,(lambda (source dest) `(copy-file ,source ,dest)))
+ ("help" ,help-command)
+ ("ls" ,ls-command)
+ ("which" ,which-command)
+ ("cat" ,cat-command)))
+
+(define (read-bournish port env)
+ "Read a Bournish expression from PORT, and return the corresponding Scheme
+code as an sexp."
+ (match (string-tokenize (read-line port))
+ ((command args ...)
+ (match (assoc command %commands)
+ ((command proc) ;built-in command
+ (apply proc (map expand-variable args)))
+ (#f
+ (let ((command (if (string-prefix? "\\" command)
+ (string-drop command 1)
+ command)))
+ `(system* ,command ,@(map expand-variable args))))))))
+
+(define %bournish-language
+ (let ((scheme (lookup-language 'scheme)))
+ (make-language #:name 'bournish
+ #:title "Bournish"
+ #:reader read-bournish
+ #:compilers (language-compilers scheme)
+ #:decompilers (language-decompilers scheme)
+ #:evaluator (language-evaluator scheme)
+ #:printer (language-printer scheme)
+ #:make-default-environment
+ (language-make-default-environment scheme))))
+
+;; XXX: ",L bournish" won't work unless we call our module (language bournish
+;; spec), which is kinda annoying, so provide another meta-command.
+(define-meta-command ((bournish guix) repl)
+ "bournish
+Switch to the Bournish language."
+ (let ((current (repl-language repl)))
+ (format #t "Welcome to ~a, a minimal Bourne-like shell!~%To switch back, type `,L ~a'.\n"
+ (language-title %bournish-language)
+ (language-name current))
+ (current-language %bournish-language)
+ (set! (repl-language repl) %bournish-language)))
+
+;;; bournish.scm ends here