From a2d392bc4d95a62aadd2595116f676d3cdbb9321 Mon Sep 17 00:00:00 2001 From: Joscha Date: Sun, 15 Mar 2020 14:55:39 +0000 Subject: [PATCH] [server] Remove old tree modules --- forest-server/forest-server.cabal | 7 -- forest-server/src/Forest/Server.hs | 71 ----------- forest-server/src/Forest/Server/Broadcast.hs | 52 -------- forest-server/src/Forest/Server/TreeModule.hs | 25 ---- .../src/Forest/Server/TreeModule/Animate.hs | 27 ---- .../src/Forest/Server/TreeModule/Const.hs | 118 ------------------ .../src/Forest/Server/TreeModule/Fork.hs | 102 --------------- .../Forest/Server/TreeModule/SharedEditing.hs | 56 --------- 8 files changed, 458 deletions(-) delete mode 100644 forest-server/src/Forest/Server.hs delete mode 100644 forest-server/src/Forest/Server/Broadcast.hs delete mode 100644 forest-server/src/Forest/Server/TreeModule.hs delete mode 100644 forest-server/src/Forest/Server/TreeModule/Animate.hs delete mode 100644 forest-server/src/Forest/Server/TreeModule/Const.hs delete mode 100644 forest-server/src/Forest/Server/TreeModule/Fork.hs delete mode 100644 forest-server/src/Forest/Server/TreeModule/SharedEditing.hs diff --git a/forest-server/forest-server.cabal b/forest-server/forest-server.cabal index 03be485..64e5f60 100644 --- a/forest-server/forest-server.cabal +++ b/forest-server/forest-server.cabal @@ -26,15 +26,8 @@ source-repository head library exposed-modules: - Forest.Server - Forest.Server.Broadcast Forest.Server.Schema Forest.Server.TreeApp - Forest.Server.TreeModule - Forest.Server.TreeModule.Animate - Forest.Server.TreeModule.Const - Forest.Server.TreeModule.Fork - Forest.Server.TreeModule.SharedEditing other-modules: Paths_forest_server hs-source-dirs: diff --git a/forest-server/src/Forest/Server.hs b/forest-server/src/Forest/Server.hs deleted file mode 100644 index 7a665a6..0000000 --- a/forest-server/src/Forest/Server.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Server - ( withThread - , serverApp - ) where - -import Control.Concurrent.Chan -import Control.Exception -import qualified Network.WebSockets as WS - -import Forest.Api -import Forest.Node -import Forest.Server.TreeModule -import Forest.Util - -{- Thread that sends updates to the client -} - -sendUpdatesThread :: WS.Connection -> Chan Node -> Node -> IO () -sendUpdatesThread conn nodeChan nodeA = do - nodeB <- readChan nodeChan - case diffNodes nodeA nodeB of - Nothing -> do - putStrLn "Sending no update because the node didn't change" - sendUpdatesThread conn nodeChan nodeA - Just (path, nextNode) -> do - putStrLn $ "Sending partial update for path " ++ show path ++ ": " ++ show nextNode - sendPacket conn $ ServerUpdate path nextNode - sendUpdatesThread conn nodeChan nodeB - -{- Main server application that receives and processes client packets -} - -receivePackets :: TreeModule a () => WS.Connection -> a () -> IO () -receivePackets conn treeModule = whileNothingM $ do - packet <- receivePacket conn - case packet of - ClientEdit path text -> do - putStrLn $ "Editing " ++ show path ++ " to " ++ show text - edit treeModule path text - ClientDelete path -> do - putStrLn $ "Deleting " ++ show path - delete treeModule path - ClientReply path text -> do - putStrLn $ "Replying to " ++ show path ++ " with " ++ show text - reply treeModule path text - ClientAct path -> do - putStrLn $ "Acting upon " ++ show path - act treeModule path - ClientHello _ -> closeWithErrorMessage conn "Invalid packet: Hello can only be sent once" - -printException :: SomeException -> IO () -printException e = putStrLn $ "Encountered exception: " ++ show e - -serverApp :: TreeModule a () => Int -> ModuleConstructor (a ()) -> WS.ServerApp -serverApp pingDelay constructor pendingConnection = do - conn <- WS.acceptRequest pendingConnection - chan <- newChan - WS.withPingThread conn pingDelay (pure ()) $ handle printException $ do - firstPacket <- receivePacket conn - case firstPacket of - ClientHello _ -> do - putStrLn $ "Sending hello reply with " ++ show initialNode - sendPacket conn $ ServerHello [] initialNode - withThread (sendUpdatesThread conn chan initialNode) $ - constructor (writeChan chan) $ \tm -> do - receivePackets conn tm - putStrLn "Module finished, closing connection" - _ -> closeWithErrorMessage conn "Invalid packet: Expected a hello packet" - where - initialNode = txtNode "" "Loading..." diff --git a/forest-server/src/Forest/Server/Broadcast.hs b/forest-server/src/Forest/Server/Broadcast.hs deleted file mode 100644 index e7fb4b0..0000000 --- a/forest-server/src/Forest/Server/Broadcast.hs +++ /dev/null @@ -1,52 +0,0 @@ --- | A 'Broadcaster' allows threads to 'broadcast' values to 'Listeners' --- attached to that broadcaster. A value that is sent through a broadcaster will --- arrive exactly once at each attached listener and can then be collected by --- calling 'listen'. --- --- All functions included in this module should be threadsafe. Be sure to read --- the warning on the 'broadcast' function. - -module Forest.Server.Broadcast - ( Broadcaster - , Listener - , newBroadcaster - , attachListener - , broadcast - , listen - ) where - -import Control.Concurrent.Chan - --- | A 'Broadcaster' can broadcast values to all attached 'Listener's -newtype Broadcaster a = Broadcaster (Chan a) - --- | A 'Listener' receives values from the 'Broadcaster' it is attached to -newtype Listener a = Listener (Chan a) - --- | Create a new 'Broadcaster' -newBroadcaster :: IO (Broadcaster a) -newBroadcaster = Broadcaster <$> newChan - --- | Create a new 'Listener' that is attached to a 'Broadcaster' -attachListener :: Broadcaster a -> IO (Listener a) -attachListener (Broadcaster chan) = Listener <$> dupChan chan - --- | Send a value through the 'Broadcaster'. That value will arrive exactly once --- at all 'Listener's attached to this broadcaster via 'attachListener'. --- --- Warning: During this function call, no exception should occur or elements may --- build up in the broadcaster, leading to a memory/space leak. -broadcast :: Broadcaster a -> a -> IO () --- Because the same function that puts something into the broadcaster channel --- also immediately reads something from that channel, there is no build-up of --- values in the broadcaster channel, as one element is removed for each element --- written. Since the broadcaster channel is separate from the listener --- channels, no event is swallowed accidentally. --- --- If some exception happens after the write operation succeeds but before the --- read operation finishes, elements can build up in the broadcast channel. -broadcast (Broadcaster chan) value = writeChan chan value <* readChan chan - --- | Read the next value from the 'Listener'. Blocks when the listener is empty. -listen :: Listener a -> IO a -listen (Listener chan) = readChan chan diff --git a/forest-server/src/Forest/Server/TreeModule.hs b/forest-server/src/Forest/Server/TreeModule.hs deleted file mode 100644 index b289179..0000000 --- a/forest-server/src/Forest/Server/TreeModule.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -module Forest.Server.TreeModule - ( TreeModule(..) - , ModuleConstructor - ) where - -import qualified Data.Text as T - -import Forest.Node - -class TreeModule a r where - edit :: a r -> Path -> T.Text -> IO (Maybe r) - edit _ _ _ = pure Nothing - - delete :: a r -> Path -> IO (Maybe r) - delete _ _ = pure Nothing - - reply :: a r -> Path -> T.Text -> IO (Maybe r) - reply _ _ _ = pure Nothing - - act :: a r -> Path -> IO (Maybe r) - act _ _ = pure Nothing - -type ModuleConstructor a = (Node -> IO ()) -> (a -> IO ()) -> IO () diff --git a/forest-server/src/Forest/Server/TreeModule/Animate.hs b/forest-server/src/Forest/Server/TreeModule/Animate.hs deleted file mode 100644 index 9aef0f8..0000000 --- a/forest-server/src/Forest/Server/TreeModule/Animate.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Server.TreeModule.Animate - ( AnimateModule - , animateModule - ) where - -import Control.Concurrent - -import Forest.Node -import Forest.Server.TreeModule -import Forest.Util - -data AnimateModule r = AnimateModule - -instance TreeModule AnimateModule () where - -animateModule :: Int -> [Node] -> ModuleConstructor (AnimateModule ()) -animateModule delay frames sendNode continue = - withThread (animateThread frames) $ continue AnimateModule - where - animateThread [] = sendNode $ txtNode "" "Invalid animation: No frames provided" - animateThread (x:xs) = do - sendNode x - threadDelay delay - animateThread $ xs ++ [x] diff --git a/forest-server/src/Forest/Server/TreeModule/Const.hs b/forest-server/src/Forest/Server/TreeModule/Const.hs deleted file mode 100644 index 3d8124f..0000000 --- a/forest-server/src/Forest/Server/TreeModule/Const.hs +++ /dev/null @@ -1,118 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - -module Forest.Server.TreeModule.Const - ( ConstModule - , constModule - , projectDescriptionNode - ) where - -import Forest.Node -import Forest.Server.TreeModule - -data ConstModule r = ConstModule - -instance TreeModule ConstModule () where - -constModule :: Node -> ModuleConstructor (ConstModule ()) -constModule node sendNode continue = do - sendNode node - continue ConstModule - -projectDescriptionNode :: Node -projectDescriptionNode = - newNode "" "About" - [ txtNode "" "This project is an experiment in tree-based interaction." - , newNode "" "Motivation" - [ txtNode "" "My goals for this project were:" - , newNode "" "Interactons between multiple people" - [ txtNode "" - ( "I wanted to create a project that let multiple people interact with " - <> "each other in different ways. Examples for interactions include:\n" - <> "* Chatting\n" - <> "* Collaborative editing\n" - <> "* Playing (multiplayer) games\n" - ) - , txtNode "" "The project should allow for many different kinds of interactions." - ] - , newNode "" "Portability" - [ txtNode "" - ( "The project should be usable on multiple different platforms. To " - <> "facilitate this, clients should be easy to create. In particular, I " - <> "want at least one terminal-based and one web-based client." - ) - ] - , txtNode "" "Based on these goals, I made the following design decisions:" - , newNode "" "Text-based" - [ txtNode "" - ( "Text is a medium that works on all platforms and easy to work with " - <> "as a developer." - ) - , txtNode "" - ( "But text still allows for a lot of different interactions. Of all " - <> "the kinds of media one can produce with a computer, text is easy " - <> "and quick to create. After all, pretty much every computer has a " - <> "keyboard." - ) - ] - , newNode "" "Tree-based" - [ txtNode "" - ( "While plain text may be easy to work with, it makes interactions " - <> "cumbersome if limited to basic input and output. To make " - <> "interactions nicer, the server could send the client a screen's " - <> "worth of text to display, in effect creating a TUI-like interface. " - <> "The client would then only need to send key presses or mouse clicks " - <> "to the server." - ) - , txtNode "" - ( "In my opinion, that approach moves too many decisions on how to " - <> "interact to the server and imposes unnecessary limits on the client " - <> "design. Instead, I went with a plaintext-in-tree-structure " - <> "approach, which allows for more flexibility in the client design. " - <> "Also, this should make bots easier to write, since they don't have " - <> "to emulate human input." - ) - ] - , newNode "" "Simple API" - [ txtNode "" - ( "Every client must use the same API to interact with the server. " - <> "Because clients should be easy to create on different platforms, " - <> "the API should also be simple." - ) - , txtNode "" - ( "One way in which the API is simple is that the server doesn't send " - <> "direct responses to client commands. Instead, there is only the " - <> "'update' packet, which is sent whenever the client should modify " - <> "its tree structure." - ) - , txtNode "" - ( "In total, there are 5 different client packages and 2 different " - <> "server packages. If at some point the API turns out to be too " - <> "simple, it has a built-in way of negotiating protocol extensions." - ) - ] - , newNode "" "Most logic in server" - [ txtNode "" - ( "All logic besides the immediate input handling and tree folding " - <> "happens in the server. This has multiple advantages:" - ) - , txtNode "" "The API and clients are simpler, clients are easier to write or maintain." - , txtNode "" "Updates in logic don't require updates of the client." - , txtNode "" "The server-side logic becomes easier to write." - ] - , txtNode "" - ( "Those design decisions should allow for various different kinds of " - <> "interactions, for example linear and threaded chat, collaborative " - <> "node editing, reading node-based documents (like this one), playing " - <> "text adventures and more." - ) - , txtNode "" - ( "And of course, which interactions are supported only depends on the " - <> "server and not on the client." - ) - ] - , newNode "" "Inspirations" - [ txtNode "" "The tree-based chat model and UI of euphoria (euphoria.io) and instant (instant.leet.nu)" - , txtNode "" "MUDs (which are text based and most of the logic happens server-side)" - ] - ] diff --git a/forest-server/src/Forest/Server/TreeModule/Fork.hs b/forest-server/src/Forest/Server/TreeModule/Fork.hs deleted file mode 100644 index 7be309e..0000000 --- a/forest-server/src/Forest/Server/TreeModule/Fork.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} - -module Forest.Server.TreeModule.Fork - ( ForkModule - , ProngConstructor(..) - , forkModule - ) where - -import Control.Concurrent.MVar -import Control.Monad.Trans.Cont -import qualified Data.Map as Map -import qualified Data.Text as T - -import Forest.Node -import qualified Forest.OrderedMap as OMap -import Forest.Server.TreeModule - -data Prong = forall r a . TreeModule a r => Prong (a r) - -data ProngConstructor = forall r a . TreeModule a r => - ProngConstructor T.Text (ModuleConstructor (a r)) - -newtype ForkModule r = ForkModule (Map.Map NodeId Prong) - -instance TreeModule ForkModule () where - edit _ (Path []) _ = pure Nothing - edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of - Nothing -> pure Nothing - Just (Prong a) -> do - result <- edit a (Path xs) text - pure $ () <$ result - - delete _ (Path []) = pure Nothing - delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of - Nothing -> pure Nothing - Just (Prong a) -> do - result <- delete a (Path xs) - pure $ () <$ result - - reply _ (Path []) _ = pure Nothing - reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of - Nothing -> pure Nothing - Just (Prong a) -> do - result <- reply a (Path xs) text - pure $ () <$ result - - act _ (Path []) = pure Nothing - act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of - Nothing -> pure Nothing - Just (Prong a) -> do - result <- act a (Path xs) - pure $ () <$ result - -data ProngInfo = ProngInfo - { piTopName :: T.Text - , piNames :: Map.Map NodeId T.Text - , piNodes :: Map.Map NodeId Node - , piOrder :: [NodeId] - } - -renderProngInfo :: ProngInfo -> Node -renderProngInfo pInfo = - let childMap = Map.intersectionWith - (\name node -> node{nodeText = name}) - (piNames pInfo) - (piNodes pInfo) - children = OMap.fromMapWithOrder childMap $ piOrder pInfo - in Node {nodeText = piTopName pInfo, nodeFlags = mempty, nodeChildren = children} - -sendNodeFromProng :: MVar ProngInfo -> (Node -> IO ()) -> NodeId -> Node -> IO () -sendNodeFromProng piVar sendNode nodeId node = - modifyMVar_ piVar $ \pInfo -> do - let newPInfo = pInfo {piNodes = Map.insert nodeId node $ piNodes pInfo} - sendNode $ renderProngInfo newPInfo - pure newPInfo - -constructProngs - :: MVar ProngInfo - -> (Node -> IO ()) - -> Map.Map NodeId ProngConstructor - -> Cont (IO ()) (Map.Map NodeId Prong) -constructProngs piVar sendNode = - Map.traverseWithKey constructProng - where - constructProng nodeId (ProngConstructor _ constructor) = - Prong <$> cont (constructor $ sendNodeFromProng piVar sendNode nodeId) - -forkModule :: T.Text -> [ProngConstructor] -> ModuleConstructor (ForkModule ()) -forkModule text prongs sendNode continue = do - let namePairs = zip enumerateIds $ map (\(ProngConstructor name _) -> name) prongs - nodesVar <- newMVar ProngInfo - { piTopName = text - , piNames = Map.fromList namePairs - , piNodes = Map.empty - , piOrder = map fst namePairs - } - let numbers = map (T.pack . show) [(0::Integer)..] - prongMap = Map.fromList $ zip numbers prongs - runCont (constructProngs nodesVar sendNode prongMap) (continue . ForkModule) diff --git a/forest-server/src/Forest/Server/TreeModule/SharedEditing.hs b/forest-server/src/Forest/Server/TreeModule/SharedEditing.hs deleted file mode 100644 index 59e4bc2..0000000 --- a/forest-server/src/Forest/Server/TreeModule/SharedEditing.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} - -module Forest.Server.TreeModule.SharedEditing - ( SharedEditingModule - , sharedEditingModule - ) where - -import Control.Concurrent.MVar -import Control.Monad - -import Forest.Node -import Forest.Server.Broadcast -import Forest.Server.TreeModule -import Forest.Util - -data SharedEditingModule r = SharedEditingModule - { seNodeVar :: MVar Node - , seBroadcaster :: Broadcaster Node - } - -instance TreeModule SharedEditingModule r where - edit _ (Path []) _ = pure Nothing - edit se path text = do - node' <- modifyMVar (seNodeVar se) $ \node -> do - let updatedNode = adjustAt (\n -> n{nodeText = text}) path node - pure (updatedNode, updatedNode) - broadcast (seBroadcaster se) node' - pure Nothing - - delete _ (Path []) = pure Nothing - delete se path = do - node' <- modifyMVar (seNodeVar se) $ \node -> do - let updatedNode = deleteAt path node - pure (updatedNode, updatedNode) - broadcast (seBroadcaster se) node' - pure Nothing - - reply se path text = do - node' <- modifyMVar (seNodeVar se) $ \node -> do - let updatedNode = appendAt (txtNode "edr" text) path node - pure (updatedNode, updatedNode) - broadcast (seBroadcaster se) node' - pure Nothing - -sharedEditingModule :: - MVar Node -> Broadcaster Node -> ModuleConstructor (SharedEditingModule ()) -sharedEditingModule nodeVar broadcaster sendNode continue = do - listener <- attachListener broadcaster - withThread (updateOnNewBroadcast listener) $ do - withMVar nodeVar sendNode -- We need to show our initial edit state - continue $ SharedEditingModule nodeVar broadcaster - where - updateOnNewBroadcast listener = forever $ do - node <- listen listener - sendNode node