diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for net-spider +## 0.4.3.1 -- 2020-04-26 + +* Spider is now implemented with greskell-1.1.0.0 + ## 0.4.3.0 -- 2020-04-18 * Add SeqID module. diff --git a/net-spider.cabal b/net-spider.cabal --- a/net-spider.cabal +++ b/net-spider.cabal @@ -1,5 +1,5 @@ name: net-spider -version: 0.4.3.0 +version: 0.4.3.1 author: Toshio Ito maintainer: Toshio Ito license: BSD3 @@ -57,7 +57,7 @@ time >=1.8.0.2 && <1.10, vector >=0.12.0.1 && <0.13, greskell-websocket >=0.1.1 && <0.2, - greskell >=1.0.0 && <1.1, + greskell >=1.1.0.0 && <1.2, aeson >=1.2.4 && <1.5, safe-exceptions >=0.1.6 && <0.2, text >=1.2.2.2 && <1.3, diff --git a/src/NetSpider/Spider.hs b/src/NetSpider/Spider.hs --- a/src/NetSpider/Spider.hs +++ b/src/NetSpider/Spider.hs @@ -24,17 +24,20 @@ import Control.Category ((<<<)) import Control.Exception.Safe (throwString, bracket) -import Control.Monad (void, mapM_, mapM) +import Control.Monad (void, mapM_, mapM, when) +import Control.Monad.IO.Class (liftIO) import Data.Aeson (ToJSON) import Data.Foldable (foldr', toList, foldl') -import Data.List (intercalate) +import Data.List (reverse) import Data.Greskell ( runBinder, ($.), (<$.>), (<*.>), - Binder, ToGreskell(GreskellReturn), AsIterator(IteratorItem), FromGraphSON, + Greskell, Binder, ToGreskell(GreskellReturn), AsIterator(IteratorItem), FromGraphSON, liftWalk, gLimit, gIdentity, gSelect1, gAs, gProject, gByL, gIdentity, gFold, + gRepeat, gEmitHead, gSimplePath, gConstant, gLocal, lookupAsM, newAsLabel, - Transform, Walk + Transform, Walk, SideEffect ) +import Data.Greskell.Extra (gWhenEmptyInput) import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM @@ -43,7 +46,7 @@ import Data.IORef (IORef, modifyIORef, newIORef, readIORef, atomicModifyIORef') import Data.Maybe (catMaybes, mapMaybe, listToMaybe) import Data.Monoid (mempty, (<>)) -import Data.Text (Text, pack) +import Data.Text (Text, pack, intercalate) import Data.Vector (Vector) import qualified Data.Vector as V import Network.Greskell.WebSocket (Host, Port) @@ -73,13 +76,14 @@ import NetSpider.Spider.Internal.Graph ( gMakeFoundNode, gAllNodes, gHasNodeID, gHasNodeEID, gNodeEID, gNodeID, gMakeNode, gClearAll, gLatestFoundNode, gSelectFoundNode, gFinds, gFindsTarget, gHasFoundNodeEID, gAllFoundNode, - gFilterFoundNodeByTime + gFilterFoundNodeByTime, gSubjectNodeID, gTraverseViaFinds, + gNodeMix, gFoundNodeOnly, gEitherNodeMix, gDedupNodes ) import NetSpider.Spider.Internal.Log ( runLogger, logDebug, logWarn, logLine ) import NetSpider.Spider.Internal.Spider (Spider(..)) -import NetSpider.Timestamp (Timestamp, showEpochTime) +import NetSpider.Timestamp (Timestamp, showTimestamp) import NetSpider.Unify (LinkSampleUnifier, LinkSample(..), LinkSampleID, linkSampleId) import NetSpider.Weaver (Weaver, newWeaver) import qualified NetSpider.Weaver as Weaver @@ -139,19 +143,16 @@ vToMaybe :: Vector a -> Maybe a vToMaybe v = v V.!? 0 -getNode :: (ToJSON n) => Spider n na fla -> n -> IO (Maybe (EID VNode)) -getNode spider nid = fmap vToMaybe $ Gr.slurpResults =<< submitB spider gt - where - gt = gNodeEID <$.> gHasNodeID spider nid <*.> pure gAllNodes - getOrMakeNode :: (ToJSON n) => Spider n na fla -> n -> IO (EID VNode) -getOrMakeNode spider nid = do - mvid <- getNode spider nid - case mvid of - Just vid -> return vid - Nothing -> makeNode +getOrMakeNode spider nid = expectOne =<< Gr.slurpResults =<< submitB spider bound_traversal where - makeNode = expectOne =<< Gr.slurpResults =<< submitB spider (liftWalk gNodeEID <$.> gMakeNode spider nid) + bound_traversal = do + wMakeNode <- gMakeNode spider nid + wHasNodeID <- gHasNodeID spider nid + return + $ (liftWalk gNodeEID :: Walk SideEffect VNode (EID VNode)) + $. gWhenEmptyInput wMakeNode + $. liftWalk $ wHasNodeID $. gAllNodes expectOne v = case vToMaybe v of Just e -> return e Nothing -> throwString "Expects at least single result, but got nothing." @@ -176,142 +177,144 @@ -> Query n na fla sla -> IO (SnapshotGraph n na sla) getSnapshot spider query = do - ref_state <- newIORef $ initSnapshotState (startsFrom query) (foundNodePolicy query) - recurseVisitNodesForSnapshot spider query ref_state - (nodes, links, logs) <- fmap (makeSnapshot $ unifyLinkSamples query) $ readIORef ref_state + let fn_policy = foundNodePolicy query + ref_weaver <- newIORef $ newWeaver fn_policy + mapM_ (traverseFromOneNode spider (timeInterval query) fn_policy ref_weaver) $ startsFrom query + (graph, logs) <- fmap (Weaver.getSnapshot' $ unifyLinkSamples query) $ readIORef ref_weaver mapM_ (logLine spider) logs - return (nodes, links) + return graph -recurseVisitNodesForSnapshot :: (ToJSON n, Ord n, Hashable n, FromGraphSON n, Show n, LinkAttributes fla, NodeAttributes na) - => Spider n na fla - -> Query n na fla sla - -> IORef (SnapshotState n na fla) - -> IO () -recurseVisitNodesForSnapshot spider query ref_state = go +traverseFromOneNode :: (FromGraphSON n, ToJSON n, Eq n, Hashable n, Show n, LinkAttributes fla, NodeAttributes na) + => Spider n na fla + -> Interval Timestamp + -> FoundNodePolicy n na + -> IORef (Weaver n na fla) + -> n -- ^ starting node + -> IO () +traverseFromOneNode spider time_interval fn_policy ref_weaver start_nid = do + init_weaver <- readIORef ref_weaver + logDebug spider ("Start traverse from: " <> spack start_nid) + get_next <- traverseFoundNodes spider time_interval fn_policy start_nid + doTraverseWith init_weaver get_next where - go = do - mnext_visit <- getNextVisit - case mnext_visit of - Nothing -> return () - Just next_visit -> do - visitNodeForSnapshot spider query ref_state next_visit - go - getNextVisit = atomicModifyIORef' ref_state popUnvisitedNode - -- TODO: limit number of steps. + logTraverseItem eitem = logDebug spider ("Visit: " <> showTraverseItem eitem) + showTraverseItem (Left nid) = "Node(" <> spack nid <> ")" + showTraverseItem (Right fn) = + "FoundNode(" + <> "ts:" <> (showTimestamp $ foundAt fn) + <> ", sub:" <> (spack $ subjectNode fn) + <> ", tgt:[" <> (intercalate ", " $ map showLink $ neighborLinks fn) + <> "])" + showLink l = spack $ targetNode l + doTraverseWith init_weaver getNext = go + where + go = do + mvisited_node <- getNext + case mvisited_node of + Nothing -> return () + Just eitem -> do + logTraverseItem eitem + case eitem of + Left sub_nid -> tryAdd sub_nid Nothing + Right fnode -> tryAdd (subjectNode fnode) (Just fnode) + go + tryAdd sub_nid mfnode = do + when (not $ Weaver.isVisited sub_nid init_weaver) $ do + modifyIORef ref_weaver $ \w -> + case mfnode of + Nothing -> Weaver.markAsVisited sub_nid w + Just fnode -> Weaver.addFoundNode fnode w --- | Traverse one hop from the visited 'VNode'. +-- | Recursively traverse the history graph based on the query to get +-- the FoundNodes. -- --- Returns: list of (VFoundNode of the VNode, EFinds links), where an --- EFinds link = (EFindsData, target Node Id) -traverseEFindsOneHop :: (FromGraphSON n, NodeAttributes na, LinkAttributes fla) - => Spider n na fla - -> Interval Timestamp - -> FoundNodePolicy n na - -> EID VNode - -> IO [(VFoundNodeData na, [(EFindsData fla, n)])] -traverseEFindsOneHop spider time_interval fn_policy visit_eid = getTraversedEdges +-- It returns an action that emits the visited Node IDs and +-- 'FoundNode's the node has. Those items are emitted as a single +-- stream, in a mixed and unordered fashion. If it reaches to the end +-- of the stream, the action returns 'Nothing'. +traverseFoundNodes :: (ToJSON n, NodeAttributes na, LinkAttributes fla, FromGraphSON n) + => Spider n na fla + -> Interval Timestamp -- ^ query time interval. + -> FoundNodePolicy n na -- ^ query found node policy + -> n -- ^ the starting node + -> IO (IO (Maybe (Either n (FoundNode n na fla)))) +traverseFoundNodes spider time_interval fn_policy start_nid = do + rhandle <- Gr.submit (spiderClient spider) gr_query (Just gr_binding) + return $ do + msmap <- Gr.nextResult rhandle + maybe (return Nothing) (fmap Just . extractSMap) msmap where - foundNodeTraversal = pure latestFoundNodeIfOverwrite - <*.> fmap gSelectFoundNode (gFilterFoundNodeByTime time_interval) - <*.> gHasNodeEID visit_eid - <*.> pure gAllNodes - latestFoundNodeIfOverwrite = + sourceVNode = gHasNodeID spider start_nid <*.> pure gAllNodes + walkLatestFoundNodeIfOverwrite = case fn_policy of PolicyOverwrite -> gLatestFoundNode PolicyAppend -> gIdentity - - getTraversedEdges = fmap V.toList $ traverse extractFromSMap =<< Gr.slurpResults =<< submitQuery - where - submitQuery = Gr.submit (spiderClient spider) query (Just bindings) - ((query, label_vfnd, label_efs, label_efd, label_target_nid), bindings) = runBinder $ do - lvfnd <- newAsLabel - lefs <- newAsLabel - lefd <- newAsLabel - ltarget <- newAsLabel - let gEFindsAndTarget = - gProject - ( gByL lefd gEFindsData ) - [ gByL ltarget (gNodeID spider <<< gFindsTarget) - ] - <<< gFinds - gt <- gProject - ( gByL lvfnd gVFoundNodeData ) - [ gByL lefs (gFold <<< gEFindsAndTarget) - ] - <$.> foundNodeTraversal - return (gt, lvfnd, lefs, lefd, ltarget) - extractFromSMap smap = do - vfnd <- lookupAsM label_vfnd smap - efs <- lookupAsM label_efs smap - parsed_efs <- mapM extractHopFromSMap efs - return (vfnd, parsed_efs) - extractHopFromSMap smap = - (,) - <$> lookupAsM label_efd smap - <*> lookupAsM label_target_nid smap + walkSelectFoundNode = (<<<) walkLatestFoundNodeIfOverwrite + <$> fmap gSelectFoundNode (gFilterFoundNodeByTime time_interval) + repeat_until = Nothing -- TODO: specify the maximum number of traversals. + ((gr_query, label_smap_type, label_subject, label_vfnd, label_efs, label_efd, label_target), gr_binding) = runBinder $ do + walk_select_fnode <- walkSelectFoundNode + lsmap_type <- newAsLabel + lsubject <- newAsLabel + lefd <- newAsLabel + ltarget <- newAsLabel + lvfnd <- newAsLabel + lefs <- newAsLabel + let walk_select_mixed = gLocal $ gNodeMix walk_select_fnode -- gLocal is necessary because we may have .limit() step inside. + walk_finds_and_target = + gProject + ( gByL lefd gEFindsData ) + [ gByL ltarget (gNodeID spider <<< gFindsTarget) + ] + <<< gFinds + walk_construct_result = gEitherNodeMix walk_construct_vnode walk_construct_vfnode + walk_construct_vnode = + gProject + ( gByL lsmap_type (gConstant ("vn" :: Greskell Text)) ) + [ gByL lsubject (gNodeID spider) + ] + walk_construct_vfnode = + gProject + ( gByL lsmap_type (gConstant ("vfn" :: Greskell Text)) ) + [ gByL lsubject (gSubjectNodeID spider), + gByL lvfnd gVFoundNodeData, + gByL lefs (gFold <<< walk_finds_and_target) + ] + gt <- walk_construct_result + <$.> gDedupNodes + <$.> gRepeat Nothing repeat_until gEmitHead + (walk_select_mixed <<< gSimplePath <<< gTraverseViaFinds <<< gFoundNodeOnly) + <$.> walk_select_mixed + <$.> sourceVNode + return (gt, lsmap_type, lsubject, lvfnd, lefs, lefd, ltarget) + extractSMap smap = do + got_type <- lookupAsM label_smap_type smap + case got_type of + "vn" -> fmap Left $ extractSubjectNodeID smap + "vfn" -> fmap Right $ extractFoundNode smap + _ -> throwString ("Unknow type of traversal result: " ++ show got_type) + -- TODO: make decent exception type + extractSubjectNodeID smap = lookupAsM label_subject smap + extractFoundNode smap = do + sub_nid <- lookupAsM label_subject smap + vfnd <- lookupAsM label_vfnd smap + efs <- lookupAsM label_efs smap + parsed_efs <- mapM extractHopFromSMap efs + return $ makeFoundNodeFromHops sub_nid (vfnd, parsed_efs) + extractHopFromSMap smap = + (,) + <$> lookupAsM label_efd smap + <*> lookupAsM label_target smap -makeFoundNodesFromHops :: n -- ^ Subject node ID - -> (VFoundNodeData na, [(EFindsData fla, n)]) -- ^ Hops +makeFoundNodeFromHops :: n -- ^ Subject node ID + -> (VFoundNodeData na, [(EFindsData fla, n)]) -- ^ (FoundNode data, hops) -> FoundNode n na fla -makeFoundNodesFromHops subject_nid (vfnd, efs) = +makeFoundNodeFromHops subject_nid (vfnd, efs) = makeFoundNode subject_nid vfnd $ map toFoundLink efs where toFoundLink (ef, target_nid) = makeFoundLink target_nid ef -visitNodeForSnapshot :: (ToJSON n, Ord n, Hashable n, FromGraphSON n, Show n, LinkAttributes fla, NodeAttributes na) - => Spider n na fla - -> Query n na fla sla - -> IORef (SnapshotState n na fla) - -> n - -> IO () -visitNodeForSnapshot spider query ref_state visit_nid = do - logDebug spider ("Visiting node " <> spack visit_nid <> " ...") - cur_state <- readIORef ref_state - if isAlreadyVisited cur_state visit_nid - then logAndQuit - else doVisit - where - logAndQuit = do - logDebug spider ("Node " <> spack visit_nid <> " is already visited. Skip.") - return () - doVisit = do - mvisit_eid <- getVisitedNodeEID - case mvisit_eid of - Nothing -> do - logWarn spider ("Node " <> spack visit_nid <> " does not exist.") - return () - Just visit_eid -> do - found_nodes <- fmap (map $ makeFoundNodesFromHops visit_nid) - $ traverseEFindsOneHop spider (timeInterval query) (foundNodePolicy query) visit_eid - logFoundNodes found_nodes - modifyIORef ref_state $ addFoundNodes visit_nid found_nodes - getVisitedNodeEID = fmap vToMaybe $ Gr.slurpResults =<< submitB spider binder - where - binder = gNodeEID <$.> gHasNodeID spider visit_nid <*.> pure gAllNodes - logFoundNodes [] = logDebug spider ("No local finding is found for node " <> spack visit_nid) - logFoundNodes fns = mapM_ logFoundNode $ Found.sortByTime fns - logFoundNode fn = do - let neighbors = neighborLinks fn - logDebug spider - ( "Node " <> (spack $ subjectNode fn) - <> ": local finding at " <> (showEpochTime $ foundAt fn) - <> ", " <> (spack $ length neighbors) <> " neighbors" - ) - mapM_ logFoundLink neighbors - logFoundLink fl = - logDebug spider - ( " Link is found to " <> (spack $ targetNode fl) - ) - --- | The state kept while making the snapshot graph. -data SnapshotState n na fla = - SnapshotState - { ssUnvisitedNodes :: Queue n, - ssWeaver :: Weaver n na fla - } - deriving (Show) - -- debugShowState :: Show n => SnapshotState n na fla -> String -- debugShowState state = unvisited ++ visited_nodes ++ visited_links -- where @@ -325,45 +328,3 @@ -- visited_links = "visitedLinks: " -- ++ (intercalate ", " $ map show $ HM.keys $ ssVisitedLinks state) -emptySnapshotState :: FoundNodePolicy n na -> SnapshotState n na fla -emptySnapshotState p = - SnapshotState - { ssUnvisitedNodes = mempty, - ssWeaver = newWeaver p - } - -initSnapshotState :: [n] -> FoundNodePolicy n na -> SnapshotState n na fla -initSnapshotState init_unvisited_nodes p = - (emptySnapshotState p) { ssUnvisitedNodes = newQueue init_unvisited_nodes } - -isAlreadyVisited :: (Eq n, Hashable n) => SnapshotState n na fla -> n -> Bool -isAlreadyVisited state nid = Weaver.isVisited nid $ ssWeaver state - -popUnvisitedNode :: SnapshotState n na fla -> (SnapshotState n na fla, Maybe n) -popUnvisitedNode state = (updated, popped) - where - updated = state { ssUnvisitedNodes = updatedUnvisited } - (popped, updatedUnvisited) = popQueue $ ssUnvisitedNodes state - -makeSnapshot :: (Ord n, Hashable n, Show n) - => LinkSampleUnifier n na fla sla - -> SnapshotState n na fla - -> ([SnapshotNode n na], [SnapshotLink n sla], [LogLine]) -makeSnapshot unifier state = (nodes, links, logs) - where - ((nodes, links), logs) = Weaver.getSnapshot' unifier $ ssWeaver state - -addFoundNodes :: (Eq n, Hashable n) - => n -> [FoundNode n na fla] -> SnapshotState n na fla -> SnapshotState n na fla -addFoundNodes visited_nid [] state = state { ssWeaver = new_weaver } - where - new_weaver = Weaver.markAsVisited visited_nid $ ssWeaver state -addFoundNodes _ fns state = foldl' (\s fn -> addOneFoundNode fn s) state fns - -addOneFoundNode :: (Eq n, Hashable n) - => FoundNode n na fla -> SnapshotState n na fla -> SnapshotState n na fla -addOneFoundNode fn state = state { ssUnvisitedNodes = new_queue, ssWeaver = new_weaver } - where - new_weaver = Weaver.addFoundNode fn $ ssWeaver state - new_boundary_nodes = filter (\n -> not $ Weaver.isVisited n new_weaver) $ allTargetNodes fn - new_queue = foldl' (\q n -> pushQueue n q) (ssUnvisitedNodes state) new_boundary_nodes diff --git a/src/NetSpider/Spider/Internal/Graph.hs b/src/NetSpider/Spider/Internal/Graph.hs --- a/src/NetSpider/Spider/Internal/Graph.hs +++ b/src/NetSpider/Spider/Internal/Graph.hs @@ -20,7 +20,15 @@ gMakeFoundNode, gSelectFoundNode, gLatestFoundNode, + gSubjectNodeID, gFilterFoundNodeByTime, + gTraverseViaFinds, + -- * Mix of VNode and VFoundNode + gNodeMix, + gFoundNodeOnly, + gEitherNodeMix, + gNodeFirst, + gDedupNodes, -- * EFinds gFinds, gFindsTarget @@ -32,15 +40,16 @@ import Data.Foldable (fold) import Data.Greskell ( WalkType, AEdge, - GTraversal, Filter, Transform, SideEffect, Walk, liftWalk, + GTraversal, Filter, Transform, SideEffect, Walk, liftWalk, unsafeCastEnd, unsafeCastStart, Binder, newBind, - source, sV, sV', sAddV, gHasLabel, gHasId, gHas2, gHas2P, gId, gProperty, gPropertyV, gV, - gNot, gIdentity', - gAddE, gSideEffect, gTo, gFrom, gDrop, gOut, gOrder, gBy2, gValues, gOutE, gInV, + source, sV, sV', sAddV, gAddV, gHasLabel, gHasId, gHas2, gHas2P, gId, gProperty, gPropertyV, gV, + gNot, gIdentity', gIdentity, gUnion, gChoose3, gDedup, + gAddE, gSideEffect, gTo, gFrom, gDrop, gOut, gOrder, gBy, gBy2, gValues, gOutE, gIn, gLabel, ($.), (<*.>), (=:), ToGTraversal, Key, oDecr, gLimit, - pGt, pGte, pLt, pLte + pGt, pGte, pLt, pLte, + tId ) import Data.Int (Int64) import Data.Text (Text, pack) @@ -84,10 +93,10 @@ var_eid <- newBind eid return $ gHasId var_eid -gMakeNode :: ToJSON n => Spider n na fla -> n -> Binder (GTraversal SideEffect () VNode) +gMakeNode :: ToJSON n => Spider n na fla -> n -> Binder (Walk SideEffect a VNode) gMakeNode spider nid = do var_nid <- newBind nid - return $ gProperty (spiderNodeIdKey spider) var_nid $. sAddV "node" $ source "g" + return $ gProperty (spiderNodeIdKey spider) var_nid <<< gAddV "node" gGetNodeByEID :: EID VNode -> Binder (Walk Transform s VNode) gGetNodeByEID vid = do @@ -142,6 +151,9 @@ gLatestFoundNode :: Walk Transform VFoundNode VFoundNode gLatestFoundNode = gLimit 1 <<< gOrder [gBy2 keyTimestamp oDecr] +gSubjectNodeID :: Spider n na fla -> Walk Transform VFoundNode n +gSubjectNodeID spider = gNodeID spider <<< gIn ["is_observed_as"] + gFilterFoundNodeByTime :: Interval Timestamp -> Binder (Walk Filter VFoundNode VFoundNode) gFilterFoundNodeByTime interval = do fl <- filterLower @@ -161,3 +173,44 @@ gFinds :: Walk Transform VFoundNode EFinds gFinds = gOutE ["finds"] + +gTraverseViaFinds :: Walk Transform VFoundNode VNode +gTraverseViaFinds = gOut ["finds"] + +-- | Make a mixed stream of 'VNode' and 'VFoundNode'. In the result +-- walk, the input 'VNode' is output first, and then, the 'VFoundNode' +-- derived from the 'VNode' follows. +gNodeMix :: Walk Transform VNode VFoundNode -- ^ walk to derive 'VFoundNode's from 'VNode'. + -> Walk Transform VNode (Either VNode VFoundNode) +gNodeMix walk_vfn = gUnion [unsafeCastEnd gIdentity, unsafeCastEnd walk_vfn] + +-- | Filter the 'VFoundNode' only from the mix of 'VNode' and +-- 'VFoundNode'. +gFoundNodeOnly :: Walk Transform (Either VNode VFoundNode) VFoundNode +gFoundNodeOnly = unsafeCastStart $ gHasLabel "found_node" + +-- | Transform the mixed stream of 'VNode' and 'VFoundNode' into a +-- common type @a@. +gEitherNodeMix :: Walk Transform VNode a + -> Walk Transform VFoundNode a + -> Walk Transform (Either VNode VFoundNode) a +gEitherNodeMix walk_vn walk_vfn = + gChoose3 (unsafeCastStart walk_pred) (unsafeCastStart walk_vn) (unsafeCastStart walk_vfn) + where + walk_pred :: Walk Filter VNode VNode + walk_pred = gHasLabel "node" + +-- | Sort the mix of 'VNode' and 'VFoundNode' so that 'VNode' is +-- output first. +gNodeFirst :: Walk Transform (Either VNode VFoundNode) (Either VNode VFoundNode) +gNodeFirst = unsafeCastEnd $ unsafeCastStart $ walk_for_elem + where + walk_for_elem :: Walk Transform VNode VNode + walk_for_elem = gOrder [gBy2 gLabel oDecr] + +-- | Dedup mix of 'VNode' and 'VFoundNode' based on their 'EID'. +gDedupNodes :: Walk Transform (Either VNode VFoundNode) (Either VNode VFoundNode) +gDedupNodes = unsafeCastEnd $ unsafeCastStart $ walk_for_elem + where + walk_for_elem :: Walk Transform VNode VNode + walk_for_elem = gDedup $ Just $ gBy tId diff --git a/test/SnapshotTestCase.hs b/test/SnapshotTestCase.hs --- a/test/SnapshotTestCase.hs +++ b/test/SnapshotTestCase.hs @@ -16,13 +16,14 @@ import NetSpider.Found (FoundNode(..), FoundLink(..), LinkState(..)) import NetSpider.Graph (NodeAttributes, LinkAttributes) +import NetSpider.Pair (Pair(Pair)) import NetSpider.Query ( Query, defQuery, unifyLinkSamples, - foundNodePolicy, policyOverwrite, policyAppend + FoundNodePolicy, foundNodePolicy, policyOverwrite, policyAppend ) import NetSpider.Snapshot ( SnapshotLink, SnapshotGraph, - nodeId, linkNodeTuple, isDirected, linkTimestamp, + nodeId, linkNodeTuple, linkNodePair, isDirected, linkTimestamp, isOnBoundary, nodeTimestamp ) import qualified NetSpider.Snapshot as S (nodeAttributes, linkAttributes) @@ -79,6 +80,78 @@ where getKey link = (linkNodeTuple link, S.linkAttributes link) + +diamondTopologyCase :: FoundNodePolicy Text () -> SnapshotTestCase +diamondTopologyCase fn_policy = + SnapshotTestCase + { caseName = "diamond topology, " ++ show fn_policy, + caseInput = + let mkLink target = + FoundLink + { targetNode = target, + linkState = LinkBidirectional, + linkAttributes = () + } + mkNode sub ts targets = + FoundNode + { subjectNode = sub, + foundAt = fromS ts, + nodeAttributes = (), + neighborLinks = map mkLink targets + } + -- (n1)---(n2)---(n4)---(n5)---(n6) + -- | | + -- +----(n3)----+ + fns :: [FoundNode Text () ()] + fns = [ mkNode "n1" "2020-04-23T10:30" ["n2", "n3"], + mkNode "n2" "2020-04-23T10:35" ["n1", "n4"], + mkNode "n3" "2020-04-23T10:20" ["n1", "n4"], + mkNode "n4" "2020-04-23T10:30" ["n2", "n3", "n5"], + mkNode "n5" "2020-04-23T11:10" ["n4", "n6"], + mkNode "n6" "2020-04-23T10:25" ["n5"] + ] + in fns, + caseQuery = (defQuery ["n1"]) { foundNodePolicy = fn_policy }, + caseAssert = \got_graph -> do + let (got_ns, _) = sortSnapshotElements got_graph + got_ls = V.fromList $ sortOn linkNodePair $ snd got_graph + -- print got_graph + nodeId (got_ns ! 0) `shouldBe` "n1" + nodeId (got_ns ! 1) `shouldBe` "n2" + nodeId (got_ns ! 2) `shouldBe` "n3" + nodeId (got_ns ! 3) `shouldBe` "n4" + nodeId (got_ns ! 4) `shouldBe` "n5" + nodeId (got_ns ! 5) `shouldBe` "n6" + V.length got_ns `shouldBe` 6 + isOnBoundary (got_ns ! 0) `shouldBe` False + isOnBoundary (got_ns ! 1) `shouldBe` False + isOnBoundary (got_ns ! 2) `shouldBe` False + isOnBoundary (got_ns ! 3) `shouldBe` False + isOnBoundary (got_ns ! 4) `shouldBe` False + isOnBoundary (got_ns ! 5) `shouldBe` False + linkNodePair (got_ls ! 0) `shouldBe` Pair ("n1", "n2") + linkNodePair (got_ls ! 1) `shouldBe` Pair ("n1", "n3") + linkNodePair (got_ls ! 2) `shouldBe` Pair ("n2", "n4") + linkNodePair (got_ls ! 3) `shouldBe` Pair ("n3", "n4") + linkNodePair (got_ls ! 4) `shouldBe` Pair ("n4", "n5") + linkNodePair (got_ls ! 5) `shouldBe` Pair ("n5", "n6") + V.length got_ls `shouldBe` 6 + isDirected (got_ls ! 0) `shouldBe` False + isDirected (got_ls ! 1) `shouldBe` False + isDirected (got_ls ! 2) `shouldBe` False + isDirected (got_ls ! 3) `shouldBe` False + isDirected (got_ls ! 4) `shouldBe` False + isDirected (got_ls ! 5) `shouldBe` False + linkTimestamp (got_ls ! 0) `shouldBe` fromS "2020-04-23T10:35" + linkTimestamp (got_ls ! 1) `shouldBe` fromS "2020-04-23T10:30" + linkTimestamp (got_ls ! 2) `shouldBe` fromS "2020-04-23T10:35" + linkTimestamp (got_ls ! 3) `shouldBe` fromS "2020-04-23T10:30" + linkTimestamp (got_ls ! 4) `shouldBe` fromS "2020-04-23T11:10" + linkTimestamp (got_ls ! 5) `shouldBe` fromS "2020-04-23T11:10" + } + + + -- | \"Basic\" test cases are shared by ServerTest and -- WeaverSpec. Weaver has the following limitation, so the test cases -- should not include any of those features. @@ -243,6 +316,11 @@ { targetNode = "n2", linkState = LinkToTarget, linkAttributes = () + }, + FoundLink + { targetNode = "n3", + linkState = LinkToSubject, + linkAttributes = () } ], nodeAttributes = () @@ -581,8 +659,10 @@ isDirected (got_ls ! 2) `shouldBe` True linkTimestamp (got_ls ! 2) `shouldBe` fromS "2020-02-18T10:00" V.length got_ls `shouldBe` 3 - } - + }, + + diamondTopologyCase policyOverwrite, + diamondTopologyCase policyAppend ] where one_neighbor_assert (got_ns, got_ls) = do