Implement basic server executable

server/Main.hs

@@ -1,2 +1,22 @@
+module Main where
+
+import qualified Network.WebSockets as WS
+
+import Forest.Server
+import Forest.TreeModule.ConstModule
+
+pingDelay :: Int
+pingDelay = 10
+
+pongDelay :: Int
+pongDelay = 3 * pingDelay
+
+options :: WS.ServerOptions
+options = WS.defaultServerOptions
+  { WS.serverRequirePong = Just pongDelay
+  }
+
 main :: IO ()
-main = putStrLn "There is only night."
+main = do
+  putStrLn "Starting server"
+  WS.runServerWithOptions options $ serverApp pingDelay constModule

src/Forest/Server.hs

@@ -5,6 +5,7 @@ module Forest.Server
   , serverApp
   ) where
 
+import Control.Monad
 import           Control.Concurrent.Async
 import           Control.Concurrent.Chan
 import           Data.Aeson
@@ -52,22 +53,23 @@ sendUpdatesThread conn nodeChan _ = do
 {- Main server application that receives and processes client packets -}
 
 receivePackets :: TreeModule a => WS.Connection -> a -> IO ()
-receivePackets conn treeModule = do
+receivePackets conn treeModule = forever $ do
   maybePacket <- receivePacket conn
   case maybePacket of
-    Just packet -> case packet of
+    Nothing -> pure ()
-      ClientEdit path text  -> edit treeModule path text  >> receivePackets conn treeModule
+    Just packet ->
-      ClientDelete path     -> delete treeModule path     >> receivePackets conn treeModule
+      case packet of
-      ClientReply path text -> reply treeModule path text >> receivePackets conn treeModule
+        ClientEdit path text -> edit treeModule path text
-      ClientAct path        -> act treeModule path        >> receivePackets conn treeModule
+        ClientDelete path -> delete treeModule path
-      ClientHello _         -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once"
+        ClientReply path text -> reply treeModule path text
-    Nothing -> pure () -- Connection already closed by receivePacket
+        ClientAct path -> act treeModule path
+        ClientHello _ -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once"
 
-serverApp :: TreeModule a => ModuleConstructor a -> WS.ServerApp
+serverApp :: TreeModule a => Int -> ModuleConstructor a -> WS.ServerApp
-serverApp constructor pendingConnection = do
+serverApp pingDelay constructor pendingConnection = do
   conn <- WS.acceptRequest pendingConnection
   chan <- newChan
-  WS.withPingThread conn 10 (pure ()) $ do
+  WS.withPingThread conn pingDelay (pure ()) $ do
     firstPacket <- receivePacket conn
     case firstPacket of
       Nothing -> pure ()

src/Forest/TreeModule/ConstModule.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Forest.TreeModule.ConstModule
+  ( constModule
+  ) where
+
+import           Forest.Tree
+import           Forest.TreeModule
+
+data ConstModule = ConstModule
+
+instance TreeModule ConstModule where
+  edit _ _ _ = pure ()
+  delete _ _ = pure ()
+  reply _ _ _ = pure ()
+  act _ _ = pure ()
+
+constModule :: ModuleConstructor ConstModule
+constModule sendNode continue = do
+  sendNode (emptyNode "Loaded ConstModule" False False False False)
+  continue ConstModule