Permalink
Browse files

Start multi-protocol server.

  • Loading branch information...
1 parent 3b12f40 commit 197326180d3e282de88128861d14dcfd1b7be576 @MarcWeber MarcWeber committed with nominolo Jan 7, 2009
View
@@ -1,6 +1,154 @@
+{-# LANGUAGE BangPatterns, DeriveDataTypeable, ScopedTypeVariables,
+ TypeFamilies, PatternGuards, CPP #-}
+-- |
+-- Module : Scion.Server.Emacs
+-- License : BSD-style
+--
+-- Maintainer : marco-oweber@gmx.de
+-- Stability : pre-alpha
+-- Portability : portable
+--
+-- An example server which will talk to different backends
+-- The first handshake is done this way:
+-- The client sends : "select scion-server protocol: name version"
+-- where name and version specify the protocol to be used.
+-- the server replies in any case by either
+-- "ok\n" or "failure : message\n"
+-- From then on the specific protocol handler takes over control
+--
+-- multiple connections to the same server are not yet supported
+-- because I don't know yet in detail when ghc api calls can be made
+-- concurrently.. Maybe using an MVar is an option (TODO)
+
module Main where
+import Prelude hiding ( log )
+import System.Environment (getArgs, getProgName)
+import System.Exit (exitSuccess)
+import System.IO (stdin, stdout)
+import qualified System.Log.Logger as HL
+import qualified System.Log.Handler.Syslog as HL
+import qualified Data.ByteString.Char8 as S
+import Network ( listenOn, PortID(..) )
+import Network.Socket hiding (send, sendTo, recv, recvFrom)
+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.ProtocolVim as Vim
+import qualified Scion.Server.ConnectionIO as CIO
+import Scion (runScion)
+
+log = HL.logM __FILE__
+logInfo = log HL.INFO
+logError = log HL.ERROR
+
+-- how should the client connect to the server?
+-- if you're paranoid about your code Socketfile or StdInOut
+-- will be the most secure choice.. (Everyone can connect via TCP/IP at the
+-- moment)
+data ConnectionMode = TCPIP PortNumber
+ | StdInOut
+#ifndef mingw32_HOST_OS
+ | Socketfile FilePath
+#endif
+ deriving Show
+
+data StartupConfig = StartupConfig {
+ connectionMode :: ConnectionMode,
+ showHelp :: Bool
+ } deriving Show
+defaultStartupConfig = StartupConfig ( TCPIP (fromInteger 4005)) False
+
+-- options :: [OptDescr (Options -> Options)]
+options =
+ [ Option ['p'] ["port"]
+ (ReqArg (\o opts -> return $ opts { connectionMode = (TCPIP . fromInteger) (read o) }) "8010")
+ "listen on this TCP port"
+ , Option ['i'] ["stdinout"]
+ (NoArg (\opts -> return $ opts { connectionMode = StdInOut}))
+ "client must connect to stdin and stdout (untested)"
+#ifndef mingw32_HOST_OS
+ , Option ['s'] ["socketfile"]
+ (ReqArg (\o opts -> return $ opts { connectionMode = Socketfile o}) "/tmp/scion-io")
+ "listen on this socketfile (untested)"
+#endif
+ , Option ['h'] ["help"] (NoArg (\opts -> return $ opts { showHelp = True } )) "show this help"
+ ]
+
+initializeLogging = do
+ stdout <- HL.openlog "" [] HL.USER HL.DEBUG
+ HL.updateGlobalLogger "" (HL.addHandler stdout) -- add a default logger
+ HL.updateGlobalLogger "" (HL.setLevel HL.DEBUG)
+
+helpText = do
+ pN <- getProgName
+ let header = unlines [ "usage of scion server (executable :" ++ pN ++ ")" ]
+ return $ usageInfo header options
+
+serve :: ConnectionMode -> IO ()
+serve (TCPIP nr) = do
+ sock <- liftIO $ listenOn (PortNumber 4005)
+ (sock', _addr) <- liftIO $ accept sock
+ handleClient sock'
+serve StdInOut = handleClient (stdin, stdout)
+#ifndef mingw32_HOST_OS
+serve (Socketfile file) = do
+ sock <- liftIO $ listenOn (PortNumber 4005)
+ forever $ do
+ -- no multithreading for now (I don't know yet when it may be used.. the
+ -- ghc library is using some IO refs)
+ (sock', _addr) <- liftIO $ accept sock
+ handleClient sock'
+#endif
+
+
+-- does the handshaking and then runs the protocol implementation
+handleClient :: (CIO.ConnectionIO con) => con -> IO ()
+handleClient con = do
+ greeting <- CIO.getLine con
+ let prefix = S.pack "select scion-server protocol:"
+ quit :: String -> IO ()
+ quit msg = do
+ CIO.putLine con (S.pack msg)
+ logError msg
+ handle "vim" version = runScion $ Vim.handle con version
+ handle "emacs" version = runScion $ Emacs.handle con version
+ 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) (S.unpack b)
+ else quit $ "prefix " ++ (show $ (S.unpack prefix)) ++ " expected, but got : " ++ (S.unpack greeting)
+
+main = do
+
+ -- logging
+ initializeLogging
+
+ -- cmd opts
+ (opts, nonOpts, err_msgs) <- fmap (getOpt Permute options) getArgs
+
+ when ((not . null) nonOpts) $ logError $ "no additional arguments expected, got: " ++ (show nonOpts)
+
+ startupConfig <- foldrM ($) defaultStartupConfig opts
+
+ -- help
+ when (showHelp startupConfig) $ helpText >>= putStrLn >> exitSuccess
+
+ -- start server
+ logInfo "starting server"
+ -- E.handle (\(e :: SomeException) -> "shutting down server due to exception " ++ show e) $
+ do
+ log HL.DEBUG $ "opts: " ++ (show startupConfig)
+ serve (connectionMode startupConfig)
+
-import Scion
-import Scion.Server.Emacs
-main = runScion $ runServer
@@ -11,7 +11,10 @@
--
-- Commands provided by the server.
--
-module Scion.Server.Commands ( allCommands ) where
+module Scion.Server.Commands ( allCommands,
+ -- these are reused in the vim interface
+ supportedPragmas, allExposedModules
+) where
import Prelude as P
import Scion.Types
@@ -0,0 +1,64 @@
+{-# LANGUAGE FlexibleInstances #-}
+-- |
+-- Module : Scion.Server.ConnectionIO
+-- License : BSD-style
+--
+-- Maintainer : marco-oweber@gmx.de
+-- Stability : experimental
+-- Portability : portable
+--
+-- abstraction over Socket and Handle IO
+
+
+module Scion.Server.ConnectionIO (
+ ConnectionIO(..)
+)where
+import Control.Exception (throw, IOException, Exception)
+-- import System.IO.Error (mkIOError, IOErrorType(..) )
+import Prelude hiding (log)
+import System.IO (Handle, hClose, hPutStr, hPutStrLn)
+import Control.Monad (when)
+import Network.Socket (Socket, sClose)
+import Network.Socket.ByteString (recv, send)
+import qualified System.Log.Logger as HL
+import qualified Data.ByteString.Char8 as S
+
+log = HL.logM "__FILE__"
+logError = log HL.ERROR
+logWarning = log HL.WARNING
+
+class ConnectionIO con where
+ getLine :: con -> IO S.ByteString
+ getN :: con -> Int -> IO S.ByteString
+ put :: con -> S.ByteString -> IO ()
+ putLine :: con -> S.ByteString -> IO ()
+ putLine c s = put c s >> put c (S.singleton '\n')
+
+-- (stdin,stdout) implemenation
+instance ConnectionIO (Handle, Handle) where
+ getLine (i, _) = S.hGetLine i
+ getN (i,_) = S.hGet i
+ put (_,o) = S.hPutStr o
+ putLine (_,o) = S.hPutStrLn o
+
+-- Socket.ByteString implemenation
+instance ConnectionIO Socket where
+ getLine con =
+ -- not optimized. Does this matter, do we receive huge data chunks? (TODO)
+ let nl = (S.pack "\n")
+ gl got = do
+ c <- getN con 1
+ if c == nl then return got
+ else return $ S.concat [got, c] -- bad performance, memcpy !
+ in do b <- gl S.empty
+ when (S.length b > 1024) $
+ logWarning "received chunk bigger than 1k. Check performance of implementation"
+ return b
+ getN con len = recv con len
+ put con str = do
+ let l = S.length str
+ sent <- send con str
+ when (sent /= l) $ do
+ logError $ (show l) ++ " bytes to be sent but could only sent : " ++ (show sent)
+ -- is there a better excption which should be thrown instead? (TODO)
+ -- throw $ mkIOError ResourceBusy ("put in " ++ __FILE__) Nothing Nothing
Oops, something went wrong.

0 comments on commit 1973261

Please sign in to comment.