Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Temporary server-hacking commit.

  • Loading branch information...
commit fb600aa6f85283766dead171f6cde7f7fd031a7b 1 parent 2c070ad
Thomas Schilling nominolo authored
1,052 emacs/scion.el
... ... @@ -0,0 +1,1052 @@
  1 +
  2 +
  3 +;;;; License
  4 +;; Copyright (C) 2003 Eric Marsden, Luke Gorrie, Helmut Eller
  5 +;; Copyright (C) 2004,2005,2006 Luke Gorrie, Helmut Eller
  6 +;;
  7 +;; This program is free software; you can redistribute it and/or
  8 +;; modify it under the terms of the GNU General Public License as
  9 +;; published by the Free Software Foundation; either version 2 of
  10 +;; the License, or (at your option) any later version.
  11 +;;
  12 +;; This program is distributed in the hope that it will be useful,
  13 +;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 +;; GNU General Public License for more details.
  16 +;;
  17 +;; You should have received a copy of the GNU General Public
  18 +;; License along with this program; if not, write to the Free
  19 +;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20 +;; MA 02111-1307, USA.
  21 +
  22 +(eval-and-compile
  23 + (require 'cl)
  24 + (unless (fboundp 'define-minor-mode)
  25 + (require 'easy-mmode)
  26 + (defalias 'define-minor-mode 'easy-mmode-define-minor-mode)))
  27 +
  28 +(defgroup scion nil
  29 + "Interaction with the Superior Lisp Environment."
  30 + :prefix "scion-"
  31 + :group 'applications)
  32 +
  33 +(defgroup scion-ui nil
  34 + "Interaction with the Superior Lisp Environment."
  35 + :prefix "scion-"
  36 + :group 'scion)
  37 +
  38 +(defcustom scion-kill-without-query-p nil
  39 + "If non-nil, kill SCION processes without query when quitting Emacs.
  40 +This applies to the *inferior-lisp* buffer and the network connections."
  41 + :type 'boolean
  42 + :group 'scion-ui)
  43 +
  44 +(defgroup scion-haskell nil
  45 + "Haskell server configuration."
  46 + :prefix "scion-"
  47 + :group 'scion)
  48 +
  49 +(defcustom scion-connected-hook nil
  50 + "List of functions to call when SCION connects to Haskell."
  51 + :type 'hook
  52 + :group 'scion-haskell)
  53 +
  54 +(defcustom scion-haskell-host "127.0.0.1"
  55 + "The default hostname (or IP address) to connect to."
  56 + :type 'string
  57 + :group 'scion-haskell)
  58 +
  59 +(defcustom scion-port 4005
  60 + "Port to use as the default for `scion-connect'."
  61 + :type 'integer
  62 + :group 'scion-haskell)
  63 +
  64 +;;;---------------------------------------------------------------------------
  65 +
  66 +(defmacro destructure-case (value &rest patterns)
  67 + "Dispatch VALUE to one of PATTERNS.
  68 +A cross between `case' and `destructuring-bind'.
  69 +The pattern syntax is:
  70 + ((HEAD . ARGS) . BODY)
  71 +The list of patterns is searched for a HEAD `eq' to the car of
  72 +VALUE. If one is found, the BODY is executed with ARGS bound to the
  73 +corresponding values in the CDR of VALUE."
  74 + (let ((operator (gensym "op-"))
  75 + (operands (gensym "rand-"))
  76 + (tmp (gensym "tmp-")))
  77 + `(let* ((,tmp ,value)
  78 + (,operator (car ,tmp))
  79 + (,operands (cdr ,tmp)))
  80 + (case ,operator
  81 + ,@(mapcar (lambda (clause)
  82 + (if (eq (car clause) t)
  83 + `(t ,@(cdr clause))
  84 + (destructuring-bind ((op &rest rands) &rest body) clause
  85 + `(,op (destructuring-bind ,rands ,operands
  86 + . ,body)))))
  87 + patterns)
  88 + ,@(if (eq (caar (last patterns)) t)
  89 + '()
  90 + `((t (error "Elisp destructure-case failed: %S" ,tmp))))))))
  91 +
  92 +;;;---------------------------------------------------------------------------
  93 +
  94 +
  95 +;; dummy definitions for the compiler
  96 +(defvar slime-net-coding-system)
  97 +(defvar slime-net-processes)
  98 +(defvar slime-default-connection)
  99 +
  100 +
  101 +
  102 +(defun scion-connect (host port &optional coding-system)
  103 + "Connect to a running Swank server."
  104 + (interactive (list (read-from-minibuffer "Host: " scion-haskell-host)
  105 + (read-from-minibuffer "Port: " (format "%d" scion-port)
  106 + nil t)))
  107 + (when (and (interactive-p) scion-net-processes
  108 + (y-or-n-p "Close old connections first? "))
  109 + (scion-disconnect))
  110 + (message "Connecting to Scion Server on port %S.." port)
  111 + (let ((coding-system (or coding-system scion-net-coding-system)))
  112 + (scion-check-coding-system coding-system)
  113 + (message "Connecting to Scion Server on port %S.." port)
  114 + (let* ((process (scion-net-connect host port coding-system))
  115 + (scion-dispatching-connection process))
  116 + (scion-setup-connection process))))
  117 +
  118 +;;;---------------------------------------------------------------------------
  119 +;;;; Networking
  120 +;;;---------------------------------------------------------------------------
  121 +;;;
  122 +;;; This section covers the low-level networking: establishing
  123 +;;; connections and encoding/decoding protocol messages.
  124 +;;;
  125 +;;; Each SCION protocol message begins with a 3-byte length header
  126 +;;; followed by an S-expression as text. [XXX: The sexp must be readable
  127 +;;; both by Emacs and by Common Haskell, so if it contains any embedded
  128 +;;; code fragments they should be sent as strings.]
  129 +;;;
  130 +;;; The set of meaningful protocol messages are not specified
  131 +;;; here. They are defined elsewhere by the event-dispatching
  132 +;;; functions in this file and in Scion/Server/Emacs.hs.
  133 +
  134 +(defvar scion-net-processes nil
  135 + "List of processes (sockets) connected to Haskell.")
  136 +
  137 +(defvar scion-net-process-close-hooks '()
  138 + "List of functions called when a scion network connection closes.
  139 +The functions are called with the process as their argument.")
  140 +
  141 +(defun scion-secret ()
  142 + "Finds the magic secret from the user's home directory.
  143 +Returns nil if the file doesn't exist or is empty; otherwise the first
  144 +line of the file."
  145 + ;; (condition-case err
  146 +;; (with-temp-buffer
  147 +;; (insert-file-contents "~/.scion-secret")
  148 +;; (goto-char (point-min))
  149 +;; (buffer-substring (point-min) (line-end-position)))
  150 +;; (file-error nil))
  151 + nil) ; disable for now
  152 +
  153 +;;;---------------------------------------------------------------------------
  154 +;;; Interface
  155 +
  156 +(defun scion-net-connect (host port coding-system)
  157 + "Establish a connection with a Scion Server.
  158 +
  159 +<hostname> <port> <coding-system> -> <network-stream-process>"
  160 + (let* ((inhibit-quit nil)
  161 + (proc (open-network-stream "Scion Server" nil host port))
  162 + (buffer (scion-make-net-buffer " *scion-connection*")))
  163 + (push proc scion-net-processes)
  164 + (set-process-buffer proc buffer)
  165 + (set-process-filter proc 'scion-net-filter)
  166 + (set-process-sentinel proc 'scion-net-sentinel)
  167 + (scion-set-query-on-exit-flag proc)
  168 + (when (fboundp 'set-process-coding-system)
  169 + (scion-check-coding-system coding-system)
  170 + (set-process-coding-system proc coding-system coding-system))
  171 + (when-let (secret (scion-secret))
  172 + (scion-net-send secret proc))
  173 + proc))
  174 +
  175 +(defun scion-make-net-buffer (name)
  176 + "Make a buffer suitable for a network process."
  177 + (let ((buffer (generate-new-buffer name)))
  178 + (with-current-buffer buffer
  179 + (buffer-disable-undo))
  180 + buffer))
  181 +
  182 +(defun scion-set-query-on-exit-flag (process)
  183 + "Set PROCESS's query-on-exit-flag to `scion-kill-without-query-p'."
  184 + (when scion-kill-without-query-p
  185 + ;; avoid byte-compiler warnings
  186 + (let ((fun (if (fboundp 'set-process-query-on-exit-flag)
  187 + 'set-process-query-on-exit-flag
  188 + 'process-kill-without-query)))
  189 + (funcall fun process nil))))
  190 +
  191 +
  192 +;;;---------------------------------------------------------------------------
  193 +;;;;; Coding system madness
  194 +
  195 +(defvar scion-net-valid-coding-systems
  196 + '((iso-latin-1-unix nil "iso-latin-1-unix")
  197 + (iso-8859-1-unix nil "iso-latin-1-unix")
  198 + (binary nil "iso-latin-1-unix")
  199 + ;; (utf-8-unix t "utf-8-unix")
  200 +;; (emacs-mule-unix t "emacs-mule-unix")
  201 +;; (euc-jp-unix t "euc-jp-unix")
  202 + )
  203 + "A list of valid coding systems.
  204 +Each element is of the form: (NAME MULTIBYTEP CL-NAME)")
  205 +
  206 +(defun scion-find-coding-system (name)
  207 + "Return the coding system for the symbol NAME.
  208 +The result is either an element in `scion-net-valid-coding-systems'
  209 +or NIL."
  210 + (let* ((probe (assq name scion-net-valid-coding-systems)))
  211 + (if (and probe (if (fboundp 'check-coding-system)
  212 + (ignore-errors (check-coding-system (car probe)))
  213 + (eq (car probe) 'binary)))
  214 + probe)))
  215 +
  216 +(defvar scion-net-coding-system
  217 + (find-if 'scion-find-coding-system
  218 + '(iso-latin-1-unix iso-8859-1-unix binary))
  219 + "*Coding system used for network connections.
  220 +See also `scion-net-valid-coding-systems'.")
  221 +
  222 +(defun scion-check-coding-system (coding-system)
  223 + "Signal an error if CODING-SYSTEM isn't a valid coding system."
  224 + (interactive)
  225 + (let ((props (scion-find-coding-system coding-system)))
  226 + (unless props
  227 + (error "Invalid scion-net-coding-system: %s. %s"
  228 + coding-system (mapcar #'car scion-net-valid-coding-systems)))
  229 + (when (and (second props) (boundp 'default-enable-multibyte-characters))
  230 + (assert default-enable-multibyte-characters))
  231 + t))
  232 +
  233 +(defcustom scion-repl-history-file-coding-system
  234 + (cond ((scion-find-coding-system 'utf-8-unix) 'utf-8-unix)
  235 + (t scion-net-coding-system))
  236 + "*The coding system for the history file."
  237 + :type 'symbol
  238 + :group 'scion-repl)
  239 +
  240 +(defun scion-coding-system-mulibyte-p (coding-system)
  241 + (second (scion-find-coding-system coding-system)))
  242 +
  243 +(defun scion-coding-system-cl-name (coding-system)
  244 + (third (scion-find-coding-system coding-system)))
  245 +
  246 +;;;---------------------------------------------------------------------------
  247 +;;; Interface
  248 +
  249 +(defun scion-net-send (sexp proc)
  250 + "Send a SEXP to Lisp over the socket PROC.
  251 +This is the lowest level of communication. The sexp will be READ and
  252 +EVAL'd by Lisp."
  253 + (let* ((msg (concat (scion-prin1-to-string sexp) "\n"))
  254 + (string (concat (scion-net-encode-length (length msg)) msg))
  255 + (coding-system (cdr (process-coding-system proc))))
  256 + (scion-log-event sexp)
  257 + (cond ((scion-safe-encoding-p coding-system string)
  258 + (process-send-string proc string))
  259 + (t (error "Coding system %s not suitable for %S"
  260 + coding-system string)))))
  261 +
  262 +(defun scion-safe-encoding-p (coding-system string)
  263 + "Return true iff CODING-SYSTEM can safely encode STRING."
  264 + (if (featurep 'xemacs)
  265 + ;; FIXME: XEmacs encodes non-encodeable chars as ?~ automatically
  266 + t
  267 + (or (let ((candidates (find-coding-systems-string string))
  268 + (base (coding-system-base coding-system)))
  269 + (or (equal candidates '(undecided))
  270 + (memq base candidates)))
  271 + (and (not (multibyte-string-p string))
  272 + (not (scion-coding-system-mulibyte-p coding-system))))))
  273 +
  274 +(defun scion-net-close (process &optional debug)
  275 + (setq scion-net-processes (remove process scion-net-processes))
  276 + (when (eq process scion-default-connection)
  277 + (setq scion-default-connection nil))
  278 + (cond (debug
  279 + (set-process-sentinel process 'ignore)
  280 + (set-process-filter process 'ignore)
  281 + (delete-process process))
  282 + (t
  283 + (run-hook-with-args 'scion-net-process-close-hooks process)
  284 + ;; killing the buffer also closes the socket
  285 + (kill-buffer (process-buffer process)))))
  286 +
  287 +(defun scion-net-sentinel (process message)
  288 + (message "Lisp connection closed unexpectedly: %s" message)
  289 + (scion-net-close process))
  290 +
  291 +;;; Socket input is handled by `scion-net-filter', which decodes any
  292 +;;; complete messages and hands them off to the event dispatcher.
  293 +
  294 +(defun scion-net-filter (process string)
  295 + "Accept output from the socket and process all complete messages."
  296 + (with-current-buffer (process-buffer process)
  297 + (goto-char (point-max))
  298 + (insert string))
  299 + (scion-process-available-input process))
  300 +
  301 +(defun scion-process-available-input (process)
  302 + "Process all complete messages that have arrived from Lisp."
  303 + (with-current-buffer (process-buffer process)
  304 + (while (scion-net-have-input-p)
  305 + (let ((event (scion-net-read-or-lose process))
  306 + (ok nil))
  307 + (scion-log-event event)
  308 + (unwind-protect
  309 + (save-current-buffer
  310 + (scion-dispatch-event event process)
  311 + (setq ok t))
  312 + (unless ok
  313 + (scion-run-when-idle 'scion-process-available-input process)))))))
  314 +
  315 +(defun scion-net-have-input-p ()
  316 + "Return true if a complete message is available."
  317 + (goto-char (point-min))
  318 + (and (>= (buffer-size) 6)
  319 + (>= (- (buffer-size) 6) (scion-net-decode-length))))
  320 +
  321 +(defun scion-run-when-idle (function &rest args)
  322 + "Call FUNCTION as soon as Emacs is idle."
  323 + (apply #'run-at-time
  324 + (if (featurep 'xemacs) itimer-short-interval 0)
  325 + nil function args))
  326 +
  327 +(defun scion-net-read-or-lose (process)
  328 + (condition-case error
  329 + (scion-net-read)
  330 + (error
  331 + (debug)
  332 + (scion-net-close process t)
  333 + (error "net-read error: %S" error))))
  334 +
  335 +(defun scion-net-read ()
  336 + "Read a message from the network buffer."
  337 + (goto-char (point-min))
  338 + (let* ((length (scion-net-decode-length))
  339 + (start (+ 6 (point)))
  340 + (end (+ start length)))
  341 + (assert (plusp length))
  342 + (prog1 (save-restriction
  343 + (narrow-to-region start end)
  344 + (read (current-buffer)))
  345 + (delete-region (point-min) end))))
  346 +
  347 +(defun scion-net-decode-length ()
  348 + "Read a 24-bit hex-encoded integer from buffer."
  349 + (string-to-number (buffer-substring-no-properties (point) (+ (point) 6)) 16))
  350 +
  351 +(defun scion-net-encode-length (n)
  352 + "Encode an integer into a 24-bit hex string."
  353 + (format "%06x" n))
  354 +
  355 +(defun scion-prin1-to-string (sexp)
  356 + "Like `prin1-to-string' but don't octal-escape non-ascii characters.
  357 +This is more compatible with the CL reader."
  358 + (with-temp-buffer
  359 + (let (print-escape-nonascii
  360 + print-escape-newlines
  361 + print-length
  362 + print-level)
  363 + (prin1 sexp (current-buffer))
  364 + (buffer-string))))
  365 +
  366 +;;;---------------------------------------------------------------------------
  367 +
  368 +
  369 +;;;; Connections
  370 +;;;
  371 +;;; "Connections" are the high-level Emacs<->Lisp networking concept.
  372 +;;;
  373 +;;; Emacs has a connection to each Lisp process that it's interacting
  374 +;;; with. Typically there would only be one, but a user can choose to
  375 +;;; connect to many Lisps simultaneously.
  376 +;;;
  377 +;;; A connection consists of a control socket, optionally an extra
  378 +;;; socket dedicated to receiving Lisp output (an optimization), and a
  379 +;;; set of connection-local state variables.
  380 +;;;
  381 +;;; The state variables are stored as buffer-local variables in the
  382 +;;; control socket's process-buffer and are used via accessor
  383 +;;; functions. These variables include things like the *FEATURES* list
  384 +;;; and Unix Pid of the Lisp process.
  385 +;;;
  386 +;;; One connection is "current" at any given time. This is:
  387 +;;; `scion-dispatching-connection' if dynamically bound, or
  388 +;;; `scion-buffer-connection' if this is set buffer-local, or
  389 +;;; `scion-default-connection' otherwise.
  390 +;;;
  391 +;;; When you're invoking commands in your source files you'll be using
  392 +;;; `scion-default-connection'. This connection can be interactively
  393 +;;; reassigned via the connection-list buffer.
  394 +;;;
  395 +;;; When a command creates a new buffer it will set
  396 +;;; `scion-buffer-connection' so that commands in the new buffer will
  397 +;;; use the connection that the buffer originated from. For example,
  398 +;;; the apropos command creates the *Apropos* buffer and any command
  399 +;;; in that buffer (e.g. `M-.') will go to the same Lisp that did the
  400 +;;; apropos search. REPL buffers are similarly tied to their
  401 +;;; respective connections.
  402 +;;;
  403 +;;; When Emacs is dispatching some network message that arrived from a
  404 +;;; connection it will dynamically bind `scion-dispatching-connection'
  405 +;;; so that the event will be processed in the context of that
  406 +;;; connection.
  407 +;;;
  408 +;;; This is mostly transparent. The user should be aware that he can
  409 +;;; set the default connection to pick which Lisp handles commands in
  410 +;;; Lisp-mode source buffers, and scion hackers should be aware that
  411 +;;; they can tie a buffer to a specific connection. The rest takes
  412 +;;; care of itself.
  413 +
  414 +(defvar scion-dispatching-connection nil
  415 + "Network process currently executing.
  416 +This is dynamically bound while handling messages from Lisp; it
  417 +overrides `scion-buffer-connection' and `scion-default-connection'.")
  418 +
  419 +(make-variable-buffer-local
  420 + (defvar scion-buffer-connection nil
  421 + "Network connection to use in the current buffer.
  422 +This overrides `scion-default-connection'."))
  423 +
  424 +(defvar scion-default-connection nil
  425 + "Network connection to use by default.
  426 +Used for all Lisp communication, except when overridden by
  427 +`scion-dispatching-connection' or `scion-buffer-connection'.")
  428 +
  429 +(defun scion-current-connection ()
  430 + "Return the connection to use for Lisp interaction.
  431 +Return nil if there's no connection."
  432 + (or scion-dispatching-connection
  433 + scion-buffer-connection
  434 + scion-default-connection))
  435 +
  436 +(defun scion-connection ()
  437 + "Return the connection to use for Lisp interaction.
  438 +Signal an error if there's no connection."
  439 + (let ((conn (scion-current-connection)))
  440 + (cond ((and (not conn) scion-net-processes)
  441 + (or (scion-auto-select-connection)
  442 + (error "No default connection selected.")))
  443 + ((not conn)
  444 + (or (scion-auto-connect)
  445 + (error "Not connected.")))
  446 + ((not (eq (process-status conn) 'open))
  447 + (error "Connection closed."))
  448 + (t conn))))
  449 +
  450 +(defvar scion-auto-connect 'never)
  451 +
  452 +(defun scion-auto-connect ()
  453 + (cond ((or (eq scion-auto-connect 'always)
  454 + (and (eq scion-auto-connect 'ask)
  455 + (y-or-n-p "No connection. Start Scion? ")))
  456 + (save-window-excursion
  457 + (scion)
  458 + (while (not (scion-current-connection))
  459 + (sleep-for 1))
  460 + (scion-connection)))
  461 + (t nil)))
  462 +
  463 +(defvar scion-auto-select-connection 'ask)
  464 +
  465 +(defun scion-auto-select-connection ()
  466 + (let* ((c0 (car scion-net-processes))
  467 + (c (cond ((eq scion-auto-select-connection 'always) c0)
  468 + ((and (eq scion-auto-select-connection 'ask)
  469 + (y-or-n-p
  470 + (format "No default connection selected. %s %s? "
  471 + "Switch to" (scion-connection-name c0))))
  472 + c0))))
  473 + (when c
  474 + (scion-select-connection c)
  475 + (message "Switching to connection: %s" (scion-connection-name c))
  476 + c)))
  477 +
  478 +(defun scion-select-connection (process)
  479 + "Make PROCESS the default connection."
  480 + (setq scion-default-connection process))
  481 +
  482 +(defun scion-cycle-connections ()
  483 + "Change current scion connection, and make it buffer local."
  484 + (interactive)
  485 + (let* ((tail (or (cdr (member (scion-current-connection)
  486 + scion-net-processes))
  487 + scion-net-processes))
  488 + (p (car tail)))
  489 + (scion-select-connection p)
  490 + (unless (eq major-mode 'scion-repl-mode)
  491 + (setq scion-buffer-connection p))
  492 + (message "Lisp: %s %s" (scion-connection-name p) (process-contact p))))
  493 +
  494 +(defmacro* scion-with-connection-buffer ((&optional process) &rest body)
  495 + "Execute BODY in the process-buffer of PROCESS.
  496 +If PROCESS is not specified, `scion-connection' is used.
  497 +
  498 +\(fn (&optional PROCESS) &body BODY))"
  499 + `(with-current-buffer
  500 + (process-buffer (or ,process (scion-connection)
  501 + (error "No connection")))
  502 + ,@body))
  503 +
  504 +(put 'scion-with-connection-buffer 'lisp-indent-function 1)
  505 +
  506 +
  507 +(defun scion-compute-connection-state (conn)
  508 + (cond ((null conn) :disconnected)
  509 + ((scion-stale-connection-p conn) :stale)
  510 + ((scion-debugged-connection-p conn) :debugged)
  511 + ((and (scion-use-sigint-for-interrupt conn)
  512 + (scion-busy-p conn)) :busy)
  513 + ((eq scion-buffer-connection conn) :local)
  514 + (t :connected)))
  515 +
  516 +(defun scion-connection-state-as-string (state)
  517 + (case state
  518 + (:connected "")
  519 + (:disconnected "not connected")
  520 + (:busy "busy..")
  521 + (:debugged "debugged..")
  522 + (:stale "stale")
  523 + (:local "local")
  524 + ))
  525 +
  526 +;;; Connection-local variables:
  527 +
  528 +(defmacro scion-def-connection-var (varname &rest initial-value-and-doc)
  529 + "Define a connection-local variable.
  530 +The value of the variable can be read by calling the function of the
  531 +same name (it must not be accessed directly). The accessor function is
  532 +setf-able.
  533 +
  534 +The actual variable bindings are stored buffer-local in the
  535 +process-buffers of connections. The accessor function refers to
  536 +the binding for `scion-connection'."
  537 + (let ((real-var (intern (format "%s:connlocal" varname))))
  538 + `(progn
  539 + ;; Variable
  540 + (make-variable-buffer-local
  541 + (defvar ,real-var ,@initial-value-and-doc))
  542 + ;; Accessor
  543 + (defun ,varname (&optional process)
  544 + (scion-with-connection-buffer (process) ,real-var))
  545 + ;; Setf
  546 + (defsetf ,varname (&optional process) (store)
  547 + `(scion-with-connection-buffer (,process)
  548 + (setq (\, (quote (\, real-var))) (\, store))
  549 + (\, store)))
  550 + '(\, varname))))
  551 +
  552 +(put 'scion-def-connection-var 'lisp-indent-function 2)
  553 +
  554 +;; Let's indulge in some pretty colours.
  555 +(unless (featurep 'xemacs)
  556 + (font-lock-add-keywords
  557 + 'emacs-lisp-mode
  558 + '(("(\\(scion-def-connection-var\\)\\s +\\(\\(\\w\\|\\s_\\)+\\)"
  559 + (1 font-lock-keyword-face)
  560 + (2 font-lock-variable-name-face)))))
  561 +
  562 +(scion-def-connection-var scion-connection-number nil
  563 + "Serial number of a connection.
  564 +Bound in the connection's process-buffer.")
  565 +
  566 +;; (scion-def-connection-var scion-lisp-features '()
  567 +;; "The symbol-names of Lisp's *FEATURES*.
  568 +;; This is automatically synchronized from Lisp.")
  569 +
  570 +;; (scion-def-connection-var scion-lisp-modules '()
  571 +;; "The strings of Lisp's *MODULES*.")
  572 +
  573 +;; (scion-def-connection-var scion-lisp-package
  574 +;; "COMMON-LISP-USER"
  575 +;; "The current package name of the Superior lisp.
  576 +;; This is automatically synchronized from Lisp.")
  577 +
  578 +;; (scion-def-connection-var scion-lisp-package-prompt-string
  579 +;; "CL-USER"
  580 +;; "The current package name of the Superior lisp.
  581 +;; This is automatically synchronized from Lisp.")
  582 +
  583 +(scion-def-connection-var scion-pid nil
  584 + "The process id of the Haskell process.")
  585 +
  586 +;; (scion-def-connection-var scion-lisp-implementation-type nil
  587 +;; "The implementation type of the Lisp process.")
  588 +
  589 +;; (scion-def-connection-var scion-lisp-implementation-version nil
  590 +;; "The implementation type of the Lisp process.")
  591 +
  592 +;; (scion-def-connection-var scion-lisp-implementation-name nil
  593 +;; "The short name for the Lisp implementation.")
  594 +
  595 +;; (scion-def-connection-var scion-connection-name nil
  596 +;; "The short name for connection.")
  597 +
  598 +;; (scion-def-connection-var scion-inferior-process nil
  599 +;; "The inferior process for the connection if any.")
  600 +
  601 +;; (scion-def-connection-var scion-communication-style nil
  602 +;; "The communication style.")
  603 +
  604 +;; (scion-def-connection-var scion-machine-instance nil
  605 +;; "The name of the (remote) machine running the Lisp process.")
  606 +
  607 +;;;;; Connection setup
  608 +
  609 +(defvar scion-connection-counter 0
  610 + "The number of SCION connections made. For generating serial numbers.")
  611 +
  612 +;;; Interface
  613 +(defun scion-setup-connection (process)
  614 + "Make a connection out of PROCESS."
  615 + (let ((scion-dispatching-connection process))
  616 + (scion-init-connection-state process)
  617 + (scion-select-connection process)
  618 + process))
  619 +
  620 +(defun scion-init-connection-state (proc)
  621 + "Initialize connection state in the process-buffer of PROC."
  622 + ;; To make life simpler for the user: if this is the only open
  623 + ;; connection then reset the connection counter.
  624 + (when (equal scion-net-processes (list proc))
  625 + (setq scion-connection-counter 0))
  626 + (scion-with-connection-buffer ()
  627 + (setq scion-buffer-connection proc))
  628 + (setf (scion-connection-number proc) (incf scion-connection-counter))
  629 + ;; We do the rest of our initialization asynchronously. The current
  630 + ;; function may be called from a timer, and if we setup the REPL
  631 + ;; from a timer then it mysteriously uses the wrong keymap for the
  632 + ;; first command.
  633 + (scion-eval-async '(connection-info)
  634 + (scion-curry #'scion-set-connection-info proc)))
  635 +
  636 +(defun scion-set-connection-info (connection info)
  637 + "Initialize CONNECTION with INFO received from Lisp."
  638 + (let ((scion-dispatching-connection connection))
  639 + (destructuring-bind (&key pid ;style ;lisp-implementation machine
  640 + ;features package
  641 + version ;modules
  642 + &allow-other-keys) info
  643 + (scion-check-version version connection)
  644 + (setf (scion-pid) pid
  645 + ;(scion-communication-style) style
  646 + ;; (scion-lisp-features) features
  647 + ;; (scion-lisp-modules) modules
  648 + )
  649 +;; (destructuring-bind (&key name prompt) package
  650 +;; (setf (scion-lisp-package) name
  651 +;; (scion-lisp-package-prompt-string) prompt))
  652 +;; (destructuring-bind (&key type name version) lisp-implementation
  653 +;; (setf (scion-lisp-implementation-type) type
  654 +;; (scion-lisp-implementation-version) version
  655 +;; (scion-lisp-implementation-name) name
  656 +;; (scion-connection-name) (scion-generate-connection-name name)))
  657 +;; (destructuring-bind (&key instance type version) machine
  658 +;; (setf (scion-machine-instance) instance))
  659 + )
  660 + (let ((args nil ;; (when-let (p (scion-inferior-process))
  661 +;; (scion-inferior-lisp-args p))
  662 + ))
  663 +;; (when-let (name (plist-get args ':name))
  664 +;; (unless (string= (scion-lisp-implementation-name) name)
  665 +;; (setf (scion-connection-name)
  666 +;; (scion-generate-connection-name (symbol-name name)))))
  667 + ;(scion-hide-inferior-lisp-buffer)
  668 + ;(scion-init-output-buffer connection)
  669 + ;(scion-load-contribs)
  670 + (run-hooks 'scion-connected-hook)
  671 + ;; (when-let (fun (plist-get args ':init-function))
  672 +;; (funcall fun))
  673 + )
  674 + (message "Connected.")))
  675 +
  676 +(defun scion-check-version (version conn)
  677 + (or (equal version scion-protocol-version)
  678 + (equal scion-protocol-version 'ignore)
  679 + (y-or-n-p
  680 + (format "Versions differ: %s (scion) vs. %s (swank). Continue? "
  681 + scion-protocol-version version))
  682 + (scion-net-close conn)
  683 + (top-level)))
  684 +
  685 +(defun scion-generate-connection-name (lisp-name)
  686 + (loop for i from 1
  687 + for name = lisp-name then (format "%s<%d>" lisp-name i)
  688 + while (find name scion-net-processes
  689 + :key #'scion-connection-name :test #'equal)
  690 + finally (return name)))
  691 +
  692 +(defun scion-connection-close-hook (process)
  693 + (when (eq process scion-default-connection)
  694 + (when scion-net-processes
  695 + (scion-select-connection (car scion-net-processes))
  696 + (message "Default connection closed; switched to #%S (%S)"
  697 + (scion-connection-number)
  698 + (scion-connection-name)))))
  699 +
  700 +(add-hook 'scion-net-process-close-hooks 'scion-connection-close-hook)
  701 +
  702 +;;;;; Commands on connections
  703 +
  704 +(defun scion-disconnect ()
  705 + "Disconnect all connections."
  706 + (interactive)
  707 + (mapc #'scion-net-close scion-net-processes))
  708 +
  709 +(defun scion-connection-port (connection)
  710 + "Return the remote port number of CONNECTION."
  711 + (if (featurep 'xemacs)
  712 + (car (process-id connection))
  713 + (cadr (process-contact connection))))
  714 +
  715 +(defun scion-process (&optional connection)
  716 + "Return the Lisp process for CONNECTION (default `scion-connection').
  717 +Can return nil if there's no process object for the connection."
  718 + (let ((proc (scion-inferior-process connection)))
  719 + (if (and proc
  720 + (memq (process-status proc) '(run stop)))
  721 + proc)))
  722 +
  723 +;; Non-macro version to keep the file byte-compilable.
  724 +(defun scion-set-inferior-process (connection process)
  725 + (setf (scion-inferior-process connection) process))
  726 +
  727 +(defun scion-use-sigint-for-interrupt (&optional connection)
  728 + (let ((c (or connection (scion-connection))))
  729 + (ecase (scion-communication-style c)
  730 + ((:fd-handler nil) t)
  731 + ((:spawn :sigio) nil))))
  732 +
  733 +(defvar scion-inhibit-pipelining t
  734 + "*If true, don't send background requests if Lisp is already busy.")
  735 +
  736 +(defun scion-background-activities-enabled-p ()
  737 + (and (or scion-mode
  738 + (eq major-mode 'sldb-mode)
  739 + (eq major-mode 'scion-repl-mode))
  740 + (let ((con (scion-current-connection)))
  741 + (and con
  742 + (eq (process-status con) 'open)))
  743 + (or (not (scion-busy-p))
  744 + (not scion-inhibit-pipelining))))
  745 +
  746 +
  747 +;;;; Communication protocol
  748 +
  749 +;;;;; Emacs Lisp programming interface
  750 +;;;
  751 +;;; The programming interface for writing Emacs commands is based on
  752 +;;; remote procedure calls (RPCs). The basic operation is to ask Lisp
  753 +;;; to apply a named Lisp function to some arguments, then to do
  754 +;;; something with the result.
  755 +;;;
  756 +;;; Requests can be either synchronous (blocking) or asynchronous
  757 +;;; (with the result passed to a callback/continuation function). If
  758 +;;; an error occurs during the request then the debugger is entered
  759 +;;; before the result arrives -- for synchronous evaluations this
  760 +;;; requires a recursive edit.
  761 +;;;
  762 +;;; You should use asynchronous evaluations (`scion-eval-async') for
  763 +;;; most things. Reserve synchronous evaluations (`scion-eval') for
  764 +;;; the cases where blocking Emacs is really appropriate (like
  765 +;;; completion) and that shouldn't trigger errors (e.g. not evaluate
  766 +;;; user-entered code).
  767 +;;;
  768 +;;; We have the concept of the "current Lisp package". RPC requests
  769 +;;; always say what package the user is making them from and the Lisp
  770 +;;; side binds that package to *BUFFER-PACKAGE* to use as it sees
  771 +;;; fit. The current package is defined as the buffer-local value of
  772 +;;; `scion-buffer-package' if set, and otherwise the package named by
  773 +;;; the nearest IN-PACKAGE as found by text search (first backwards,
  774 +;;; then forwards).
  775 +;;;
  776 +;;; Similarly we have the concept of the current thread, i.e. which
  777 +;;; thread in the Lisp process should handle the request. The current
  778 +;;; thread is determined solely by the buffer-local value of
  779 +;;; `scion-current-thread'. This is usually bound to t meaning "no
  780 +;;; particular thread", but can also be used to nominate a specific
  781 +;;; thread. The REPL and the debugger both use this feature to deal
  782 +;;; with specific threads.
  783 +
  784 +(make-variable-buffer-local
  785 + (defvar scion-current-thread t
  786 + "The id of the current thread on the Lisp side.
  787 +t means the \"current\" thread;
  788 +:repl-thread the thread that executes REPL requests;
  789 +fixnum a specific thread."))
  790 +
  791 +(make-variable-buffer-local
  792 + (defvar scion-buffer-package nil
  793 + "The Lisp package associated with the current buffer.
  794 +This is set only in buffers bound to specific packages."))
  795 +
  796 +
  797 +(defmacro* when-let ((var value) &rest body)
  798 + "Evaluate VALUE, and if the result is non-nil bind it to VAR and
  799 +evaluate BODY.
  800 +
  801 +\(fn (VAR VALUE) &rest BODY)"
  802 + `(let ((,var ,value))
  803 + (when ,var ,@body)))
  804 +
  805 +
  806 +(defun scion-current-package ()
  807 + nil)
  808 +
  809 +(defun scion-eval-async (sexp &optional cont package)
  810 + "Evaluate EXPR on the superior Lisp and call CONT with the result."
  811 + (scion-rex (cont (buffer (current-buffer)))
  812 + (sexp (or package (scion-current-package)))
  813 + ((:ok result)
  814 + (when cont
  815 + (set-buffer buffer)
  816 + (funcall cont result)))
  817 + ((:abort)
  818 + (message "Evaluation aborted."))))
  819 +
  820 +
  821 +
  822 +
  823 +;;; `scion-rex' is the RPC primitive which is used to implement both
  824 +;;; `scion-eval' and `scion-eval-async'. You can use it directly if
  825 +;;; you need to, but the others are usually more convenient.
  826 +
  827 +(defmacro* scion-rex ((&rest saved-vars)
  828 + (sexp &optional
  829 + (package '(scion-current-package))
  830 + (thread 'scion-current-thread))
  831 + &rest continuations)
  832 + "(scion-rex (VAR ...) (SEXP &optional PACKAGE THREAD) CLAUSES ...)
  833 +
  834 +Remote EXecute SEXP.
  835 +
  836 +VARs are a list of saved variables visible in the other forms. Each
  837 +VAR is either a symbol or a list (VAR INIT-VALUE).
  838 +
  839 +SEXP is evaluated and the princed version is sent to Lisp.
  840 +
  841 +PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package.
  842 +The default value is (scion-current-package).
  843 +
  844 +CLAUSES is a list of patterns with same syntax as
  845 +`destructure-case'. The result of the evaluation of SEXP is
  846 +dispatched on CLAUSES. The result is either a sexp of the
  847 +form (:ok VALUE) or (:abort). CLAUSES is executed
  848 +asynchronously.
  849 +
  850 +Note: don't use backquote syntax for SEXP, because Emacs20 cannot
  851 +deal with that."
  852 + (let ((result (gensym)))
  853 + `(lexical-let ,(loop for var in saved-vars
  854 + collect (etypecase var
  855 + (symbol (list var var))
  856 + (cons var)))
  857 + (scion-dispatch-event
  858 + (list :emacs-rex ,sexp ,package ,thread
  859 + (lambda (,result)
  860 + (destructure-case ,result
  861 + ,@continuations)))))))
  862 +
  863 +;;;;; Protocol event handler (the guts)
  864 +;;;
  865 +;;; This is the protocol in all its glory. The input to this function
  866 +;;; is a protocol event that either originates within Emacs or arrived
  867 +;;; over the network from Lisp.
  868 +;;;
  869 +;;; Each event is a list beginning with a keyword and followed by
  870 +;;; arguments. The keyword identifies the type of event. Events
  871 +;;; originating from Emacs have names starting with :emacs- and events
  872 +;;; from Lisp don't.
  873 +
  874 +(scion-def-connection-var scion-rex-continuations '()
  875 + "List of (ID . FUNCTION) continuations waiting for RPC results.")
  876 +
  877 +(scion-def-connection-var scion-continuation-counter 0
  878 + "Continuation serial number counter.")
  879 +
  880 +(defvar scion-event-hooks)
  881 +
  882 +(defun scion-dispatch-event (event &optional process)
  883 + (let ((scion-dispatching-connection (or process (scion-connection))))
  884 + (or (run-hook-with-args-until-success 'scion-event-hooks event)
  885 + (destructure-case event
  886 + ((:write-string output &optional target)
  887 + (scion-write-string output target))
  888 + ((:emacs-rex form package thread continuation)
  889 + (when (and (scion-use-sigint-for-interrupt) (scion-busy-p))
  890 + (scion-display-oneliner "; pipelined request... %S" form))
  891 + (let ((id (incf (scion-continuation-counter))))
  892 + (push (cons id continuation) (scion-rex-continuations))
  893 + (scion-send `(:emacs-rex ,form
  894 + ;,package ,thread
  895 + ,id))))
  896 + ((:return value id)
  897 + (let ((rec (assq id (scion-rex-continuations))))
  898 + (cond (rec (setf (scion-rex-continuations)
  899 + (remove rec (scion-rex-continuations)))
  900 + (funcall (cdr rec) value))
  901 + (t
  902 + (error "Unexpected reply: %S %S" id value)))))
  903 + ;; ((:debug-activate thread level &optional select)
  904 +;; (assert thread)
  905 +;; (sldb-activate thread level select))
  906 + ;; ((:debug thread level condition restarts frames conts)
  907 +;; (assert thread)
  908 +;; (sldb-setup thread level condition restarts frames conts))
  909 + ;; ((:debug-return thread level stepping)
  910 +;; (assert thread)
  911 +;; (sldb-exit thread level stepping))
  912 + ((:emacs-interrupt thread)
  913 + (scion-send `(:emacs-interrupt ,thread)))
  914 + ((:read-string thread tag)
  915 + (assert thread)
  916 + (scion-repl-read-string thread tag))
  917 + ;; ((:y-or-n-p thread tag question)
  918 +;; (scion-y-or-n-p thread tag question))
  919 + ;; ((:read-aborted thread tag)
  920 +;; (assert thread)
  921 +;; (scion-repl-abort-read thread tag))
  922 + ((:emacs-return-string thread tag string)
  923 + (scion-send `(:emacs-return-string ,thread ,tag ,string)))
  924 + ;;
  925 + ;; ((:new-package package prompt-string)
  926 +;; (setf (scion-lisp-package) package)
  927 +;; (setf (scion-lisp-package-prompt-string) prompt-string))
  928 + ;; ((:new-features features)
  929 +;; (setf (scion-lisp-features) features))
  930 + ;; ((:indentation-update info)
  931 +;; (scion-handle-indentation-update info))
  932 + ;; ((:open-dedicated-output-stream port)
  933 +;; (scion-open-stream-to-lisp port))
  934 + ((:eval-no-wait fun args)
  935 + (apply (intern fun) args))
  936 + ((:eval thread tag form-string)
  937 + (scion-check-eval-in-emacs-enabled)
  938 + (scion-eval-for-lisp thread tag form-string))
  939 + ((:emacs-return thread tag value)
  940 + (scion-send `(:emacs-return ,thread ,tag ,value)))
  941 + ;; ((:ed what)
  942 +;; (scion-ed what))
  943 + ;; ((:inspect what)
  944 +;; (scion-open-inspector what))
  945 + ;; ((:background-message message)
  946 +;; (scion-background-message "%s" message))
  947 + ;; ((:debug-condition thread message)
  948 +;; (assert thread)
  949 +;; (message "%s" message))
  950 + ((:ping thread tag)
  951 + (scion-send `(:emacs-pong ,thread ,tag)))
  952 + ;; ((:reader-error packet condition)
  953 +;; (scion-with-popup-buffer ("*Scion Error*")
  954 +;; (princ (format "Invalid protocol message:\n%s\n\n%S"
  955 +;; condition packet))
  956 +;; (goto-char (point-min)))
  957 +;; (error "Invalid protocol message"))
  958 + ))))
  959 +
  960 +(defun scion-send (sexp)
  961 + "Send SEXP directly over the wire on the current connection."
  962 + (scion-net-send sexp (scion-connection)))
  963 +
  964 +(defun scion-use-sigint-for-interrupt (&optional connection)
  965 + ;; (let ((c (or connection (scion-connection))))
  966 +;; (ecase (scion-communication-style c)
  967 +;; ((:fd-handler nil) t)
  968 +;; ((:spawn :sigio) nil)))
  969 + nil
  970 + )
  971 +
  972 +(defun scion-busy-p (&optional conn)
  973 + "True if Haskell has outstanding requests.
  974 +Debugged requests are ignored."
  975 + ;; (let ((debugged (sldb-debugged-continuations (or conn (scion-connection)))))
  976 +;; (remove-if (lambda (id)
  977 +;; (memq id debugged))
  978 +;; (scion-rex-continuations)
  979 +;; :key #'car))
  980 + nil
  981 + )
  982 +
  983 +
  984 +(defun scion-display-oneliner (format-string &rest format-args)
  985 + (let* ((msg (apply #'format format-string format-args)))
  986 + (unless (minibuffer-window-active-p (minibuffer-window))
  987 + (message "%s" (scion-oneliner msg)))))
  988 +
  989 +(defun scion-oneliner (string)
  990 + "Return STRING truncated to fit in a single echo-area line."
  991 + (substring string 0 (min (length string)
  992 + (or (position ?\n string) most-positive-fixnum)
  993 + (1- (frame-width)))))
  994 +
  995 +(defun scion-curry (fun &rest args)
  996 + `(lambda (&rest more) (apply ',fun (append ',args more))))
  997 +
  998 +(defun scion-rcurry (fun &rest args)
  999 + `(lambda (&rest more) (apply ',fun (append more ',args))))
  1000 +
  1001 +
  1002 +
  1003 +;;;;; Event logging to *scion-events*
  1004 +;;;
  1005 +;;; The *scion-events* buffer logs all protocol messages for debugging
  1006 +;;; purposes. Optionally you can enable outline-mode in that buffer,
  1007 +;;; which is convenient but slows things down significantly.
  1008 +
  1009 +(defvar scion-log-events t
  1010 + "*Log protocol events to the *scion-events* buffer.")
  1011 +
  1012 +(defvar scion-outline-mode-in-events-buffer nil
  1013 + "*Non-nil means use outline-mode in *scion-events*.")
  1014 +
  1015 +(defvar scion-event-buffer-name "*scion-events*"
  1016 + "The name of the scion event buffer.")
  1017 +
  1018 +(defun scion-log-event (event)
  1019 + "Record the fact that EVENT occurred."
  1020 + (when scion-log-events
  1021 + (with-current-buffer (scion-events-buffer)
  1022 + ;; trim?
  1023 + (when (> (buffer-size) 100000)
  1024 + (goto-char (/ (buffer-size) 2))
  1025 + (re-search-forward "^(" nil t)
  1026 + (delete-region (point-min) (point)))
  1027 + (goto-char (point-max))
  1028 + (save-excursion
  1029 + (scion-pprint-event event (current-buffer)))
  1030 + (when (and (boundp 'outline-minor-mode)
  1031 + outline-minor-mode)
  1032 + (hide-entry))
  1033 + (goto-char (point-max)))))
  1034 +
  1035 +(defun scion-pprint-event (event buffer)
  1036 + "Pretty print EVENT in BUFFER with limited depth and width."
  1037 + (let ((print-length 20)
  1038 + (print-level 6)
  1039 + (pp-escape-newlines t))
  1040 + (pp event buffer)))
  1041 +
  1042 +(defun scion-events-buffer ()
  1043 + (or (get-buffer scion-event-buffer-name)
  1044 + (let ((buffer (get-buffer-create scion-event-buffer-name)))
  1045 + (with-current-buffer buffer
  1046 + (buffer-disable-undo)
  1047 + (set (make-local-variable 'outline-regexp) "^(")
  1048 + (set (make-local-variable 'comment-start) ";")
  1049 + (set (make-local-variable 'comment-end) "")
  1050 + (when scion-outline-mode-in-events-buffer
  1051 + (outline-minor-mode)))
  1052 + buffer)))
88 src/Scion/Server/Emacs.hs
... ... @@ -1,20 +1,26 @@
1   -{-# LANGUAGE TypeSynonymInstances, BangPatterns #-}
  1 +{-# LANGUAGE BangPatterns, DeriveDataTypeable, ScopedTypeVariables, TypeFamilies #-}
2 2 module Scion.Server.Emacs where
3 3
4 4 import Scion.Server.Protocol
5 5
6 6 import MonadUtils
7 7
8   -import Numeric ( showHex )
9   -import qualified Data.ByteString.Char8 as S
10   ---import qualified Data.ByteString.Lazy.Char8 as L
  8 +import Data.Bits ( shiftL )
  9 +import Data.Char ( isHexDigit, digitToInt )
  10 +import Data.Data ( Typeable )
11 11 import Network ( listenOn, PortID(..) )
12 12 import Network.Socket hiding (send, sendTo, recv, recvFrom)
13 13 import Network.Socket.ByteString
  14 +import Numeric ( showHex, showInt )
  15 +import Prelude hiding ( log )
14 16 import System.IO.Error (catch, isEOFError)
15 17 import Text.ParserCombinators.ReadP
16   -import Data.Char ( isHexDigit, digitToInt )
17   -import Data.Bits ( shiftL )
  18 +import qualified Data.ByteString.Char8 as S
  19 +
  20 +import Control.Exception
  21 +
  22 +data SocketClosed = SocketClosed deriving (Show, Typeable)
  23 +instance Exception SocketClosed
18 24
19 25 runServer :: MonadIO m => m ()
20 26 runServer =
@@ -26,25 +32,28 @@ runServer =
26 32 loop sock
27 33 where
28 34 loop sock = do
29   - print "accepting"
  35 + log 4 "accepting"
30 36 (sock', addr) <- accept sock
31   - print "starting to serve"
  37 + log 4 "starting to serve"
32 38 more <- loop2 sock'
33   - print "done serving"
  39 + log 4 "done serving"
34 40 sClose sock'
35   - print "socket closed"
  41 + log 4 "socket closed"
36 42 if more then loop sock
37 43 else return ()
38 44
39   - loop2 sock = do
40   - r <- getRequest sock
41   - putStrLn $ "got request: " ++ show r
42   - case r of
43   - Nothing -> sendResponse sock RUnknown >> loop2 sock
44   - Just req
45   - | req == Stop -> return False
46   - | otherwise ->
47   - handleRequest req >>= sendResponse sock >> loop2 sock
  45 + -- returns False if server should be shut down,
  46 + -- returns True if socket was closed
  47 + loop2 sock =
  48 + handle (\(e :: SocketClosed) -> return True) $ do
  49 + r <- getRequest sock
  50 + --log 2 $ "got request: " ++ show r
  51 + case r of
  52 + Nothing -> sendResponse sock RUnknown >> loop2 sock
  53 + Just req
  54 + | RQuit <- req -> return False
  55 + | otherwise ->
  56 + handleRequest req >>= sendResponse sock >> loop2 sock
48 57
49 58 sendResponse sock r = do
50 59 let payload = S.pack (showResponse r)
@@ -60,18 +69,19 @@ myrecv sock len =
60 69 in System.IO.Error.catch (recv sock len) handler
61 70
62 71 -- | A message is a sequence of bytes, prefixed by the message length encoded
63   --- as a 3 character hexadecimal number.
  72 +-- as a 6 character hexadecimal number.
64 73 getRequest :: Socket -> IO (Maybe Request)
65 74 getRequest sock = do
66   - len_as_hex <- S.unpack `fmap` myrecv sock 3
  75 + len_as_hex <- S.unpack `fmap` myrecv sock 6
67 76 len <- case len_as_hex of
68   - [_,_,_] ->
  77 + [_,_,_,_,_,_] ->
69 78 case readP_to_S parseHex len_as_hex of
70 79 [(n, "")] -> return n
71   - _ -> error "Could not parse message header."
72   - _ -> error "Length header too short"
  80 + _ ->
  81 + error "Could not parse message header."
  82 + _ -> throwIO SocketClosed
73 83 payload <- myrecv sock len
74   - return $ parseRequest (S.unpack payload)
  84 + return $ parseRequest allCommands (S.unpack payload)
75 85
76 86 parseHex :: ReadP Int
77 87 parseHex = munch1 isHexDigit >>= return . go 0
@@ -80,7 +90,9 @@ parseHex = munch1 isHexDigit >>= return . go 0
80 90 go !r (c:cs) = go (r `shiftL` 4 + digitToInt c) cs
81 91
82 92 handleRequest :: Request -> IO Response
83   -handleRequest _ = return ROk
  93 +handleRequest (Rex r i) = do answer <- r
  94 + return (RReturn answer i)
  95 +--handleRequest _ = return ROk
84 96
85 97 {-
86 98 blockSize :: Int
@@ -95,9 +107,21 @@ handleMessage chunks =
95 107 return ()
96 108 -}
97 109 mkHeader :: Int -> String
98   -mkHeader len =
99   - case showHex len "" of
100   - s@[_] -> ' ':' ':s
101   - s@[_,_] -> ' ':s
102   - s@[_,_,_] -> s
103   - _ -> error "Message too big"
  110 +mkHeader len = reverse . take 6 $ reverse (showHex len "") ++ repeat '0'
  111 +
  112 +log :: MonadIO m => Int -> String -> m ()
  113 +log _ s = liftIO $ putStrLn s
  114 +
  115 +scionVersion :: Int
  116 +scionVersion = 1
  117 +
  118 +connInfo :: Command
  119 +connInfo = Command (string "connection-info" >> return c)
  120 + where
  121 + c = do let pid = 0
  122 + return $ parens (showString ":version" <+> showInt scionVersion <+>
  123 + showString ":pid" <+> showInt pid)
  124 + $ ""
  125 +
  126 +allCommands :: [Command]
  127 +allCommands = [ connInfo ]
65 src/Scion/Server/Protocol.hs
... ... @@ -1,3 +1,4 @@
  1 +{-# LANGUAGE ExistentialQuantification #-}
1 2 -- |
2 3 -- Module : Scion.Server.Protocol
3 4 -- Copyright : (c) Thomas Schilling 2008
@@ -15,60 +16,62 @@
15 16 module Scion.Server.Protocol where
16 17
17 18 import Text.ParserCombinators.ReadP
18   -import Data.Char ( isHexDigit, digitToInt )
  19 +import Data.Char ( isHexDigit, digitToInt, isDigit )
  20 +import Numeric ( showInt )
  21 +import Control.Monad ( liftM2 )
19 22
20 23 ------------------------------------------------------------------------------
21 24
22 25 -- TODO: Make these a typeclass?
23 26
24 27 data Request
25   - = Hello String
26   - | Stop
27   - | OpenProject String
28   - | TypeofId String
29   - deriving (Eq, Ord, Show, Read)
  28 + = Rex (IO String) Int -- Remote EXecute
  29 + | RQuit
30 30
31 31 data Response
32   - = ROk
  32 + = RReturn String Int
33 33 | RUnknown
34   - | RError String
35   - | RString String
36   - deriving (Eq, Ord, Show)
  34 + deriving Show
37 35
38 36 ------------------------------------------------------------------------------
39 37
40 38 -- * Parsing Requests
41 39
42   -parseRequest :: String -> Maybe Request
43   -parseRequest msg =
44   - case readP_to_S messageParser msg of