Permalink
Browse files

Use JSON as the external format.

Finding a suitable abstraction that works for a variety of protocols
is difficult.  Maintaining several protocols also probably isn't worth
the effort.  By using a single protocol we also keep the front-ends
completely independent of the server.  (Otherwise some front-ends may
end up broken with various versions of the server because some
protocol-specific patch didn't make it into the release.)

JSON is a simple and very widely supported protocol.  It doesn't fit
too well with Haskell's or Emacs' type system (e.g., ambiguous
encodings) but at least this Hydra has only one head.

ATM, the Emacs front-end is mostly broken because the commands are
often not encoded correctly, but the server itself should be fine.
  • Loading branch information...
1 parent 116dc71 commit d4b1e50d512b9c3138f741f881be7a665f78e4ce @nominolo committed Jun 22, 2009
Showing with 540 additions and 329 deletions.
  1. +3 −1 Makefile
  2. +79 −69 emacs/scion.el
  3. +19 −28 server/Main.hs
  4. +376 −220 server/Scion/Server/Commands.hs
  5. +6 −8 server/Scion/Server/ConnectionIO.hs
  6. +50 −0 server/Scion/Server/Generic.hs
  7. +7 −3 server/scion-server.cabal
View
@@ -1,4 +1,4 @@
-.PHONY: default clean install-lib install-deps
+.PHONY: default clean install-lib install-deps setup
default: all
all: build
@@ -56,6 +56,8 @@ $(SETUP): Setup.hs
@mkdir -p $(SETUP_DIST)
@$(HC) --make -odir $(SETUP_DIST) -hidir $(SETUP_DIST) -o $@ $<
+setup: $(SETUP)
+
build: $(DIST_LIB)/build/libHSscion-0.1.a $(DIST_SERVER)/build/scion_server/scion_server
# test: build
View
@@ -34,9 +34,11 @@
(eval-when (compile)
(require 'apropos)
(require 'outline)
+ (require 'json)
;; (require 'etags)
)
+
;;;---------------------------------------------------------------------------
;;;; Customize groups
;;
@@ -287,7 +289,7 @@ This is used for labels spanning multiple lines."
;;;---------------------------------------------------------------------------
-(defvar scion-program "scion_emacs"
+(defvar scion-program "scion_server"
"Program name of the Scion server.")
(defvar scion-last-compilation-result nil
@@ -526,8 +528,11 @@ See also `scion-net-valid-coding-systems'.")
"Send a SEXP to Lisp over the socket PROC.
This is the lowest level of communication. The sexp will be READ and
EVAL'd by Lisp."
- (let* ((msg (concat (scion-prin1-to-string sexp) "\n"))
- (string (concat (scion-net-encode-length (length msg)) msg))
+ (let* ((json-object-type 'plist)
+ (json-key-type 'keyword)
+ (json-array-type 'list)
+ (string (concat (json-encode sexp) "\n"))
+ ;; (string (concat (scion-net-encode-length (length msg)) msg))
(coding-system (cdr (process-coding-system proc))))
(scion-log-event sexp)
(cond ((scion-safe-encoding-p coding-system string)
@@ -591,8 +596,9 @@ EVAL'd by Lisp."
(defun scion-net-have-input-p ()
"Return true if a complete message is available."
(goto-char (point-min))
- (and (>= (buffer-size) 6)
- (>= (- (buffer-size) 6) (scion-net-decode-length))))
+ (if (= 0 (forward-line 1))
+ t
+ nil))
(defun scion-run-when-idle (function &rest args)
"Call FUNCTION as soon as Emacs is idle."
@@ -601,24 +607,25 @@ EVAL'd by Lisp."
nil function args))
(defun scion-net-read-or-lose (process)
- (condition-case error
+ (condition-case net-read-error
(scion-net-read)
- (error
- (debug)
+ (net-read-error
+ ;; (debug)
(scion-net-close process t)
- (error "net-read error: %S" error))))
+ (error "net-read error: %S" net-read-error))))
(defun scion-net-read ()
"Read a message from the network buffer."
(goto-char (point-min))
- (let* ((length (scion-net-decode-length))
- (start (+ 6 (point)))
- (end (+ start length)))
- (assert (plusp length))
- (prog1 (save-restriction
- (narrow-to-region start end)
- (read (current-buffer)))
- (delete-region (point-min) end))))
+ (let ((json-object-type 'plist)
+ (json-key-type 'keyword)
+ (json-array-type 'list))
+ (let* ((start (point))
+ (message (json-read))
+ (end (1+ (point))))
+ ;; TODO: handle errors somehow
+ (delete-region start end)
+ message)))
(defun scion-net-decode-length ()
"Read a 24-bit hex-encoded integer from buffer."
@@ -874,7 +881,7 @@ Bound in the connection's process-buffer.")
;; function may be called from a timer, and if we setup the REPL
;; from a timer then it mysteriously uses the wrong keymap for the
;; first command.
- (scion-eval-async '(connection-info)
+ (scion-eval-async '("connection-info")
(scion-curry #'scion-set-connection-info proc)))
(defun scion-set-connection-info (connection info)
@@ -1041,7 +1048,7 @@ Remote EXecute SEXP.
VARs are a list of saved variables visible in the other forms. Each
VAR is either a symbol or a list (VAR INIT-VALUE).
-SEXP is evaluated and the princed version is sent to Lisp.
+SEXP is evaluated and the printed version is sent to Lisp.
PACKAGE is evaluated and Lisp binds *BUFFER-PACKAGE* to this package.
The default value is (scion-current-package).
@@ -1054,18 +1061,20 @@ asynchronously.
Note: don't use backquote syntax for SEXP, because Emacs20 cannot
deal with that."
- (let ((result (gensym)))
+ (let ((result (gensym))
+ (gsexp (gensym)))
`(lexical-let ,(loop for var in saved-vars
collect (etypecase var
(symbol (list var var))
(cons var)))
- (scion-dispatch-event
- (list :emacs-rex ,sexp ,package ,thread
- (lambda (,result)
- (destructure-case ,result
- ,@continuations)))))))
-
-
+ (let ((,gsexp ,sexp))
+ (scion-dispatch-event
+ (list :method (car ,gsexp)
+ :params (cdr ,gsexp)
+ :package ,package
+ :continuation (lambda (,result)
+ (destructure-case ,result
+ ,@continuations))))))))
(defun scion-eval (sexp &optional package)
"Evaluate EXPR on the Scion server and return the result."
@@ -1083,6 +1092,8 @@ deal with that."
(error "Reply to canceled synchronous eval request tag=%S sexp=%S"
tag sexp))
(throw tag (list #'identity value)))
+ ((:error msg)
+ (throw tag (list #'error (format "Scion Eval Error: %s" msg))))
((:abort)
(throw tag (list #'error "Synchronous Remote Evaluation aborted"))))
(let ((debug-on-quit t)
@@ -1098,9 +1109,12 @@ deal with that."
(scion-rex (cont (buffer (current-buffer)))
(sexp (or package (scion-current-package)))
((:ok result)
+ (print result)
(when cont
(set-buffer buffer)
(funcall cont result)))
+ ((:error msg)
+ (message "Scion Eval Async: %s" msg))
((:abort)
(message "Evaluation aborted."))))
@@ -1128,46 +1142,42 @@ deal with that."
(defun scion-dispatch-event (event &optional process)
(let ((scion-dispatching-connection (or process (scion-connection))))
(or (run-hook-with-args-until-success 'scion-event-hooks event)
- (destructure-case event
-;; ((:write-string output &optional target)
-;; (scion-write-string output target))
- ((:emacs-rex form package thread continuation)
- (when (and (scion-use-sigint-for-interrupt) (scion-busy-p))
- (scion-display-oneliner "; pipelined request... %S" form))
- (let ((id (incf (scion-continuation-counter))))
- (push (cons id continuation) (scion-rex-continuations))
- (scion-send `(:emacs-rex ,form
- ;,package ,thread
- ,id))))
- ((:return value id)
- (let ((rec (assq id (scion-rex-continuations))))
- (cond (rec (setf (scion-rex-continuations)
- (remove rec (scion-rex-continuations)))
- (funcall (cdr rec) value))
- (t
- (error "Unexpected reply: %S %S" id value)))))
- ((:emacs-interrupt thread)
- (scion-send `(:emacs-interrupt ,thread)))
-;; ((:read-string thread tag)
-;; (assert thread)
-;; (scion-repl-read-string thread tag))
- ((:emacs-return-string thread tag string)
- (scion-send `(:emacs-return-string ,thread ,tag ,string)))
- ((:eval-no-wait fun args)
- (apply (intern fun) args))
-;; ((:eval thread tag form-string)
-;; (scion-check-eval-in-emacs-enabled)
-;; (scion-eval-for-lisp thread tag form-string))
- ((:emacs-return thread tag value)
- (scion-send `(:emacs-return ,thread ,tag ,value)))
- ((:ping thread tag)
- (scion-send `(:emacs-pong ,thread ,tag)))
- ((:reader-error packet condition)
- (scion-with-popup-buffer ("*Scion Error*")
- (princ (format "Invalid protocol message:\n%s\n\n%S"
- condition packet))
- (goto-char (point-min)))
- (error "Invalid protocol message"))))))
+ (destructuring-bind (&key method error result params id
+ continuation package
+ &allow-other-keys)
+ event
+ (cond
+ ((and method)
+ ;; we're trying to send a message
+ (when (and (scion-use-sigint-for-interrupt) (scion-busy-p))
+ (scion-display-oneliner "; pipelined request... %S" form))
+ (let ((id (incf (scion-continuation-counter))))
+ (push (cons id continuation) (scion-rex-continuations))
+ (scion-send `(:method ,method
+ :params ,params
+ :id ,id))))
+ ((and (or error result) id)
+ (let ((value nil))
+ (if error
+ (destructuring-bind (&key name message) error
+ (if (string= name "MalformedRequest")
+ (progn
+ (scion-with-popup-buffer ("*Scion Error*")
+ (princ (format "Invalid protocol message:\n%s"
+ event))
+ (goto-char (point-min)))
+ (error "Invalid protocol message"))
+ (setq value (list :error message))))
+ (setq value (list :ok result)))
+
+ ;; we're receiving the result of a remote call
+ (let ((rec (assq id (scion-rex-continuations))))
+ (print value)
+ (cond (rec (setf (scion-rex-continuations)
+ (remove rec (scion-rex-continuations)))
+ (funcall (cdr rec) value))
+ (t
+ (error "Unexpected reply: %S %S" id value)))))))))))
(defun scion-send (sexp)
"Send SEXP directly over the wire on the current connection."
@@ -1176,7 +1186,7 @@ deal with that."
(defun scion-stop-server ()
"Stop the server we are currently connected to."
(interactive)
- (scion-send '(:quit)))
+ (scion-send '(:method :quit :params nil :id -1)))
(defun scion-use-sigint-for-interrupt (&optional connection)
@@ -2323,7 +2333,7 @@ loaded."
(defun scion-load-component% (comp)
(message "Loading %s..." (scion-format-component comp))
- (scion-eval-async `(load ,comp)
+ (scion-eval-async `(load :component ,comp)
(scion-handling-failure (result)
(scion-report-compilation-result result))))
View
@@ -1,5 +1,6 @@
{-# LANGUAGE BangPatterns, DeriveDataTypeable, ScopedTypeVariables,
TypeFamilies, PatternGuards, CPP #-}
+{-# OPTIONS_GHC -Wall #-}
-- |
-- Module : Scion.Server.Emacs
-- License : BSD-style
@@ -21,6 +22,15 @@
-- concurrently.. Maybe using an MVar is an option (TODO)
module Main where
+
+import MonadUtils ( liftIO )
+import Scion.Server.Generic as Gen
+--import qualified Scion.Server.ProtocolEmacs as Emacs
+import qualified Scion.Server.Protocol.Vim as Vim
+import qualified Scion.Server.ConnectionIO as CIO
+import Scion (runScion)
+
+
import Prelude hiding ( log )
import System.Environment (getArgs, getProgName)
import System.Exit (exitSuccess)
@@ -35,17 +45,9 @@ import Network.Socket.ByteString
import Data.List (isPrefixOf, break)
import Data.Foldable (foldrM)
import qualified Control.Exception as E
-
-
import Control.Monad ( when, forever )
-
import System.Console.GetOpt
-import MonadUtils ( liftIO )
---import qualified Scion.Server.ProtocolEmacs as Emacs
-import qualified Scion.Server.Protocol.Vim as Vim
-import qualified Scion.Server.ConnectionIO as CIO
-import Scion (runScion)
log = HL.logM __FILE__
logInfo = log HL.INFO
@@ -79,10 +81,12 @@ options =
"client must connect to stdin and stdout"
#ifndef mingw32_HOST_OS
, Option ['s'] ["socketfile"]
- (ReqArg (\o opts -> return $ opts { connectionMode = Socketfile o}) "/tmp/scion-io")
+ (ReqArg (\o opts -> return $ opts { connectionMode = Socketfile o})
+ "/tmp/scion-io")
"listen on this socketfile"
#endif
- , Option ['h'] ["help"] (NoArg (\opts -> return $ opts { showHelp = True } )) "show this help"
+ , Option ['h'] ["help"] (NoArg (\opts -> return $ opts { showHelp = True } ))
+ "show this help"
, Option ['f'] ["log-file"] (ReqArg (\f opts -> do
fh <- HL.fileHandler f HL.DEBUG
@@ -102,6 +106,7 @@ helpText = do
serve :: ConnectionMode -> IO ()
serve (TCPIP nr) = do
sock <- liftIO $ listenOn (PortNumber nr)
+ putStrLn $ "=== Listening on port: " ++ show nr
forever $ E.handle (\(e::E.IOException) -> logInfo ("caught :" ++ (show e) ++ "\n\nwaiting for next client")) $ do
(sock', _addr) <- liftIO $ accept sock
sock_conn <- CIO.mkSocketConnection sock'
@@ -125,24 +130,9 @@ serve (Socketfile file) = do
-- does the handshaking and then runs the protocol implementation
handleClient :: (CIO.ConnectionIO con) => con -> IO ()
handleClient con = do
- logDebug $ "waiting for greeting"
- greeting <- CIO.getLine con
- logDebug $ "got greeting " ++ show greeting
- let prefix = S.pack "select scion-server protocol:"
- quit :: String -> IO ()
- quit msg = do
- CIO.putLine con (S.pack msg)
- logError msg
- handle :: String -> String -> IO ()
- handle "vim" v = runScion $ Vim.handle con v
- --handle "emacs" v = runScion $ Emacs.handle con v
- handle name _ = quit $ "unkown protocol type : " ++ name
-
- if S.isPrefixOf prefix greeting
- then let (a,b) = S.break (== ' ') (S.drop (S.length prefix) greeting)
- in handle (S.unpack a) (tail $ S.unpack b)
- else quit $ "prefix " ++ (show $ (S.unpack prefix)) ++ " expected, but got : " ++ (S.unpack greeting)
+ runScion $ Gen.handle con 0
+main :: IO ()
main = do
-- logging
@@ -151,7 +141,8 @@ main = do
-- cmd opts
(opts, nonOpts, err_msgs) <- fmap (getOpt Permute options) getArgs
- when ((not . null) nonOpts) $ logError $ "no additional arguments expected, got: " ++ (show nonOpts)
+ when ((not . null) nonOpts) $
+ logError $ "no additional arguments expected, got: " ++ (show nonOpts)
startupConfig <- foldrM ($) defaultStartupConfig opts
Oops, something went wrong.

0 comments on commit d4b1e50

Please sign in to comment.