Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
182 lines (156 sloc) 6.16 KB
{-# LANGUAGE BangPatterns, DeriveDataTypeable, ScopedTypeVariables,
TypeFamilies, PatternGuards, CPP #-}
{-# OPTIONS_GHC -Wall #-}
-- |
-- 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 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)
import System.IO (stdin, stdout, hSetBuffering, hFlush, BufferMode(..))
import qualified System.Log.Logger as HL
import qualified System.Log.Handler.Simple as HL
import qualified System.Log.Handler.Syslog as HL
import qualified Data.ByteString.Lazy.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, liftM )
import System.Console.GetOpt
log = HL.logM __FILE__
logInfo = log HL.INFO
logDebug = log HL.DEBUG
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 Bool PortNumber -- the Bool indicates whether to scan
| StdInOut
#ifndef mingw32_HOST_OS
| Socketfile FilePath
#endif
deriving Show
data StartupConfig = StartupConfig {
connectionMode :: ConnectionMode,
autoPort :: Bool,
showHelp :: Bool
} deriving Show
defaultStartupConfig = StartupConfig (TCPIP False (fromInteger 4005)) False False
-- options :: [OptDescr (Options -> Options)]
options =
[ Option ['p'] ["port"]
(ReqArg (\o opts -> return $ opts { connectionMode = (TCPIP False . fromInteger) (read o) }) "8010")
"listen on this TCP port"
, Option ['a'] ["autoport"]
(NoArg (\opts -> return $ opts { autoPort = True }))
"scan until a free TCP port is found"
, Option ['i'] ["stdinout"]
(NoArg (\opts -> return $ opts { connectionMode = StdInOut}))
"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")
"listen on this socketfile"
#endif
, 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
HL.updateGlobalLogger "" (HL.addHandler fh)
return opts ) "/tmp/scion-log") "log to the given file"
]
initializeLogging = do
-- by default log everything to stdout
HL.updateGlobalLogger "" (HL.setLevel HL.DEBUG)
helpText = do
pN <- getProgName
let header = unlines [ "usage of scion server (executable :" ++ pN ++ ")" ]
return $ usageInfo header options
-- attempts to listen on each port in the list in turn, and returns the first successful
listenOnOneOf :: [PortID] -> IO Socket
listenOnOneOf (p:ps) = catch
(listenOn p)
(\(ex :: IOError) -> if null ps then E.throwIO ex else listenOnOneOf ps)
-- this way, we can iterate until we find a free port number
instance Bounded PortNumber where
minBound = 0
maxBound = 0xFFFF
serve :: ConnectionMode -> IO ()
serve (TCPIP auto nr) = do
sock <- liftIO $ if auto
then listenOnOneOf (map PortNumber [nr..maxBound])
else listenOn (PortNumber nr)
realNr <- liftIO $ socketPort sock
putStrLn $ "=== Listening on port: " ++ show realNr
hFlush stdout
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'
handleClient sock_conn
serve StdInOut = do
hSetBuffering stdout LineBuffering
hSetBuffering stdin LineBuffering
handleClient (stdin, stdout)
#ifndef mingw32_HOST_OS
serve (Socketfile file) = do
sock <- liftIO $ listenOn (UnixSocket file)
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
sock_conn <- CIO.mkSocketConnection sock'
handleClient sock_conn
#endif
-- does the handshaking and then runs the protocol implementation
handleClient :: (CIO.ConnectionIO con) => con -> IO ()
handleClient con = do
runScion $ Gen.handle con 0
fixConfig :: StartupConfig -> StartupConfig
fixConfig conf = case connectionMode conf of
TCPIP _ nr -> conf { connectionMode = TCPIP (autoPort conf) nr }
otherwise -> conf
main :: IO ()
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 <- return . fixConfig =<< 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)