Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
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...
commit d4b1e50d512b9c3138f741f881be7a665f78e4ce 1 parent 116dc71
@nominolo nominolo authored
View
4 Makefile
@@ -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
148 emacs/scion.el
@@ -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
47 server/Main.hs
@@ -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
View
596 server/Scion/Server/Commands.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE ScopedTypeVariables, CPP, PatternGuards #-}
+{-# LANGUAGE ScopedTypeVariables, CPP, PatternGuards,
+ ExistentialQuantification #-} -- for 'Cmd'
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module : Scion.Server.Commands
@@ -11,13 +12,17 @@
--
-- Commands provided by the server.
--
-module Scion.Server.Commands ( allCommands,
+-- TODO: Need some way to document the wire protocol. Autogenerate?
+--
+module Scion.Server.Commands (
+ handleRequest, malformedRequest, -- allCommands, allCommands',
-- these are reused in the vim interface
- supportedPragmas, allExposedModules
+ supportedPragmas, allExposedModules,
) where
import Prelude as P
import Scion.Types
+import Scion.Types.Notes
import Scion.Utils
import Scion.Session
import Scion.Server.Protocol
@@ -25,11 +30,11 @@ import Scion.Inspect
import Scion.Inspect.DefinitionSite
import Scion.Configure
+import DynFlags ( supportedLanguages, allFlags )
+import Exception
import FastString
import GHC
import PprTyThing ( pprTypeForUser )
-import Exception
-import DynFlags ( supportedLanguages, allFlags )
import Outputable ( ppr, showSDoc, showSDocDump, dcolon, showSDocForUser,
showSDocDebug )
import qualified Outputable as O ( (<+>), ($$) )
@@ -37,12 +42,14 @@ import qualified Outputable as O ( (<+>), ($$) )
import Control.Applicative
import Control.Monad
import Data.List ( nub )
-import Text.ParserCombinators.ReadP
-import qualified Data.Map as M
+import Data.Time.Clock ( NominalDiffTime )
import System.Exit ( ExitCode(..) )
+import Text.JSON
+import qualified Data.Map as M
+import qualified Data.MultiSet as MS
-import qualified Distribution.PackageDescription as PD
import Distribution.Text ( display )
+import qualified Distribution.PackageDescription as PD
import GHC.SYB.Utils
#ifndef HAVE_PACKAGE_DB_MODULES
@@ -54,36 +61,116 @@ import Distribution.InstalledPackageInfo
------------------------------------------------------------------------
-instance Applicative ReadP where
- pure x = return x
- x <*> y = x `ap` y
+lookupKey :: JSON a => JSObject JSValue -> String -> Result a
+lookupKey = flip valFromObj
+
+makeObject :: [(String, JSValue)] -> JSValue
+makeObject = makeObj
------------------------------------------------------------------------------
+type KeepGoing = Bool
+
+handleRequest :: JSValue -> ScionM (JSValue, KeepGoing)
+handleRequest (JSObject req) =
+ let request = do JSString method <- lookupKey req "method"
+ params <- lookupKey req "params"
+ seq_id <- lookupKey req "id"
+ return (fromJSString method, params, seq_id)
+ in
+ case request of
+ Error _ -> return (malformedRequest, True)
+ Ok (method, params, seq_id)
+ | method == "quit" -> return (makeObject
+ [("version", str "0.1")
+ ,("result", JSNull)
+ ,("id", seq_id)], False)
+ | otherwise ->
+ case M.lookup method allCmds of
+ Nothing -> return (unknownCommand seq_id, True)
+ Just (Cmd _ arg_parser) ->
+ decode_params params arg_parser seq_id
+ where
+ decode_params JSNull arg_parser seq_id =
+ decode_params (makeObject []) arg_parser seq_id
+ decode_params (JSObject args) arg_parser seq_id =
+ case unPa arg_parser args of
+ Left err -> return (paramParseError seq_id err, True)
+ Right act -> do
+ r <- handleScionException act
+ case r of
+ Error msg -> return (commandExecError seq_id msg, True)
+ Ok a ->
+ return (makeObject
+ [("version", str "0.1")
+ ,("id", seq_id)
+ ,("result", showJSON a)], True)
+ decode_params _ _ seq_id =
+ return (paramParseError seq_id "Params not an object", True)
+
+handleRequest _ = do
+ return (malformedRequest, True)
+
+malformedRequest :: JSValue
+malformedRequest = makeObject
+ [("version", str "0.1")
+ ,("error", makeObject
+ [("name", str "MalformedRequest")
+ ,("message", str "Request was not a proper request object.")])]
+
+unknownCommand :: JSValue -> JSValue
+unknownCommand seq_id = makeObject
+ [("version", str "0.1")
+ ,("id", seq_id)
+ ,("error", makeObject
+ [("name", str "UnknownCommand")
+ ,("message", str "The requested method is not supported.")])]
+
+paramParseError :: JSValue -> String -> JSValue
+paramParseError seq_id msg = makeObject
+ [("version", str "0.1")
+ ,("id", seq_id)
+ ,("error", makeObject
+ [("name", str "ParamParseError")
+ ,("message", str msg)])]
+
+commandExecError :: JSValue -> String -> JSValue
+commandExecError seq_id msg = makeObject
+ [("version", str "0.1")
+ ,("id", seq_id)
+ ,("error", makeObject
+ [("name", str "CommandFailed")
+ ,("message", str msg)])]
+
+allCmds :: M.Map String Cmd
+allCmds = M.fromList [ (cmdName c, c) | c <- allCommands ]
+
+------------------------------------------------------------------------
+
-- | All Commands supported by this Server.
-allCommands :: [Command]
+allCommands :: [Cmd]
allCommands =
[ cmdConnectionInfo
, cmdOpenCabalProject
, cmdConfigureCabalProject
, cmdLoadComponent
- , cmdCurrentComponent
- , cmdCurrentCabalFile
- , cmdListCabalComponents
, cmdListSupportedLanguages
, cmdListSupportedPragmas
, cmdListSupportedFlags
+ , cmdListCabalComponents
, cmdListRdrNamesInScope
, cmdListExposedModules
+ , cmdCurrentComponent
+ , cmdCurrentCabalFile
+ , cmdSetVerbosity
+ , cmdGetVerbosity
+ , cmdLoad
+ , cmdDumpSources
+ , cmdThingAtPoint
, cmdSetGHCVerbosity
, cmdBackgroundTypecheckFile
- , cmdForceUnload
, cmdAddCmdLineFlag
- , cmdThingAtPoint
- , cmdDumpSources
- , cmdLoad
- , cmdSetVerbosity
- , cmdGetVerbosity
+ , cmdForceUnload
, cmdDumpDefinedNames
, cmdDefinedNames
, cmdNameDefinitions
@@ -91,17 +178,11 @@ allCommands =
------------------------------------------------------------------------------
-toString :: Sexp s => s -> String
-toString s = toSexp s ""
-
-data OkErr a = Ok a | Error String
-instance Sexp a => Sexp (OkErr a) where
- toSexp (Ok a) = parens (showString ":ok " . toSexp a)
- toSexp (Error e) = parens (showString ":error " . toSexp e)
+type OkErr a = Result a
-- encode expected errors as proper return values
handleScionException :: ScionM a -> ScionM (OkErr a)
-handleScionException m = (((do
+handleScionException m = ((((do
r <- m
return (Ok r)
`gcatch` \(e :: SomeScionException) -> return (Error (show e)))
@@ -114,58 +195,190 @@ handleScionException m = (((do
`gcatch` \(e :: ExitCode) ->
-- client code may not exit the server!
return (Error (show e)))
+ `gcatch` \(e :: IOError) ->
+ return (Error (show e)))
-- `gcatch` \(e :: SomeException) ->
-- liftIO (print e) >> liftIO (throwIO e)
------------------------------------------------------------------------------
+newtype Pa a = Pa { unPa :: JSObject JSValue -> Either String a }
+instance Monad Pa where
+ return x = Pa $ \_ -> Right x
+ m >>= k = Pa $ \req ->
+ case unPa m req of
+ Left err -> Left err
+ Right a -> unPa (k a) req
+ fail msg = Pa $ \_ -> Left msg
+
+withReq :: (JSObject JSValue -> Pa a) -> Pa a
+withReq f = Pa $ \req -> unPa (f req) req
+
+reqArg' :: JSON a => String -> (a -> b) -> (b -> r) -> Pa r
+reqArg' name trans f = withReq $ \req ->
+ case lookupKey req name of
+ Error _ -> fail $ "required arg missing: " ++ name
+ Ok x ->
+ case readJSON x of
+ Error m -> fail $ "could not decode: " ++ name ++ " - " ++ m
+ Ok a -> return (f (trans a))
+
+optArg' :: JSON a => String -> b -> (a -> b) -> (b -> r) -> Pa r
+optArg' name dflt trans f = withReq $ \req ->
+ case lookupKey req name of
+ Error _ -> return (f dflt)
+ Ok x ->
+ case readJSON x of
+ Error n -> fail $ "could not decode: " ++ name ++ " - " ++ n
+ Ok a -> return (f (trans a))
+
+reqArg :: JSON a => String -> (a -> r) -> Pa r
+reqArg name f = reqArg' name id f
+
+optArg :: JSON a => String -> a -> (a -> r) -> Pa r
+optArg name dflt f = optArg' name dflt id f
+
+noArgs :: r -> Pa r
+noArgs = return
+
+infixr 1 <&>
+
+-- | Combine two arguments.
+--
+-- TODO: explain type
+(<&>) :: (a -> Pa b)
+ -> (b -> Pa c)
+ -> a -> Pa c
+a1 <&> a2 = \f -> do f' <- a1 f; a2 f'
+
+data Cmd = forall a. JSON a => Cmd String (Pa (ScionM a))
+
+cmdName :: Cmd -> String
+cmdName (Cmd n _) = n
+
+------------------------------------------------------------------------
+
-- | Used by the client to initialise the connection.
-cmdConnectionInfo :: Command
-cmdConnectionInfo = Command (string "connection-info" >> return (toString `fmap` c))
+cmdConnectionInfo :: Cmd
+cmdConnectionInfo = Cmd "connection-info" $ noArgs worker
where
- c = do let pid = 0
- return $ M.fromList
- [ (K "version", scionVersion)
- , (K "pid", pid)
- ]
+ worker = let pid = 0 :: Int in
+ return $ makeObject
+ [("version", showJSON scionVersion)
+ ,("pid", showJSON pid)]
-cmdOpenCabalProject :: Command
+cmdOpenCabalProject :: Cmd
cmdOpenCabalProject =
- Command (do string "open-cabal-project" >> sp
- root_dir <- getString
- dist_dir <- sp >> getString
- extra_args <- sp >> getString
- return (toString `fmap` cmd root_dir dist_dir (words extra_args)))
- where
- cmd path rel_dist extra_args = handleScionException $ do
- openOrConfigureCabalProject path rel_dist extra_args
- preprocessPackage rel_dist
- (display . PD.package) `fmap` currentCabalPackage
-
-cmdConfigureCabalProject :: Command
+ Cmd "open-cabal-project" $
+ reqArg' "root-dir" fromJSString <&>
+ optArg' "dist-dir" ".dist-scion" fromJSString <&>
+ optArg' "extra-args" "" fromJSString $ worker
+ where
+ worker root_dir dist_dir extra_args = do
+ openOrConfigureCabalProject root_dir dist_dir (words extra_args)
+ preprocessPackage dist_dir
+ (toJSString . display . PD.package) `fmap` currentCabalPackage
+
+cmdConfigureCabalProject :: Cmd
cmdConfigureCabalProject =
- Command (do string "configure-cabal-project" >> sp
- root_dir <- getString
- dist_dir <- sp >> getString
- extra_args <- sp >> getString
- return (toString `fmap` cmd root_dir dist_dir (words extra_args)))
+ Cmd "configure-cabal-project" $
+ reqArg' "root-dir" fromJSString <&>
+ optArg' "dist-dir" ".dist-scion" fromJSString <&>
+ optArg' "extra-args" "" fromJSString $ cmd
where
- cmd path rel_dist extra_args = handleScionException $ do
- configureCabalProject path rel_dist extra_args
+ cmd path rel_dist extra_args = do
+ configureCabalProject path rel_dist (words extra_args)
preprocessPackage rel_dist
- (display . PD.package) `fmap` currentCabalPackage
-
-cmdLoadComponent :: Command
+ (toJSString . display . PD.package) `fmap` currentCabalPackage
+
+instance JSON Component where
+ readJSON (JSObject obj)
+ | Ok JSNull <- lookupKey obj "library" = return Library
+ | Ok s <- lookupKey obj "executable" =
+ return $ Executable (fromJSString s)
+ | Ok s <- lookupKey obj "file" =
+ return $ File (fromJSString s)
+ readJSON _ = fail "component"
+
+ showJSON Library = makeObject [("library", JSNull)]
+ showJSON (Executable n) =
+ makeObject [("executable", JSString (toJSString n))]
+ showJSON (File n) =
+ makeObject [("file", JSString (toJSString n))]
+
+instance JSON CompilationResult where
+ showJSON (CompilationResult suc notes time) =
+ makeObject [("succeeded", JSBool suc)
+ ,("notes", showJSON notes)
+ ,("duration", showJSON time)]
+ readJSON (JSObject obj) = do
+ JSBool suc <- lookupKey obj "succeeded"
+ notes <- readJSON =<< lookupKey obj "notes"
+ dur <- readJSON =<< lookupKey obj "duration"
+ return (CompilationResult suc notes dur)
+ readJSON _ = fail "compilation-result"
+
+instance (Ord a, JSON a) => JSON (MS.MultiSet a) where
+ showJSON ms = showJSON (MS.toList ms)
+ readJSON o = MS.fromList <$> readJSON o
+
+instance JSON Note where
+ showJSON (Note note_kind loc msg) =
+ makeObject [("kind", showJSON note_kind)
+ ,("location", showJSON loc)
+ ,("message", JSString (toJSString msg))]
+ readJSON (JSObject obj) = do
+ note_kind <- readJSON =<< lookupKey obj "kind"
+ loc <- readJSON =<< lookupKey obj "location"
+ JSString s <- lookupKey obj "message"
+ return (Note note_kind loc (fromJSString s))
+ readJSON _ = fail "note"
+
+str :: String -> JSValue
+str = JSString . toJSString
+
+instance JSON NoteKind where
+ showJSON ErrorNote = JSString (toJSString "error")
+ showJSON WarningNote = JSString (toJSString "warning")
+ showJSON InfoNote = JSString (toJSString "info")
+ showJSON OtherNote = JSString (toJSString "other")
+ readJSON (JSString s) =
+ case lookup (fromJSString s)
+ [("error", ErrorNote), ("warning", WarningNote)
+ ,("info", InfoNote), ("other", OtherNote)]
+ of Just x -> return x
+ Nothing -> fail "note-kind"
+ readJSON _ = fail "note-kind"
+
+instance JSON Location where
+ showJSON loc | (src, l0, c0, l1, c1) <- viewLoc loc =
+ makeObject [case src of
+ FileSrc f -> ("file", str (show f))
+ OtherSrc s -> ("other", str s)
+ ,("region", JSArray (map showJSON [l0,c0,l1,c1]))]
+ readJSON (JSObject obj) = do
+ src <- (do JSString f <- lookupKey obj "file"
+ return (FileSrc (mkAbsFilePath "/" (fromJSString f))))
+ <|>
+ (do JSString s <- lookupKey obj "other"
+ return (OtherSrc (fromJSString s)))
+ JSArray ls <- lookupKey obj "region"
+ case mapM readJSON ls of
+ Ok [l0,c0,l1,c1] -> return (mkLocation src l0 c0 l1 c1)
+ _ -> fail "region"
+ readJSON _ = fail "location"
+
+instance JSON NominalDiffTime where
+ showJSON t = JSRational True (fromRational (toRational t))
+ readJSON (JSRational _ n) = return $ fromRational (toRational n)
+ readJSON _ = fail "diff-time"
+
+cmdLoadComponent :: Cmd
cmdLoadComponent =
- Command $ do
- string "load-component" >> sp
- comp <- choice
- [ string "library" >> return Library
- , inParens $
- string "executable" >> liftM Executable (getString)]
- return (toString `fmap` cmd comp)
+ Cmd "load-component" $
+ reqArg "component" $ cmd
where
- cmd comp = handleScionException $ do
+ cmd comp = do
loadComponent comp
instance Sexp CompilationResult where
@@ -177,17 +390,13 @@ instance Sexp CompilationResult where
toSexp (ExactSexp (showString (show
(fromRational (toRational time) :: Float))))
-cmdListSupportedLanguages :: Command
-cmdListSupportedLanguages =
- Command $ do
- string "list-supported-languages"
- return (return (toString (Lst supportedLanguages)))
+cmdListSupportedLanguages :: Cmd
+cmdListSupportedLanguages = Cmd "list-supported-languages" $ noArgs cmd
+ where cmd = return (map toJSString supportedLanguages)
-cmdListSupportedPragmas :: Command
-cmdListSupportedPragmas =
- Command $ do
- string "list-supported-pragmas"
- return (return (toString (Lst supportedPragmas)))
+cmdListSupportedPragmas :: Cmd
+cmdListSupportedPragmas =
+ Cmd "list-supported-pragmas" $ noArgs $ return supportedPragmas
supportedPragmas :: [String]
supportedPragmas =
@@ -197,29 +406,21 @@ supportedPragmas =
, "LINE" -- XXX: only used by code generators, still include?
]
-cmdListSupportedFlags :: Command
+cmdListSupportedFlags :: Cmd
cmdListSupportedFlags =
- Command $ do
- string "list-supported-flags"
- return (return (toString (Lst (nub allFlags))))
+ Cmd "list-supported-flags" $ noArgs $ return (nub allFlags)
-cmdListRdrNamesInScope :: Command
+cmdListRdrNamesInScope :: Cmd
cmdListRdrNamesInScope =
- Command $ do
- string "list-rdr-names-in-scope"
- return $ do
- rdr_names <- getNamesInScope
- return (toString (Lst (map (showSDoc . ppr) rdr_names)))
-
+ Cmd "list-rdr-names-in-scope" $ noArgs $ cmd
+ where cmd = do
+ rdr_names <- getNamesInScope
+ return (map (showSDoc . ppr) rdr_names)
-cmdListCabalComponents :: Command
+cmdListCabalComponents :: Cmd
cmdListCabalComponents =
- Command $ do
- string "list-cabal-components" >> sp
- cabal_file <- getString
- return $
- toString `fmap` (handleScionException $
- Lst `fmap` cabalProjectComponents cabal_file)
+ Cmd "list-cabal-components" $ reqArg' "cabal-file" fromJSString $ cmd
+ where cmd cabal_file = cabalProjectComponents cabal_file
allExposedModules :: ScionM [ModuleName]
#ifdef HAVE_PACKAGE_DB_MODULES
@@ -232,60 +433,39 @@ allExposedModules = do
return $ P.concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
#endif
-cmdListExposedModules :: Command
-cmdListExposedModules =
- Command $ do
- string "list-exposed-modules"
- return $ do
- mod_names <- allExposedModules
- return $ toString $ Lst $
- map (showSDoc . ppr) mod_names
+cmdListExposedModules :: Cmd
+cmdListExposedModules = Cmd "list-exposed-modules" $ noArgs $ cmd
+ where cmd = do
+ mod_names <- allExposedModules
+ return $ map (showSDoc . ppr) mod_names
-cmdSetGHCVerbosity :: Command
+cmdSetGHCVerbosity :: Cmd
cmdSetGHCVerbosity =
- Command $ do
- string "set-ghc-verbosity" >> sp
- lvl <- getInt
- return $ do
- toString `fmap` setGHCVerbosity lvl
-
-cmdBackgroundTypecheckFile :: Command
-cmdBackgroundTypecheckFile =
- Command $ do
- string "background-typecheck-file" >> sp
- fname <- getString
- return $ do
- toString `fmap` (handleScionException $ backgroundTypecheckFile fname)
-
-cmdForceUnload :: Command
-cmdForceUnload =
- Command $ do
- string "force-unload"
- return $
- toString `fmap` (handleScionException $ unload)
-
-cmdAddCmdLineFlag :: Command
-cmdAddCmdLineFlag =
- Command $ do
- string "add-command-line-flag" >> sp
- str <- getString
- return $
- toString `fmap` (handleScionException $ addCmdLineFlags [str] >> return ())
-
-cmdThingAtPoint :: Command
+ Cmd "set-ghc-verbosity" $ reqArg "level" $ setGHCVerbosity
+
+cmdBackgroundTypecheckFile :: Cmd
+cmdBackgroundTypecheckFile =
+ Cmd "background-typecheck-file" $ reqArg' "file" fromJSString $ cmd
+ where cmd fname = backgroundTypecheckFile fname
+
+cmdForceUnload :: Cmd
+cmdForceUnload = Cmd "force-unload" $ noArgs $ unload
+
+cmdAddCmdLineFlag :: Cmd
+cmdAddCmdLineFlag =
+ Cmd "add-command-line-flag" $ reqArg' "flag" fromJSString $ cmd
+ where cmd flag = addCmdLineFlags [flag] >> return JSNull
+
+cmdThingAtPoint :: Cmd
cmdThingAtPoint =
- Command $ do
- string "thing-at-point" >> sp
- fname <- getString
- sp
- line <- getInt
- sp
- col <- getInt
- return $ toString `fmap` cmd fname line col
+ Cmd "thing-at-point" $
+ reqArg "file" <&> reqArg "line" <&> reqArg "column" $ cmd
where
- cmd fname line col = handleScionException $ do
+ cmd fname line col = do
let loc = srcLocSpan $ mkSrcLoc (fsLit fname) line col
tc_res <- gets bgTcCache
+ -- TODO: don't return something of type @Maybe X@. The default
+ -- serialisation sucks.
case tc_res of
Just (Typechecked tcm) -> do
--let Just (src, _, _, _, _) = renamedSource tcm
@@ -307,84 +487,60 @@ cmdThingAtPoint =
_ -> return (Just (showSDocDebug (ppr x O.$$ ppr xs )))
_ -> return Nothing
-cmdDumpSources :: Command
-cmdDumpSources =
- Command $ do
- string "dump-sources"
- return $ toString `fmap` cmd
- where cmd = handleScionException $ do
- tc_res <- gets bgTcCache
- case tc_res of
- Just (Typechecked tcm) -> do
- let Just (rn, _, _, _, _) = renamedSource tcm
- let tc = typecheckedSource tcm
- liftIO $ putStrLn $ showSDocDump $ ppr rn
- liftIO $ putStrLn $ showData TypeChecker 2 tc
- return ()
- _ -> return ()
-
-parseComponent :: ReadP Component
-parseComponent =
- choice [ Library <$ string ":library"
- , inParens $ Executable <$> (string ":executable" *> sp *> getString)
- , inParens $ File <$> (string ":file" *> sp *> getString)
- ]
-
-cmdLoad :: Command
-cmdLoad =
- Command $ do
- comp <- string "load" *> sp *> parseComponent
- return $ toString <$> (do
+cmdDumpSources :: Cmd
+cmdDumpSources = Cmd "dump-sources" $ noArgs $ cmd
+ where
+ cmd = do
+ tc_res <- gets bgTcCache
+ case tc_res of
+ Just (Typechecked tcm) -> do
+ let Just (rn, _, _, _, _) = renamedSource tcm
+ let tc = typecheckedSource tcm
+ liftIO $ putStrLn $ showSDocDump $ ppr rn
+ liftIO $ putStrLn $ showData TypeChecker 2 tc
+ return ()
+ _ -> return ()
+
+cmdLoad :: Cmd
+cmdLoad = Cmd "load" $ reqArg "component" $ cmd
+ where
+ cmd comp = do
liftIO (putStrLn $ "Loading " ++ show comp)
- handleScionException (loadComponent comp))
-
-cmdSetVerbosity :: Command
-cmdSetVerbosity =
- Command $ do
- v <- string "set-verbosity" *> sp *> getInt
- return $ toString <$> setVerbosity (intToVerbosity v)
-
-cmdGetVerbosity :: Command
-cmdGetVerbosity =
- Command $ do
- string "get-verbosity"
- return $ toString <$> verbosityToInt <$> getVerbosity
-
-cmdCurrentComponent :: Command
-cmdCurrentComponent =
- Command $ do
- string "current-component"
- return $ toString <$> getActiveComponent
-
-cmdCurrentCabalFile :: Command
-cmdCurrentCabalFile =
- Command $ do
- string "current-cabal-file"
- return $ toString <$> (do
- r <- gtry currentCabalFile
- case r of
- Right f -> return (Just f)
- Left (_::SomeScionException) -> return Nothing)
-
-cmdDumpDefinedNames :: Command
-cmdDumpDefinedNames =
- Command $ do
- string "dump-defined-names"
- return $ toString <$> ((do
- db <- gets defSiteDB
- liftIO $ putStrLn $ dumpDefSiteDB db))
+ loadComponent comp
-cmdDefinedNames :: Command
-cmdDefinedNames =
- Command $ do
- string "defined-names"
- return $ (toString . Lst . definedNames <$> gets defSiteDB)
+cmdSetVerbosity :: Cmd
+cmdSetVerbosity =
+ Cmd "set-verbosity" $ reqArg "level" $ cmd
+ where cmd v = setVerbosity (intToVerbosity v)
-cmdNameDefinitions :: Command
+cmdGetVerbosity :: Cmd
+cmdGetVerbosity = Cmd "get-verbosity" $ noArgs $ verbosityToInt <$> getVerbosity
+
+cmdCurrentComponent :: Cmd
+cmdCurrentComponent = Cmd "current-component" $ noArgs $ getActiveComponent
+
+cmdCurrentCabalFile :: Cmd
+cmdCurrentCabalFile = Cmd "current-cabal-file" $ noArgs $ cmd
+ where cmd = do
+ r <- gtry currentCabalFile
+ case r of
+ Right f -> return (showJSON f)
+ Left (_::SomeScionException) -> return JSNull
+
+cmdDumpDefinedNames :: Cmd
+cmdDumpDefinedNames = Cmd "dump-defined-names" $ noArgs $ cmd
+ where
+ cmd = do db <- gets defSiteDB
+ liftIO $ putStrLn $ dumpDefSiteDB db
+
+cmdDefinedNames :: Cmd
+cmdDefinedNames = Cmd "defined-names" $ noArgs $ cmd
+ where cmd = definedNames <$> gets defSiteDB
+
+cmdNameDefinitions :: Cmd
cmdNameDefinitions =
- Command $ do
- nm <- string "name-definitions" *> sp *> getString
- return $ toString <$> (do
- db <- gets defSiteDB
- let locs = map fst $ lookupDefSite db nm
- return (Lst locs))
+ Cmd "name-definitions" $ reqArg' "name" fromJSString $ cmd
+ where cmd nm = do
+ db <- gets defSiteDB
+ let locs = map fst $ lookupDefSite db nm
+ return locs
View
14 server/Scion/Server/ConnectionIO.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, ExistentialQuantification, MultiParamTypeClasses #-}
-- |
-- Module : Scion.Server.ConnectionIO
-- License : BSD-style
@@ -9,26 +9,24 @@
--
-- Abstraction over Socket and Handle IO.
-
module Scion.Server.ConnectionIO (
ConnectionIO(..), mkSocketConnection
) where
-import Control.Exception (throw, IOException, Exception)
--- import System.IO.Error (mkIOError, IOErrorType(..) )
import Prelude hiding (log)
-import System.IO (Handle, hClose, hPutStr, hPutStrLn, hFlush)
-import Control.Monad (when)
-import Network.Socket (Socket, sClose)
+import System.IO (Handle, hFlush)
+import Network.Socket (Socket)
import Network.Socket.ByteString (recv, send)
import Data.IORef
import qualified System.Log.Logger as HL
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
+log :: HL.Priority -> String -> IO ()
log = HL.logM "io.connection"
+
+logError :: String -> IO ()
logError = log HL.ERROR
-logWarning = log HL.WARNING
class ConnectionIO con where
getLine :: con -> IO L.ByteString
View
50 server/Scion/Server/Generic.hs
@@ -0,0 +1,50 @@
+module Scion.Server.Generic
+ ( handle
+ ) where
+
+import Prelude hiding ( log )
+
+import Scion
+import Scion.Server.ConnectionIO as CIO
+import Scion.Server.Commands
+
+import Text.JSON
+import qualified Data.ByteString.Lazy.Char8 as S
+import qualified Data.ByteString.Lazy.UTF8 as S
+import qualified System.Log.Logger as HL
+
+log :: HL.Priority -> String -> IO ()
+log = HL.logM "protocol.generic"
+logDebug :: MonadIO m => String -> m ()
+logDebug = liftIO . log HL.DEBUG
+
+
+handle :: (ConnectionIO con) =>
+ con
+ -> Int
+ -> ScionM ()
+handle con 0 = do
+ loop
+ where
+ loop = do
+ -- TODO: don't require line-based input
+ str <- liftIO $ CIO.getLine con
+ logDebug $ "parsing command: " ++ show str
+ let mb_req = decodeStrict (S.toString str)
+ (resp, keep_going)
+ <- case mb_req of
+ Error _ -> return (malformedRequest, True)
+ Ok req -> handleRequest req
+ let resp_str = encodeStrict resp
+ logDebug $ show resp_str
+ liftIO $ CIO.putLine con (S.fromString resp_str)
+ --logDebug $ "sent response"
+ if keep_going then loop else do
+ --logDebug "finished serving connection."
+ return ()
+
+handle con unknownVersion =
+ -- handshake failure, don't accept this client version
+ liftIO $ CIO.putLine con $
+ S.pack $ "failure: Don't know how to talk to client version "
+ ++ (show unknownVersion)
View
10 server/scion-server.cabal
@@ -11,7 +11,7 @@ category: Development
stability: provisional
build-type: Simple
cabal-version: >= 1.4
-extra-source-files: README.markdown emacs/scion.el
+extra-source-files: README.markdown ../emacs/scion.el
executable scion_server
main-is: Main.hs
@@ -21,15 +21,19 @@ executable scion_server
network-bytestring == 0.1.*,
containers == 0.2.*,
bytestring == 0.9.*,
+ utf8-string == 0.3.*,
ghc >= 6.10 && < 6.12,
ghc-syb == 0.1.*,
Cabal >= 1.5 && < 1.8,
scion == 0.1.*,
multiset == 0.1.*,
hslogger == 1.0.*,
- parsec == 2.1.*,
- time == 1.1.*
+ parsec == 3.0.*,
+ time == 1.1.*,
+ json == 0.4.*
other-modules: Scion.Server.Emacs,
Scion.Server.Commands,
Scion.Server.Protocol
+
+ ghc-options: -Wall
Please sign in to comment.
Something went wrong with that request. Please try again.