diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs index d10d040..04c2171 100644 --- a/src/Forest/Server.hs +++ b/src/Forest/Server.hs @@ -6,7 +6,6 @@ module Forest.Server ) where import Control.Concurrent.Chan -import Control.Monad import qualified Network.WebSockets as WS import Forest.Api @@ -31,7 +30,7 @@ sendUpdatesThread conn nodeChan nodeA = do {- Main server application that receives and processes client packets -} receivePackets :: TreeModule a => WS.Connection -> a -> IO () -receivePackets conn treeModule = forever $ do +receivePackets conn treeModule = whileM $ do packet <- receivePacket conn case packet of ClientEdit path text -> do diff --git a/src/Forest/TreeModule.hs b/src/Forest/TreeModule.hs index d9e12ce..a7425f4 100644 --- a/src/Forest/TreeModule.hs +++ b/src/Forest/TreeModule.hs @@ -8,16 +8,16 @@ import qualified Data.Text as T import Forest.Node class TreeModule a where - edit :: a -> Path -> T.Text -> IO () - edit _ _ _ = pure () + edit :: a -> Path -> T.Text -> IO Bool + edit _ _ _ = pure True - delete :: a -> Path -> IO () - delete _ _ = pure () + delete :: a -> Path -> IO Bool + delete _ _ = pure True - reply :: a -> Path -> T.Text -> IO () - reply _ _ _ = pure () + reply :: a -> Path -> T.Text -> IO Bool + reply _ _ _ = pure True - act :: a -> Path -> IO () - act _ _ = pure () + act :: a -> Path -> IO Bool + act _ _ = pure True type ModuleConstructor a = (Node -> IO ()) -> (a -> IO ()) -> IO () diff --git a/src/Forest/TreeModule/Fork.hs b/src/Forest/TreeModule/Fork.hs index 4229ec4..14740f3 100644 --- a/src/Forest/TreeModule/Fork.hs +++ b/src/Forest/TreeModule/Fork.hs @@ -22,25 +22,25 @@ data ProngConstructor = forall a . TreeModule a => ProngConstructor (ModuleConst newtype ForkModule = ForkModule (Map.Map NodeId Prong) instance TreeModule ForkModule where - edit _ (Path []) _ = pure () + edit _ (Path []) _ = pure True edit (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of Just (Prong a) -> edit a (Path xs) text - Nothing -> pure () + Nothing -> pure True - delete _ (Path []) = pure () + delete _ (Path []) = pure True delete (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of Just (Prong a) -> delete a (Path xs) - Nothing -> pure () + Nothing -> pure True - reply _ (Path []) _ = pure () + reply _ (Path []) _ = pure True reply (ForkModule prongs) (Path (x:xs)) text = case prongs Map.!? x of Just (Prong a) -> reply a (Path xs) text - Nothing -> pure () + Nothing -> pure True - act _ (Path []) = pure () + act _ (Path []) = pure True act (ForkModule prongs) (Path (x:xs)) = case prongs Map.!? x of Just (Prong a) -> act a (Path xs) - Nothing -> pure () + Nothing -> pure True sendNodeFromProng :: T.Text diff --git a/src/Forest/Util.hs b/src/Forest/Util.hs index 04ef67b..8a2a30f 100644 --- a/src/Forest/Util.hs +++ b/src/Forest/Util.hs @@ -3,6 +3,7 @@ module Forest.Util ( findPrev , findNext + , whileM , withThread , sendPacket , closeWithErrorMessage @@ -25,6 +26,14 @@ findNext f as = snd <$> find (f . fst) (zip as $ tail as) withThread :: IO () -> IO () -> IO () withThread thread main = withAsync thread $ const main +-- | Run a monadic action until it returns @False@ for the first time. +whileM :: Monad m => m Bool -> m () +whileM f = do + continue <- f + if continue + then whileM f + else pure () + sendPacket :: ToJSON a => WS.Connection -> a -> IO () sendPacket conn packet = WS.sendTextData conn $ encode packet