server.scm 13 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331
  1. ;;; Repl server
  2. ;; Copyright (C) 2003,2010,2011,2014,2016,2019,2021 Free Software Foundation, Inc.
  3. ;; This library is free software; you can redistribute it and/or
  4. ;; modify it under the terms of the GNU Lesser General Public
  5. ;; License as published by the Free Software Foundation; either
  6. ;; version 3 of the License, or (at your option) any later version.
  7. ;;
  8. ;; This library is distributed in the hope that it will be useful,
  9. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  11. ;; Lesser General Public License for more details.
  12. ;;
  13. ;; You should have received a copy of the GNU Lesser General Public
  14. ;; License along with this library; if not, write to the Free Software
  15. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16. ;; 02110-1301 USA
  17. ;;; Code:
  18. (define-module (system repl server)
  19. #:use-module (system repl repl)
  20. #:use-module (ice-9 threads)
  21. #:use-module (ice-9 rdelim)
  22. #:use-module (ice-9 match)
  23. #:use-module (ice-9 iconv)
  24. #:use-module (rnrs bytevectors)
  25. #:use-module (ice-9 binary-ports)
  26. #:use-module (srfi srfi-26) ; cut
  27. #:export (make-tcp-server-socket
  28. make-unix-domain-server-socket
  29. run-server
  30. spawn-server
  31. stop-server-and-clients!))
  32. ;; List of pairs of the form (SOCKET . FORCE-CLOSE), where SOCKET is a
  33. ;; socket port, and FORCE-CLOSE is a thunk that forcefully shuts down
  34. ;; the socket.
  35. (define *open-sockets* '())
  36. (define sockets-lock (make-mutex))
  37. ;; WARNING: it is unsafe to call 'close-socket!' from another thread.
  38. ;; Note: although not exported, this is used by (system repl coop-server)
  39. (define (close-socket! s)
  40. (with-mutex sockets-lock
  41. (set! *open-sockets* (assq-remove! *open-sockets* s)))
  42. ;; Close-port could block or raise an exception flushing buffered
  43. ;; output. Hmm.
  44. (close-port s))
  45. ;; Note: although not exported, this is used by (system repl coop-server)
  46. (define (add-open-socket! s force-close)
  47. (with-mutex sockets-lock
  48. (set! *open-sockets* (acons s force-close *open-sockets*))))
  49. (define (stop-server-and-clients!)
  50. (cond
  51. ((with-mutex sockets-lock
  52. (match *open-sockets*
  53. (() #f)
  54. (((s . force-close) . rest)
  55. (set! *open-sockets* rest)
  56. force-close)))
  57. => (lambda (force-close)
  58. (force-close)
  59. (stop-server-and-clients!)))))
  60. (define* (make-tcp-server-socket #:key
  61. (host #f)
  62. (addr (if host
  63. (inet-pton AF_INET host)
  64. INADDR_LOOPBACK))
  65. (port 37146))
  66. (let ((sock (socket PF_INET SOCK_STREAM 0)))
  67. (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
  68. (bind sock AF_INET addr port)
  69. sock))
  70. (define* (make-unix-domain-server-socket #:key (path "/tmp/guile-socket"))
  71. (let ((sock (socket PF_UNIX SOCK_STREAM 0)))
  72. (setsockopt sock SOL_SOCKET SO_REUSEADDR 1)
  73. (bind sock AF_UNIX path)
  74. sock))
  75. (define* (run-server #:optional (server-socket (make-tcp-server-socket)))
  76. (run-server* server-socket serve-client))
  77. ;; Note: although not exported, this is used by (system repl coop-server)
  78. (define (run-server* server-socket serve-client)
  79. ;; We use a pipe to notify the server when it should shut down.
  80. (define shutdown-pipes (pipe))
  81. (define shutdown-read-pipe (car shutdown-pipes))
  82. (define shutdown-write-pipe (cdr shutdown-pipes))
  83. ;; 'shutdown-server' is called by 'stop-server-and-clients!'.
  84. (define (shutdown-server)
  85. (display #\! shutdown-write-pipe)
  86. (force-output shutdown-write-pipe))
  87. (define monitored-ports
  88. (list server-socket
  89. shutdown-read-pipe))
  90. (define (accept-new-client)
  91. (let ((ready-ports (car (select monitored-ports '() '()))))
  92. ;; If we've been asked to shut down, return #f.
  93. (and (not (memq shutdown-read-pipe ready-ports))
  94. ;; If the socket turns out to actually not be ready, this
  95. ;; will return #f. ECONNABORTED etc are still possible of
  96. ;; course.
  97. (or (false-if-exception (accept server-socket)
  98. #:warning "Failed to accept client:")
  99. (accept-new-client)))))
  100. ;; Put the socket into non-blocking mode.
  101. (fcntl server-socket F_SETFL
  102. (logior O_NONBLOCK
  103. (fcntl server-socket F_GETFL)))
  104. (sigaction SIGPIPE SIG_IGN)
  105. (add-open-socket! server-socket shutdown-server)
  106. (listen server-socket 5)
  107. (let lp ()
  108. (match (accept-new-client)
  109. (#f
  110. ;; If client is false, we are shutting down.
  111. (close shutdown-write-pipe)
  112. (close shutdown-read-pipe)
  113. (close server-socket))
  114. ((client-socket . client-addr)
  115. (make-thread serve-client client-socket client-addr)
  116. (lp)))))
  117. (define* (spawn-server #:optional (server-socket (make-tcp-server-socket)))
  118. (make-thread run-server server-socket))
  119. (define (serve-client client addr)
  120. (let ((thread (current-thread)))
  121. ;; To shut down this thread and socket, cause it to unwind.
  122. (add-open-socket! client (lambda () (cancel-thread thread))))
  123. (guard-against-http-request client)
  124. (dynamic-wind
  125. (lambda () #f)
  126. (with-continuation-barrier
  127. (lambda ()
  128. (parameterize ((current-input-port client)
  129. (current-output-port client)
  130. (current-error-port client)
  131. (current-warning-port client))
  132. (with-fluids ((*repl-stack* '()))
  133. (start-repl)))))
  134. (lambda () (close-socket! client))))
  135. ;;;
  136. ;;; The following code adds protection to Guile's REPL servers against
  137. ;;; HTTP inter-protocol exploitation attacks, a scenario whereby an
  138. ;;; attacker can, via an HTML page, cause a web browser to send data to
  139. ;;; TCP servers listening on a loopback interface or private network.
  140. ;;; See <https://en.wikipedia.org/wiki/Inter-protocol_exploitation> and
  141. ;;; <https://www.jochentopf.com/hfpa/hfpa.pdf>, The HTML Form Protocol
  142. ;;; Attack (2001) by Tochen Topf <jochen@remote.org>.
  143. ;;;
  144. ;;; Here we add a procedure to 'before-read-hook' that looks for a possible
  145. ;;; HTTP request-line in the first line of input from the client socket. If
  146. ;;; present, the socket is drained and closed, and a loud warning is written
  147. ;;; to stderr (POSIX file descriptor 2).
  148. ;;;
  149. (define (with-temporary-port-encoding port encoding thunk)
  150. "Call THUNK in a dynamic environment in which the encoding of PORT is
  151. temporarily set to ENCODING."
  152. (let ((saved-encoding #f))
  153. (dynamic-wind
  154. (lambda ()
  155. (unless (port-closed? port)
  156. (set! saved-encoding (port-encoding port))
  157. (set-port-encoding! port encoding)))
  158. thunk
  159. (lambda ()
  160. (unless (port-closed? port)
  161. (set! encoding (port-encoding port))
  162. (set-port-encoding! port saved-encoding))))))
  163. (define (with-saved-port-line+column port thunk)
  164. "Save the line and column of PORT before entering THUNK, and restore
  165. their previous values upon normal or non-local exit from THUNK."
  166. (let ((saved-line #f) (saved-column #f))
  167. (dynamic-wind
  168. (lambda ()
  169. (unless (port-closed? port)
  170. (set! saved-line (port-line port))
  171. (set! saved-column (port-column port))))
  172. thunk
  173. (lambda ()
  174. (unless (port-closed? port)
  175. (set-port-line! port saved-line)
  176. (set-port-column! port saved-column))))))
  177. (define (drain-input-and-close socket)
  178. "Drain input from SOCKET using ISO-8859-1 encoding until it would block,
  179. and then close it. Return the drained input as a string."
  180. (dynamic-wind
  181. (lambda ()
  182. ;; Enable full buffering mode on the socket to allow
  183. ;; 'get-bytevector-some' to return non-trivial chunks.
  184. (setvbuf socket 'block))
  185. (lambda ()
  186. (let loop ((chunks '()))
  187. (let ((result (and (char-ready? socket)
  188. (get-bytevector-some socket))))
  189. (if (bytevector? result)
  190. (loop (cons (bytevector->string result "ISO-8859-1")
  191. chunks))
  192. (string-concatenate-reverse chunks)))))
  193. (lambda ()
  194. ;; Close the socket even in case of an exception.
  195. (close-port socket))))
  196. (define permissive-http-request-line?
  197. ;; This predicate is deliberately permissive
  198. ;; when checking the Request-URI component.
  199. (let ((cs (ucs-range->char-set #x20 #x7E))
  200. (rx (make-regexp
  201. (string-append
  202. "^(OPTIONS|GET|HEAD|POST|PUT|DELETE|TRACE|CONNECT) "
  203. "[^ ]+ "
  204. "HTTP/[0123456789]+.[0123456789]+$"))))
  205. (lambda (line)
  206. "Return true if LINE might plausibly be an HTTP request-line,
  207. otherwise return #f."
  208. ;; We cannot simplify this to a simple 'regexp-exec', because
  209. ;; 'regexp-exec' cannot cope with NUL bytes.
  210. (and (string-every cs line)
  211. (regexp-exec rx line)))))
  212. (define (check-for-http-request socket)
  213. "Check for a possible HTTP request in the initial input from SOCKET.
  214. If one is found, close the socket and print a report to STDERR (fdes 2).
  215. Otherwise, put back the bytes."
  216. ;; Temporarily set the port encoding to ISO-8859-1 to allow lossless
  217. ;; reading and unreading of the first line, regardless of what bytes
  218. ;; are present. Note that a valid HTTP request-line contains only
  219. ;; ASCII characters.
  220. (with-temporary-port-encoding socket "ISO-8859-1"
  221. (lambda ()
  222. ;; Save the port 'line' and 'column' counters and later restore
  223. ;; them, since unreading what we read is not sufficient to do so.
  224. (with-saved-port-line+column socket
  225. (lambda ()
  226. ;; Read up to (but not including) the first CR or LF.
  227. ;; Although HTTP mandates CRLF line endings, we are permissive
  228. ;; here to guard against the possibility that in some
  229. ;; environments CRLF might be converted to LF before it
  230. ;; reaches us.
  231. (match (read-delimited "\r\n" socket 'peek)
  232. ((? eof-object?)
  233. ;; We found EOF before any input. Nothing to do.
  234. 'done)
  235. ((? permissive-http-request-line? request-line)
  236. ;; The input from the socket began with a plausible HTTP
  237. ;; request-line, which is unlikely to be legitimate and may
  238. ;; indicate an possible break-in attempt.
  239. ;; First, set the current port parameters to a void-port,
  240. ;; to avoid sending any more data over the socket, to cause
  241. ;; the REPL reader to see EOF, and to swallow any remaining
  242. ;; output gracefully.
  243. (let ((void-port (%make-void-port "rw")))
  244. (current-input-port void-port)
  245. (current-output-port void-port)
  246. (current-error-port void-port)
  247. (current-warning-port void-port))
  248. ;; Read from the socket until we would block,
  249. ;; and then close it.
  250. (let ((drained-input (drain-input-and-close socket)))
  251. ;; Print a report to STDERR (POSIX file descriptor 2).
  252. ;; XXX Can we do better here?
  253. (call-with-port (dup->port 2 "w")
  254. (cut format <> "
  255. @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  256. @@ POSSIBLE BREAK-IN ATTEMPT ON THE REPL SERVER @@
  257. @@ BY AN HTTP INTER-PROTOCOL EXPLOITATION ATTACK. See: @@
  258. @@ <https://en.wikipedia.org/wiki/Inter-protocol_exploitation> @@
  259. @@ Possible HTTP request received: ~S
  260. @@ The associated socket has been closed. @@
  261. @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\n"
  262. (string-append request-line
  263. drained-input)))))
  264. (start-line
  265. ;; The HTTP request-line was not found, so
  266. ;; 'unread' the characters that we have read.
  267. (unread-string start-line socket))))))))
  268. (define (guard-against-http-request socket)
  269. "Arrange for the Guile REPL to check for an HTTP request in the
  270. initial input from SOCKET, in which case the socket will be closed.
  271. This guards against HTTP inter-protocol exploitation attacks, a scenario
  272. whereby an attacker can, via an HTML page, cause a web browser to send
  273. data to TCP servers listening on a loopback interface or private
  274. network."
  275. (%set-port-property! socket 'guard-against-http-request? #t))
  276. (define* (maybe-check-for-http-request
  277. #:optional (socket (current-input-port)))
  278. "Apply check-for-http-request to SOCKET if previously requested by
  279. guard-against-http-request. This procedure is intended to be added to
  280. before-read-hook."
  281. (when (%port-property socket 'guard-against-http-request?)
  282. (check-for-http-request socket)
  283. (unless (port-closed? socket)
  284. (%set-port-property! socket 'guard-against-http-request? #f))))
  285. ;; Install the hook.
  286. (add-hook! before-read-hook
  287. maybe-check-for-http-request)
  288. ;;; Local Variables:
  289. ;;; eval: (put 'with-temporary-port-encoding 'scheme-indent-function 2)
  290. ;;; eval: (put 'with-saved-port-line+column 'scheme-indent-function 1)
  291. ;;; End: