coop-server.scm 7.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200
  1. ;;; Cooperative REPL server
  2. ;; Copyright (C) 2014, 2016 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 coop-server)
  19. #:use-module (ice-9 match)
  20. #:use-module (ice-9 threads)
  21. #:use-module (ice-9 q)
  22. #:use-module (srfi srfi-9)
  23. #:export (spawn-coop-repl-server
  24. poll-coop-repl-server))
  25. ;; Hack to import private bindings from (system repl repl).
  26. (define-syntax-rule (import-private module sym ...)
  27. (begin
  28. (define sym (@@ module sym))
  29. ...))
  30. (import-private (system repl repl) start-repl* prompting-meta-read)
  31. (import-private (system repl server)
  32. run-server* add-open-socket! close-socket!
  33. make-tcp-server-socket guard-against-http-request)
  34. (define-record-type <coop-repl-server>
  35. (%make-coop-repl-server mutex queue)
  36. coop-repl-server?
  37. (mutex coop-repl-server-mutex)
  38. (queue coop-repl-server-queue))
  39. (define (make-coop-repl-server)
  40. (%make-coop-repl-server (make-mutex) (make-q)))
  41. (define (coop-repl-server-eval coop-server opcode . args)
  42. "Queue a new instruction with the symbolic name OPCODE and an arbitrary
  43. number of arguments, to be processed the next time COOP-SERVER is polled."
  44. (with-mutex (coop-repl-server-mutex coop-server)
  45. (enq! (coop-repl-server-queue coop-server)
  46. (cons opcode args))))
  47. (define-record-type <coop-repl>
  48. (%make-coop-repl mutex condvar thunk cont)
  49. coop-repl?
  50. (mutex coop-repl-mutex)
  51. (condvar coop-repl-condvar) ; signaled when thunk becomes non-#f
  52. (thunk coop-repl-read-thunk set-coop-repl-read-thunk!)
  53. (cont coop-repl-cont set-coop-repl-cont!))
  54. (define (make-coop-repl)
  55. (%make-coop-repl (make-mutex) (make-condition-variable) #f #f))
  56. (define (coop-repl-read coop-repl)
  57. "Read an expression via the thunk stored in COOP-REPL."
  58. (let ((thunk
  59. (with-mutex (coop-repl-mutex coop-repl)
  60. (unless (coop-repl-read-thunk coop-repl)
  61. (wait-condition-variable (coop-repl-condvar coop-repl)
  62. (coop-repl-mutex coop-repl)))
  63. (let ((thunk (coop-repl-read-thunk coop-repl)))
  64. (unless thunk
  65. (error "coop-repl-read: condvar signaled, but thunk is #f!"))
  66. (set-coop-repl-read-thunk! coop-repl #f)
  67. thunk))))
  68. (thunk)))
  69. (define (store-repl-cont cont coop-repl)
  70. "Save the partial continuation CONT within COOP-REPL."
  71. (set-coop-repl-cont! coop-repl
  72. (lambda (exp)
  73. (coop-repl-prompt
  74. (lambda () (cont exp))))))
  75. (define (coop-repl-prompt thunk)
  76. "Apply THUNK within a prompt for cooperative REPLs."
  77. (call-with-prompt 'coop-repl-prompt thunk store-repl-cont))
  78. (define (make-coop-reader coop-repl)
  79. "Return a new procedure for reading user input from COOP-REPL. The
  80. generated procedure passes the responsibility of reading input to
  81. another thread and aborts the cooperative REPL prompt."
  82. (lambda (repl)
  83. (let ((read-thunk
  84. ;; Need to preserve the REPL stack and current module across
  85. ;; threads.
  86. (let ((stack (fluid-ref *repl-stack*))
  87. (module (current-module)))
  88. (lambda ()
  89. (with-fluids ((*repl-stack* stack))
  90. (set-current-module module)
  91. (prompting-meta-read repl))))))
  92. (with-mutex (coop-repl-mutex coop-repl)
  93. (when (coop-repl-read-thunk coop-repl)
  94. (error "coop-reader: read-thunk is not #f!"))
  95. (set-coop-repl-read-thunk! coop-repl read-thunk)
  96. (signal-condition-variable (coop-repl-condvar coop-repl))))
  97. (abort-to-prompt 'coop-repl-prompt coop-repl)))
  98. (define (reader-loop coop-server coop-repl)
  99. "Run an unbounded loop that reads an expression for COOP-REPL and
  100. stores the expression within COOP-SERVER for later evaluation."
  101. (coop-repl-server-eval coop-server 'eval coop-repl
  102. (coop-repl-read coop-repl))
  103. (reader-loop coop-server coop-repl))
  104. (define (poll-coop-repl-server coop-server)
  105. "Poll the cooperative REPL server COOP-SERVER and apply a pending
  106. operation if there is one, such as evaluating an expression typed at the
  107. REPL prompt. This procedure must be called from the same thread that
  108. called spawn-coop-repl-server."
  109. (let ((op (with-mutex (coop-repl-server-mutex coop-server)
  110. (let ((queue (coop-repl-server-queue coop-server)))
  111. (and (not (q-empty? queue))
  112. (deq! queue))))))
  113. (when op
  114. (match op
  115. (('new-repl client)
  116. (start-repl-client coop-server client))
  117. (('eval coop-repl exp)
  118. ((coop-repl-cont coop-repl) exp))))
  119. *unspecified*))
  120. (define (start-coop-repl coop-server)
  121. "Start a new cooperative REPL process for COOP-SERVER."
  122. ;; Calling stop-server-and-clients! from a REPL will cause an
  123. ;; exception to be thrown when trying to read from the socket that has
  124. ;; been closed, so we catch that here.
  125. (false-if-exception
  126. (let ((coop-repl (make-coop-repl)))
  127. (make-thread reader-loop coop-server coop-repl)
  128. (start-repl* (current-language) #f (make-coop-reader coop-repl)))))
  129. (define (run-coop-repl-server coop-server server-socket)
  130. "Start the cooperative REPL server for COOP-SERVER using the socket
  131. SERVER-SOCKET."
  132. (run-server* server-socket (make-coop-client-proc coop-server)))
  133. (define* (spawn-coop-repl-server
  134. #:optional (server-socket (make-tcp-server-socket)))
  135. "Create and return a new cooperative REPL server object, and spawn a
  136. new thread to listen for connections on SERVER-SOCKET. Proper
  137. functioning of the REPL server requires that poll-coop-repl-server be
  138. called periodically on the returned server object."
  139. (let ((coop-server (make-coop-repl-server)))
  140. (make-thread run-coop-repl-server
  141. coop-server
  142. server-socket)
  143. coop-server))
  144. (define (make-coop-client-proc coop-server)
  145. "Return a new procedure that is used to schedule the creation of a new
  146. cooperative REPL for COOP-SERVER."
  147. (lambda (client addr)
  148. (coop-repl-server-eval coop-server 'new-repl client)))
  149. (define (start-repl-client coop-server client)
  150. "Run a cooperative REPL for COOP-SERVER within a prompt. All input
  151. and output is sent over the socket CLIENT."
  152. ;; Add the client to the list of open sockets, with a 'force-close'
  153. ;; procedure that closes the underlying file descriptor. We do it
  154. ;; this way because we cannot close the port itself safely from
  155. ;; another thread.
  156. (add-open-socket! client (lambda () (close-fdes (fileno client))))
  157. (guard-against-http-request client)
  158. (with-continuation-barrier
  159. (lambda ()
  160. (coop-repl-prompt
  161. (lambda ()
  162. (parameterize ((current-input-port client)
  163. (current-output-port client)
  164. (current-error-port client)
  165. (current-warning-port client))
  166. (with-fluids ((*repl-stack* '()))
  167. (save-module-excursion
  168. (lambda ()
  169. (start-coop-repl coop-server)))))
  170. ;; This may fail if 'stop-server-and-clients!' is called,
  171. ;; because the 'force-close' procedure above closes the
  172. ;; underlying file descriptor instead of the port itself.
  173. (false-if-exception
  174. (close-socket! client)))))))