From 42e9f6d462dec2748c9a2b83e8f425f0fb817996 Mon Sep 17 00:00:00 2001
From: Joscha <joscha@plugh.de>
Date: Sat, 8 Feb 2020 18:57:54 +0000
Subject: [PATCH] Implement basic server executable

---
 server/Main.hs                       | 22 +++++++++++++++++++++-
 src/Forest/Server.hs                 | 24 +++++++++++++-----------
 src/Forest/TreeModule/ConstModule.hs | 21 +++++++++++++++++++++
 3 files changed, 55 insertions(+), 12 deletions(-)
 create mode 100644 src/Forest/TreeModule/ConstModule.hs

diff --git a/server/Main.hs b/server/Main.hs
index e4b9b4d..ba216f9 100644
--- a/server/Main.hs
+++ b/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
diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs
index 3cc36ca..f6710b0 100644
--- a/src/Forest/Server.hs
+++ b/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
-      ClientEdit path text  -> edit treeModule path text  >> receivePackets conn treeModule
-      ClientDelete path     -> delete treeModule path     >> receivePackets conn treeModule
-      ClientReply path text -> reply treeModule path text >> receivePackets conn treeModule
-      ClientAct path        -> act treeModule path        >> receivePackets conn treeModule
-      ClientHello _         -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once"
-    Nothing -> pure () -- Connection already closed by receivePacket
+    Nothing -> pure ()
+    Just packet ->
+      case packet of
+        ClientEdit path text -> edit treeModule path text
+        ClientDelete path -> delete treeModule path
+        ClientReply path text -> reply treeModule path text
+        ClientAct path -> act treeModule path
+        ClientHello _ -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once"
 
-serverApp :: TreeModule a => ModuleConstructor a -> WS.ServerApp
-serverApp constructor pendingConnection = do
+serverApp :: TreeModule a => Int -> ModuleConstructor a -> WS.ServerApp
+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 ()
diff --git a/src/Forest/TreeModule/ConstModule.hs b/src/Forest/TreeModule/ConstModule.hs
new file mode 100644
index 0000000..40d5c61
--- /dev/null
+++ b/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