[all] Reorganize haskell code into multiple packages

forest-server/src/Forest/Server/Broadcast.hs

@@ -0,0 +1,52 @@
+-- | 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

forest-server/src/Forest/Server/TreeModule.hs

@@ -0,0 +1,25 @@
+{-# 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 ()

forest-server/src/Forest/Server/TreeModule/Animate.hs

@@ -0,0 +1,27 @@
+{-# 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]

forest-server/src/Forest/Server/TreeModule/Const.hs

@@ -0,0 +1,118 @@
+{-# 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)"
+    ]
+  ]

forest-server/src/Forest/Server/TreeModule/Fork.hs

@@ -0,0 +1,102 @@
+{-# 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)

forest-server/src/Forest/Server/TreeModule/SharedEditing.hs

@@ -0,0 +1,56 @@
+{-# 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