From 33f1076b529d937a32ad3f48e11c19c727bce1c5 Mon Sep 17 00:00:00 2001
From: Joscha <joscha@plugh.de>
Date: Sat, 8 Feb 2020 18:02:08 +0000
Subject: [PATCH] Add basic server

---
 package.yaml             |  2 ++
 src/Forest/Server.hs     | 78 ++++++++++++++++++++++++++++++++++++++++
 src/Forest/Tree.hs       | 17 +++++++++
 src/Forest/TreeModule.hs | 16 +++++++++
 4 files changed, 113 insertions(+)
 create mode 100644 src/Forest/Server.hs
 create mode 100644 src/Forest/Tree.hs
 create mode 100644 src/Forest/TreeModule.hs

diff --git a/package.yaml b/package.yaml
index ae735b3..e4df401 100644
--- a/package.yaml
+++ b/package.yaml
@@ -15,8 +15,10 @@ extra-source-files:
 dependencies:
 - base >= 4.7 && < 5
 - aeson
+- async
 - text
 - unordered-containers
+- websockets
 
 library:
   source-dirs: src
diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs
new file mode 100644
index 0000000..3cc36ca
--- /dev/null
+++ b/src/Forest/Server.hs
@@ -0,0 +1,78 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Forest.Server
+  ( withThread
+  , serverApp
+  ) where
+
+import           Control.Concurrent.Async
+import           Control.Concurrent.Chan
+import           Data.Aeson
+import qualified Data.Text                as T
+import qualified Network.WebSockets       as WS
+
+import           Forest.Api
+import           Forest.Tree
+import           Forest.TreeModule
+
+{- Helper functions -}
+
+withThread :: IO () -> IO () -> IO ()
+withThread thread main = withAsync thread $ const main
+
+sendPacket :: WS.Connection -> ServerPacket -> IO ()
+sendPacket conn packet = WS.sendTextData conn $ encode packet
+
+closeWithErrorMessage :: WS.Connection -> T.Text -> IO ()
+closeWithErrorMessage conn = WS.sendCloseCode conn 1003
+
+receivePacket :: WS.Connection -> IO (Maybe ClientPacket)
+receivePacket conn = do
+  dataMessage <- WS.receiveDataMessage conn
+  closeOnErrorMessage $ case dataMessage of
+    WS.Binary _ -> Left "Invalid message format: Binary"
+    WS.Text bs _ -> case eitherDecode' bs of
+      Left errorMsg -> Left $ "Invalid packet: " <> T.pack errorMsg
+      Right packet -> Right packet
+  where
+    closeOnErrorMessage :: Either T.Text a -> IO (Maybe a)
+    closeOnErrorMessage (Right a) = pure $ Just a
+    closeOnErrorMessage (Left errorMsg) =
+      Nothing <$ closeWithErrorMessage conn errorMsg
+
+{- Thread that sends updates to the client -}
+
+sendUpdatesThread :: WS.Connection -> Chan Node -> Node -> IO ()
+sendUpdatesThread conn nodeChan _ = do
+  newNode <- readChan nodeChan
+  -- TODO Don't send the whole node every time
+  sendPacket conn $ ServerUpdate (Path []) newNode
+  sendUpdatesThread conn nodeChan newNode
+
+{- Main server application that receives and processes client packets -}
+
+receivePackets :: TreeModule a => WS.Connection -> a -> IO ()
+receivePackets conn treeModule = 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
+
+serverApp :: TreeModule a => ModuleConstructor a -> WS.ServerApp
+serverApp constructor pendingConnection = do
+  conn <- WS.acceptRequest pendingConnection
+  chan <- newChan
+  WS.withPingThread conn 10 (pure ()) $ do
+    firstPacket <- receivePacket conn
+    case firstPacket of
+      Nothing -> pure ()
+      Just (ClientHello _) -> do
+        sendPacket conn $ ServerHello [] initialNode
+        withThread (sendUpdatesThread conn chan initialNode) $
+          constructor (writeChan chan) $ receivePackets conn
+      Just _ -> closeWithErrorMessage conn "Invalid packet: Expected a hello packet"
diff --git a/src/Forest/Tree.hs b/src/Forest/Tree.hs
new file mode 100644
index 0000000..0491562
--- /dev/null
+++ b/src/Forest/Tree.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Forest.Tree
+  ( emptyNode
+  , initialNode
+  ) where
+
+import qualified Data.HashMap.Strict as Map
+import qualified Data.Text           as T
+
+import           Forest.Api
+
+emptyNode :: T.Text -> Bool -> Bool -> Bool -> Bool -> Node
+emptyNode text edit delete reply act = Node text edit delete reply act Map.empty
+
+initialNode :: Node
+initialNode = emptyNode "Loading..." False False False False
diff --git a/src/Forest/TreeModule.hs b/src/Forest/TreeModule.hs
new file mode 100644
index 0000000..9397d6a
--- /dev/null
+++ b/src/Forest/TreeModule.hs
@@ -0,0 +1,16 @@
+module Forest.TreeModule
+  ( TreeModule(..)
+  , ModuleConstructor
+  ) where
+
+import qualified Data.Text  as T
+
+import           Forest.Api
+
+class TreeModule a where
+  edit   :: a -> Path -> T.Text -> IO ()
+  delete :: a -> Path -> IO ()
+  reply  :: a -> Path -> T.Text -> IO ()
+  act    :: a -> Path -> IO ()
+
+type ModuleConstructor a = (Node -> IO ()) -> (a -> IO ()) -> IO ()