net-spider 0.4.3.0 → 0.4.3.1
raw patch · 5 files changed
+291/−193 lines, 5 filesdep ~greskellPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: greskell
API changes (from Hackage documentation)
- NetSpider.Spider: instance (GHC.Show.Show n, GHC.Show.Show fla, GHC.Show.Show na) => GHC.Show.Show (NetSpider.Spider.SnapshotState n na fla)
Files
- ChangeLog.md +4/−0
- net-spider.cabal +2/−2
- src/NetSpider/Spider.hs +141/−180
- src/NetSpider/Spider/Internal/Graph.hs +60/−7
- test/SnapshotTestCase.hs +84/−4
ChangeLog.md view
@@ -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.
net-spider.cabal view
@@ -1,5 +1,5 @@ name: net-spider-version: 0.4.3.0+version: 0.4.3.1 author: Toshio Ito <debug.ito@gmail.com> maintainer: Toshio Ito <debug.ito@gmail.com> 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,
src/NetSpider/Spider.hs view
@@ -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
src/NetSpider/Spider/Internal/Graph.hs view
@@ -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
test/SnapshotTestCase.hs view
@@ -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