http server scaffolding

4 files changed, 58 insertions, 5 deletions

diff --git a/CmdLine.hs b/CmdLine.hs
index cf9e2b7..2c71327 100644
--- a/CmdLine.hs
+++ b/CmdLine.hs
@@ -2,6 +2,7 @@ module CmdLine where
 
 import Data.Monoid
 import Options.Applicative
+import Network.Wai.Handler.Warp (Port)
 
 data CmdLine = CmdLine
 	{ mode :: Mode
@@ -11,6 +12,7 @@ data Mode
 	= Test 
 	| Graphviz GraphvizOpts
 	| Replay ReplayOpts
+	| Server ServerOpts
 
 data GraphvizOpts = GraphvizOpts
 	{ graphvizLogFile :: FilePath
@@ -21,13 +23,19 @@ data ReplayOpts = ReplayOpts
 	{ replayLogFile :: FilePath
 	}
 
+data ServerOpts = ServerOpts
+	{ serverDirectory :: FilePath
+	, serverPort :: Port
+	}
+
 parseCmdLine :: Parser CmdLine
 parseCmdLine = CmdLine <$> parseMode
 
 parseMode :: Parser Mode
 parseMode = (Graphviz <$> parsegraphviz)
 	<|> (Replay <$> parsereplay)
-	<|> pure Test
+	<|> (Server <$> parseserver)
+	<|> pure Test -- default, so last
   where
 	parsegraphviz = GraphvizOpts
 		<$> option str
@@ -45,6 +53,19 @@ parseMode = (Graphviz <$> parsegraphviz)
 			<> metavar "logfile"
 			<> help "replay log file"
 			)
+	parseserver = ServerOpts
+		<$> option str
+			( long "server"
+			<> metavar "logdir"
+			<> help "run server, storing logs in the specified directory"
+			)
+		<*> option auto
+			( long "port"
+			<> metavar "N"
+			<> value 8080
+			<> showDefault
+			<> help "port for server to listen on"
+			)
 
 getCmdLine :: IO CmdLine
 getCmdLine = execParser opts
diff --git a/Server.hs b/Server.hs
new file mode 100644
index 0000000..5d919b8
--- /dev/null
+++ b/Server.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Server where
+
+import CmdLine
+
+import Network.Wai
+import Network.Wai.Handler.Warp
+import Network.Wai.Handler.WebSockets
+import qualified Network.WebSockets as WS
+import Network.HTTP.Types
+import Data.Text (Text)
+
+server :: ServerOpts -> IO ()
+server o = run (serverPort o) app
+
+app :: Application
+app = websocketsOr WS.defaultConnectionOptions websocketApp webapp
+  where
+	webapp _ respond = respond $
+		responseLBS status400 [] "Not a WebSocket request"
+
+websocketApp :: WS.ServerApp
+websocketApp pending_conn = do
+	conn <- WS.acceptRequest pending_conn
+	WS.sendTextData conn ("Hello, client!" :: Text)
diff --git a/debug-me.cabal b/debug-me.cabal
index 5042ee3..f32f195 100644
--- a/debug-me.cabal
+++ b/debug-me.cabal
@@ -40,8 +40,11 @@ Executable debug-me
     , time (>= 1.6)
     , unbounded-delays (>= 0.1)
     , memory (>= 0.13)
-    --, websockets (>= 0.9)
-    --, wai-websockets (>= 3.0)
+    , warp (>= 3.2)
+    , wai (>= 3.2)
+    , http-types (>= 0.9)
+    , websockets (>= 0.9)
+    , wai-websockets (>= 3.0)
   Other-Modules:
     CmdLine
     Crypto
@@ -54,6 +57,7 @@ Executable debug-me
     Session
     Types
     Serialization
+    Server
     Val
 
 source-repository head
diff --git a/debug-me.hs b/debug-me.hs
index 5238b89..a17a740 100644
--- a/debug-me.hs
+++ b/debug-me.hs
@@ -12,6 +12,7 @@ import Graphviz
 import Replay
 import Session
 import Crypto
+import Server
 
 import Control.Concurrent
 import Control.Concurrent.Async
@@ -30,8 +31,9 @@ main = do
 	c <- getCmdLine
 	case mode c of
 		Test -> test
-		Graphviz g -> graphviz g
-		Replay r -> replay r
+		Graphviz o -> graphviz o
+		Replay o -> replay o
+		Server o -> server o
  
 test :: IO ()
 test = do