diff --git a/src/Forest/Node.hs b/src/Forest/Node.hs index f35002f..fc54f54 100644 --- a/src/Forest/Node.hs +++ b/src/Forest/Node.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TupleSections #-} module Forest.Node ( @@ -8,11 +9,15 @@ module Forest.Node , Node(..) , newNode , txtNode + , getChild , hasChildren , mapChildren , applyId , applyPath + , alterAt + , editAt , replaceAt + , diffNodes -- * Path , Path(..) , localPath @@ -25,10 +30,10 @@ module Forest.Node import Control.Monad import Data.Aeson import Data.Char -import qualified Data.Map.Strict as Map +import qualified Data.Map.Strict as Map import Data.Maybe -import qualified Data.Set as Set -import qualified Data.Text as T +import qualified Data.Set as Set +import qualified Data.Text as T import GHC.Generics {- Node -} @@ -42,7 +47,8 @@ data Node = Node , nodeReply :: !Bool , nodeAct :: !Bool , nodeChildren :: !(Map.Map NodeId Node) - } deriving (Show, Generic) + } + deriving (Show, Generic) nodeOptions :: Options nodeOptions = defaultOptions{fieldLabelModifier = map toLower . drop 4} @@ -69,6 +75,9 @@ newNode flags text children = txtNode :: String -> T.Text -> Node txtNode flags text = newNode flags text [] +getChild :: NodeId -> Node -> Maybe Node +getChild nodeId node = nodeChildren node Map.!? nodeId + hasChildren :: Node -> Bool hasChildren = not . Map.null . nodeChildren @@ -81,11 +90,35 @@ applyId nodeId node = nodeChildren node Map.!? nodeId applyPath :: Path -> Node -> Maybe Node applyPath (Path ids) node = foldM (flip applyId) node ids +alterChild :: (Maybe Node -> Maybe Node) -> NodeId -> Node -> Node +alterChild f nodeId node = node{nodeChildren = Map.alter f nodeId (nodeChildren node)} + +alterAt :: (Maybe Node -> Maybe Node) -> Path -> Node -> Maybe Node +alterAt f (Path []) node = f (Just node) +alterAt f (Path (x:xs)) node = Just $ alterChild (>>= alterAt f (Path xs)) x node + +editAt :: (Node -> Node) -> Path -> Node -> Node +editAt f (Path []) = f +editAt f (Path (x:xs)) = alterChild (fmap $ editAt f (Path xs)) x + replaceAt :: Node -> Path -> Node -> Node -replaceAt childNode (Path []) _ = childNode -replaceAt childNode (Path (x:xs)) node = - let newChildren = Map.adjust (replaceAt childNode $ Path xs) x $ nodeChildren node - in node{nodeChildren = newChildren} +replaceAt child = editAt (const child) + +diffNodes :: Node -> Node -> Maybe (Path, Node) +diffNodes a b + | nodesDiffer || childrenChanged = Just (Path [], b) + | otherwise = case differingChildren of + [] -> Nothing + [(x, Path xs, node)] -> Just (Path (x:xs), node) + _ -> Just (Path [], b) + where + nodesDiffer = nodeText a /= nodeText b + || any (\f -> f a /= f b) [nodeEdit, nodeDelete, nodeReply, nodeAct] + aChildren = nodeChildren a + bChildren = nodeChildren b + childrenChanged = Map.keysSet aChildren /= Map.keysSet bChildren + diffedChildren = Map.toList $ Map.intersectionWith diffNodes aChildren bChildren + differingChildren = [(key, path, node) | (key, Just (path, node)) <- diffedChildren] {- Path -} diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs index 6e7a720..d10d040 100644 --- a/src/Forest/Server.hs +++ b/src/Forest/Server.hs @@ -17,12 +17,16 @@ import Forest.Util {- Thread that sends updates to the client -} sendUpdatesThread :: WS.Connection -> Chan Node -> Node -> IO () -sendUpdatesThread conn nodeChan _ = do - node' <- readChan nodeChan - -- TODO Don't send the whole node every time - putStrLn $ "Sending full node update with " ++ show node' - sendPacket conn $ ServerUpdate (Path []) node' - sendUpdatesThread conn nodeChan node' +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 -}