LilyPond-Ruby 0.1.1 → 0.1.2

data/share/guile/2.2/system/repl/repl.scm

@@ -0,0 +1,233 @@
+;;; Read-Eval-Print Loop
+
+;; Copyright (C) 2001, 2009, 2010, 2011, 2013,
+;;   2014 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;; 
+;; This library 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
+;; Lesser General Public License for more details.
+;; 
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Code:
+
+(define-module (system repl repl)
+  #:use-module (system base syntax)
+  #:use-module (system base pmatch)
+  #:use-module (system base compile)
+  #:use-module (system base language)
+  #:use-module (system vm vm)
+  #:use-module (system repl error-handling)
+  #:use-module (system repl common)
+  #:use-module (system repl command)
+  #:use-module (ice-9 control)
+  #:export (start-repl run-repl))
+
+
+;;;
+;;; Comments
+;;;
+;;; (You don't want a comment to force a continuation line.)
+;;;
+
+(define (read-scheme-line-comment port)
+  (let lp ()
+    (let ((ch (read-char port)))
+      (or (eof-object? ch)
+          (eqv? ch #\newline)
+          (lp)))))
+
+(define (read-scheme-datum-comment port)
+  (read port))
+
+;; ch is a peeked char
+(define (read-comment lang port ch)
+  (and (eq? (language-name lang) 'scheme)
+       (case ch
+         ((#\;)
+          (read-char port)
+          (read-scheme-line-comment port)
+          #t)
+         ((#\#)
+          (read-char port)
+          (case (peek-char port)
+            ((#\;)
+             (read-char port)
+             (read-scheme-datum-comment port)
+             #t)
+            ;; Not doing R6RS block comments because of the possibility
+            ;; of read-hash extensions.  Lame excuse.  Not doing scsh
+            ;; block comments either, because I don't feel like handling
+            ;; #!r6rs.
+            (else
+             (unread-char #\# port)
+             #f)))
+         (else
+          #f))))
+
+
+
+;;;
+;;; Meta commands
+;;;
+
+(define meta-command-token (cons 'meta 'command))
+
+(define (meta-reader lang env)
+  (lambda* (#:optional (port (current-input-port)))
+    (with-input-from-port port
+      (lambda ()
+        (let ((ch (flush-leading-whitespace)))
+          (cond ((eof-object? ch)
+                 (read-char))  ; consume the EOF and return it
+                ((eqv? ch #\,)
+                 (read-char)
+                 meta-command-token)
+                ((read-comment lang port ch)
+                 *unspecified*)
+                (else ((language-reader lang) port env))))))))
+        
+(define (flush-all-input)
+  (if (and (char-ready?)
+           (not (eof-object? (peek-char))))
+      (begin
+        (read-char)
+        (flush-all-input))))
+
+;; repl-reader is a function defined in boot-9.scm, and is replaced by
+;; something else if readline has been activated. much of this hoopla is
+;; to be able to re-use the existing readline machinery.
+;;
+;; Catches read errors, returning *unspecified* in that case.
+;;
+;; Note: although not exported, this is used by (system repl coop-server)
+(define (prompting-meta-read repl)
+  (catch #t
+    (lambda ()
+      (repl-reader (lambda () (repl-prompt repl))
+                   (meta-reader (repl-language repl) (current-module))))
+    (lambda (key . args)
+      (case key
+        ((quit)
+         (apply throw key args))
+        (else
+         (format (current-output-port) "While reading expression:\n")
+         (print-exception (current-output-port) #f key args)
+         (flush-all-input)
+         *unspecified*)))))
+
+
+
+;;;
+;;; The repl
+;;;
+
+(define* (start-repl #:optional (lang (current-language)) #:key debug)
+  (start-repl* lang debug prompting-meta-read))
+
+;; Note: although not exported, this is used by (system repl coop-server)
+(define (start-repl* lang debug prompting-meta-read)
+  ;; ,language at the REPL will update the current-language.  Make
+  ;; sure that it does so in a new dynamic scope.
+  (parameterize ((current-language lang))
+    (run-repl* (make-repl lang debug) prompting-meta-read)))
+
+;; (put 'abort-on-error 'scheme-indent-function 1)
+(define-syntax-rule (abort-on-error string exp)
+  (catch #t
+    (lambda () exp)
+    (lambda (key . args)
+      (format #t "While ~A:~%" string)
+      (print-exception (current-output-port) #f key args)
+      (abort))))
+
+(define (run-repl repl)
+  (run-repl* repl prompting-meta-read))
+
+(define (run-repl* repl prompting-meta-read)
+  (define (with-stack-and-prompt thunk)
+    (call-with-prompt (default-prompt-tag)
+                      (lambda () (start-stack #t (thunk)))
+                      (lambda (k proc)
+                        (with-stack-and-prompt (lambda () (proc k))))))
+  
+  (% (with-fluids ((*repl-stack*
+                    (cons repl (or (fluid-ref *repl-stack*) '()))))
+       (if (null? (cdr (fluid-ref *repl-stack*)))
+           (repl-welcome repl))
+       (let prompt-loop ()
+         (let ((exp (prompting-meta-read repl)))
+           (cond
+            ((eqv? exp *unspecified*))  ; read error or comment, pass
+            ((eq? exp meta-command-token)
+             (catch #t
+               (lambda ()
+                 (meta-command repl))
+               (lambda (k . args)
+                 (if (eq? k 'quit)
+                     (abort args)
+                     (begin
+                       (format #t "While executing meta-command:~%")
+                       (print-exception (current-output-port) #f k args))))))
+            ((eof-object? exp)
+             (newline)
+             (abort '()))
+            (else
+             ;; since the input port is line-buffered, consume up to the
+             ;; newline
+             (flush-to-newline)
+             (call-with-error-handling
+              (lambda ()
+                (catch 'quit
+                  (lambda ()
+                    (call-with-values
+                        (lambda ()
+                          (% (let ((thunk
+                                    (abort-on-error "compiling expression"
+                                      (repl-prepare-eval-thunk
+                                       repl
+                                       (abort-on-error "parsing expression"
+                                         (repl-parse repl exp))))))
+                               (run-hook before-eval-hook exp)
+                               (call-with-error-handling
+                                (lambda ()
+                                  (with-stack-and-prompt thunk))
+                                #:on-error (repl-option-ref repl 'on-error)))
+                             (lambda (k) (values))))
+                      (lambda l
+                        (for-each (lambda (v)
+                                    (repl-print repl v))
+                                  l))))
+                  (lambda (k . args)
+                    (abort args))))
+              #:on-error (repl-option-ref repl 'on-error)
+              #:trap-handler 'disabled)))
+           (flush-to-newline) ;; consume trailing whitespace
+           (prompt-loop))))
+     (lambda (k status)
+       status)))
+
+;; Returns first non-whitespace char.
+(define (flush-leading-whitespace)
+  (let ((ch (peek-char)))
+    (cond ((eof-object? ch) ch)
+          ((char-whitespace? ch) (read-char) (flush-leading-whitespace))
+          (else ch))))
+
+(define (flush-to-newline) 
+  (if (char-ready?)
+      (let ((ch (peek-char)))
+        (if (and (not (eof-object? ch)) (char-whitespace? ch))
+            (begin
+              (read-char)
+              (if (not (char=? ch #\newline))
+                  (flush-to-newline)))))))

data/share/guile/2.2/system/repl/server.scm

@@ -0,0 +1,332 @@
+;;; Repl server
+
+;; Copyright (C)  2003, 2010, 2011, 2014, 2016, 2019 Free Software Foundation, Inc.
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+;; 02110-1301 USA
+
+;;; Code:
+
+(define-module (system repl server)
+  #:use-module (system repl repl)
+  #:use-module (ice-9 threads)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 iconv)
+  #:use-module (rnrs bytevectors)
+  #:use-module (ice-9 binary-ports)
+  #:use-module ((rnrs io ports) #:select (call-with-port))
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)           ; cut
+  #:export (make-tcp-server-socket
+            make-unix-domain-server-socket
+            run-server
+            spawn-server
+            stop-server-and-clients!))
+
+;; List of pairs of the form (SOCKET . FORCE-CLOSE), where SOCKET is a
+;; socket port, and FORCE-CLOSE is a thunk that forcefully shuts down
+;; the socket.
+(define *open-sockets* '())
+
+(define sockets-lock (make-mutex))
+
+;; WARNING: it is unsafe to call 'close-socket!' from another thread.
+;; Note: although not exported, this is used by (system repl coop-server)
+(define (close-socket! s)
+  (with-mutex sockets-lock
+    (set! *open-sockets* (assq-remove! *open-sockets* s)))
+  ;; Close-port could block or raise an exception flushing buffered
+  ;; output.  Hmm.
+  (close-port s))
+
+;; Note: although not exported, this is used by (system repl coop-server)
+(define (add-open-socket! s force-close)
+  (with-mutex sockets-lock
+    (set! *open-sockets* (acons s force-close *open-sockets*))))
+
+(define (stop-server-and-clients!)
+  (cond
+   ((with-mutex sockets-lock
+      (match *open-sockets*
+        (() #f)
+        (((s . force-close) . rest)
+         (set! *open-sockets* rest)
+         force-close)))
+    => (lambda (force-close)
+         (force-close)
+         (stop-server-and-clients!)))))
+
+(define* (make-tcp-server-socket #:key
+                          (host #f)
+                          (addr (if host
+                                    (inet-pton AF_INET host)
+                                    INADDR_LOOPBACK))
+                          (port 37146))
+  (let ((sock (socket PF_INET SOCK_STREAM 0)))
+    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+    (bind sock AF_INET addr port)
+    sock))
+
+(define* (make-unix-domain-server-socket #:key (path "/tmp/guile-socket"))
+  (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
+    (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
+    (bind sock AF_UNIX path)
+    sock))
+
+(define* (run-server #:optional (server-socket (make-tcp-server-socket)))
+  (run-server* server-socket serve-client))
+
+;; Note: although not exported, this is used by (system repl coop-server)
+(define (run-server* server-socket serve-client)
+  ;; We use a pipe to notify the server when it should shut down.
+  (define shutdown-pipes      (pipe))
+  (define shutdown-read-pipe  (car shutdown-pipes))
+  (define shutdown-write-pipe (cdr shutdown-pipes))
+
+  ;; 'shutdown-server' is called by 'stop-server-and-clients!'.
+  (define (shutdown-server)
+    (display #\!  shutdown-write-pipe)
+    (force-output shutdown-write-pipe))
+
+  (define monitored-ports
+    (list server-socket
+          shutdown-read-pipe))
+
+  (define (accept-new-client)
+    (let ((ready-ports (car (select monitored-ports '() '()))))
+      ;; If we've been asked to shut down, return #f.
+      (and (not (memq shutdown-read-pipe ready-ports))
+           ;; If the socket turns out to actually not be ready, this
+           ;; will return #f.  ECONNABORTED etc are still possible of
+           ;; course.
+           (or (false-if-exception (accept server-socket)
+                                   #:warning "Failed to accept client:")
+               (accept-new-client)))))
+
+  ;; Put the socket into non-blocking mode.
+  (fcntl server-socket F_SETFL
+         (logior O_NONBLOCK
+                 (fcntl server-socket F_GETFL)))
+
+  (sigaction SIGPIPE SIG_IGN)
+  (add-open-socket! server-socket shutdown-server)
+  (listen server-socket 5)
+  (let lp ()
+    (match (accept-new-client)
+      (#f
+       ;; If client is false, we are shutting down.
+       (close shutdown-write-pipe)
+       (close shutdown-read-pipe)
+       (close server-socket))
+      ((client-socket . client-addr)
+       (make-thread serve-client client-socket client-addr)
+       (lp)))))
+
+(define* (spawn-server #:optional (server-socket (make-tcp-server-socket)))
+  (make-thread run-server server-socket))
+
+(define (serve-client client addr)
+
+  (let ((thread (current-thread)))
+    ;; To shut down this thread and socket, cause it to unwind.
+    (add-open-socket! client (lambda () (cancel-thread thread))))
+
+  (guard-against-http-request client)
+
+  (dynamic-wind
+    (lambda () #f)
+    (with-continuation-barrier
+     (lambda ()
+       (parameterize ((current-input-port client)
+                      (current-output-port client)
+                      (current-error-port client)
+                      (current-warning-port client))
+         (with-fluids ((*repl-stack* '()))
+           (start-repl)))))
+    (lambda () (close-socket! client))))
+
+
+;;;
+;;; The following code adds protection to Guile's REPL servers against
+;;; HTTP inter-protocol exploitation attacks, a scenario whereby an
+;;; attacker can, via an HTML page, cause a web browser to send data to
+;;; TCP servers listening on a loopback interface or private network.
+;;; See <https://en.wikipedia.org/wiki/Inter-protocol_exploitation> and
+;;; <https://www.jochentopf.com/hfpa/hfpa.pdf>, The HTML Form Protocol
+;;; Attack (2001) by Tochen Topf <jochen@remote.org>.
+;;;
+;;; Here we add a procedure to 'before-read-hook' that looks for a possible
+;;; HTTP request-line in the first line of input from the client socket.  If
+;;; present, the socket is drained and closed, and a loud warning is written
+;;; to stderr (POSIX file descriptor 2).
+;;;
+
+(define (with-temporary-port-encoding port encoding thunk)
+  "Call THUNK in a dynamic environment in which the encoding of PORT is
+temporarily set to ENCODING."
+  (let ((saved-encoding #f))
+    (dynamic-wind
+      (lambda ()
+        (unless (port-closed? port)
+          (set! saved-encoding (port-encoding port))
+          (set-port-encoding! port encoding)))
+      thunk
+      (lambda ()
+        (unless (port-closed? port)
+          (set! encoding (port-encoding port))
+          (set-port-encoding! port saved-encoding))))))
+
+(define (with-saved-port-line+column port thunk)
+  "Save the line and column of PORT before entering THUNK, and restore
+their previous values upon normal or non-local exit from THUNK."
+  (let ((saved-line #f) (saved-column #f))
+    (dynamic-wind
+      (lambda ()
+        (unless (port-closed? port)
+          (set! saved-line   (port-line   port))
+          (set! saved-column (port-column port))))
+      thunk
+      (lambda ()
+        (unless (port-closed? port)
+          (set-port-line!   port saved-line)
+          (set-port-column! port saved-column))))))
+
+(define (drain-input-and-close socket)
+  "Drain input from SOCKET using ISO-8859-1 encoding until it would block,
+and then close it.  Return the drained input as a string."
+  (dynamic-wind
+    (lambda ()
+      ;; Enable full buffering mode on the socket to allow
+      ;; 'get-bytevector-some' to return non-trivial chunks.
+      (setvbuf socket 'block))
+    (lambda ()
+      (let loop ((chunks '()))
+        (let ((result (and (char-ready? socket)
+                           (get-bytevector-some socket))))
+          (if (bytevector? result)
+              (loop (cons (bytevector->string result "ISO-8859-1")
+                          chunks))
+              (string-concatenate-reverse chunks)))))
+    (lambda ()
+      ;; Close the socket even in case of an exception.
+      (close-port socket))))
+
+(define permissive-http-request-line?
+  ;; This predicate is deliberately permissive
+  ;; when checking the Request-URI component.
+  (let ((cs (ucs-range->char-set #x20 #x7E))
+        (rx (make-regexp
+             (string-append
+              "^(OPTIONS|GET|HEAD|POST|PUT|DELETE|TRACE|CONNECT) "
+              "[^ ]+ "
+              "HTTP/[0123456789]+.[0123456789]+$"))))
+    (lambda (line)
+      "Return true if LINE might plausibly be an HTTP request-line,
+otherwise return #f."
+      ;; We cannot simplify this to a simple 'regexp-exec', because
+      ;; 'regexp-exec' cannot cope with NUL bytes.
+      (and (string-every cs line)
+           (regexp-exec  rx line)))))
+
+(define (check-for-http-request socket)
+  "Check for a possible HTTP request in the initial input from SOCKET.
+If one is found, close the socket and print a report to STDERR (fdes 2).
+Otherwise, put back the bytes."
+  ;; Temporarily set the port encoding to ISO-8859-1 to allow lossless
+  ;; reading and unreading of the first line, regardless of what bytes
+  ;; are present.  Note that a valid HTTP request-line contains only
+  ;; ASCII characters.
+  (with-temporary-port-encoding socket "ISO-8859-1"
+    (lambda ()
+      ;; Save the port 'line' and 'column' counters and later restore
+      ;; them, since unreading what we read is not sufficient to do so.
+      (with-saved-port-line+column socket
+        (lambda ()
+          ;; Read up to (but not including) the first CR or LF.
+          ;; Although HTTP mandates CRLF line endings, we are permissive
+          ;; here to guard against the possibility that in some
+          ;; environments CRLF might be converted to LF before it
+          ;; reaches us.
+          (match (read-delimited "\r\n" socket 'peek)
+            ((? eof-object?)
+             ;; We found EOF before any input.  Nothing to do.
+             'done)
+
+            ((? permissive-http-request-line? request-line)
+             ;; The input from the socket began with a plausible HTTP
+             ;; request-line, which is unlikely to be legitimate and may
+             ;; indicate an possible break-in attempt.
+
+             ;; First, set the current port parameters to a void-port,
+             ;; to avoid sending any more data over the socket, to cause
+             ;; the REPL reader to see EOF, and to swallow any remaining
+             ;; output gracefully.
+             (let ((void-port (%make-void-port "rw")))
+               (current-input-port   void-port)
+               (current-output-port  void-port)
+               (current-error-port   void-port)
+               (current-warning-port void-port))
+
+             ;; Read from the socket until we would block,
+             ;; and then close it.
+             (let ((drained-input (drain-input-and-close socket)))
+
+               ;; Print a report to STDERR (POSIX file descriptor 2).
+               ;; XXX Can we do better here?
+               (call-with-port (dup->port 2 "w")
+                 (cut format <> "
+@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+@@ POSSIBLE BREAK-IN ATTEMPT ON THE REPL SERVER                @@
+@@ BY AN HTTP INTER-PROTOCOL EXPLOITATION ATTACK.  See:        @@
+@@ <https://en.wikipedia.org/wiki/Inter-protocol_exploitation> @@
+@@ Possible HTTP request received: ~S
+@@ The associated socket has been closed.                      @@
+@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n"
+                      (string-append request-line
+                                     drained-input)))))
+
+            (start-line
+             ;; The HTTP request-line was not found, so
+             ;; 'unread' the characters that we have read.
+             (unread-string start-line socket))))))))
+
+(define (guard-against-http-request socket)
+  "Arrange for the Guile REPL to check for an HTTP request in the
+initial input from SOCKET, in which case the socket will be closed.
+This guards against HTTP inter-protocol exploitation attacks, a scenario
+whereby an attacker can, via an HTML page, cause a web browser to send
+data to TCP servers listening on a loopback interface or private
+network."
+  (%set-port-property! socket 'guard-against-http-request? #t))
+
+(define* (maybe-check-for-http-request
+          #:optional (socket (current-input-port)))
+  "Apply check-for-http-request to SOCKET if previously requested by
+guard-against-http-request.  This procedure is intended to be added to
+before-read-hook."
+  (when (%port-property socket 'guard-against-http-request?)
+    (check-for-http-request socket)
+    (unless (port-closed? socket)
+      (%set-port-property! socket 'guard-against-http-request? #f))))
+
+;; Install the hook.
+(add-hook! before-read-hook
+           maybe-check-for-http-request)
+
+;;; Local Variables:
+;;; eval: (put 'with-temporary-port-encoding 'scheme-indent-function 2)
+;;; eval: (put 'with-saved-port-line+column  'scheme-indent-function 1)
+;;; End:

data/share/guile/2.2/system/syntax.scm

@@ -0,0 +1,33 @@
+;;; Syntax utilities
+
+;;; Copyright (C) 2017 Free Software Foundation, Inc.
+
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;; 
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;; 
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Code:
+
+(define-module (system syntax)
+  #:use-module (system syntax internal)
+  #:re-export (syntax?
+               syntax-local-binding
+               (%syntax-module . syntax-module)
+               syntax-locally-bound-identifiers
+               syntax-session-id))
+
+;; Used by syntax.c.
+(define (print-syntax obj port)
+  ;; FIXME: Use syntax->datum instad of syntax-expression, when
+  ;; syntax->datum can operate on new syntax objects.
+  (format port "#<syntax ~s>" (syntax-expression obj)))