Permalink
Browse files

Start server support.

  • Loading branch information...
nominolo committed Oct 31, 2008
1 parent 35500f9 commit 2c070ad9f22f037e89a0f17e2425769f9fe5f990
Showing with 224 additions and 1 deletion.
  1. +1 −1 Makefile
  2. +20 −0 scion.cabal
  3. +103 −0 src/Scion/Server/Emacs.hs
  4. +100 −0 src/Scion/Server/Protocol.hs
View
@@ -9,7 +9,7 @@ $(SETUP): Setup.hs
$(HC) --make $<
configure:
- $(SETUP) configure --with-compiler=$(HC) --with-hc-pkg=$(PKG) --user -ftesting
+ $(SETUP) configure --with-compiler=$(HC) --with-hc-pkg=$(PKG) --user -ftesting -femacs
build:
$(SETUP) build
View
@@ -17,6 +17,10 @@ flag testing
description: Enable Debugging things like QuickCheck properties, etc.
default: False
+flag emacs
+ description: Build emacs-specific parts
+ default: True
+
library
build-depends: base == 4.*,
directory == 1.0.*,
@@ -34,6 +38,12 @@ library
build-depends: QuickCheck == 2.*
cpp-options: -DDEBUG
+ if flag(emacs)
+ build-depends: network >= 2.1 && < 2.3,
+ network-bytestring == 0.1.*,
+ bytestring == 0.9.*
+ exposed-modules: Scion.Server.Emacs
+
executable test_get_imports
main-is: GetImports.hs
hs-source-dirs: examples
@@ -69,3 +79,13 @@ executable test_thing_at_point
if flag(testing)
build-depends: QuickCheck == 2.*
cpp-options: -DDEBUG
+
+executable emacs_server
+ main-is: EmacsServer.hs
+ hs-source-dirs: programs src
+ if !flag(emacs)
+ buildable: False
+ other-modules: Scion.Server.Emacs
+ if flag(testing)
+ build-depends: QuickCheck == 2.*
+ cpp-options: -DDEBUG
View
@@ -0,0 +1,103 @@
+{-# LANGUAGE TypeSynonymInstances, BangPatterns #-}
+module Scion.Server.Emacs where
+
+import Scion.Server.Protocol
+
+import MonadUtils
+
+import Numeric ( showHex )
+import qualified Data.ByteString.Char8 as S
+--import qualified Data.ByteString.Lazy.Char8 as L
+import Network ( listenOn, PortID(..) )
+import Network.Socket hiding (send, sendTo, recv, recvFrom)
+import Network.Socket.ByteString
+import System.IO.Error (catch, isEOFError)
+import Text.ParserCombinators.ReadP
+import Data.Char ( isHexDigit, digitToInt )
+import Data.Bits ( shiftL )
+
+runServer :: MonadIO m => m ()
+runServer =
+ liftIO $
+ withSocketsDo $ do
+ print $ "starting up server..."
+ sock <- listenOn (PortNumber 4005)
+ print $ "listing on port 4005"
+ loop sock
+ where
+ loop sock = do
+ print "accepting"
+ (sock', addr) <- accept sock
+ print "starting to serve"
+ more <- loop2 sock'
+ print "done serving"
+ sClose sock'
+ print "socket closed"
+ if more then loop sock
+ else return ()
+
+ loop2 sock = do
+ r <- getRequest sock
+ putStrLn $ "got request: " ++ show r
+ case r of
+ Nothing -> sendResponse sock RUnknown >> loop2 sock
+ Just req
+ | req == Stop -> return False
+ | otherwise ->
+ handleRequest req >>= sendResponse sock >> loop2 sock
+
+ sendResponse sock r = do
+ let payload = S.pack (showResponse r)
+ let hdr = mkHeader (S.length payload)
+ send sock (S.pack hdr)
+ send sock payload
+ return ()
+
+myrecv sock 0 = return S.empty
+myrecv sock len =
+ let handler e | isEOFError e = return S.empty
+ | otherwise = ioError e
+ in System.IO.Error.catch (recv sock len) handler
+
+-- | A message is a sequence of bytes, prefixed by the message length encoded
+-- as a 3 character hexadecimal number.
+getRequest :: Socket -> IO (Maybe Request)
+getRequest sock = do
+ len_as_hex <- S.unpack `fmap` myrecv sock 3
+ len <- case len_as_hex of
+ [_,_,_] ->
+ case readP_to_S parseHex len_as_hex of
+ [(n, "")] -> return n
+ _ -> error "Could not parse message header."
+ _ -> error "Length header too short"
+ payload <- myrecv sock len
+ return $ parseRequest (S.unpack payload)
+
+parseHex :: ReadP Int
+parseHex = munch1 isHexDigit >>= return . go 0
+ where
+ go !r [] = r
+ go !r (c:cs) = go (r `shiftL` 4 + digitToInt c) cs
+
+handleRequest :: Request -> IO Response
+handleRequest _ = return ROk
+
+{-
+blockSize :: Int
+blockSize = 4 * 1024
+
+chunksToString :: [S.ByteString] -> String
+chunksToString = L.unpack . L.fromChunks
+
+handleMessage :: [S.ByteString] -> IO ()
+handleMessage chunks =
+ let str = chunksToString chunks in
+ return ()
+-}
+mkHeader :: Int -> String
+mkHeader len =
+ case showHex len "" of
+ s@[_] -> ' ':' ':s
+ s@[_,_] -> ' ':s
+ s@[_,_,_] -> s
+ _ -> error "Message too big"
@@ -0,0 +1,100 @@
+-- |
+-- Module : Scion.Server.Protocol
+-- Copyright : (c) Thomas Schilling 2008
+-- License : BSD-style
+--
+-- Maintainer : nominolo@gmail.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- Server message types and methods for serialising and deserialising them to
+-- strings.
+--
+-- TODO: Document protocol + message format.
+--
+module Scion.Server.Protocol where
+
+import Text.ParserCombinators.ReadP
+import Data.Char ( isHexDigit, digitToInt )
+
+------------------------------------------------------------------------------
+
+-- TODO: Make these a typeclass?
+
+data Request
+ = Hello String
+ | Stop
+ | OpenProject String
+ | TypeofId String
+ deriving (Eq, Ord, Show, Read)
+
+data Response
+ = ROk
+ | RUnknown
+ | RError String
+ | RString String
+ deriving (Eq, Ord, Show)
+
+------------------------------------------------------------------------------
+
+-- * Parsing Requests
+
+parseRequest :: String -> Maybe Request
+parseRequest msg =
+ case readP_to_S messageParser msg of
+ [(m, "")] -> Just m
+ [] -> Nothing
+ _ -> error "Ambiguous grammar for message. This is a bug."
+
+-- | At the moment messages are in a very simple Lisp-style format. This
+-- should also be easy to parse (and generate) for non-lisp clients.
+messageParser :: ReadP Request
+messageParser =
+ inParens $ choice
+ [ string "hello" >> sp >> Hello `fmap` getString
+ , string "type-of" >> sp >> TypeofId `fmap` getString
+ , string "hasta-la-vista" >> return Stop
+ ]
+
+inParens :: ReadP a -> ReadP a
+inParens = between (char '(') (char ')')
+
+getString :: ReadP String
+getString = decodeEscapes `fmap` (char '"' >> munchmunch False)
+ where
+ munchmunch had_backspace = do
+ c <- get
+ if c == '"' && not had_backspace
+ then return []
+ else do
+ (c:) `fmap` munchmunch (c == '\\')
+
+decodeEscapes :: String -> String
+decodeEscapes = id -- XXX
+
+-- | One or more spaces.
+sp :: ReadP ()
+sp = skipMany (char ' ')
+
+
+------------------------------------------------------------------------------
+
+-- * Writing Responses
+
+showResponse :: Response -> String
+showResponse r = shows' r ""
+ where
+ shows' ROk = showString "ok"
+ shows' RUnknown = showString "unknown"
+ shows' (RError e) = parens (showString "error" <+> putString e)
+ shows' (RString s) = putString s
+
+parens :: ShowS -> ShowS
+parens p = showChar '(' . p . showChar ')'
+
+putString :: String -> ShowS
+putString s = showString (show s)
+
+infixr 1 <+>
+(<+>) :: ShowS -> ShowS -> ShowS
+l <+> r = l . showChar ' ' . r

0 comments on commit 2c070ad

Please sign in to comment.