guix/build/bournish.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2016 Efraim Flashner <efraim@flashner.co.il>
   4 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
   5 ;;;
   6 ;;; This file is part of GNU Guix.
   7 ;;;
   8 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   9 ;;; under the terms of the GNU General Public License as published by
  10 ;;; the Free Software Foundation; either version 3 of the License, or (at
  11 ;;; your option) any later version.
  12 ;;;
  13 ;;; GNU Guix is distributed in the hope that it will be useful, but
  14 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;;; GNU General Public License for more details.
  17 ;;;
  18 ;;; You should have received a copy of the GNU General Public License
  19 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  20
  21 (define-module (guix build bournish)
  22   #:use-module (system base language)
  23   #:use-module (system base compile)
  24   #:use-module (system repl command)
  25   #:use-module (system repl common)
  26   #:use-module (ice-9 rdelim)
  27   #:use-module (ice-9 match)
  28   #:use-module (ice-9 ftw)
  29   #:use-module (srfi srfi-1)
  30   #:use-module (srfi srfi-11)
  31   #:use-module (srfi srfi-26)
  32   #:export (%bournish-language))
  33
  34 ;;; Commentary:
  35 ;;;
  36 ;;; This is a super minimal Bourne-like shell language for Guile.  It is meant
  37 ;;; to be used at the REPL as a rescue shell.  In a way, this is to Guile what
  38 ;;; eshell is to Emacs.
  39 ;;;
  40 ;;; Code:
  41
  42 (define (expand-variable str)
  43   "Return STR or code to obtain the value of the environment variable STR
  44 refers to."
  45   ;; XXX: No support for "${VAR}".
  46   (if (string-prefix? "$" str)
  47       `(or (getenv ,(string-drop str 1)) "")
  48       str))
  49
  50 (define* (display-tabulated lst
  51                             #:key
  52                             (terminal-width 80)
  53                             (column-gap 2))
  54   "Display the list of string LST in as many columns as needed given
  55 TERMINAL-WIDTH.  Use COLUMN-GAP spaces between two subsequent columns."
  56   (define len (length lst))
  57   (define column-width
  58     ;; The width of a column.  Assume all the columns have the same width
  59     ;; (GNU ls is smarter than that.)
  60     (+ column-gap (reduce max 0 (map string-length lst))))
  61   (define columns
  62     (max 1
  63          (quotient terminal-width column-width)))
  64   (define pad
  65     (if (zero? (modulo len columns))
  66         0
  67         columns))
  68   (define items-per-column
  69     (quotient (+ len pad) columns))
  70   (define items (list->vector lst))
  71
  72   (let loop ((indexes (unfold (cut >= <> columns)
  73                               (cut * <> items-per-column)
  74                               1+
  75                               0)))
  76     (unless (>= (first indexes) items-per-column)
  77       (for-each (lambda (index)
  78                   (let ((item (if (< index len)
  79                                   (vector-ref items index)
  80                                   "")))
  81                     (display (string-pad-right item column-width))))
  82                 indexes)
  83       (newline)
  84       (loop (map 1+ indexes)))))
  85
  86 (define ls-command-implementation
  87   ;; Run-time support procedure.
  88   (case-lambda
  89     (()
  90      (display-tabulated (scandir ".")))
  91     (files
  92      (let ((files (append-map (lambda (file)
  93                                 (catch 'system-error
  94                                   (lambda ()
  95                                     (match (stat:type (lstat file))
  96                                       ('directory
  97                                        ;; Like GNU ls, list the contents of
  98                                        ;; FILE rather than FILE itself.
  99                                        (match (scandir file
 100                                                        (match-lambda
 101                                                          ((or "." "..") #f)
 102                                                          (_ #t)))
 103                                          (#f
 104                                           (list file))
 105                                          ((files ...)
 106                                           (map (cut string-append file "/" <>)
 107                                                files))))
 108                                       (_
 109                                        (list file))))
 110                                   (lambda args
 111                                     (let ((errno (system-error-errno args)))
 112                                       (format (current-error-port) "~a: ~a~%"
 113                                               file (strerror errno))
 114                                       '()))))
 115                               files)))
 116        (display-tabulated files)))))
 117
 118 (define (ls-command . files)
 119   `((@@ (guix build bournish) ls-command-implementation) ,@files))
 120
 121 (define (which-command program)
 122   `(search-path ((@@ (guix build bournish) executable-path))
 123                 ,program))
 124
 125 (define (cat-command file)
 126   `(call-with-input-file ,file
 127      (lambda (port)
 128        ((@ (guix build utils) dump-port) port (current-output-port))
 129        *unspecified*)))
 130
 131 (define (rm-command . args)
 132   "Emit code for the 'rm' command."
 133   (cond ((member "-r" args)
 134          `(for-each (@ (guix build utils) delete-file-recursively)
 135                     (list ,@(delete "-r" args))))
 136         (else
 137          `(for-each delete-file (list ,@args)))))
 138
 139 (define (lines+chars port)
 140   "Return the number of lines and number of chars read from PORT."
 141   (let loop ((lines 0) (chars 0))
 142     (match (read-char port)
 143       ((? eof-object?)              ;done!
 144        (values lines chars))
 145       (#\newline                    ;recurse
 146        (loop (1+ lines) (1+ chars)))
 147       (_                            ;recurse
 148        (loop lines (1+ chars))))))
 149
 150 (define (file-exists?* file)
 151   "Like 'file-exists?' but emits a warning if FILE is not accessible."
 152   (catch 'system-error
 153     (lambda ()
 154       (stat file))
 155     (lambda args
 156       (let ((errno (system-error-errno args)))
 157         (format (current-error-port) "~a: ~a~%"
 158                 file (strerror errno))
 159         #f))))
 160
 161 (define (wc-print file)
 162   (let-values (((lines chars)
 163                 (call-with-input-file file lines+chars)))
 164               (format #t "~a ~a ~a~%" lines chars file)))
 165
 166 (define (wc-l-print file)
 167   (let-values (((lines chars)
 168                 (call-with-input-file file lines+chars)))
 169               (format #t "~a ~a~%" lines file)))
 170
 171 (define (wc-c-print file)
 172   (let-values (((lines chars)
 173                 (call-with-input-file file lines+chars)))
 174               (format #t "~a ~a~%" chars file)))
 175
 176 (define (wc-command-implementation . files)
 177   (for-each wc-print (filter file-exists?* files)))
 178
 179 (define (wc-l-command-implementation . files)
 180   (for-each wc-l-print (filter file-exists?* files)))
 181
 182 (define (wc-c-command-implementation . files)
 183   (for-each wc-c-print (filter file-exists?* files)))
 184
 185 (define (wc-command . args)
 186   "Emit code for the 'wc' command."
 187   (cond ((member "-l" args)
 188          `((@@ (guix build bournish) wc-l-command-implementation)
 189            ,@(delete "-l" args)))
 190         ((member "-c" args)
 191          `((@@ (guix build bournish) wc-c-command-implementation)
 192            ,@(delete "-c" args)))
 193         (else
 194          `((@@ (guix build bournish) wc-command-implementation) ,@args))))
 195
 196 (define (reboot-command . args)
 197   "Emit code for 'reboot'."
 198   ;; Normally Bournish is used in the initrd, where 'reboot' is provided
 199   ;; directly by (guile-user).  In other cases, just bail out.
 200   `(if (defined? 'reboot)
 201        (reboot)
 202        (begin
 203          (format (current-error-port)
 204                  "I don't know how to reboot, sorry about that!~%")
 205          #f)))
 206
 207 (define (help-command . _)
 208   (display "\
 209 Hello, this is Bournish, a minimal Bourne-like shell in Guile!
 210
 211 The shell is good enough to navigate the file system and run commands but not
 212 much beyond that.  It is meant to be used as a rescue shell in the initial RAM
 213 disk and is probably not very useful apart from that.  It has a few built-in
 214 commands such as 'ls' and 'cd'; it lacks globbing, pipes---everything.\n"))
 215
 216 (define %not-colon (char-set-complement (char-set #\:)))
 217 (define (executable-path)
 218   "Return the search path for programs as a list."
 219   (match (getenv "PATH")
 220     (#f  '())
 221     (str (string-tokenize str %not-colon))))
 222
 223 (define %commands
 224   ;; Built-in commands.
 225   `(("echo"   ,(lambda strings `(list ,@strings)))
 226     ("cd"     ,(lambda (dir) `(chdir ,dir)))
 227     ("pwd"    ,(lambda () `(getcwd)))
 228     ("rm"     ,rm-command)
 229     ("cp"     ,(lambda (source dest) `(copy-file ,source ,dest)))
 230     ("help"   ,help-command)
 231     ("ls"     ,ls-command)
 232     ("which"  ,which-command)
 233     ("cat"    ,cat-command)
 234     ("wc"     ,wc-command)
 235     ("reboot" ,reboot-command)))
 236
 237 (define (read-bournish port env)
 238   "Read a Bournish expression from PORT, and return the corresponding Scheme
 239 code as an sexp."
 240   (match (read-line port)
 241     ((? eof-object? eof)
 242      eof)
 243     ((= string-tokenize (command args ...))
 244      (match (assoc command %commands)
 245        ((command proc)                            ;built-in command
 246         (apply proc (map expand-variable args)))
 247        (#f
 248         (let ((command (if (string-prefix? "\\" command)
 249                            (string-drop command 1)
 250                            command)))
 251           `(system* ,command ,@(map expand-variable args))))))))
 252
 253 (define %bournish-language
 254   (let ((scheme (lookup-language 'scheme)))
 255     ;; XXX: The 'scheme' language lacks a "joiner", so we add one here.  This
 256     ;; allows us to have 'read-bournish' read one shell statement at a time
 257     ;; instead of having to read until EOF.
 258     (set! (language-joiner scheme)
 259       (lambda (exps env)
 260         (match exps
 261           (()   '(begin))
 262           ((exp) exp)
 263           (_    `(begin ,@exps)))))
 264
 265     (make-language #:name 'bournish
 266                    #:title "Bournish"
 267
 268                    ;; The reader does all the heavy lifting.
 269                    #:reader read-bournish
 270                    #:compilers `((scheme . ,(lambda (exp env options)
 271                                               (values exp env env))))
 272                    #:decompilers '()
 273                    #:evaluator (language-evaluator scheme)
 274                    #:printer (language-printer scheme)
 275                    #:make-default-environment
 276                    (language-make-default-environment scheme))))
 277
 278 ;; XXX: ",L bournish" won't work unless we call our module (language bournish
 279 ;; spec), which is kinda annoying, so provide another meta-command.
 280 (define-meta-command ((bournish guix) repl)
 281   "bournish
 282 Switch to the Bournish language."
 283   (let ((current (repl-language repl)))
 284     (format #t "Welcome to ~a, a minimal Bourne-like shell!~%To switch back, type `,L ~a'.\n"
 285             (language-title %bournish-language)
 286             (language-name current))
 287     (current-language %bournish-language)
 288     (set! (repl-language repl) %bournish-language)))
 289
 290 ;;; bournish.scm ends here