diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/net-spider.cabal b/net-spider.cabal --- a/net-spider.cabal +++ b/net-spider.cabal @@ -1,5 +1,5 @@ name: net-spider -version: 0.4.1.0 +version: 0.4.2.0 author: Toshio Ito maintainer: Toshio Ito 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, diff --git a/src/NetSpider.hs b/src/NetSpider.hs --- a/src/NetSpider.hs +++ b/src/NetSpider.hs @@ -23,6 +23,10 @@ -- * "NetSpider.Query" -- * "NetSpider.Unify" -- +-- == Weaver (on-memory snapshot builder) +-- +-- * "NetSpider.Weaver" +-- -- == Data models -- -- * "NetSpider.Found" diff --git a/src/NetSpider/Found.hs b/src/NetSpider/Found.hs --- a/src/NetSpider/Found.hs +++ b/src/NetSpider/Found.hs @@ -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 diff --git a/src/NetSpider/Graph/Internal.hs b/src/NetSpider/Graph/Internal.hs --- a/src/NetSpider/Graph/Internal.hs +++ b/src/NetSpider/Graph/Internal.hs @@ -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 + } diff --git a/src/NetSpider/Spider.hs b/src/NetSpider/Spider.hs --- a/src/NetSpider/Spider.hs +++ b/src/NetSpider/Spider.hs @@ -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 diff --git a/src/NetSpider/Unify.hs b/src/NetSpider/Unify.hs --- a/src/NetSpider/Unify.hs +++ b/src/NetSpider/Unify.hs @@ -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 diff --git a/src/NetSpider/Weaver.hs b/src/NetSpider/Weaver.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Weaver.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, OverloadedStrings #-} +-- | +-- Module: NetSpider.Weaver +-- Description: On-memory builder for snapshot graphs +-- Maintainer: Toshio Ito +-- +-- @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 + } diff --git a/test/NetSpider/WeaverSpec.hs b/test/NetSpider/WeaverSpec.hs new file mode 100644 --- /dev/null +++ b/test/NetSpider/WeaverSpec.hs @@ -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 + diff --git a/test/ServerTest/Attributes.hs b/test/ServerTest/Attributes.hs --- a/test/ServerTest/Attributes.hs +++ b/test/ServerTest/Attributes.hs @@ -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) diff --git a/test/ServerTest/Common.hs b/test/ServerTest/Common.hs deleted file mode 100644 --- a/test/ServerTest/Common.hs +++ /dev/null @@ -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 diff --git a/test/ServerTest/ServerCommon.hs b/test/ServerTest/ServerCommon.hs new file mode 100644 --- /dev/null +++ b/test/ServerTest/ServerCommon.hs @@ -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 + } + + diff --git a/test/ServerTest/Snapshot.hs b/test/ServerTest/Snapshot.hs --- a/test/ServerTest/Snapshot.hs +++ b/test/ServerTest/Snapshot.hs @@ -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) diff --git a/test/SnapshotTestCase.hs b/test/SnapshotTestCase.hs new file mode 100644 --- /dev/null +++ b/test/SnapshotTestCase.hs @@ -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 + } + ] diff --git a/test/TestCommon.hs b/test/TestCommon.hs new file mode 100644 --- /dev/null +++ b/test/TestCommon.hs @@ -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