initial http server

Incomplete, but the client is able to connect and send messages which
get logged.

Split up debug-me.hs into Role/*

Switched from cereal to binary, since websockets operate on lazy
ByteStrings, and using cereal would involve a copy on every receive.

This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.

1 files changed, 88 insertions, 7 deletions

diff --git a/Server.hs b/Server.hs
index 5d919b8..37316c3 100644
--- a/Server.hs
+++ b/Server.hs
@@ -3,24 +3,105 @@
 module Server where
 
 import CmdLine
+import WebSockets
+import SessionID
+import Log
 
 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)
+import Control.Concurrent.STM
+import Control.Concurrent.STM.TMChan
+import Control.Concurrent.Async
+import qualified Data.Map as M
+import System.IO
+import Control.Exception
+import Data.Time.Clock.POSIX
 
 server :: ServerOpts -> IO ()
-server o = run (serverPort o) app
+server o = run (serverPort o) . app o =<< newServerState
 
-app :: Application
-app = websocketsOr WS.defaultConnectionOptions websocketApp webapp
+type ServerState = M.Map SessionID (TMChan Log)
+
+newServerState :: IO (TVar ServerState)
+newServerState = newTVarIO M.empty
+
+app :: ServerOpts -> TVar ServerState -> Application
+app o ssv = websocketsOr WS.defaultConnectionOptions (websocketApp o ssv) webapp
   where
 	webapp _ respond = respond $
 		responseLBS status400 [] "Not a WebSocket request"
 
-websocketApp :: WS.ServerApp
-websocketApp pending_conn = do
+websocketApp :: ServerOpts -> TVar ServerState -> WS.ServerApp
+websocketApp o ssv pending_conn = do
+	print ("new connection" :: String)
 	conn <- WS.acceptRequest pending_conn
-	WS.sendTextData conn ("Hello, client!" :: Text)
+	sendWireVersions conn
+	print ("new connection open" :: String)
+	-- wv <- negotiateWireVersion conn
+	-- print ("version negotiated" :: String, wv)
+	theirmode <- getMode conn
+	print ("Connected" :: String, theirmode)
+	case theirmode of
+		InitMode _ -> user o ssv conn
+		ConnectMode t -> case mkSessionID t of
+			Nothing -> error "Invalid session id!"
+			Just sid -> developer o ssv sid conn
+
+user :: ServerOpts -> TVar ServerState -> WS.Connection -> IO ()
+user o ssv conn = withSessionID (serverDirectory o) $ \(logh, sid) ->
+	bracket (setup sid) (cleanup sid) (go logh)
+  where
+	setup sid = do
+		bchan <- newBroadcastTMChanIO
+		atomically $ modifyTVar' ssv $ M.insert sid bchan
+		return bchan
+
+	cleanup sid bchan = atomically $ do
+		closeTMChan bchan
+		modifyTVar' ssv $ M.delete sid
+
+	go logh bchan = do
+		logchan <- atomically $ dupTMChan bchan
+		userchan <- atomically $ dupTMChan bchan
+		_ <- storelog logh logchan
+			`concurrently` relaytouser userchan
+			`concurrently` relayfromuser bchan
+		return ()
+	
+	-- Read from logchan and store each value to the log file.
+	storelog logh logchan = do
+		v <- atomically $ readTMChan logchan
+		case v of
+			Nothing -> return ()
+			Just l -> do
+				writeLogHandle l logh
+				storelog logh logchan
+	
+	relaytouser userchan = relayToSocket conn $ do
+		v <- atomically $ readTMChan userchan
+		return $ case v of
+			Just l -> case loggedMessage l of
+				Developer m -> Just m
+				User _ -> Nothing
+			Nothing -> Nothing
+	
+	relayfromuser bchan = relayFromSocket conn $ \msg -> do
+		l <- mkLog (User msg) <$> getPOSIXTime
+		atomically $ writeTMChan bchan l
+
+developer ::  ServerOpts -> TVar ServerState -> SessionID -> WS.Connection -> IO ()
+developer o ssv sid conn = bracket setup cleanup go
+  where
+	setup = atomically $ M.lookup sid <$> readTVar ssv
+	cleanup _ = return ()
+	go Nothing = error "Invalid session id!"
+	go (Just logchan) = relayToSocket conn $ do
+		v <- atomically $ readTMChan logchan
+		return $ case v of
+			Just l -> case loggedMessage l of
+				User m -> Just m
+				Developer _ -> Nothing
+			Nothing -> Nothing