net-spider 0.4.1.0 → 0.4.2.0

raw patch · 15 files changed

+1503/−832 lines, 15 filesdep ~greskelldep ~hashablePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: greskell, hashable

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−0
• net-spider.cabal +14/−6
• src/NetSpider.hs +4/−0
• src/NetSpider/Found.hs +21/−2
• src/NetSpider/Graph/Internal.hs +32/−2
• src/NetSpider/Spider.hs +97/−153
• src/NetSpider/Unify.hs +17/−2
• src/NetSpider/Weaver.hs +203/−0
• test/NetSpider/WeaverSpec.hs +180/−0
• test/ServerTest/Attributes.hs +2/−4
• test/ServerTest/Common.hs +0/−140
• test/ServerTest/ServerCommon.hs +34/−0
• test/ServerTest/Snapshot.hs +32/−523
• test/SnapshotTestCase.hs +741/−0
• test/TestCommon.hs +114/−0

@@ -1,5 +1,17 @@ # Revision history for net-spider +## 0.4.2.0  -- 2020-03-21++* Add Weaver module.++### Unify module++* Add `toLinkSamples` function.++### Found module++* Add `sortByTime`, `allTargetNodes` functions.+ ## 0.4.1.0  -- 2020-01-26  * Add `GraphML.Attribute` module. `AttributeValue` and related types

@@ -1,5 +1,5 @@ name:                   net-spider-version:                0.4.1.0+version:                0.4.2.0 author:                 Toshio Ito <debug.ito@gmail.com> maintainer:             Toshio Ito <debug.ito@gmail.com> license:                BSD3@@ -44,7 +44,8 @@                         NetSpider.Snapshot.Internal,                         NetSpider.GraphML.Writer,                         NetSpider.GraphML.Attribute,-                        NetSpider.Interval+                        NetSpider.Interval,+                        NetSpider.Weaver   other-modules:        NetSpider.Graph.Internal,                         NetSpider.Spider.Internal.Graph,                         NetSpider.Spider.Internal.Log,@@ -86,13 +87,18 @@   main-is:              Spec.hs   -- default-extensions:      other-extensions:     OverloadedStrings,-                        DeriveGeneric+                        DeriveGeneric,+                        GADTs   other-modules:        NetSpider.GraphML.WriterSpec,                         NetSpider.TimestampSpec,                         NetSpider.FoundSpec,                         NetSpider.SnapshotSpec,-                        JSONUtil+                        NetSpider.WeaverSpec+                        JSONUtil,+                        SnapshotTestCase,+                        TestCommon   build-depends:        base, net-spider, vector, text, aeson, bytestring, time,+                        greskell, hashable,                         hspec >=2.4.4  flag server-test@@ -109,9 +115,11 @@   hs-source-dirs:       test   ghc-options:          -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m"   main-is:              ServerTest.hs-  other-modules:        ServerTest.Common,+  other-modules:        TestCommon,+                        SnapshotTestCase,                         ServerTest.Snapshot,-                        ServerTest.Attributes+                        ServerTest.Attributes,+                        ServerTest.ServerCommon   if flag(server-test)     build-depends:        base, hspec, net-spider, vector, text, greskell-websocket, greskell,                           aeson, unordered-containers, text, hashable, time, safe-exceptions,

@@ -23,6 +23,10 @@ -- * "NetSpider.Query" -- * "NetSpider.Unify" --+-- == Weaver (on-memory snapshot builder)+--+-- * "NetSpider.Weaver"+-- -- == Data models -- -- * "NetSpider.Found"

@@ -6,11 +6,16 @@ -- --  module NetSpider.Found-       ( FoundNode(..),+       ( -- * Local findings+         FoundNode(..),          FoundLink(..),+         -- * LinkState          LinkState(..),          linkStateToText,-         linkStateFromText+         linkStateFromText,+         -- * Utilities+         sortByTime,+         allTargetNodes        ) where  import qualified Control.Monad.Fail as Fail@@ -19,6 +24,7 @@ import Data.Bifunctor (Bifunctor(..)) import Data.Char (isUpper, toLower) import Data.Greskell (FromGraphSON(..))+import Data.List (sortOn, reverse) import Data.Text (Text, unpack) import GHC.Generics (Generic) import qualified Text.Regex.Applicative as RE@@ -151,3 +157,16 @@ instance (ToJSON n, ToJSON na, ToJSON la) => ToJSON (FoundNode n na la) where   toJSON = Aeson.genericToJSON aesonOpt   toEncoding = Aeson.genericToEncoding aesonOpt++-- | Sort the list of 'FoundNode's by descending order of their+-- timestamps. The latest 'FoundNode' is at the top.+--+-- @since 0.4.2.0+sortByTime :: [FoundNode n na la] -> [FoundNode n na la]+sortByTime fns = reverse $ sortOn foundAt fns++-- | Get all 'targetNode's of the 'FoundNode'.+--+-- @since 0.4.2.0+allTargetNodes :: FoundNode n na la -> [n]+allTargetNodes = map targetNode . neighborLinks

@@ -24,7 +24,10 @@          LinkAttributes(..),          gSetLinkState,          gFindsTarget,-         gEFindsData+         gEFindsData,+         -- * Reconstruction+         makeFoundNode,+         makeFoundLink        ) where  import Control.Category ((<<<))@@ -51,7 +54,10 @@ import Data.Time.LocalTime (TimeZone(..))  import NetSpider.Timestamp (Timestamp(..))-import NetSpider.Found (LinkState, linkStateToText, linkStateFromText)+import NetSpider.Found+  ( LinkState, linkStateToText, linkStateFromText,+    FoundLink(..), FoundNode(..)+  )  -- | Generic element ID used in the graph DB. type EID = ElementID@@ -260,3 +266,27 @@   writeLinkAttributes = writePMapProperties   parseLinkAttributes = traverse parseGraphSON . pMapFromList . pMapToList   +-- | Make 'FoundLink' out of 'EFindsData'.+makeFoundLink :: n -- ^ Target node ID+              -> EFindsData la -- ^ Attributes of \"finds\" edge+              -> FoundLink n la+makeFoundLink target_nid ef_data =+  FoundLink+  { targetNode = target_nid,+    linkState = efLinkState ef_data,+    linkAttributes = efLinkAttributes ef_data+  }++-- | Make 'FoundNode' out of 'VFoundNodeData' and other graph+-- elements.+makeFoundNode :: n -- ^ Subject node ID+              -> VFoundNodeData na -- ^ Attributes of the 'FoundNode'.+              -> [FoundLink n la] -- ^ neighbor links+              -> FoundNode n na la+makeFoundNode subject_nid vfn neighbors =+  FoundNode+  { subjectNode = subject_nid,+    foundAt = vfnTimestamp vfn,+    neighborLinks = neighbors,+    nodeAttributes = vfnAttributes vfn+  }

@@ -26,12 +26,12 @@ import Control.Exception.Safe (throwString, bracket) import Control.Monad (void, mapM_, mapM) import Data.Aeson (ToJSON)-import Data.Foldable (foldr', toList)+import Data.Foldable (foldr', toList, foldl') import Data.List (intercalate) import Data.Greskell   ( runBinder, ($.), (<$.>), (<*.>),     Binder, ToGreskell(GreskellReturn), AsIterator(IteratorItem), FromGraphSON,-    liftWalk, gLimit, gIdentity, gSelect1, gAs, gProject, gByL, gIdentity,+    liftWalk, gLimit, gIdentity, gSelect1, gAs, gProject, gByL, gIdentity, gFold,     lookupAsM, newAsLabel,     Transform, Walk   )@@ -43,7 +43,6 @@ import Data.IORef (IORef, modifyIORef, newIORef, readIORef, atomicModifyIORef') import Data.Maybe (catMaybes, mapMaybe, listToMaybe) import Data.Monoid (mempty, (<>))-import Data.List (sortOn) import Data.Text (Text, pack) import Data.Vector (Vector) import qualified Data.Vector as V@@ -54,9 +53,12 @@ import NetSpider.Graph.Internal   ( VFoundNode, EFinds, VNode,     VFoundNodeData(..), EFindsData(..),-    gVFoundNodeData, gEFindsData+    gVFoundNodeData, gEFindsData,+    makeFoundNode, makeFoundLink   )-import NetSpider.Found (FoundNode(..), FoundLink(..), LinkState(..))+import NetSpider.Found+  (FoundNode(..), FoundLink(..), LinkState(..), allTargetNodes)+import qualified NetSpider.Found as Found import NetSpider.Log (runWriterLoggingM, WriterLoggingM, logDebugW, LogLine, spack) import NetSpider.Pair (Pair) import NetSpider.Queue (Queue, newQueue, popQueue, pushQueue)@@ -79,6 +81,8 @@ import NetSpider.Spider.Internal.Spider (Spider(..)) import NetSpider.Timestamp (Timestamp, showEpochTime) import NetSpider.Unify (LinkSampleUnifier, LinkSample(..), LinkSampleID, linkSampleId)+import NetSpider.Weaver (Weaver, newWeaver)+import qualified NetSpider.Weaver as Weaver  -- | Connect to the WebSocket endpoint of Tinkerpop Gremlin Server -- that hosts the NetSpider database.@@ -172,7 +176,7 @@             -> Query n na fla sla             -> IO (SnapshotGraph n na sla) getSnapshot spider query = do-  ref_state <- newIORef $ initSnapshotState $ startsFrom query+  ref_state <- newIORef $ initSnapshotState (startsFrom query) (foundNodePolicy query)   recurseVisitNodesForSnapshot spider query ref_state   (nodes, links, logs) <- fmap (makeSnapshot $ unifyLinkSamples query) $ readIORef ref_state   mapM_ (logLine spider) logs@@ -195,51 +199,64 @@     getNextVisit = atomicModifyIORef' ref_state popUnvisitedNode     -- TODO: limit number of steps. --- | Returns the result of query: (latest VFoundNode, list of traversed edges)+-- | Traverse one hop from the visited 'VNode'.+--+-- 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 (Maybe (VFoundNodeData na), [(VFoundNodeData na, EFindsData fla, n)])-traverseEFindsOneHop spider time_interval visit_eid = (,) <$> getLatestVFoundNode <*> getTraversedEdges+                     -> IO [(VFoundNodeData na, [(EFindsData fla, n)])]+traverseEFindsOneHop spider time_interval fn_policy visit_eid = getTraversedEdges   where-    foundNodeTraversal = fmap gSelectFoundNode (gFilterFoundNodeByTime time_interval)+    foundNodeTraversal = pure latestFoundNodeIfOverwrite+                         <*.> fmap gSelectFoundNode (gFilterFoundNodeByTime time_interval)                          <*.> gHasNodeEID visit_eid                          <*.> pure gAllNodes-    getLatestVFoundNode = fmap vToMaybe $ Gr.slurpResults =<< submitQuery-      where-        submitQuery = submitB spider binder-        binder = gVFoundNodeData <$.> gLatestFoundNode <$.> foundNodeTraversal+    latestFoundNodeIfOverwrite =+      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_vfn, label_ef, label_target_nid), bindings) = runBinder $ do-          lvfn <- newAsLabel+        ((query, label_vfnd, label_efs, label_efd, label_target_nid), bindings) = runBinder $ do           lvfnd <- newAsLabel-          lef <- newAsLabel+          lefs <- newAsLabel           lefd <- newAsLabel-          ln <- newAsLabel+          ltarget <- newAsLabel+          let gEFindsAndTarget =+                gProject+                ( gByL lefd gEFindsData )+                [ gByL ltarget (gNodeID spider <<< gFindsTarget)+                ]+                <<< gFinds           gt <- gProject-                ( gByL lvfnd (gVFoundNodeData <<< gSelect1 lvfn) )-                [ gByL lefd (gEFindsData <<< gSelect1 lef),-                  gByL ln (gIdentity :: Walk Transform n n)-                ] <$.> gNodeID spider <$.> gFindsTarget-                <$.> gAs lef <$.> gFinds <$.> gAs lvfn <$.> foundNodeTraversal-          return (gt, lvfnd, lefd, ln)-        extractFromSMap smap =-          (,,)-          <$> lookupAsM label_vfn smap -          <*> lookupAsM label_ef smap -          <*> lookupAsM label_target_nid smap +                ( 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 -makeLinkSample :: n -> VFoundNodeData na -> EFindsData la -> n -> LinkSample n la-makeLinkSample subject_nid vfn efinds target_nid = -  LinkSample { lsSubjectNode = subject_nid,-               lsTargetNode = target_nid,-               lsLinkState = efLinkState efinds,-               lsTimestamp = vfnTimestamp vfn,-               lsLinkAttributes = efLinkAttributes efinds-             }+makeFoundNodesFromHops :: n -- ^ Subject node ID+                       -> (VFoundNodeData na, [(EFindsData fla, n)]) -- ^ Hops+                       -> FoundNode n na fla+makeFoundNodesFromHops 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@@ -264,48 +281,34 @@          logWarn spider ("Node " <> spack visit_nid <> " does not exist.")          return ()        Just visit_eid -> do-         (mlatest_vfn, hops) <- traverseEFindsOneHop spider (timeInterval query) visit_eid-         markAsVisited $ mlatest_vfn-         logLatestVFN mlatest_vfn-         let next_hops = filterHops mlatest_vfn $ hops-         -- putStrLn ("-- visit " ++ show visit_nid)-         -- putStrLn ("   latest vfn: " ++ (show $ fmap vfnTimestamp mlatest_vfn))-         -- forM_ next_hops $ \(vfn, _, next_nid) -> do-         --   putStrLn ("   next: " ++ (show $ vfnTimestamp vfn) ++ " -> " ++ show next_nid)-         mapM_ logHop next_hops-         modifyIORef ref_state $ addLinkSamples-           $ map (uncurry3 $ makeLinkSample visit_nid) $ next_hops-         -- cur_state <- readIORef ref_state-         -- putStrLn $ debugShowState cur_state+         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-    markAsVisited mvfn = modifyIORef ref_state $ addVisitedNode visit_nid mvfn-    logLatestVFN Nothing = logDebug spider ("No local finding is found for node " <> spack visit_nid)-    logLatestVFN (Just vfn) = logDebug spider ( "Node " <> spack visit_nid-                                                <> ": latest local finding is at "-                                                <> (showEpochTime $ vfnTimestamp vfn)-                                              )-    uncurry3 f (a,b,c) = f a b c-    filterHops mvfn =-      case foundNodePolicy query of-       PolicyOverwrite -> filter (hopHasVFN mvfn)-       PolicyAppend -> id-    hopHasVFN Nothing _ = True-    hopHasVFN (Just vfn1) (vfn2, _, _) = vfnId vfn1 == vfnId vfn2-    logHop (vfn, _, next_nid) = logDebug spider ( "Link " <> spack visit_nid-                                                  <> " -> " <> spack next_nid-                                                  <> " at " <> (showEpochTime $ vfnTimestamp vfn)-                                                )+    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,-    ssVisitedNodes :: HashMap n (Maybe (VFoundNodeData na)),-    -- ^ If the visited node has no observation yet, its node-    -- attributes 'Nothing'.-    ssVisitedLinks :: HashMap (LinkSampleID n) [LinkSample n fla]+    ssWeaver :: Weaver n na fla   }   deriving (Show) @@ -322,39 +325,19 @@ --     visited_links = "visitedLinks: " --                     ++ (intercalate ", " $ map show $ HM.keys $ ssVisitedLinks state) -emptySnapshotState :: (Ord n, Hashable n) => SnapshotState n na fla-emptySnapshotState = SnapshotState-                     { ssUnvisitedNodes = mempty,-                       ssVisitedNodes = mempty,-                       ssVisitedLinks = mempty-                     }--initSnapshotState :: (Ord n, Hashable n) => [n] -> SnapshotState n na fla-initSnapshotState init_unvisited_nodes = emptySnapshotState { ssUnvisitedNodes = newQueue init_unvisited_nodes }+emptySnapshotState :: FoundNodePolicy n na -> SnapshotState n na fla+emptySnapshotState p =+  SnapshotState+  { ssUnvisitedNodes = mempty,+    ssWeaver = newWeaver p+  } -addVisitedNode :: (Eq n, Hashable n) => n -> Maybe (VFoundNodeData na) -> SnapshotState n na fla -> SnapshotState n na fla-addVisitedNode nid mv state = state { ssVisitedNodes = HM.insert nid mv $ ssVisitedNodes state }+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 = HM.member nid $ ssVisitedNodes state--addLinkSample :: (Ord n, Hashable n)-              => LinkSample n fla -> SnapshotState n na fla -> SnapshotState n na fla-addLinkSample ls state = state { ssVisitedLinks = updatedLinks,-                                 ssUnvisitedNodes = updatedUnvisited-                               }-  where-    link_id = linkSampleId ls-    updatedLinks = HM.insertWith (++) link_id (return ls) $ ssVisitedLinks state-    target_nid = lsTargetNode ls-    target_already_visited = isAlreadyVisited state target_nid-    updatedUnvisited = if target_already_visited-                       then ssUnvisitedNodes state-                       else pushQueue target_nid $ ssUnvisitedNodes state--addLinkSamples :: (Ord n, Hashable n)-               => [LinkSample n fla] -> SnapshotState n na fla -> SnapshotState n na fla-addLinkSamples links orig_state = foldr' addLinkSample orig_state links+isAlreadyVisited state nid = Weaver.isVisited nid $ ssWeaver state  popUnvisitedNode :: SnapshotState n na fla -> (SnapshotState n na fla, Maybe n) popUnvisitedNode state = (updated, popped)@@ -362,64 +345,25 @@     updated = state { ssUnvisitedNodes = updatedUnvisited }     (popped, updatedUnvisited) = popQueue $ ssUnvisitedNodes state -makeSnapshot :: (Eq n, Hashable n, Show n)+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 = visited_nodes ++ boundary_nodes-    visited_nodes = map (makeSnapshotNode state) $ HM.keys $ ssVisitedNodes state-    boundary_nodes = map (makeSnapshotNode state) $ toList $ ssUnvisitedNodes state-    (links, logs) = runWriterLoggingM $ fmap mconcat-                    $ mapM (makeSnapshotLinks unifier state) $ HM.elems $ ssVisitedLinks state-    +    ((nodes, links), logs) = Weaver.getSnapshot' unifier $ ssWeaver state -makeSnapshotNode :: (Eq n, Hashable n) => SnapshotState n na fla -> n -> SnapshotNode n na-makeSnapshotNode state nid =-  SnapshotNode { _nodeId = nid,-                 _isOnBoundary = on_boundary,-                 _nodeTimestamp = fmap vfnTimestamp $ mvfn,-                 _nodeAttributes = fmap vfnAttributes $ mvfn-               }+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-    (on_boundary, mvfn) =-      case HM.lookup nid $ ssVisitedNodes state of-       Nothing -> (True, Nothing)-       Just mv -> (False, mv)+    new_weaver = Weaver.markAsVisited visited_nid $ ssWeaver state+addFoundNodes _ fns state = foldl' (\s fn -> addOneFoundNode fn s) state fns --- | The input 'LinkSample's must be for the equivalent--- 'LinkSampleID'. The output is list of 'SnapshotLink's, each of--- which corresponds to a subgroup of 'LinkSample's.-makeSnapshotLinks :: (Eq n, Hashable n, Show n)-                  => LinkSampleUnifier n na fla sla-                  -> SnapshotState n na fla-                  -> [LinkSample n fla]-                  -> WriterLoggingM [SnapshotLink n sla]-makeSnapshotLinks _ _ [] = return []-makeSnapshotLinks unifier state link_samples@(head_sample : _) = do-  unified <- doUnify link_samples-  logUnified unified-  return $ mapMaybe makeSnapshotLink unified+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-    makeEndNode getter = makeSnapshotNode state $ getter $ head_sample-    doUnify = unifier (makeEndNode lsSubjectNode) (makeEndNode lsTargetNode)-    logUnified unified = logDebugW ( "Unify link [" <> (spack $ lsSubjectNode head_sample) <> "]-["-                                     <> (spack $ lsTargetNode head_sample) <> "]: "-                                     <> "from " <> (spack $ length link_samples) <> " samples "-                                     <> "to " <> (spack $ length unified) <> " samples"-                                   )-    makeSnapshotLink unified_sample = do-      case lsLinkState unified_sample of-       LinkUnused -> Nothing-       LinkToTarget -> Just $ sampleToLink unified_sample True True-       LinkToSubject -> Just $ sampleToLink unified_sample False True-       LinkBidirectional -> Just $ sampleToLink unified_sample True False-    sampleToLink sample to_target is_directed = -      SnapshotLink { _sourceNode = (if to_target then lsSubjectNode else lsTargetNode) sample,-                     _destinationNode = (if to_target then lsTargetNode else lsSubjectNode) sample,-                     _isDirected = is_directed,-                     _linkTimestamp = lsTimestamp sample,-                     _linkAttributes = lsLinkAttributes sample-                   }-+    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

@@ -11,6 +11,7 @@          LinkSample(..),          LinkSampleID,          linkSampleId,+         toLinkSamples,          -- * Standard unifiers          unifyToOne,          unifyToMany,@@ -30,7 +31,8 @@ import Data.Monoid ((<>)) import GHC.Exts (groupWith) -import NetSpider.Found (FoundLink, LinkState)+import NetSpider.Found (FoundLink, LinkState, FoundNode)+import qualified NetSpider.Found as Found import NetSpider.Log (WriterLoggingM, logDebugW, spack) import NetSpider.Pair (Pair(..)) import NetSpider.Snapshot (SnapshotNode, nodeTimestamp, nodeId, SnapshotLink)@@ -60,7 +62,20 @@ linkSampleId :: LinkSample n la -> LinkSampleID n linkSampleId l = Pair (lsSubjectNode l, lsTargetNode l) -+-- | Make 'LinkSample's from 'FoundLink's in 'FoundNode'.+--+-- @since 0.4.2.0+toLinkSamples :: FoundNode n na la -> [LinkSample n la]+toLinkSamples fn = map fromFoundLink $ Found.neighborLinks fn+  where+    fromFoundLink fl =+      LinkSample+      { lsSubjectNode = Found.subjectNode fn,+        lsTargetNode = Found.targetNode fl,+        lsLinkState = Found.linkState fl,+        lsTimestamp = Found.foundAt fn,+        lsLinkAttributes = Found.linkAttributes fl+      }  -- | Function to unify 'LinkSample's collected for the given pair of -- nodes and return 'LinkSample' per physical link. The returned

@@ -0,0 +1,203 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-}+-- |+-- Module: NetSpider.Weaver+-- Description: On-memory builder for snapshot graphs+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- @since 0.4.2.0+module NetSpider.Weaver+  ( -- * Type+    Weaver,+    -- * Construction+    newWeaver,+    -- * Add FoundNode+    addFoundNode,+    markAsVisited,+    -- * Query+    getSnapshot,+    getSnapshot',+    isVisited,+    getFoundNodes,+    getBoundaryNodes,+    -- * Misc.+    visitAllBoundaryNodes+  ) where++import Data.Foldable (foldl')+import Data.Hashable (Hashable)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HM+import qualified Data.HashSet as HS+import Data.List (sort, reverse, sortOn)+import Data.Maybe (listToMaybe, mapMaybe)+import GHC.Exts (groupWith)++import NetSpider.Found (FoundNode(..), LinkState(..), FoundLink(targetNode))+import NetSpider.Log+  ( runWriterLoggingM, WriterLoggingM, logDebugW, LogLine, spack+  )+import NetSpider.Log ()+import NetSpider.Query.Internal (FoundNodePolicy(..))+import NetSpider.Query (policyOverwrite, policyAppend)+import NetSpider.Snapshot.Internal+  ( SnapshotGraph, SnapshotNode(..), SnapshotLink(..)+  )+import NetSpider.Timestamp (Timestamp)+import NetSpider.Unify+  ( LinkSampleUnifier,+    LinkSampleID,+    LinkSample(..),+    linkSampleId+  )+import qualified NetSpider.Unify as Unify++-- | 'Weaver' is an on-memory builder for snapshot graphs. It builds a+-- 'SnapshotGraph' from 'FoundNode's without using an external graph+-- database.+data Weaver n na la =+  Weaver+  { visitedNodes :: HashMap n [FoundNode n na la],+    -- ^ Node IDs for visited nodes are kept as the key. The value is+    -- empty if there is no observation for that visited node.+    foundNodePolicy :: FoundNodePolicy n na+    -- ^ Policy to maintain the value of 'visitedNodes'.+  }+  deriving (Show,Eq)++-- | Make a new 'Weaver'.+--+-- The 'FoundNodePolicy' controls the behavior of 'addFoundNode'. If+-- it's 'policyOverwrite', 'Weaver' maintains only the 'FoundNode'+-- with the latest timestamp for each node. If it's 'policyAppend',+-- 'Weaver' maintains all 'FoundNode's added.+newWeaver :: FoundNodePolicy n na -> Weaver n na la+newWeaver p = Weaver HM.empty p++-- | Add a 'FoundNode' to the 'Weaver'. See also 'newWeaver'.+addFoundNode :: (Eq n, Hashable n) => FoundNode n na la -> Weaver n na la -> Weaver n na la+addFoundNode fn weaver = new_weaver+  where+    nid = subjectNode fn+    new_weaver = weaver { visitedNodes = HM.insertWith updater nid [fn] $ visitedNodes weaver }+    updater =+      case foundNodePolicy weaver of+        PolicyOverwrite -> \new old -> if latestTimeOfNodes new >= latestTimeOfNodes old+                                       then new+                                       else old+        PolicyAppend -> \new old -> new ++ old+    latestTimeOfNodes ns = listToMaybe $ reverse $ sort $ map foundAt ns++-- | Mark the node ID as visited in the 'Weaver' without any+-- 'FoundNode'. If there is already some 'FoundNode' for the node ID,+-- this function does nothing.+markAsVisited :: (Eq n, Hashable n) => n -> Weaver n na la -> Weaver n na la+markAsVisited nid w = w { visitedNodes = HM.insertWith updater nid [] $ visitedNodes w }+  where+    updater _ old = old++-- | Returns 'True' if the node ID is already visited in the 'Weaver'.+--+-- A visited node is the one that has at least one 'FoundNode' added,+-- or on which 'markAsVisited' has executed.+isVisited :: (Eq n, Hashable n) => n -> Weaver n na la -> Bool+isVisited n w = HM.member n (visitedNodes w)++-- | Get the 'FoundNode's for the given node ID kept in 'Weaver'.+--+-- It returns 'Nothing' if the node ID is not visited. It returns an+-- empty list if the node ID is visited (by 'markAsVisited'), but+-- doesn't have any 'FoundNode'.+getFoundNodes :: (Eq n, Hashable n) => n -> Weaver n na la -> Maybe [FoundNode n na la]+getFoundNodes n w = HM.lookup n (visitedNodes w)++-- | Make 'SnapshotGraph' from the current 'Weaver'.+--+-- The 'SnapshotGraph' is constructed from all 'FoundNode's added to+-- the 'Weaver' so far.+getSnapshot :: (Ord n, Hashable n, Show n) => LinkSampleUnifier n na fla sla -> Weaver n na fla -> SnapshotGraph n na sla+getSnapshot u w = fst $ getSnapshot' u w++-- | Get boundary nodes from the 'Weaver'.+--+-- A boundary node is a node that has been observed as a target of+-- some links but not visited yet. This function returns the set of+-- unique boundary nodes.+getBoundaryNodes :: (Eq n, Hashable n) => Weaver n na fla -> [n]+getBoundaryNodes weaver = HS.toList boundary_nodes_set+  where+    boundary_nodes_set = HS.fromList $ filter (\nid -> not $ isVisited nid weaver) $ all_target_nodes+    all_target_nodes = (map targetNode . neighborLinks) =<< (concat $ HM.elems $ visitedNodes weaver)++-- | (Basically for testing): run 'markAsVisited' on all boundary+-- nodes.+visitAllBoundaryNodes :: (Eq n, Hashable n) => Weaver n na fla -> Weaver n na fla+visitAllBoundaryNodes weaver = foldl' (\w n -> markAsVisited n w) weaver $ getBoundaryNodes weaver++latestFoundNodeFor :: (Eq n, Hashable n) => n -> Weaver n na fla -> Maybe (FoundNode n na fla)+latestFoundNodeFor nid weaver = do+  found_nodes <- HM.lookup nid $ visitedNodes weaver+  listToMaybe $ reverse $ sortOn foundAt $ found_nodes++makeSnapshotNode :: (Eq n, Hashable n) => Weaver n na fla -> n -> SnapshotNode n na+makeSnapshotNode weaver nid =+  SnapshotNode { _nodeId = nid,+                 _isOnBoundary = not $ isVisited nid weaver,+                 _nodeTimestamp = m_timestamp,+                 _nodeAttributes = m_attributes+               }+  where+    mfn = latestFoundNodeFor nid weaver+    m_timestamp = fmap foundAt mfn+    m_attributes = fmap nodeAttributes mfn++allLinkSamples :: Weaver n na la -> [LinkSample n la]+allLinkSamples w = Unify.toLinkSamples =<< (concat $ HM.elems $ visitedNodes w)++-- | Same as 'getSnapshot', but it also returns logs.+getSnapshot' :: (Ord n, Hashable n, Show n)+             => LinkSampleUnifier n na fla sla+             -> Weaver n na fla+             -> (SnapshotGraph n na sla, [LogLine])+getSnapshot' unifier weaver = ((nodes, links), logs)+  where+    nodes = visited_nodes ++ boundary_nodes+    visited_nodes = map (makeSnapshotNode weaver) $ HM.keys $ visitedNodes weaver+    boundary_nodes = map (makeSnapshotNode weaver) $ getBoundaryNodes weaver+    (links, logs) = runWriterLoggingM $ fmap mconcat+                    $ mapM (makeSnapshotLinks unifier weaver)+                    $ groupWith linkSampleId $ allLinkSamples weaver++-- | The input 'LinkSample's must be for the equivalent+-- 'LinkSampleID'. The output is list of 'SnapshotLink's, each of+-- which corresponds to a subgroup of 'LinkSample's.+makeSnapshotLinks :: (Eq n, Hashable n, Show n)+                  => LinkSampleUnifier n na fla sla+                  -> Weaver n na fla+                  -> [LinkSample n fla]+                  -> WriterLoggingM [SnapshotLink n sla]+makeSnapshotLinks _ _ [] = return []+makeSnapshotLinks unifier weaver link_samples@(head_sample : _) = do+  unified <- doUnify link_samples+  logUnified unified+  return $ mapMaybe makeSnapshotLink unified+  where+    makeEndNode getter = makeSnapshotNode weaver $ getter $ head_sample+    doUnify = unifier (makeEndNode lsSubjectNode) (makeEndNode lsTargetNode)+    logUnified unified = logDebugW ( "Unify link [" <> (spack $ lsSubjectNode head_sample) <> "]-["+                                     <> (spack $ lsTargetNode head_sample) <> "]: "+                                     <> "from " <> (spack $ length link_samples) <> " samples "+                                     <> "to " <> (spack $ length unified) <> " samples"+                                   )+    makeSnapshotLink unified_sample = do+      case lsLinkState unified_sample of+       LinkUnused -> Nothing+       LinkToTarget -> Just $ sampleToLink unified_sample True True+       LinkToSubject -> Just $ sampleToLink unified_sample False True+       LinkBidirectional -> Just $ sampleToLink unified_sample True False+    sampleToLink sample to_target is_directed = +      SnapshotLink { _sourceNode = (if to_target then lsSubjectNode else lsTargetNode) sample,+                     _destinationNode = (if to_target then lsTargetNode else lsSubjectNode) sample,+                     _isDirected = is_directed,+                     _linkTimestamp = lsTimestamp sample,+                     _linkAttributes = lsLinkAttributes sample+                   }

@@ -0,0 +1,180 @@+{-# LANGUAGE OverloadedStrings #-}+module NetSpider.WeaverSpec (main,spec) where++import Data.Foldable (foldl')+import Data.Hashable (Hashable)+import Data.Int (Int64)+import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef')+import Data.Maybe (fromJust)+import Data.Text (Text)+import Test.Hspec++import NetSpider.Found (FoundNode(..), FoundLink(..), LinkState(..))+import NetSpider.Query+  ( policyOverwrite, policyAppend,+    foundNodePolicy, unifyLinkSamples+  )+import NetSpider.Timestamp (fromEpochMillisecond)+import NetSpider.Weaver+  ( Weaver, newWeaver,+    markAsVisited, addFoundNode,+    isVisited, getFoundNodes, getSnapshot,+    visitAllBoundaryNodes,+    getBoundaryNodes+  )++import SnapshotTestCase (SnapshotTestCase(..))+import qualified SnapshotTestCase++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "Weaver" $ do+  spec_visitedNodes+  spec_boundaryNodes+  describe "SnapshotTestCase" $ do+    mapM_ makeTestCase SnapshotTestCase.basics+  +spec_visitedNodes :: Spec+spec_visitedNodes = describe "visited nodes" $ do+  specify "mark and add" $ do+    let fn = FoundNode { subjectNode = 5,+                         foundAt = fromEpochMillisecond 100,+                         neighborLinks = [],+                         nodeAttributes = ()+                       }+        w :: Weaver Int () ()+        w = addFoundNode fn $ markAsVisited 10 $ markAsVisited 5 $ newWeaver policyOverwrite+    isVisited 1 w `shouldBe` False+    isVisited 5 w `shouldBe` True+    isVisited 10 w `shouldBe` True+    getFoundNodes 1 w `shouldBe` Nothing+    getFoundNodes 5 w `shouldBe` Just [fn]+    getFoundNodes 10 w `shouldBe` Just []+  specify "add and mark" $ do+    let fn = FoundNode { subjectNode = 5,+                         foundAt = fromEpochMillisecond 100,+                         neighborLinks = [],+                         nodeAttributes = ()+                       }+        w :: Weaver Int () ()+        w = markAsVisited 10 $ markAsVisited 5 $ addFoundNode fn $ newWeaver policyOverwrite+    isVisited 1 w `shouldBe` False+    isVisited 5 w `shouldBe` True+    isVisited 10 w `shouldBe` True+    getFoundNodes 1 w `shouldBe` Nothing+    getFoundNodes 5 w `shouldBe` Just [fn]+    getFoundNodes 10 w `shouldBe` Just []+  describe "FoundNodePolicy for Weaver" $ do+    let fn1 = FoundNode { subjectNode = 5,+                          foundAt = fromEpochMillisecond 100,+                          neighborLinks = [],+                          nodeAttributes = "foobar"+                        }+        fn2 = FoundNode { subjectNode = 5,+                          foundAt = fromEpochMillisecond 150,+                          neighborLinks = [],+                          nodeAttributes = "quux"+                        }+    specify "policyOverwrite should keep only the latest FoundNode" $ do+      let w :: Weaver Int String ()+          w = newWeaver policyOverwrite+      (getFoundNodes 5 $ addFoundNode fn1 w)+        `shouldBe` Just [fn1]+      (getFoundNodes 5 $ addFoundNode fn2 w)+        `shouldBe` Just [fn2]+      (getFoundNodes 5 $ addFoundNode fn1 $ addFoundNode fn2 w)+        `shouldBe` Just [fn2]+      (getFoundNodes 5 $ addFoundNode fn2 $ addFoundNode fn1 w)+        `shouldBe` Just [fn2]+    specify "policyAppend should keep all FoundNodes" $ do+      let w :: Weaver Int String ()+          w = newWeaver policyAppend+      (getFoundNodes 5 $ addFoundNode fn1 w)+        `shouldBe` Just [fn1]+      (getFoundNodes 5 $ addFoundNode fn2 w)+        `shouldBe` Just [fn2]+      (fromJust $ getFoundNodes 5 $ addFoundNode fn1 $ addFoundNode fn2 w)+        `shouldMatchList` [fn1, fn2]+      (fromJust $ getFoundNodes 5 $ addFoundNode fn2 $ addFoundNode fn1 w)+        `shouldMatchList` [fn1, fn2]++shouldReturnSet :: (HasCallStack, Eq a, Show a) => IO [a] -> [a] -> IO ()+shouldReturnSet action expected = do+  got <- action+  got `shouldMatchList` expected++spec_boundaryNodes :: Spec+spec_boundaryNodes = describe "boundary nodes" $ do+  let addFN ref_w fn = do+        new_w <- fmap (addFoundNode fn) $ readIORef ref_w+        writeIORef ref_w new_w+      getBN ref_w = fmap getBoundaryNodes $ readIORef ref_w+      makeFN :: Text -> [Text] -> Int64 -> FoundNode Text () ()+      makeFN sub_n tar_ns time =+        FoundNode { subjectNode = sub_n,+                    foundAt = fromEpochMillisecond time,+                    nodeAttributes = (),+                    neighborLinks = map makeFL tar_ns+                  }+      makeFL tar_n = FoundLink { targetNode = tar_n, linkState = LinkToTarget, linkAttributes = () }+      markV ref_w n = modifyIORef' ref_w $ markAsVisited n+  specify "policyOverwrite" $ do+    rweaver <- newIORef $ newWeaver policyOverwrite+    let addFN' = addFN rweaver+        getBN' = getBN rweaver+        markV' = markV rweaver+    getBN' `shouldReturnSet` []+    addFN' (makeFN "n1" [] 100)+    getBN' `shouldReturnSet` []+    addFN' (makeFN "n1" ["n2"] 200)+    getBN' `shouldReturnSet` ["n2"]+    addFN' (makeFN "n2" ["n3", "n4", "n5", "n1"] 250)+    getBN' `shouldReturnSet` ["n3", "n4", "n5"]+    addFN' (makeFN "n3" ["n4"] 200)+    getBN' `shouldReturnSet` ["n4", "n5"] -- should return unique node IDs+    +    addFN' (makeFN "n5" ["n1", "n6", "n7", "n8", "n2"] 200)+    getBN' `shouldReturnSet` ["n4", "n6", "n7", "n8"]+    addFN' (makeFN "n5" ["n4", "n9"] 250)+    getBN' `shouldReturnSet` ["n4", "n9"] -- overwrites the previous FoundNode+    addFN' (makeFN "n5" ["n3", "n7"] 220)+    getBN' `shouldReturnSet` ["n4", "n9"] -- get ignored.++    markV' "n5"+    getBN' `shouldReturnSet` ["n4", "n9"]+    markV' "n9"+    getBN' `shouldReturnSet` ["n4"]+  specify "policyAppend" $ do+    rweaver <- newIORef $ newWeaver policyAppend+    let addFN' = addFN rweaver+        getBN' = getBN rweaver+        markV' = markV rweaver+    getBN' `shouldReturnSet` []+    addFN' (makeFN "n1" ["n2"] 200)+    getBN' `shouldReturnSet` ["n2"]+    addFN' (makeFN "n1" ["n3"] 100)+    getBN' `shouldReturnSet` ["n2", "n3"]    +    addFN' (makeFN "n1" ["n4"] 300)+    getBN' `shouldReturnSet` ["n2", "n3", "n4"]++    addFN' (makeFN "n3" ["n5"] 200)+    getBN' `shouldReturnSet` ["n2", "n4", "n5"]+    markV' "n2"+    getBN' `shouldReturnSet` ["n4", "n5"]+  +  ++addAllFoundNodes :: (Eq n, Hashable n) => [FoundNode n na la] -> Weaver n na la -> Weaver n na la+addAllFoundNodes fns weaver = foldl' (\w fn -> addFoundNode fn w) weaver fns++makeTestCase :: SnapshotTestCase -> Spec+makeTestCase SnapshotTestCase { caseName = name, caseInput = input, caseQuery = query, caseAssert = assert } = do+  specify name $ do+    let init_w = newWeaver $ foundNodePolicy query+        got_w = visitAllBoundaryNodes  -- SnapshotTestCase assumes unlimited number of traverse steps. So, mark all nodes as visited.+                $ addAllFoundNodes input init_w+        got_graph = getSnapshot (unifyLinkSamples query) got_w+    assert got_graph+  

@@ -12,10 +12,8 @@ import Data.Time.LocalTime (TimeZone(..)) import Test.Hspec -import ServerTest.Common-  ( withServer, withSpider', withSpider,-    AText(..), AInt(..)-  )+import TestCommon (AText(..), AInt(..))+import ServerTest.ServerCommon (withServer, withSpider', withSpider)  import NetSpider.Found (FoundNode(..), FoundLink(..), LinkState(..)) import NetSpider.Graph (NodeAttributes(..), LinkAttributes(..), VNode)

@@ -1,140 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-module ServerTest.Common-       ( withServer,-         withSpider,-         withSpider',-         sortSnapshotElements,-         AText(..),-         AInt(..),-         APorts(..),-         subIdWithAPorts,-         alignAPortsToLinkDirection-       ) where--import Control.Applicative ((<$>))-import Control.Category ((<<<))-import Control.Exception.Safe (bracket, withException)-import Data.Aeson.Types (Parser)-import Data.Greskell (gProperty, newBind, lookupAs, pMapToFail, Key)-import Data.List (sort)-import Data.Text (Text)-import Data.Vector (Vector)-import qualified Data.Vector as V-import Test.Hspec-import Test.Hspec.NeedEnv (needEnvHostPort, EnvMode(Need))--import NetSpider.Found (LinkState(..))-import NetSpider.Graph (NodeAttributes(..), LinkAttributes(..), VNode)-import NetSpider.Pair (Pair(..))-import NetSpider.Spider.Config-  ( Host, Port, Config(..), defConfig, LogLevel(..)-  )-import NetSpider.Spider-  ( connectWith, close, clearAll, Spider-  )-import NetSpider.Snapshot-  ( SnapshotNode, SnapshotLink-  )-import NetSpider.Unify-  ( LinkSample(..)-  )--withServer :: SpecWith (Host,Port) -> Spec-withServer = before $ needEnvHostPort Need "NET_SPIDER_TEST"--withSpider :: Eq n => (Spider n na fla -> IO ()) -> (Host, Port) -> IO ()-withSpider = withSpider' $ defConfig { logThreshold = LevelWarn }--withSpider' :: Config n na fla -> (Spider n na fla -> IO ()) -> (Host, Port) -> IO ()-withSpider' orig_conf action (host, port) = bracket (connectWith conf) close $ \spider -> do-  clearAll spider-  action spider-    where-      conf = orig_conf { wsHost = host,-                         wsPort = port-                       }--sortSnapshotElements :: (Ord n, Eq na, Eq la)-                     => ([SnapshotNode n na], [SnapshotLink n la])-                     -> (Vector (SnapshotNode n na), Vector (SnapshotLink n la))-sortSnapshotElements (ns, ls) = (sortV ns, sortV ls)-  where-    sortV :: Ord a => [a] -> Vector a-    sortV = V.fromList . sort---newtype AText = AText Text-              deriving (Show,Eq,Ord)--keyText :: Key e Text-keyText = "text"--instance NodeAttributes AText where-  writeNodeAttributes (AText t) = gProperty keyText <$> newBind t-  parseNodeAttributes ps = fmap AText $ pMapToFail $ lookupAs keyText ps--instance LinkAttributes AText where-  writeLinkAttributes (AText t) = gProperty keyText <$> newBind t-  parseLinkAttributes ps = fmap AText $ pMapToFail $ lookupAs keyText ps--newtype AInt = AInt Int-             deriving (Show,Eq,Ord)--keyInt :: Key e Int -keyInt = "integer"--instance NodeAttributes AInt where-  writeNodeAttributes (AInt n) = gProperty keyInt <$> newBind n-  parseNodeAttributes ps = fmap AInt $ pMapToFail $ lookupAs keyInt ps--instance LinkAttributes AInt where-  writeLinkAttributes (AInt n) = gProperty keyInt <$> newBind n-  parseLinkAttributes ps = fmap AInt $ pMapToFail $ lookupAs keyInt ps----- | Pair of ports.------ This type is used in two ways. (subject port, target port) and--- (source port, destination port).-data APorts =-  APorts-  { apFst :: Text,-    apSnd :: Text-  }-  deriving (Show,Eq,Ord)--keySubjectPort :: Key e Text-keySubjectPort = "subject_port"--keyTargetPort :: Key e Text-keyTargetPort = "target_port"--instance LinkAttributes APorts where-  writeLinkAttributes ap = do-    writeSource <- gProperty keySubjectPort <$> newBind (apFst ap)-    writeDest <- gProperty keyTargetPort <$> newBind (apSnd ap)-    return (writeDest <<< writeSource)-  parseLinkAttributes ps = APorts-                           <$> (pMapToFail $ lookupAs keySubjectPort ps)-                           <*> (pMapToFail $ lookupAs keyTargetPort ps)--swapAPorts :: APorts -> APorts-swapAPorts ap = ap { apFst = apSnd ap,-                     apSnd = apFst ap-                   }---- | Link sub-ID with 'APorts'.-subIdWithAPorts :: LinkSample n APorts -> Pair (n, Text)-subIdWithAPorts ls = Pair ( (lsSubjectNode ls, apFst $ lsLinkAttributes ls),-                            (lsTargetNode ls, apSnd $ lsLinkAttributes ls)-                          )---- | Sort 'APorts' according to 'LinkState'. This converts the--- 'APorts' as (subject port, target port) into (source port,--- destination port).-alignAPortsToLinkDirection :: LinkSample n APorts -> LinkSample n APorts-alignAPortsToLinkDirection ls = ls { lsLinkAttributes = updated }-  where-    updated = case lsLinkState ls of-               LinkToSubject -> swapAPorts $ lsLinkAttributes ls-               _ -> lsLinkAttributes ls

@@ -0,0 +1,34 @@+module ServerTest.ServerCommon+  ( withServer,+    withSpider,+    withSpider'+  ) where++import Control.Exception.Safe (bracket)+import Test.Hspec+import Test.Hspec.NeedEnv (needEnvHostPort, EnvMode(Need))++import NetSpider.Spider+  ( connectWith, close, clearAll, Spider+  )+import NetSpider.Spider.Config+  ( Host, Port, Config(..), defConfig, LogLevel(..)+  )+++withServer :: SpecWith (Host,Port) -> Spec+withServer = before $ needEnvHostPort Need "NET_SPIDER_TEST"++withSpider :: Eq n => (Spider n na fla -> IO ()) -> (Host, Port) -> IO ()+withSpider = withSpider' $ defConfig { logThreshold = LevelWarn }++withSpider' :: Config n na fla -> (Spider n na fla -> IO ()) -> (Host, Port) -> IO ()+withSpider' orig_conf action (host, port) = bracket (connectWith conf) close $ \spider -> do+  clearAll spider+  action spider+    where+      conf = orig_conf { wsHost = host,+                         wsPort = port+                       }++

@@ -17,11 +17,14 @@ import System.IO (stderr) import Test.Hspec -import ServerTest.Common-  ( withServer, withSpider, sortSnapshotElements,+import TestCommon+  ( sortSnapshotElements,     AText(..), APorts(..), subIdWithAPorts,     alignAPortsToLinkDirection   )+import SnapshotTestCase (SnapshotTestCase(..))+import qualified SnapshotTestCase+import ServerTest.ServerCommon (withServer, withSpider)  import NetSpider.Found   ( FoundLink(..), LinkState(..), FoundNode(..)@@ -54,533 +57,39 @@ spec = do   spec_getSnapshot -makeOneNeighborExample :: Spider Text () () -> IO ()-makeOneNeighborExample spider = do-  let link = FoundLink { targetNode = "n2",-                         linkState = LinkToTarget,-                         linkAttributes = ()-                       }-      nbs = FoundNode { subjectNode = "n1",-                        foundAt = fromS "2018-12-01T10:00",-                        neighborLinks = return link,-                        nodeAttributes = ()-                      }-  debugShowE $ addFoundNode spider nbs--queryWithAPorts :: Text -> Query Text () APorts APorts-queryWithAPorts nid = (defQuery [nid]) { unifyLinkSamples = unifyStd unify_conf }-  where-    unify_conf = defUnifyStdConfig-                 { makeLinkSubId = subIdWithAPorts,-                   mergeSamples = \l r -> fmap alignAPortsToLinkDirection $ latestLinkSample (l ++ r)-                 }--sortLinksWithAttr :: (Ord n, Ord la) => Vector (SnapshotLink n la) -> Vector (SnapshotLink n la)-sortLinksWithAttr = V.fromList . sortOn getKey . V.toList-  where-    getKey link = (linkNodeTuple link, S.linkAttributes link)- spec_getSnapshot :: Spec spec_getSnapshot = withServer $ describe "getSnapshotSimple, getSnapshot" $ do-  spec_getSnapshot1-  spec_getSnapshot2+  mapM_ makeTestCase SnapshotTestCase.basics+  mapM_ makeTestCase SnapshotTestCase.traverses   spec_getSnapshot_timeInterval   spec_getSnapshot_foundNodePolicy --spec_getSnapshot1 :: SpecWith (Host,Port)-spec_getSnapshot1 = do-  specify "one neighbor" $ withSpider $ \spider -> do-    makeOneNeighborExample spider-    (got_ns, got_ls) <- debugShowE $ getSnapshotSimple spider "n1"-    let (got_n1, got_n2, got_link) = case (sort got_ns, sort got_ls) of-          ([a, b], [c]) -> (a, b, c)-          _ -> error ("Unexpected result: got = " ++ show (got_ns, got_ls))-    nodeId got_n1 `shouldBe` "n1"-    isOnBoundary got_n1 `shouldBe` False-    nodeTimestamp got_n1 `shouldBe` Just (fromS "2018-12-01T10:00")-    S.nodeAttributes got_n1 `shouldBe` Just ()-    nodeId got_n2 `shouldBe` "n2"-    isOnBoundary got_n2 `shouldBe` False-    nodeTimestamp got_n2 `shouldBe` Nothing -- n1 is not observed.-    S.nodeAttributes got_n2 `shouldBe` Nothing -- n1 is not observed.-    linkNodeTuple got_link `shouldBe` ("n1", "n2")-    isDirected got_link `shouldBe` True-    linkTimestamp got_link `shouldBe` fromS "2018-12-01T10:00"-    S.linkAttributes got_link `shouldBe` ()-  specify "no neighbor" $ withSpider $ \spider -> do-    let nbs :: FoundNode Text () ()-        nbs = FoundNode { subjectNode = "n1",-                          foundAt = fromS "2018-12-01T20:00",-                          neighborLinks = mempty,-                          nodeAttributes = ()-                        }-    addFoundNode spider nbs-    (got_ns, got_ls) <- getSnapshotSimple spider "n1"-    let got_n1 = case (sort got_ns, sort got_ls) of-          ([a], []) -> a-          _ -> error ("Unexpected result: got = " ++ show (got_ns, got_ls))-    nodeId got_n1 `shouldBe` "n1"-    isOnBoundary got_n1 `shouldBe` False-    nodeTimestamp got_n1 `shouldBe` Just (fromS "2018-12-01T20:00")-    S.nodeAttributes got_n1 `shouldBe` Just ()-  specify "missing starting node" $ withSpider $ \spider -> do-    makeOneNeighborExample spider-    (got_ns, got_ls) <- getSnapshotSimple spider "no node"-    got_ns `shouldBe` mempty-    got_ls `shouldBe` mempty-  specify "mutual neighbors" $ withSpider $ \spider -> do-    let link_12 :: FoundLink Text ()-        link_12 = FoundLink { targetNode = "n2",-                              linkState = LinkToSubject,-                              linkAttributes = ()-                            }-        link_21 = FoundLink { targetNode = "n1",-                              linkState = LinkToTarget,-                              linkAttributes = ()-                            }-        nbs1 = FoundNode { subjectNode = "n1",-                           foundAt = fromS "2018-12-01T10:00",-                           neighborLinks = return link_12,-                           nodeAttributes = ()-                         }-        nbs2 = FoundNode { subjectNode = "n2",-                           foundAt = fromS "2018-12-01T20:00",-                           neighborLinks = return link_21,-                           nodeAttributes = ()-                         }-    mapM_ (addFoundNode spider) [nbs1, nbs2]-    (got_ns, got_ls) <- getSnapshotSimple spider "n1"-    let (got_n1, got_n2, got_l) = case (sort got_ns, sort got_ls) of-          ([a,b], [c]) -> (a,b,c)-          _ -> error ("Unexpected result: got = " ++ show (got_ns, got_ls))-    nodeId got_n1 `shouldBe` "n1"-    isOnBoundary got_n1 `shouldBe` False-    nodeTimestamp got_n1 `shouldBe` Just (fromS "2018-12-01T10:00")-    S.nodeAttributes got_n1 `shouldBe` Just ()-    nodeId got_n2 `shouldBe` "n2"-    isOnBoundary got_n2 `shouldBe` False-    nodeTimestamp got_n2 `shouldBe` Just (fromS "2018-12-01T20:00")-    S.nodeAttributes got_n2 `shouldBe` Just ()-    linkNodeTuple got_l `shouldBe` ("n2", "n1")-    isDirected got_l `shouldBe` True-    linkTimestamp got_l `shouldBe` fromS "2018-12-01T20:00"-    S.linkAttributes got_l `shouldBe` ()-  specify "multiple findings for a single node" $ withSpider $ \spider -> do-    let fns :: [FoundNode Text AText ()]-        fns = [ FoundNode-                { subjectNode = "n1",-                  foundAt = fromS "2018-12-01T20:00",-                  neighborLinks = [ FoundLink-                                    { targetNode = "n2",-                                      linkState = LinkToTarget,-                                      linkAttributes = ()-                                    },-                                    FoundLink-                                    { targetNode = "n3",-                                      linkState = LinkToSubject,-                                      linkAttributes = ()-                                    }-                                  ],-                  nodeAttributes = AText "at 20:00"-                },-                FoundNode-                { subjectNode = "n1",-                  foundAt = fromS "2018-12-01T10:00",-                  neighborLinks = mempty,-                  nodeAttributes = AText "at 10:00"-                },-                FoundNode-                { subjectNode = "n1",-                  foundAt = fromS "2018-12-01T15:00",-                  neighborLinks = return $ FoundLink-                                  { targetNode = "n2",-                                    linkState = LinkToTarget,-                                    linkAttributes = ()-                                  },-                  nodeAttributes = AText "at 15:00"-                }-              ]-    mapM_ (addFoundNode spider) fns-    (got_ns, got_ls) <- getSnapshotSimple spider "n1"-    let (got_n1, got_n2, got_n3, got_l12, got_l31) = case (sort got_ns, sort got_ls) of-          ([g1, g2, g3], [g4, g5]) -> (g1, g2, g3, g4, g5)-          _ -> error ("Unexpected patter: got = " ++ show (got_ns, got_ls))-    nodeId got_n1 `shouldBe` "n1"-    isOnBoundary got_n1 `shouldBe` False-    nodeTimestamp got_n1 `shouldBe` Just (fromS "2018-12-01T20:00")-    S.nodeAttributes got_n1 `shouldBe` Just (AText "at 20:00")-    nodeId got_n2 `shouldBe` "n2"-    isOnBoundary got_n2 `shouldBe` False-    nodeTimestamp got_n2 `shouldBe` Nothing-    S.nodeAttributes got_n2 `shouldBe` Nothing-    nodeId got_n3 `shouldBe` "n3"-    isOnBoundary got_n3 `shouldBe` False-    nodeTimestamp got_n3 `shouldBe` Nothing-    S.nodeAttributes got_n3 `shouldBe` Nothing-    linkNodeTuple got_l12 `shouldBe` ("n1", "n2")-    isDirected got_l12 `shouldBe` True-    linkTimestamp got_l12 `shouldBe` fromS "2018-12-01T20:00"-    linkNodeTuple got_l31 `shouldBe` ("n3", "n1")-    isDirected got_l31 `shouldBe` True-    linkTimestamp got_l31 `shouldBe` fromS "2018-12-01T20:00"-  specify "multi-hop neighbors" $ withSpider $ \spider -> do-    let fns :: [FoundNode Text () AText]-        fns = [ FoundNode-                { subjectNode = intToNodeId 1,-                  foundAt = fromS "2018-12-01T10:00",-                  neighborLinks = return $ FoundLink-                                  { targetNode = intToNodeId 2,-                                    linkState = LinkToTarget,-                                    linkAttributes = AText "first"-                                  },-                  nodeAttributes = ()-                },-                middleNode 2 $ fromS "2018-12-01T05:00",-                middleNode 3 $ fromS "2018-12-01T15:00",-                middleNode 4 $ fromS "2018-12-01T20:00",-                FoundNode-                { subjectNode = intToNodeId 5,-                  foundAt = fromS "2018-12-01T15:00",-                  neighborLinks = return $ FoundLink-                                  { targetNode = intToNodeId 4,-                                    linkState = LinkToSubject,-                                    linkAttributes = AText "last"-                                  },-                  nodeAttributes = ()-                }-              ]-        intToNodeId :: Int -> Text-        intToNodeId i = pack ("n" ++ show i)-        middleNode node_i time =-          FoundNode-          { subjectNode = sub_nid,-            foundAt = time,-            neighborLinks = [ FoundLink-                              { targetNode = intToNodeId (node_i - 1),-                                linkState = LinkToSubject,-                                linkAttributes = AText (sub_nid <> " to prev")-                              },-                              FoundLink-                              { targetNode = intToNodeId (node_i + 1),-                                linkState = LinkToTarget,-                                linkAttributes = AText (sub_nid <> " to next")-                              }-                            ],-            nodeAttributes = ()-          }-          where-            sub_nid = intToNodeId node_i-    mapM_ (addFoundNode spider) fns-    (got_ns, got_ls) <- fmap sortSnapshotElements $ getSnapshotSimple spider "n1"-    nodeId (got_ns ! 0) `shouldBe` "n1"-    isOnBoundary (got_ns ! 0) `shouldBe` False-    nodeTimestamp (got_ns ! 0) `shouldBe` Just (fromS "2018-12-01T10:00")-    S.nodeAttributes (got_ns ! 0) `shouldBe` Just ()-    nodeId (got_ns ! 1) `shouldBe` "n2"-    isOnBoundary (got_ns ! 1) `shouldBe` False-    nodeTimestamp (got_ns ! 1) `shouldBe` Just (fromS "2018-12-01T05:00")-    S.nodeAttributes (got_ns ! 1) `shouldBe` Just ()-    nodeId (got_ns ! 2) `shouldBe` "n3"-    isOnBoundary (got_ns ! 2) `shouldBe` False-    nodeTimestamp (got_ns ! 2) `shouldBe` Just (fromS "2018-12-01T15:00")-    S.nodeAttributes (got_ns ! 2) `shouldBe` Just ()-    nodeId (got_ns ! 3) `shouldBe` "n4"-    isOnBoundary (got_ns ! 3) `shouldBe` False-    nodeTimestamp (got_ns ! 3) `shouldBe` Just (fromS "2018-12-01T20:00")-    S.nodeAttributes (got_ns ! 3) `shouldBe` Just ()-    nodeId (got_ns ! 4) `shouldBe` "n5"-    isOnBoundary (got_ns ! 4) `shouldBe` False-    nodeTimestamp (got_ns ! 4) `shouldBe` Just (fromS "2018-12-01T15:00")-    S.nodeAttributes (got_ns ! 4) `shouldBe` Just ()-    V.length got_ns `shouldBe` 5-    linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n2")-    isDirected (got_ls ! 0) `shouldBe` True-    linkTimestamp (got_ls ! 0) `shouldBe` fromS "2018-12-01T10:00"-    S.linkAttributes (got_ls ! 0) `shouldBe` AText "first"-    linkNodeTuple (got_ls ! 1) `shouldBe` ("n2", "n3")-    isDirected (got_ls ! 1) `shouldBe` True-    linkTimestamp (got_ls ! 1) `shouldBe` fromS "2018-12-01T15:00"-    S.linkAttributes (got_ls ! 1) `shouldBe` AText "n3 to prev"-    linkNodeTuple (got_ls ! 2) `shouldBe` ("n3", "n4")-    isDirected (got_ls ! 2) `shouldBe` True-    linkTimestamp (got_ls ! 2) `shouldBe` fromS "2018-12-01T20:00"-    S.linkAttributes (got_ls ! 2) `shouldBe` AText "n4 to prev"-    linkNodeTuple (got_ls ! 3) `shouldBe` ("n4", "n5")-    isDirected (got_ls ! 3) `shouldBe` True-    linkTimestamp (got_ls ! 3) `shouldBe` fromS "2018-12-01T20:00"-    S.linkAttributes (got_ls ! 3) `shouldBe` AText "n4 to next"-    V.length got_ls `shouldBe` 4--spec_getSnapshot2 :: SpecWith (Host, Port)-spec_getSnapshot2 = do-  specify "loop network" $ withSpider $ \spider -> do-    let fns :: [FoundNode Text () ()]-        fns = [ FoundNode-                { subjectNode = "n1",-                  foundAt = fromS "2018-12-01T10:00",-                  neighborLinks = [ FoundLink-                                    { targetNode = "n2",-                                      linkState = LinkToTarget,-                                      linkAttributes = ()-                                    }-                                  ],-                  nodeAttributes = ()-                },-                FoundNode-                { subjectNode = "n2",-                  foundAt = fromS "2018-12-01T15:00",-                  neighborLinks = [ FoundLink-                                    { targetNode = "n1",-                                      linkState = LinkToSubject,-                                      linkAttributes = ()-                                    },-                                    FoundLink-                                    { targetNode = "n3",-                                      linkState = LinkBidirectional,-                                      linkAttributes = ()-                                    }-                                  ],-                  nodeAttributes = ()-                },-                FoundNode-                { subjectNode = "n3",-                  foundAt = fromS "2018-12-01T10:00",-                  neighborLinks = [ FoundLink-                                    { targetNode = "n1",-                                      linkState = LinkToTarget,-                                      linkAttributes = ()-                                    },-                                    FoundLink-                                    { targetNode = "n2",-                                      linkState = LinkBidirectional,-                                      linkAttributes = ()-                                    }-                                  ],-                  nodeAttributes = ()-                }-              ]-    mapM_ (addFoundNode spider) fns-    (got_ns, got_ls) <- fmap sortSnapshotElements $ getSnapshotSimple spider "n1"-    nodeId (got_ns ! 0) `shouldBe` "n1"-    isOnBoundary (got_ns ! 0) `shouldBe` False-    nodeTimestamp (got_ns ! 0) `shouldBe` Just (fromS "2018-12-01T10:00")-    nodeId (got_ns ! 1) `shouldBe` "n2"-    isOnBoundary (got_ns ! 1) `shouldBe` False-    nodeTimestamp (got_ns ! 1) `shouldBe` Just (fromS "2018-12-01T15:00")-    nodeId (got_ns ! 2) `shouldBe` "n3"-    isOnBoundary (got_ns ! 2) `shouldBe` False-    nodeTimestamp (got_ns ! 2) `shouldBe` Just (fromS "2018-12-01T10:00")-    V.length got_ns `shouldBe` 3-    linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n2")-    isDirected (got_ls ! 0) `shouldBe` True-    linkTimestamp (got_ls ! 0) `shouldBe` fromS "2018-12-01T15:00"-    linkNodeTuple (got_ls ! 1) `shouldBe` ("n2", "n3")-    isDirected (got_ls ! 1) `shouldBe` False-    linkTimestamp (got_ls ! 1) `shouldBe` fromS "2018-12-01T15:00"-    linkNodeTuple (got_ls ! 2) `shouldBe` ("n3", "n1")-    isDirected (got_ls ! 2) `shouldBe` True-    linkTimestamp (got_ls ! 2) `shouldBe` fromS "2018-12-01T10:00"-  specify "multiple links between two nodes" $ withSpider $ \spider -> do-    let fns :: [FoundNode Text () APorts]-        fns = [ FoundNode-                { subjectNode = "n1",-                  foundAt = fromS "2018-12-01T20:00",-                  nodeAttributes = (),-                  neighborLinks = [ FoundLink-                                    { targetNode = "n2",-                                      linkState = LinkToTarget,-                                      linkAttributes = APorts "p4" "p8"-                                    },-                                    FoundLink-                                    { targetNode = "n2",-                                      linkState = LinkToTarget,-                                      linkAttributes = APorts "p3" "p6"-                                    },-                                    FoundLink-                                    { targetNode = "n2",-                                      linkState = LinkToTarget,-                                      linkAttributes = APorts "p5" "p10"-                                    }-                                  ]-                },-                FoundNode-                { subjectNode = "n2",-                  foundAt = fromS "2018-12-01T10:00",-                  nodeAttributes = (),-                  neighborLinks = [ FoundLink-                                    { targetNode = "n1",-                                      linkState = LinkToSubject,-                                      linkAttributes = APorts "p6" "p3"-                                    },-                                    FoundLink-                                    { targetNode = "n1",-                                      linkState = LinkToSubject,-                                      linkAttributes = APorts "p10" "p5"-                                    },-                                    FoundLink-                                    { targetNode = "n1",-                                      linkState = LinkToSubject,-                                      linkAttributes = APorts "p8" "p4"-                                    }-                                  ]-                }-              ]-    mapM_ (addFoundNode spider) fns-    (got_ns, got_ls_raw) <- fmap sortSnapshotElements $ getSnapshot spider $ queryWithAPorts "n1"-    nodeId (got_ns ! 0) `shouldBe` "n1"-    nodeId (got_ns ! 1) `shouldBe` "n2"-    V.length got_ns `shouldBe` 2-    let got_ls = sortLinksWithAttr got_ls_raw-    linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n2")-    S.linkAttributes (got_ls ! 0) `shouldBe` APorts "p3" "p6"-    linkTimestamp (got_ls ! 0) `shouldBe` fromS "2018-12-01T20:00"-    linkNodeTuple (got_ls ! 1) `shouldBe` ("n1", "n2")-    S.linkAttributes (got_ls ! 1) `shouldBe` APorts "p4" "p8"-    linkTimestamp (got_ls ! 1) `shouldBe` fromS "2018-12-01T20:00"-    linkNodeTuple (got_ls ! 2) `shouldBe` ("n1", "n2")-    S.linkAttributes (got_ls ! 2) `shouldBe` APorts "p5" "p10"-    linkTimestamp (got_ls ! 2) `shouldBe` fromS "2018-12-01T20:00"-    V.length got_ls `shouldBe` 3-  specify "link disappears" $ withSpider $ \spider -> do-    let fns :: [FoundNode Text () ()]-        fns = [ FoundNode-                { subjectNode = "n1",-                  foundAt = fromS "2018-12-01T10:00",-                  nodeAttributes = (),-                  neighborLinks = [ FoundLink-                                    { targetNode = "n2",-                                      linkState = LinkBidirectional,-                                      linkAttributes = ()-                                    }-                                  ]-                },-                FoundNode-                { subjectNode = "n2",-                  foundAt = fromS "2018-12-01T20:00",-                  nodeAttributes = (),-                  neighborLinks = []-                }-              ]-    mapM_ (addFoundNode spider) fns-    (got_ns, got_ls) <- fmap sortSnapshotElements $ getSnapshotSimple spider "n1"-    nodeId (got_ns ! 0) `shouldBe` "n1"-    nodeId (got_ns ! 1) `shouldBe` "n2"-    V.length got_ns `shouldBe` 2-    V.length got_ls `shouldBe` 0-    -- the n2 observes at t=200 that there is no link to n1. So the-    -- Spider should consider the link disappears.-  specify "link appears" $ withSpider $ \spider -> do-    let fns :: [FoundNode Text () ()]-        fns = [ FoundNode-                { subjectNode = "n1",-                  foundAt = fromS "2018-12-01T20:00",-                  nodeAttributes = (),-                  neighborLinks = [ FoundLink-                                    { targetNode = "n2",-                                      linkState = LinkBidirectional,-                                      linkAttributes = ()-                                    }-                                  ]-                },-                FoundNode-                { subjectNode = "n2",-                  foundAt = fromS "2018-12-01T10:00",-                  nodeAttributes = (),-                  neighborLinks = []-                }-              ]-    mapM_ (addFoundNode spider) fns-    (got_ns, got_ls) <- fmap sortSnapshotElements $ getSnapshotSimple spider "n1"-    nodeId (got_ns ! 0) `shouldBe` "n1"-    nodeId (got_ns ! 1) `shouldBe` "n2"-    V.length got_ns `shouldBe` 2-    linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n2")-    isDirected (got_ls ! 0) `shouldBe` False-    linkTimestamp (got_ls ! 0) `shouldBe` fromS "2018-12-01T20:00"-    V.length got_ls `shouldBe` 1-    -- the n2 observes at t=100 that there is no link to n1, but n1-    -- observes there is a link at t=200.  Spider should consider the-    -- link appears.-  specify "multiple links between pair, some appear, some disappear." $ withSpider $ \spider -> do-    let fns :: [FoundNode Text () APorts]-        fns = [ FoundNode-                { subjectNode = "n2",-                  foundAt = fromS "2018-12-01T20:00",-                  nodeAttributes = (),-                  neighborLinks = links2-                },-                FoundNode-                { subjectNode = "n1",-                  foundAt = fromS "2018-12-01T10:00",-                  nodeAttributes = (),-                  neighborLinks = links1-                }-              ]-        links1 = [ FoundLink -- disappears-                   { targetNode = "n2",-                     linkState = LinkToTarget,-                     linkAttributes = APorts "p11" "p21"-                   },-                   FoundLink -- stays-                   { targetNode = "n2",-                     linkState = LinkToTarget,-                     linkAttributes = APorts "p12" "p22"-                   }-                 ]-        links2 = [ FoundLink -- appears-                   { targetNode = "n1",-                     linkState = LinkToSubject,-                     linkAttributes = APorts "p23" "p13"-                   },-                   FoundLink -- stays-                   { targetNode = "n1",-                     linkState = LinkToSubject,-                     linkAttributes = APorts "p22" "p12" -                   }-                 ]-    mapM_ (addFoundNode spider) fns-    (got_ns, got_ls_raw) <- fmap sortSnapshotElements $ getSnapshot spider $ queryWithAPorts "n1"-    nodeId (got_ns ! 0) `shouldBe` "n1"-    nodeTimestamp (got_ns ! 0) `shouldBe` (Just $ fromS "2018-12-01T10:00")-    nodeId (got_ns ! 1) `shouldBe` "n2"-    nodeTimestamp (got_ns ! 1) `shouldBe` (Just $ fromS "2018-12-01T20:00")-    V.length got_ns `shouldBe` 2-    let got_ls = sortLinksWithAttr got_ls_raw-    linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n2")-    S.linkAttributes (got_ls ! 0) `shouldBe` APorts "p12" "p22"-    linkTimestamp (got_ls ! 0) `shouldBe` fromS "2018-12-01T20:00"-    linkNodeTuple (got_ls ! 1) `shouldBe` ("n1", "n2") -- TODO: looks like this link is removed. why?-    S.linkAttributes (got_ls ! 1) `shouldBe` APorts "p13" "p23"-    linkTimestamp (got_ls ! 1) `shouldBe` fromS "2018-12-01T20:00"-    V.length got_ls `shouldBe` 2----- TODO: how linkState relates to the property of SnapshotLink ?--- especially Bidirectional links? -> important thing is that if the--- link is Bidirectional, (source, destination) of snapshot link is--- always (subject, target).---debugShowE :: IO a -> IO a-debugShowE act = withException act showSubmitException--showSubmitException :: Gr.SubmitException -> IO ()-showSubmitException (Gr.ResponseError res) = showResponse res-showSubmitException (Gr.ParseError res _) = showResponse res--showResponse :: Res.ResponseMessage a -> IO ()-showResponse res = showResponseStatus $ Res.status res+makeTestCase :: SnapshotTestCase -> SpecWith (Host, Port)+makeTestCase SnapshotTestCase { caseName = name, caseInput = input, caseQuery = query, caseAssert = assert } = do+  specify name $ withSpider $ \spider -> do+    mapM_ (addFoundNode spider) input+    got_graph <- getSnapshot spider query+    assert got_graph -showResponseStatus :: Res.ResponseStatus -> IO ()-showResponseStatus status = mapM_ showKeyValue $ ("message", Res.message status) : textAttributes-  where-    textAttributes = justValue =<< (HM.toList $ fmap vToText $ Res.attributes status)-    vToText (String s) = Just s-    vToText _ = Nothing-    justValue (k, Just v) = [(k, v)]-    justValue (_, Nothing) = []-    showKeyValue (key, val) = TIO.hPutStrLn stderr (key <> ": " <> val)+---- debugShowE :: IO a -> IO a+---- debugShowE act = withException act showSubmitException+---- +---- showSubmitException :: Gr.SubmitException -> IO ()+---- showSubmitException (Gr.ResponseError res) = showResponse res+---- showSubmitException (Gr.ParseError res _) = showResponse res+---- +---- showResponse :: Res.ResponseMessage a -> IO ()+---- showResponse res = showResponseStatus $ Res.status res+---- +---- showResponseStatus :: Res.ResponseStatus -> IO ()+---- showResponseStatus status = mapM_ showKeyValue $ ("message", Res.message status) : textAttributes+----   where+----     textAttributes = justValue =<< (HM.toList $ fmap vToText $ Res.attributes status)+----     vToText (String s) = Just s+----     vToText _ = Nothing+----     justValue (k, Just v) = [(k, v)]+----     justValue (_, Nothing) = []+----     showKeyValue (key, val) = TIO.hPutStrLn stderr (key <> ": " <> val)  sort2 :: (Ord a, Ord b) => ([a], [b]) -> ([a], [b]) sort2 (a, b) = (sort a, sort b)

@@ -0,0 +1,741 @@+{-# LANGUAGE GADTs, OverloadedStrings #-}+module SnapshotTestCase+  ( SnapshotTestCase(..),+    basics,+    traverses+  ) where++import Data.Aeson (ToJSON)+import Data.Greskell (FromGraphSON)+import Data.Hashable (Hashable)+import Data.List (sort, sortOn)+import Data.Text (Text, pack)+import qualified Data.Vector as V+import Data.Vector ((!), Vector)+import Test.Hspec++import NetSpider.Found (FoundNode(..), FoundLink(..), LinkState(..))+import NetSpider.Graph (NodeAttributes, LinkAttributes)+import NetSpider.Query+  ( Query, defQuery, unifyLinkSamples,+    foundNodePolicy, policyOverwrite, policyAppend+  )+import NetSpider.Snapshot+  ( SnapshotLink, SnapshotGraph,+    nodeId, linkNodeTuple, isDirected, linkTimestamp,+    isOnBoundary, nodeTimestamp+  )+import qualified NetSpider.Snapshot as S (nodeAttributes, linkAttributes)+import NetSpider.Unify+  ( UnifyStdConfig(..), defUnifyStdConfig, unifyStd, latestLinkSample+  )++import NetSpider.Timestamp (fromS)++import TestCommon+  ( AText(..), APorts(..),+    sortSnapshotElements, subIdWithAPorts, alignAPortsToLinkDirection+  )+++++data SnapshotTestCase where+  SnapshotTestCase ::+    ( FromGraphSON n, ToJSON n, Ord n, Hashable n, Show n,+      Eq na, Show na, NodeAttributes na,+      Eq fla, Show fla, LinkAttributes fla, +      Eq sla, Show sla+    ) =>+    { caseName :: String,+      caseInput :: [FoundNode n na fla],+      caseQuery :: Query n na fla sla,+      caseAssert :: SnapshotGraph n na sla -> IO ()+    } -> SnapshotTestCase++oneNeighborFoundNodes :: [FoundNode Text () ()]+oneNeighborFoundNodes = [nbs]+  where+    link = FoundLink { targetNode = "n2",+                       linkState = LinkToTarget,+                       linkAttributes = ()+                     }+    nbs = FoundNode { subjectNode = "n1",+                      foundAt = fromS "2018-12-01T10:00",+                      neighborLinks = return link,+                      nodeAttributes = ()+                    }++queryWithAPorts :: Text -> Query Text () APorts APorts+queryWithAPorts nid = (defQuery [nid]) { unifyLinkSamples = unifyStd unify_conf }+  where+    unify_conf = defUnifyStdConfig+                 { makeLinkSubId = subIdWithAPorts,+                   mergeSamples = \l r -> fmap alignAPortsToLinkDirection $ latestLinkSample (l ++ r)+                 }++sortLinksWithAttr :: (Ord n, Ord la) => Vector (SnapshotLink n la) -> Vector (SnapshotLink n la)+sortLinksWithAttr = V.fromList . sortOn getKey . V.toList+  where+    getKey link = (linkNodeTuple link, S.linkAttributes link)++-- | \"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.+--+-- - Weaver doesn't traverse the graph, but makes a snapshot from the+--   whole FoundNodes input. A test case's query and input should+--   cover the whole graph (no disconnected components or step+--   limitation)+--+-- - Weaver doesn't support specifying time interval for a snapshot. A+--   test case's query's timeInterval should be unbounded on upper and+--   lower.+basics :: [SnapshotTestCase]+basics =+  [ SnapshotTestCase+    { caseName = "one neighbor",+      caseInput = oneNeighborFoundNodes,+      caseQuery = defQuery ["n1"],+      caseAssert = one_neighbor_assert+    },+    SnapshotTestCase+    { caseName = "no neighbor",+      caseInput =+        ([ FoundNode { subjectNode = "n1",+                       foundAt = fromS "2018-12-01T20:00",+                       neighborLinks = mempty,+                       nodeAttributes = ()+                     }+         ] :: [FoundNode Text () ()]),+      caseQuery = defQuery ["n1"],+      caseAssert = no_neighbor_assert+    },+    SnapshotTestCase+    { caseName = "mutual neighbors",+      caseInput =+        let link_12 :: FoundLink Text ()+            link_12 = FoundLink { targetNode = "n2",+                                  linkState = LinkToSubject,+                                  linkAttributes = ()+                                }+            link_21 = FoundLink { targetNode = "n1",+                                  linkState = LinkToTarget,+                                  linkAttributes = ()+                                }+            nbs1 :: FoundNode Text () ()+            nbs1 = FoundNode { subjectNode = "n1",+                               foundAt = fromS "2018-12-01T10:00",+                               neighborLinks = return link_12,+                               nodeAttributes = ()+                             }+            nbs2 = FoundNode { subjectNode = "n2",+                               foundAt = fromS "2018-12-01T20:00",+                               neighborLinks = return link_21,+                               nodeAttributes = ()+                             }+        in [nbs1, nbs2],+      caseQuery = defQuery ["n1"],+      caseAssert = mutual_neighbor_assert+    },+    SnapshotTestCase+    { caseName = "multiple findings for a single node",+      caseInput =+        let fns :: [FoundNode Text AText ()]+            fns = [ FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2018-12-01T20:00",+                      neighborLinks = [ FoundLink+                                        { targetNode = "n2",+                                          linkState = LinkToTarget,+                                          linkAttributes = ()+                                        },+                                        FoundLink+                                        { targetNode = "n3",+                                          linkState = LinkToSubject,+                                          linkAttributes = ()+                                        }+                                      ],+                      nodeAttributes = AText "at 20:00"+                    },+                    FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2018-12-01T10:00",+                      neighborLinks = mempty,+                      nodeAttributes = AText "at 10:00"+                    },+                    FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2018-12-01T15:00",+                      neighborLinks = return $ FoundLink+                                      { targetNode = "n2",+                                        linkState = LinkToTarget,+                                        linkAttributes = ()+                                      },+                      nodeAttributes = AText "at 15:00"+                    }+                  ]+        in fns,+      caseQuery = defQuery ["n1"],+      caseAssert = multi_findings_single_node_assert+    },+    SnapshotTestCase+    { caseName = "multi-hop neighbors",+      caseInput = +        let fns :: [FoundNode Text () AText]+            fns = [ FoundNode+                    { subjectNode = intToNodeId 1,+                      foundAt = fromS "2018-12-01T10:00",+                      neighborLinks = return $ FoundLink+                                      { targetNode = intToNodeId 2,+                                        linkState = LinkToTarget,+                                        linkAttributes = AText "first"+                                      },+                      nodeAttributes = ()+                    },+                    middleNode 2 $ fromS "2018-12-01T05:00",+                    middleNode 3 $ fromS "2018-12-01T15:00",+                    middleNode 4 $ fromS "2018-12-01T20:00",+                    FoundNode+                    { subjectNode = intToNodeId 5,+                      foundAt = fromS "2018-12-01T15:00",+                      neighborLinks = return $ FoundLink+                                      { targetNode = intToNodeId 4,+                                        linkState = LinkToSubject,+                                        linkAttributes = AText "last"+                                      },+                      nodeAttributes = ()+                    }+                  ]+            intToNodeId :: Int -> Text+            intToNodeId i = pack ("n" ++ show i)+            middleNode node_i time =+              FoundNode+              { subjectNode = sub_nid,+                foundAt = time,+                neighborLinks = [ FoundLink+                                  { targetNode = intToNodeId (node_i - 1),+                                    linkState = LinkToSubject,+                                    linkAttributes = AText (sub_nid <> " to prev")+                                  },+                                  FoundLink+                                  { targetNode = intToNodeId (node_i + 1),+                                    linkState = LinkToTarget,+                                    linkAttributes = AText (sub_nid <> " to next")+                                  }+                                ],+                nodeAttributes = ()+              }+              where+                sub_nid = intToNodeId node_i+        in fns,+      caseQuery = defQuery ["n1"],+      caseAssert = multi_hop_neighbors_assert+    },+    SnapshotTestCase+    { caseName = "loop network",+      caseInput =+        let fns :: [FoundNode Text () ()]+            fns = [ FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2018-12-01T10:00",+                      neighborLinks = [ FoundLink+                                        { targetNode = "n2",+                                          linkState = LinkToTarget,+                                          linkAttributes = ()+                                        }+                                      ],+                      nodeAttributes = ()+                    },+                    FoundNode+                    { subjectNode = "n2",+                      foundAt = fromS "2018-12-01T15:00",+                      neighborLinks = [ FoundLink+                                        { targetNode = "n1",+                                          linkState = LinkToSubject,+                                          linkAttributes = ()+                                        },+                                        FoundLink+                                        { targetNode = "n3",+                                          linkState = LinkBidirectional,+                                          linkAttributes = ()+                                        }+                                      ],+                      nodeAttributes = ()+                    },+                    FoundNode+                    { subjectNode = "n3",+                      foundAt = fromS "2018-12-01T10:00",+                      neighborLinks = [ FoundLink+                                        { targetNode = "n1",+                                          linkState = LinkToTarget,+                                          linkAttributes = ()+                                        },+                                        FoundLink+                                        { targetNode = "n2",+                                          linkState = LinkBidirectional,+                                          linkAttributes = ()+                                        }+                                      ],+                      nodeAttributes = ()+                    }+                  ]+        in fns,+      caseQuery = defQuery ["n1"],+      caseAssert = loop_network_assert+    },+    SnapshotTestCase+    { caseName = "multiple links between two nodes",+      caseInput = +        let fns :: [FoundNode Text () APorts]+            fns = [ FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2018-12-01T20:00",+                      nodeAttributes = (),+                      neighborLinks = [ FoundLink+                                        { targetNode = "n2",+                                          linkState = LinkToTarget,+                                          linkAttributes = APorts "p4" "p8"+                                        },+                                        FoundLink+                                        { targetNode = "n2",+                                          linkState = LinkToTarget,+                                          linkAttributes = APorts "p3" "p6"+                                        },+                                        FoundLink+                                        { targetNode = "n2",+                                          linkState = LinkToTarget,+                                          linkAttributes = APorts "p5" "p10"+                                        }+                                      ]+                    },+                    FoundNode+                    { subjectNode = "n2",+                      foundAt = fromS "2018-12-01T10:00",+                      nodeAttributes = (),+                      neighborLinks = [ FoundLink+                                        { targetNode = "n1",+                                          linkState = LinkToSubject,+                                          linkAttributes = APorts "p6" "p3"+                                        },+                                        FoundLink+                                        { targetNode = "n1",+                                          linkState = LinkToSubject,+                                          linkAttributes = APorts "p10" "p5"+                                        },+                                        FoundLink+                                        { targetNode = "n1",+                                          linkState = LinkToSubject,+                                          linkAttributes = APorts "p8" "p4"+                                        }+                                      ]+                    }+                  ]+        in fns,+      caseQuery = queryWithAPorts "n1",+      caseAssert = multiple_links_assert+    },+    SnapshotTestCase+    { caseName = "link disappears",+      caseInput = +        let fns :: [FoundNode Text () ()]+            fns = [ FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2018-12-01T10:00",+                      nodeAttributes = (),+                      neighborLinks = [ FoundLink+                                        { targetNode = "n2",+                                          linkState = LinkBidirectional,+                                          linkAttributes = ()+                                        }+                                      ]+                    },+                    FoundNode+                    { subjectNode = "n2",+                      foundAt = fromS "2018-12-01T20:00",+                      nodeAttributes = (),+                      neighborLinks = []+                    }+                  ]+        in fns,+      caseQuery = defQuery ["n1"],+      caseAssert = \got_graph -> do+        let (got_ns, got_ls) = sortSnapshotElements got_graph+        nodeId (got_ns ! 0) `shouldBe` "n1"+        nodeId (got_ns ! 1) `shouldBe` "n2"+        V.length got_ns `shouldBe` 2+        V.length got_ls `shouldBe` 0+        -- the n2 observes at t=200 that there is no link to n1. So the+        -- Spider should consider the link disappears.+    },+    SnapshotTestCase+    { caseName = "link appears",+      caseInput = +        let fns :: [FoundNode Text () ()]+            fns = [ FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2018-12-01T20:00",+                      nodeAttributes = (),+                      neighborLinks = [ FoundLink+                                        { targetNode = "n2",+                                          linkState = LinkBidirectional,+                                          linkAttributes = ()+                                        }+                                      ]+                    },+                    FoundNode+                    { subjectNode = "n2",+                      foundAt = fromS "2018-12-01T10:00",+                      nodeAttributes = (),+                      neighborLinks = []+                    }+                  ]+        in fns,+      caseQuery = defQuery ["n1"],+      caseAssert = \got_graph -> do+        let (got_ns, got_ls) = sortSnapshotElements got_graph+        nodeId (got_ns ! 0) `shouldBe` "n1"+        nodeId (got_ns ! 1) `shouldBe` "n2"+        V.length got_ns `shouldBe` 2+        linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n2")+        isDirected (got_ls ! 0) `shouldBe` False+        linkTimestamp (got_ls ! 0) `shouldBe` fromS "2018-12-01T20:00"+        V.length got_ls `shouldBe` 1+        -- the n2 observes at t=100 that there is no link to n1, but n1+        -- observes there is a link at t=200.  Spider should consider the+        -- link appears.+    },+    SnapshotTestCase+    { caseName = "multiple links between pair, some appear, some disappear.",+      caseInput = +        let fns :: [FoundNode Text () APorts]+            fns = [ FoundNode+                    { subjectNode = "n2",+                      foundAt = fromS "2018-12-01T20:00",+                      nodeAttributes = (),+                      neighborLinks = links2+                    },+                    FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2018-12-01T10:00",+                      nodeAttributes = (),+                      neighborLinks = links1+                    }+                  ]+            links1 = [ FoundLink -- disappears+                       { targetNode = "n2",+                         linkState = LinkToTarget,+                         linkAttributes = APorts "p11" "p21"+                       },+                       FoundLink -- stays+                       { targetNode = "n2",+                         linkState = LinkToTarget,+                         linkAttributes = APorts "p12" "p22"+                       }+                     ]+            links2 = [ FoundLink -- appears+                       { targetNode = "n1",+                         linkState = LinkToSubject,+                         linkAttributes = APorts "p23" "p13"+                       },+                       FoundLink -- stays+                       { targetNode = "n1",+                         linkState = LinkToSubject,+                         linkAttributes = APorts "p22" "p12" +                       }+                     ]+        in fns,+      caseQuery = queryWithAPorts "n1",+      caseAssert = \got_graph -> do+        let (got_ns, got_ls_raw) = sortSnapshotElements got_graph+        nodeId (got_ns ! 0) `shouldBe` "n1"+        nodeTimestamp (got_ns ! 0) `shouldBe` (Just $ fromS "2018-12-01T10:00")+        nodeId (got_ns ! 1) `shouldBe` "n2"+        nodeTimestamp (got_ns ! 1) `shouldBe` (Just $ fromS "2018-12-01T20:00")+        V.length got_ns `shouldBe` 2+        let got_ls = sortLinksWithAttr got_ls_raw+        linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n2")+        S.linkAttributes (got_ls ! 0) `shouldBe` APorts "p12" "p22"+        linkTimestamp (got_ls ! 0) `shouldBe` fromS "2018-12-01T20:00"+        linkNodeTuple (got_ls ! 1) `shouldBe` ("n1", "n2") -- TODO: looks like this link is removed. why?+        S.linkAttributes (got_ls ! 1) `shouldBe` APorts "p13" "p23"+        linkTimestamp (got_ls ! 1) `shouldBe` fromS "2018-12-01T20:00"+        V.length got_ls `shouldBe` 2+    },++-- TODO: how linkState relates to the property of SnapshotLink ?+-- especially Bidirectional links? -> important thing is that if the+-- link is Bidirectional, (source, destination) of snapshot link is+-- always (subject, target).++    SnapshotTestCase+    { caseName = "policyOverwrite and link disappear",+      caseInput =+        let fns :: [FoundNode Text () ()]+            fns = [ FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2020-03-10T15:00",+                      nodeAttributes = (),+                      neighborLinks =+                        [ FoundLink+                          { targetNode = "n4",+                            linkState = LinkBidirectional,+                            linkAttributes = ()+                          }+                        ]+                    },+                    FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2020-03-10T14:00",+                      nodeAttributes = (),+                      neighborLinks =+                        [ FoundLink+                          { targetNode = "n2",+                            linkState = LinkToTarget,+                            linkAttributes = ()+                          },+                          FoundLink+                          { targetNode = "n3",+                            linkState = LinkBidirectional,+                            linkAttributes = ()+                          }+                        ]+                    }+                  ]+        in fns,+      caseQuery = (defQuery ["n1"]) { foundNodePolicy = policyOverwrite },+      caseAssert = \got_graph -> do+        let (got_ns, got_ls) = sortSnapshotElements got_graph+        nodeId (got_ns ! 0) `shouldBe` "n1"+        nodeTimestamp (got_ns ! 0) `shouldBe` (Just $ fromS "2020-03-10T15:00")+        nodeId (got_ns ! 1) `shouldBe` "n4"+        nodeTimestamp (got_ns ! 1) `shouldBe` Nothing+        V.length got_ns `shouldBe` 2+        linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n4")+        linkTimestamp (got_ls ! 0) `shouldBe` fromS "2020-03-10T15:00"+        isDirected (got_ls ! 0) `shouldBe` False+        V.length got_ls `shouldBe` 1+    },++    SnapshotTestCase+    { caseName = "policyAppend",+      caseInput =+        let fns :: [FoundNode Text () ()]+            fns = [ FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2020-02-18T11:00",+                      nodeAttributes = (),+                      neighborLinks =+                        [ FoundLink+                          { targetNode = "n2",+                            linkState = LinkToTarget,+                            linkAttributes = ()+                          }+                        ]+                    },+                    FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2020-02-18T10:00",+                      nodeAttributes = (),+                      neighborLinks =+                        [ FoundLink+                          { targetNode = "n3",+                            linkState = LinkToSubject,+                            linkAttributes = ()+                          }+                        ]+                    },+                    FoundNode+                    { subjectNode = "n1",+                      foundAt = fromS "2020-02-18T09:00",+                      nodeAttributes = (),+                      neighborLinks =+                        [ FoundLink+                          { targetNode = "n4",+                            linkState = LinkBidirectional,+                            linkAttributes = ()+                          }+                        ]+                    }+                  ]+        in fns,+      caseQuery = (defQuery ["n1"]) { foundNodePolicy = policyAppend },+      caseAssert = \got_graph -> do+        let (got_ns, got_ls) = sortSnapshotElements got_graph+        nodeId (got_ns ! 0) `shouldBe` "n1"+        nodeTimestamp (got_ns ! 0) `shouldBe` (Just $ fromS "2020-02-18T11:00")+        nodeId (got_ns ! 1) `shouldBe` "n2"+        nodeTimestamp (got_ns ! 1) `shouldBe` Nothing+        nodeId (got_ns ! 2) `shouldBe` "n3"+        nodeTimestamp (got_ns ! 2) `shouldBe` Nothing+        nodeId (got_ns ! 3) `shouldBe` "n4"+        nodeTimestamp (got_ns ! 3) `shouldBe` Nothing+        V.length got_ns `shouldBe` 4+        linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n2")+        isDirected (got_ls ! 0) `shouldBe` True+        linkTimestamp (got_ls ! 0) `shouldBe` fromS "2020-02-18T11:00"+        linkNodeTuple (got_ls ! 1) `shouldBe` ("n1", "n4")+        isDirected (got_ls ! 1) `shouldBe` False+        linkTimestamp (got_ls ! 1) `shouldBe` fromS "2020-02-18T09:00"+        linkNodeTuple (got_ls ! 2) `shouldBe` ("n3", "n1")+        isDirected (got_ls ! 2) `shouldBe` True+        linkTimestamp (got_ls ! 2) `shouldBe` fromS "2020-02-18T10:00"+        V.length got_ls `shouldBe` 3+    }++  ]+  where+    one_neighbor_assert (got_ns, got_ls) = do+      let (got_n1, got_n2, got_link) = case (sort got_ns, sort got_ls) of+            ([a, b], [c]) -> (a, b, c)+            _ -> error ("Unexpected result: got = " ++ show (got_ns, got_ls))+      nodeId got_n1 `shouldBe` "n1"+      isOnBoundary got_n1 `shouldBe` False+      nodeTimestamp got_n1 `shouldBe` Just (fromS "2018-12-01T10:00")+      S.nodeAttributes got_n1 `shouldBe` Just ()+      nodeId got_n2 `shouldBe` "n2"+      isOnBoundary got_n2 `shouldBe` False+      nodeTimestamp got_n2 `shouldBe` Nothing -- n1 is not observed.+      S.nodeAttributes got_n2 `shouldBe` Nothing -- n1 is not observed.+      linkNodeTuple got_link `shouldBe` ("n1", "n2")+      isDirected got_link `shouldBe` True+      linkTimestamp got_link `shouldBe` fromS "2018-12-01T10:00"+      S.linkAttributes got_link `shouldBe` ()+    no_neighbor_assert (got_ns, got_ls) = do+      let got_n1 = case (sort got_ns, sort got_ls) of+            ([a], []) -> a+            _ -> error ("Unexpected result: got = " ++ show (got_ns, got_ls))+      nodeId got_n1 `shouldBe` "n1"+      isOnBoundary got_n1 `shouldBe` False+      nodeTimestamp got_n1 `shouldBe` Just (fromS "2018-12-01T20:00")+      S.nodeAttributes got_n1 `shouldBe` Just ()+    mutual_neighbor_assert (got_ns, got_ls) = do+      let (got_n1, got_n2, got_l) = case (sort got_ns, sort got_ls) of+            ([a,b], [c]) -> (a,b,c)+            _ -> error ("Unexpected result: got = " ++ show (got_ns, got_ls))+      nodeId got_n1 `shouldBe` "n1"+      isOnBoundary got_n1 `shouldBe` False+      nodeTimestamp got_n1 `shouldBe` Just (fromS "2018-12-01T10:00")+      S.nodeAttributes got_n1 `shouldBe` Just ()+      nodeId got_n2 `shouldBe` "n2"+      isOnBoundary got_n2 `shouldBe` False+      nodeTimestamp got_n2 `shouldBe` Just (fromS "2018-12-01T20:00")+      S.nodeAttributes got_n2 `shouldBe` Just ()+      linkNodeTuple got_l `shouldBe` ("n2", "n1")+      isDirected got_l `shouldBe` True+      linkTimestamp got_l `shouldBe` fromS "2018-12-01T20:00"+      S.linkAttributes got_l `shouldBe` ()+    multi_findings_single_node_assert (got_ns, got_ls) = do+      let (got_n1, got_n2, got_n3, got_l12, got_l31) = case (sort got_ns, sort got_ls) of+            ([g1, g2, g3], [g4, g5]) -> (g1, g2, g3, g4, g5)+            _ -> error ("Unexpected patter: got = " ++ show (got_ns, got_ls))+      nodeId got_n1 `shouldBe` "n1"+      isOnBoundary got_n1 `shouldBe` False+      nodeTimestamp got_n1 `shouldBe` Just (fromS "2018-12-01T20:00")+      S.nodeAttributes got_n1 `shouldBe` Just (AText "at 20:00")+      nodeId got_n2 `shouldBe` "n2"+      isOnBoundary got_n2 `shouldBe` False+      nodeTimestamp got_n2 `shouldBe` Nothing+      S.nodeAttributes got_n2 `shouldBe` Nothing+      nodeId got_n3 `shouldBe` "n3"+      isOnBoundary got_n3 `shouldBe` False+      nodeTimestamp got_n3 `shouldBe` Nothing+      S.nodeAttributes got_n3 `shouldBe` Nothing+      linkNodeTuple got_l12 `shouldBe` ("n1", "n2")+      isDirected got_l12 `shouldBe` True+      linkTimestamp got_l12 `shouldBe` fromS "2018-12-01T20:00"+      linkNodeTuple got_l31 `shouldBe` ("n3", "n1")+      isDirected got_l31 `shouldBe` True+      linkTimestamp got_l31 `shouldBe` fromS "2018-12-01T20:00"+    multi_hop_neighbors_assert got_graph = do+      let (got_ns, got_ls) = sortSnapshotElements got_graph+      nodeId (got_ns ! 0) `shouldBe` "n1"+      isOnBoundary (got_ns ! 0) `shouldBe` False+      nodeTimestamp (got_ns ! 0) `shouldBe` Just (fromS "2018-12-01T10:00")+      S.nodeAttributes (got_ns ! 0) `shouldBe` Just ()+      nodeId (got_ns ! 1) `shouldBe` "n2"+      isOnBoundary (got_ns ! 1) `shouldBe` False+      nodeTimestamp (got_ns ! 1) `shouldBe` Just (fromS "2018-12-01T05:00")+      S.nodeAttributes (got_ns ! 1) `shouldBe` Just ()+      nodeId (got_ns ! 2) `shouldBe` "n3"+      isOnBoundary (got_ns ! 2) `shouldBe` False+      nodeTimestamp (got_ns ! 2) `shouldBe` Just (fromS "2018-12-01T15:00")+      S.nodeAttributes (got_ns ! 2) `shouldBe` Just ()+      nodeId (got_ns ! 3) `shouldBe` "n4"+      isOnBoundary (got_ns ! 3) `shouldBe` False+      nodeTimestamp (got_ns ! 3) `shouldBe` Just (fromS "2018-12-01T20:00")+      S.nodeAttributes (got_ns ! 3) `shouldBe` Just ()+      nodeId (got_ns ! 4) `shouldBe` "n5"+      isOnBoundary (got_ns ! 4) `shouldBe` False+      nodeTimestamp (got_ns ! 4) `shouldBe` Just (fromS "2018-12-01T15:00")+      S.nodeAttributes (got_ns ! 4) `shouldBe` Just ()+      V.length got_ns `shouldBe` 5+      linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n2")+      isDirected (got_ls ! 0) `shouldBe` True+      linkTimestamp (got_ls ! 0) `shouldBe` fromS "2018-12-01T10:00"+      S.linkAttributes (got_ls ! 0) `shouldBe` AText "first"+      linkNodeTuple (got_ls ! 1) `shouldBe` ("n2", "n3")+      isDirected (got_ls ! 1) `shouldBe` True+      linkTimestamp (got_ls ! 1) `shouldBe` fromS "2018-12-01T15:00"+      S.linkAttributes (got_ls ! 1) `shouldBe` AText "n3 to prev"+      linkNodeTuple (got_ls ! 2) `shouldBe` ("n3", "n4")+      isDirected (got_ls ! 2) `shouldBe` True+      linkTimestamp (got_ls ! 2) `shouldBe` fromS "2018-12-01T20:00"+      S.linkAttributes (got_ls ! 2) `shouldBe` AText "n4 to prev"+      linkNodeTuple (got_ls ! 3) `shouldBe` ("n4", "n5")+      isDirected (got_ls ! 3) `shouldBe` True+      linkTimestamp (got_ls ! 3) `shouldBe` fromS "2018-12-01T20:00"+      S.linkAttributes (got_ls ! 3) `shouldBe` AText "n4 to next"+      V.length got_ls `shouldBe` 4+    loop_network_assert got_graph = do+      let (got_ns, got_ls) = sortSnapshotElements got_graph+      nodeId (got_ns ! 0) `shouldBe` "n1"+      isOnBoundary (got_ns ! 0) `shouldBe` False+      nodeTimestamp (got_ns ! 0) `shouldBe` Just (fromS "2018-12-01T10:00")+      nodeId (got_ns ! 1) `shouldBe` "n2"+      isOnBoundary (got_ns ! 1) `shouldBe` False+      nodeTimestamp (got_ns ! 1) `shouldBe` Just (fromS "2018-12-01T15:00")+      nodeId (got_ns ! 2) `shouldBe` "n3"+      isOnBoundary (got_ns ! 2) `shouldBe` False+      nodeTimestamp (got_ns ! 2) `shouldBe` Just (fromS "2018-12-01T10:00")+      V.length got_ns `shouldBe` 3+      linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n2")+      isDirected (got_ls ! 0) `shouldBe` True+      linkTimestamp (got_ls ! 0) `shouldBe` fromS "2018-12-01T15:00"+      linkNodeTuple (got_ls ! 1) `shouldBe` ("n2", "n3")+      isDirected (got_ls ! 1) `shouldBe` False+      linkTimestamp (got_ls ! 1) `shouldBe` fromS "2018-12-01T15:00"+      linkNodeTuple (got_ls ! 2) `shouldBe` ("n3", "n1")+      isDirected (got_ls ! 2) `shouldBe` True+      linkTimestamp (got_ls ! 2) `shouldBe` fromS "2018-12-01T10:00"+    multiple_links_assert got_graph = do+      let (got_ns, got_ls_raw) = sortSnapshotElements got_graph+      nodeId (got_ns ! 0) `shouldBe` "n1"+      nodeId (got_ns ! 1) `shouldBe` "n2"+      V.length got_ns `shouldBe` 2+      let got_ls = sortLinksWithAttr got_ls_raw+      linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n2")+      S.linkAttributes (got_ls ! 0) `shouldBe` APorts "p3" "p6"+      linkTimestamp (got_ls ! 0) `shouldBe` fromS "2018-12-01T20:00"+      linkNodeTuple (got_ls ! 1) `shouldBe` ("n1", "n2")+      S.linkAttributes (got_ls ! 1) `shouldBe` APorts "p4" "p8"+      linkTimestamp (got_ls ! 1) `shouldBe` fromS "2018-12-01T20:00"+      linkNodeTuple (got_ls ! 2) `shouldBe` ("n1", "n2")+      S.linkAttributes (got_ls ! 2) `shouldBe` APorts "p5" "p10"+      linkTimestamp (got_ls ! 2) `shouldBe` fromS "2018-12-01T20:00"+      V.length got_ls `shouldBe` 3+++-- | \"Traverses\" test cases involve traversing graphs. For example,+-- it checks some nodes are not reachable from the starting node.+traverses :: [SnapshotTestCase]+traverses =+  [ SnapshotTestCase+    { caseName = "missing starting node",+      caseInput = oneNeighborFoundNodes,+      caseQuery = defQuery ["no node"],+      caseAssert = \(got_ns, got_ls) -> do+        got_ns `shouldBe` mempty+        got_ls `shouldBe` mempty+    }+  ]

@@ -0,0 +1,114 @@+{-# LANGUAGE OverloadedStrings #-}+module TestCommon+       ( sortSnapshotElements,+         AText(..),+         AInt(..),+         APorts(..),+         subIdWithAPorts,+         alignAPortsToLinkDirection+       ) where++import Control.Applicative ((<$>))+import Control.Category ((<<<))+import Data.Aeson.Types (Parser)+import Data.Greskell (gProperty, newBind, lookupAs, pMapToFail, Key)+import Data.List (sort)+import Data.Text (Text)+import Data.Vector (Vector)+import qualified Data.Vector as V+import Test.Hspec++import NetSpider.Found (LinkState(..))+import NetSpider.Graph (NodeAttributes(..), LinkAttributes(..), VNode)+import NetSpider.Pair (Pair(..))+import NetSpider.Snapshot+  ( SnapshotNode, SnapshotLink+  )+import NetSpider.Unify+  ( LinkSample(..)+  )++sortSnapshotElements :: (Ord n, Eq na, Eq la)+                     => ([SnapshotNode n na], [SnapshotLink n la])+                     -> (Vector (SnapshotNode n na), Vector (SnapshotLink n la))+sortSnapshotElements (ns, ls) = (sortV ns, sortV ls)+  where+    sortV :: Ord a => [a] -> Vector a+    sortV = V.fromList . sort+++newtype AText = AText Text+              deriving (Show,Eq,Ord)++keyText :: Key e Text+keyText = "text"++instance NodeAttributes AText where+  writeNodeAttributes (AText t) = gProperty keyText <$> newBind t+  parseNodeAttributes ps = fmap AText $ pMapToFail $ lookupAs keyText ps++instance LinkAttributes AText where+  writeLinkAttributes (AText t) = gProperty keyText <$> newBind t+  parseLinkAttributes ps = fmap AText $ pMapToFail $ lookupAs keyText ps++newtype AInt = AInt Int+             deriving (Show,Eq,Ord)++keyInt :: Key e Int +keyInt = "integer"++instance NodeAttributes AInt where+  writeNodeAttributes (AInt n) = gProperty keyInt <$> newBind n+  parseNodeAttributes ps = fmap AInt $ pMapToFail $ lookupAs keyInt ps++instance LinkAttributes AInt where+  writeLinkAttributes (AInt n) = gProperty keyInt <$> newBind n+  parseLinkAttributes ps = fmap AInt $ pMapToFail $ lookupAs keyInt ps+++-- | Pair of ports.+--+-- This type is used in two ways. (subject port, target port) and+-- (source port, destination port).+data APorts =+  APorts+  { apFst :: Text,+    apSnd :: Text+  }+  deriving (Show,Eq,Ord)++keySubjectPort :: Key e Text+keySubjectPort = "subject_port"++keyTargetPort :: Key e Text+keyTargetPort = "target_port"++instance LinkAttributes APorts where+  writeLinkAttributes ap = do+    writeSource <- gProperty keySubjectPort <$> newBind (apFst ap)+    writeDest <- gProperty keyTargetPort <$> newBind (apSnd ap)+    return (writeDest <<< writeSource)+  parseLinkAttributes ps = APorts+                           <$> (pMapToFail $ lookupAs keySubjectPort ps)+                           <*> (pMapToFail $ lookupAs keyTargetPort ps)++swapAPorts :: APorts -> APorts+swapAPorts ap = ap { apFst = apSnd ap,+                     apSnd = apFst ap+                   }++-- | Link sub-ID with 'APorts'.+subIdWithAPorts :: LinkSample n APorts -> Pair (n, Text)+subIdWithAPorts ls = Pair ( (lsSubjectNode ls, apFst $ lsLinkAttributes ls),+                            (lsTargetNode ls, apSnd $ lsLinkAttributes ls)+                          )++-- | Sort 'APorts' according to 'LinkState'. This converts the+-- 'APorts' as (subject port, target port) into (source port,+-- destination port).+alignAPortsToLinkDirection :: LinkSample n APorts -> LinkSample n APorts+alignAPortsToLinkDirection ls = ls { lsLinkAttributes = updated }+  where+    updated = case lsLinkState ls of+               LinkToSubject -> swapAPorts $ lsLinkAttributes ls+               _ -> lsLinkAttributes ls