[all] Reorganize haskell code into multiple packages

forest-server/README.md

@@ -0,0 +1 @@
+# forest-server

forest-server/forest-server.cabal

@@ -0,0 +1,47 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.31.2.
+--
+-- see: https://github.com/sol/hpack
+--
+-- hash: c0d366de2ff27f13dd69d751b47017143df332454ad700dd8fb5089d9837f1a8
+
+name:           forest-server
+version:        0.1.0.0
+synopsis:       A framework for forest servers
+description:    Please see the README at <https://github.com/Garmelon/forest#readme>
+homepage:       https://github.com/Garmelon/forest#readme
+bug-reports:    https://github.com/Garmelon/forest/issues
+author:         Garmelon <joscha@plugh.de>
+maintainer:     Garmelon <joscha@plugh.de>
+copyright:      2020 Garmelon
+license:        MIT
+build-type:     Simple
+extra-source-files:
+    README.md
+
+source-repository head
+  type: git
+  location: https://github.com/Garmelon/forest
+
+library
+  exposed-modules:
+      Forest.Server
+      Forest.Server.Broadcast
+      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:
+      src
+  build-depends:
+      base >=4.7 && <5
+    , containers
+    , forest-common
+    , text
+    , transformers
+    , websockets
+  default-language: Haskell2010

forest-server/package.yaml

@@ -0,0 +1,23 @@
+name: forest-server
+version: 0.1.0.0
+license: MIT
+author: Garmelon <joscha@plugh.de>
+copyright: 2020 Garmelon
+
+synopsis: A framework for forest servers
+description: Please see the README at <https://github.com/Garmelon/forest#readme>
+github: Garmelon/forest
+
+extra-source-files:
+  - README.md
+
+dependencies:
+  - base >= 4.7 && < 5
+  - containers
+  - forest-common
+  - text
+  - transformers
+  - websockets
+
+library:
+  source-dirs: src

forest-server/src/Forest/Server.hs

@@ -0,0 +1,71 @@
+{-# 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..."

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