diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,48 @@ # Revision history for net-spider +## 0.2.0.0 -- 2018-12-10 + +* Add `Log` module. +* Confirmed test with base-4.12, time-1.9, containers-0.6 + +### Query module + +* Add `timeInterval` and `foundNodePolicy` fields to `Query` type. +* Add `FoundNodePolicy` type. +* Add `secUpTo`, `policyOverwrite` and `policyAppend` functions. +* Re-export symbols from Data.Interval. + +### Spider module + +* Fix bug that the Spider visits a node multiple times. The result was + correct, but it took extra time. +* Now it may produce log messages. + +### Spider.Config module + +* [BREAKING CHANGE] Now `Spider` type's internal is hidden. It was + just a mistake. +* [BREAKING CHANGE] Now `getSnapshot` and `getSnapshotSimple` requires + `(Show n)` constraint for logging. +* Add `logThreshold` field. +* Export `LogLevel` type. + +### Timestamp module + +* [BREAKING CHANGE] Rename `fromEpochSecond` to + `fromEpochMillisecond`. Now `Timestamp` represents milliseconds + since the epoch. +* Add `now`, `addSec`, `parseTimestamp`, `fromS`, `fromZonedTime`, + `fromUTCTime`, `fromSystemTime`, `fromLocalTime`, `showEpochTime`. + +### Unify modulem + +* [BREAKING CHANGE] Now `LinkSampleUnifier` returns `WriterLoggingM` + monad. +* [BREAKING CHANGE] Now `unifyToOne`, `unifyToMany` and `unifyStd` + require `(Show n)` constraint. + + ## 0.1.0.0 -- 2018-09-24 * First version. Released on an unsuspecting world. 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.1.0.0 +version: 0.2.0.0 author: Toshio Ito maintainer: Toshio Ito license: BSD3 @@ -32,22 +32,29 @@ NetSpider.Snapshot, NetSpider.Graph, NetSpider.Pair, - NetSpider.Query + NetSpider.Query, + NetSpider.Log other-modules: NetSpider.Snapshot.Internal, NetSpider.Graph.Internal, NetSpider.Spider.Internal.Graph, - NetSpider.Queue - build-depends: base >=4.10.1 && <4.12, - time >=1.8.0.2 && <1.9, + NetSpider.Spider.Internal.Log, + NetSpider.Spider.Internal.Spider, + NetSpider.Queue, + NetSpider.Query.Internal + build-depends: base >=4.10.1 && <4.13, + time >=1.8.0.2 && <1.10, vector >=0.12.0.1 && <0.13, greskell-websocket >=0.1.1 && <0.2, - greskell >=0.2.1 && <0.3, + greskell >=0.2.2 && <0.3, aeson >=1.2.4 && <1.5, safe-exceptions >=0.1.6 && <0.2, text >=1.2.2.2 && <1.3, unordered-containers >=0.2.8 && <0.3, hashable >=1.2.6.1 && <1.3, - containers >=0.5.10.2 && <0.6 + containers >=0.5.10.2 && <0.7, + data-interval >=1.3.0 && <1.4, + extended-reals >=0.2.3.0 && <0.3, + monad-logger >=0.3.28.1 && <0.4 -- executable net-spider -- default-language: Haskell2010 @@ -94,6 +101,16 @@ hspec-need-env >=0.1.0.0 && <0.2 else buildable: False + +test-suite doctest + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m" + main-is: DocTest.hs + build-depends: base, + doctest >=0.13 && <0.17, + doctest-discover >=0.1.0.7 && <0.3 source-repository head diff --git a/src/NetSpider.hs b/src/NetSpider.hs --- a/src/NetSpider.hs +++ b/src/NetSpider.hs @@ -33,7 +33,6 @@ -- == Utility -- -- * "NetSpider.Pair" +-- * "NetSpider.Log" module NetSpider () where - - diff --git a/src/NetSpider/Log.hs b/src/NetSpider/Log.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Log.hs @@ -0,0 +1,34 @@ +-- | +-- Module: NetSpider.Log +-- Description: Types and functions for basic logging +-- Maintainer: Toshio Ito +-- +-- This module is rather for internal use, but end-users can use it, +-- e.g. to implement the unifier. +-- +-- @since 0.2.0.0 +module NetSpider.Log + ( LogLine, + WriterLoggingM, + runWriterLoggingM, + logDebugW, + spack + ) where + +import qualified Control.Monad.Logger as Log +import Data.Functor.Identity (Identity, runIdentity) +import Data.Text (Text, pack) + +type LogLine = (Log.Loc, Log.LogSource, Log.LogLevel, Log.LogStr) + +type WriterLoggingM = Log.WriterLoggingT Identity + +runWriterLoggingM :: WriterLoggingM a -> (a, [LogLine]) +runWriterLoggingM = runIdentity . Log.runWriterLoggingT + +logDebugW :: Text -> WriterLoggingM () +logDebugW = Log.logDebugN + +spack :: Show a => a -> Text +spack = pack . show + diff --git a/src/NetSpider/Query.hs b/src/NetSpider/Query.hs --- a/src/NetSpider/Query.hs +++ b/src/NetSpider/Query.hs @@ -5,15 +5,33 @@ -- -- module NetSpider.Query - ( -- * Query type + ( -- * Query Query, defQuery, -- ** accessor functions startsFrom, - unifyLinkSamples + unifyLinkSamples, + timeInterval, + foundNodePolicy, + -- * FoundNodePolicy + FoundNodePolicy, + policyOverwrite, + policyAppend, + -- * Utilities + secUpTo, + -- * Re-exports + Interval, (<=..<=), (<..<=), (<=..<), (<..<), + Extended(..) ) where +import Data.ExtendedReal (Extended(..)) +import Data.Int (Int64) +import Data.Interval (Interval, (<=..<=), (<..<=), (<=..<), (<..<)) +import qualified Data.Interval as Interval + +import NetSpider.Timestamp (Timestamp, addSec) import NetSpider.Unify (LinkSampleUnifier, unifyToOne) +import NetSpider.Query.Internal (FoundNodePolicy(..)) -- | Query for snapshot graph. You can get the default 'Query' by -- 'defQuery' function, and customize its fields by the accessor @@ -29,18 +47,62 @@ { startsFrom :: [n], -- ^ Nodes from which the Spider starts traversing the history -- graph. - unifyLinkSamples :: LinkSampleUnifier n na fla sla + unifyLinkSamples :: LinkSampleUnifier n na fla sla, -- ^ See the document of 'LinkSampleUnifier'. -- -- Default: 'unifyToOne'. + timeInterval :: Interval Timestamp, + -- ^ Time interval to query. Only the local findings observed + -- during this interval are used to make the snapshot graph. + -- + -- Default: (-infinity, +infinity) + -- + -- @since 0.2.0.0 + foundNodePolicy :: FoundNodePolicy n na + -- ^ Policy to treat 'FoundNode's (local findings). + -- + -- Default: 'policyOverwrite' + -- + -- @since 0.2.0.0 } -- | The default 'Query'. -defQuery :: Eq n +defQuery :: (Eq n, Show n) => [n] -- ^ 'startsFrom' field. -> Query n na fla fla defQuery ns = Query { startsFrom = ns, - unifyLinkSamples = unifyToOne + unifyLinkSamples = unifyToOne, + timeInterval = Interval.whole, + foundNodePolicy = policyOverwrite } +-- | @s `secUpTo` ts@ returns the time interval of length @s@ (in +-- seconds) and up to @ts@. The interval is inclusive for both ends. +-- +-- @since 0.2.0.0 +secUpTo :: Int64 -> Timestamp -> Interval Timestamp +secUpTo len end = Finite start <=..<= Finite end + where + start = addSec (-len) end + +-- | A 'FoundNode' always overwrites old 'FoundNode's, so only the +-- latest one is valid. +-- +-- This policy is appropriate when you can always get the complete +-- neighbor information of a given node at once. +-- +-- @since 0.2.0.0 +policyOverwrite :: FoundNodePolicy n na +policyOverwrite = PolicyOverwrite + +-- | A 'FoundNode' appends neighbor information to old +-- 'FoundNode's. When the spider makes the snapshot graph, it +-- aggregates all 'FoundNode's in the query range. +-- +-- This policy is appropriate when you can only get part of neighbor +-- information of a given node at once. +-- +-- @since 0.2.0.0 +policyAppend :: FoundNodePolicy n na +policyAppend = PolicyAppend diff --git a/src/NetSpider/Query/Internal.hs b/src/NetSpider/Query/Internal.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Query/Internal.hs @@ -0,0 +1,19 @@ +-- | +-- Module: NetSpider.Query.Internal +-- Description: +-- Maintainer: Toshio Ito +-- +-- +module NetSpider.Query.Internal + ( FoundNodePolicy(..) + ) where + +-- | Policy to treat 'FoundNode's (local findings) when the spider +-- creates the snapshot graph. +-- +-- @since 0.2.0.0 +data FoundNodePolicy n na= + PolicyOverwrite + | PolicyAppend + deriving (Show) + diff --git a/src/NetSpider/Spider.hs b/src/NetSpider/Spider.hs --- a/src/NetSpider/Spider.hs +++ b/src/NetSpider/Spider.hs @@ -21,14 +21,15 @@ ) where import Control.Exception.Safe (throwString) -import Control.Monad (void) +import Control.Monad (void, mapM_, mapM) import Data.Aeson (ToJSON) import Data.Foldable (foldr', toList) -import Data.Hashable (Hashable) +import Data.List (intercalate) import Data.Greskell ( runBinder, ($.), (<$.>), (<*.>), Binder, ToGreskell(GreskellReturn), AsIterator(IteratorItem), FromGraphSON, - liftWalk, gLimit, gIdentity + liftWalk, gLimit, gIdentity, gSelectN, gAs, + lookupAsM, newAsLabel ) import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) @@ -36,8 +37,10 @@ import Data.HashSet (HashSet) import qualified Data.HashSet as HS import Data.IORef (IORef, modifyIORef, newIORef, readIORef, atomicModifyIORef') -import Data.Maybe (catMaybes, mapMaybe) -import Data.Monoid (mempty) +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 import Network.Greskell.WebSocket (Host, Port) @@ -46,15 +49,27 @@ import NetSpider.Graph (EID, LinkAttributes, NodeAttributes) import NetSpider.Graph.Internal (VFoundNode(..), EFinds(..)) import NetSpider.Found (FoundNode(..), FoundLink(..), LinkState(..)) +import NetSpider.Log (runWriterLoggingM, WriterLoggingM, logDebugW, LogLine, spack) import NetSpider.Pair (Pair) import NetSpider.Queue (Queue, newQueue, popQueue, pushQueue) -import NetSpider.Query (Query, defQuery, startsFrom, unifyLinkSamples) +import NetSpider.Query + ( Query, defQuery, startsFrom, unifyLinkSamples, timeInterval, + foundNodePolicy, + Interval + ) +import NetSpider.Query.Internal (FoundNodePolicy(..)) import NetSpider.Snapshot.Internal (SnapshotNode(..), SnapshotLink(..)) -import NetSpider.Spider.Config (Spider(..), Config(..), defConfig) +import NetSpider.Spider.Config (Config(..), defConfig) import NetSpider.Spider.Internal.Graph ( gMakeFoundNode, gAllNodes, gHasNodeID, gHasNodeEID, gNodeEID, gNodeID, gMakeNode, gClearAll, - gLatestFoundNode, gSelectFoundNode, gFinds, gHasFoundNodeEID, gAllFoundNode + gLatestFoundNode, gSelectFoundNode, gFinds, gFindsTarget, gHasFoundNodeEID, gAllFoundNode, + gFilterFoundNodeByTime ) +import NetSpider.Spider.Internal.Log + ( runLogger, logDebug, logWarn, logLine + ) +import NetSpider.Spider.Internal.Spider (Spider(..)) +import NetSpider.Timestamp (Timestamp, showEpochTime) import NetSpider.Unify (LinkSampleUnifier, LinkSample(..), LinkSampleID, linkSampleId) -- | Connect to the WebSocket endpoint of Tinkerpop Gremlin Server @@ -128,7 +143,7 @@ -- -- This function is very simple, and should be used only for small -- graphs. -getSnapshotSimple :: (FromGraphSON n, ToJSON n, Ord n, Hashable n, LinkAttributes fla, NodeAttributes na) +getSnapshotSimple :: (FromGraphSON n, ToJSON n, Ord n, Hashable n, Show n, LinkAttributes fla, NodeAttributes na) => Spider n na fla -> n -- ^ ID of the node where it starts traversing. -> IO ([SnapshotNode n na], [SnapshotLink n fla]) @@ -137,100 +152,131 @@ -- | Get the snapshot graph from the history graph as specified by the -- 'Query'. -getSnapshot :: (FromGraphSON n, ToJSON n, Ord n, Hashable n, LinkAttributes fla, NodeAttributes na) +getSnapshot :: (FromGraphSON n, ToJSON n, Ord n, Hashable n, Show n, LinkAttributes fla, NodeAttributes na) => Spider n na fla -> Query n na fla sla -> IO ([SnapshotNode n na], [SnapshotLink n sla]) getSnapshot spider query = do ref_state <- newIORef $ initSnapshotState $ startsFrom query - recurseVisitNodesForSnapshot spider ref_state - -- print =<< readIORef ref_state - fmap (makeSnapshot $ unifyLinkSamples query) $ readIORef ref_state - + recurseVisitNodesForSnapshot spider query ref_state + (nodes, links, logs) <- fmap (makeSnapshot $ unifyLinkSamples query) $ readIORef ref_state + mapM_ (logLine spider) logs + return (nodes, links) -recurseVisitNodesForSnapshot :: (ToJSON n, Ord n, Hashable n, FromGraphSON n, LinkAttributes fla, NodeAttributes na) +recurseVisitNodesForSnapshot :: (ToJSON n, Ord n, Hashable n, FromGraphSON n, Show n, LinkAttributes fla, NodeAttributes na) => Spider n na fla + -> Query n na fla sla -> IORef (SnapshotState n na fla) -> IO () -recurseVisitNodesForSnapshot spider ref_state = go +recurseVisitNodesForSnapshot spider query ref_state = go where go = do mnext_visit <- getNextVisit case mnext_visit of Nothing -> return () Just next_visit -> do - visitNodeForSnapshot spider ref_state next_visit + visitNodeForSnapshot spider query ref_state next_visit go getNextVisit = atomicModifyIORef' ref_state popUnvisitedNode -- TODO: limit number of steps. -visitNodeForSnapshot :: (ToJSON n, Ord n, Hashable n, FromGraphSON n, LinkAttributes fla, NodeAttributes na) +-- | Returns the result of query: (latest VFoundNode, list of traversed edges) +traverseEFindsOneHop :: (FromGraphSON n, NodeAttributes na, LinkAttributes fla) => Spider n na fla + -> Interval Timestamp + -> EID + -> IO (Maybe (VFoundNode na), [(VFoundNode na, EFinds fla, n)]) +traverseEFindsOneHop spider time_interval visit_eid = (,) <$> getLatestVFoundNode <*> getTraversedEdges + where + foundNodeTraversal = fmap gSelectFoundNode (gFilterFoundNodeByTime time_interval) + <*.> gHasNodeEID visit_eid + <*.> pure gAllNodes + getLatestVFoundNode = fmap vToMaybe $ Gr.slurpResults =<< submitQuery + where + submitQuery = submitB spider binder + binder = gLatestFoundNode <$.> foundNodeTraversal + 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 + lef <- newAsLabel + ln <- newAsLabel + gt <- gSelectN lvfn lef [ln] + <$.> gAs ln <$.> gNodeID spider <$.> gFindsTarget + <$.> gAs lef <$.> gFinds <$.> gAs lvfn <$.> foundNodeTraversal + return (gt, lvfn, lef, ln) + extractFromSMap smap = + (,,) + <$> lookupAsM label_vfn smap + <*> lookupAsM label_ef smap + <*> lookupAsM label_target_nid smap + +makeLinkSample :: n -> VFoundNode na -> EFinds 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 + } + +visitNodeForSnapshot :: (ToJSON n, Ord n, Hashable n, FromGraphSON n, Show n, LinkAttributes fla, NodeAttributes na) + => Spider n na fla + -> Query n na fla sla -> IORef (SnapshotState n na fla) -> n -> IO () -visitNodeForSnapshot spider ref_state visit_nid = do - mnode_eid <- getVisitedNodeEID - case mnode_eid of - Nothing -> return () - Just node_eid -> do - -- TODO: (2018-09-08) Final VFoundNode is the latest of those in - -- the query range. however, there should be an option to - -- traverse ALL "finds" edges in the query range, instead of - -- those with the latest timestamp. To do that, we may have to - -- use .as and .select steps to get "finds" edge and both of its - -- end nodes at once. - mnext_found <- getNextFoundNode node_eid - markAsVisited mnext_found - case mnext_found of - Nothing -> return () - Just next_found -> do - link_samples <- makeLinkSamples spider visit_nid next_found - modifyIORef ref_state $ addLinkSamples $ toList link_samples +visitNodeForSnapshot spider query ref_state visit_nid = do + logDebug spider ("Visiting node " <> spack visit_nid <> " ...") + cur_state <- readIORef ref_state + if isAlreadyVisited cur_state visit_nid + then logAndQuit + else doVisit where - markAsVisited mvfn = modifyIORef ref_state $ addVisitedNode visit_nid mvfn + logAndQuit = do + logDebug spider ("Node " <> spack visit_nid <> " is already visited. Skip.") + return () + doVisit = do + mvisit_eid <- getVisitedNodeEID + case mvisit_eid of + Nothing -> do + logWarn spider ("Node " <> spack visit_nid <> " does not exist.") + return () + Just visit_eid -> do + (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 getVisitedNodeEID = fmap vToMaybe $ Gr.slurpResults =<< submitB spider binder where binder = gNodeEID <$.> gHasNodeID spider visit_nid <*.> pure gAllNodes - getNextFoundNode node_eid = fmap vToMaybe $ Gr.slurpResults =<< submitB spider binder - where - binder = gLatestFoundNode - <$.> gSelectFoundNode gIdentity -- TODO: select FoundNode to consider - <$.> gHasNodeEID node_eid - <*.> pure gAllNodes - -makeLinkSamples :: (FromGraphSON n, LinkAttributes fla) - => Spider n na fla - -> n -- ^ subject node ID. - -> VFoundNode na - -> IO (Vector (LinkSample n fla)) -makeLinkSamples spider subject_nid vneighbors = do - finds_edges <- getFinds $ vfnId vneighbors - traverse toSnapshotLinkEntry finds_edges - where - getFinds neighbors_eid = Gr.slurpResults =<< submitB spider binder - where - binder = gFinds <$.> gHasFoundNodeEID neighbors_eid <*.> pure gAllFoundNode - toSnapshotLinkEntry efinds = do - target_nid <- getNodeID $ efTargetId $ efinds - let lsample = LinkSample { lsSubjectNode = subject_nid, - lsTargetNode = target_nid, - lsLinkState = efLinkState efinds, - lsTimestamp = vfnTimestamp vneighbors, - lsLinkAttributes = efLinkAttributes efinds - } - return lsample - getNodeID node_eid = expectOne =<< tryGetNodeID spider node_eid - -- TODO: Using .as and .select steps, we can get EFinds and its destination vertex simultaneously. - where - expectOne (Just r) = return r - expectOne Nothing = throwString "Expects a Vertex for a NodeID, but nothing found." - -- TODO: better exception spec. - -tryGetNodeID :: FromGraphSON n => Spider n na fla -> EID -> IO (Maybe n) -tryGetNodeID spider node_eid = fmap vToMaybe $ Gr.slurpResults =<< submitB spider binder - where - binder = gNodeID spider <$.> gHasNodeEID node_eid <*.> 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) + ) -- | The state kept while making the snapshot graph. data SnapshotState n na fla = @@ -243,6 +289,19 @@ } deriving (Show) +-- debugShowState :: Show n => SnapshotState n na fla -> String +-- debugShowState state = unvisited ++ visited_nodes ++ visited_links +-- where +-- unvisited = "unvisitedNodes: " +-- ++ (intercalate ", " $ map show $ toList $ ssUnvisitedNodes state) +-- ++ "\n" +-- visited_nodes = "visitedNodes: " +-- ++ (intercalate ", " $ map (uncurry showVisitedNode) $ HM.toList $ ssVisitedNodes state) +-- ++ "\n" +-- showVisitedNode nid mvfn = show nid ++ "(" ++ (show $ fmap vfnTimestamp mvfn ) ++ ")" +-- visited_links = "visitedLinks: " +-- ++ (intercalate ", " $ map show $ HM.keys $ ssVisitedLinks state) + emptySnapshotState :: (Ord n, Hashable n) => SnapshotState n na fla emptySnapshotState = SnapshotState { ssUnvisitedNodes = mempty, @@ -256,6 +315,9 @@ addVisitedNode :: (Eq n, Hashable n) => n -> Maybe (VFoundNode na) -> SnapshotState n na fla -> SnapshotState n na fla addVisitedNode nid mv state = state { ssVisitedNodes = HM.insert nid mv $ ssVisitedNodes state } +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, @@ -265,7 +327,7 @@ link_id = linkSampleId ls updatedLinks = HM.insertWith (++) link_id (return ls) $ ssVisitedLinks state target_nid = lsTargetNode ls - target_already_visited = HM.member target_nid $ ssVisitedNodes state + target_already_visited = isAlreadyVisited state target_nid updatedUnvisited = if target_already_visited then ssUnvisitedNodes state else pushQueue target_nid $ ssUnvisitedNodes state @@ -280,16 +342,18 @@ updated = state { ssUnvisitedNodes = updatedUnvisited } (popped, updatedUnvisited) = popQueue $ ssUnvisitedNodes state -makeSnapshot :: (Eq n, Hashable n) +makeSnapshot :: (Eq n, Hashable n, Show n) => LinkSampleUnifier n na fla sla -> SnapshotState n na fla - -> ([SnapshotNode n na], [SnapshotLink n sla]) -makeSnapshot unifier state = (nodes, links) + -> ([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 = mconcat $ map (makeSnapshotLinks unifier state) $ HM.elems $ ssVisitedLinks state + (links, logs) = runWriterLoggingM $ fmap mconcat + $ mapM (makeSnapshotLinks unifier state) $ HM.elems $ ssVisitedLinks state + makeSnapshotNode :: (Eq n, Hashable n) => SnapshotState n na fla -> n -> SnapshotNode n na makeSnapshotNode state nid = @@ -307,17 +371,24 @@ -- | 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) +makeSnapshotLinks :: (Eq n, Hashable n, Show n) => LinkSampleUnifier n na fla sla -> SnapshotState n na fla -> [LinkSample n fla] - -> [SnapshotLink n sla] -makeSnapshotLinks _ _ [] = [] -makeSnapshotLinks unifier state link_samples@(head_sample : _) = - mapMaybe makeSnapshotLink $ doUnify link_samples + -> WriterLoggingM [SnapshotLink n sla] +makeSnapshotLinks _ _ [] = return [] +makeSnapshotLinks unifier state link_samples@(head_sample : _) = do + unified <- doUnify link_samples + logUnified unified + return $ mapMaybe makeSnapshotLink unified 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 diff --git a/src/NetSpider/Spider/Config.hs b/src/NetSpider/Spider/Config.hs --- a/src/NetSpider/Spider/Config.hs +++ b/src/NetSpider/Spider/Config.hs @@ -4,15 +4,16 @@ -- Description: Configuration of Spider -- Maintainer: Toshio Ito -- --- +-- module NetSpider.Spider.Config - ( Spider(..), - Config(..), + ( Config(..), defConfig, Host, - Port + Port, + LogLevel(..) ) where +import Control.Monad.Logger (LogLevel(..)) import Data.Greskell (Key) import Network.Greskell.WebSocket (Host, Port) @@ -20,24 +21,6 @@ import NetSpider.Graph (VNode) --- | An IO agent of the NetSpider database. --- --- - Type @n@: node ID. Note that type of node ID has nothing to do --- with type of vertex ID used by Gremlin implementation. Node ID --- (in net-spider) is stored as a vertex property. See 'nodeIdKey' --- config field. --- - Type @na@: node attributes. It should implement --- 'NetSpider.Graph.NodeAttributes' class. You can set this to @()@ --- if you don't need node attributes. --- - Type @fla@: attributes of found links. It should implement --- 'NetSpider.Graph.LinkAttributes' class. You can set this to @()@ --- if you don't need link attributes. -data Spider n na fla = - Spider - { spiderConfig :: Config n na fla, - spiderClient :: Gr.Client - } - -- | Configuration to create a 'Spider' object. data Config n na fla = Config @@ -47,9 +30,14 @@ wsPort :: Gr.Port, -- ^ Port of WebSocket endpoint of Tinkerpop Gremlin -- Server. Default: 8182 - nodeIdKey :: Key VNode n + nodeIdKey :: Key VNode n, -- ^ Name of vertex property that stores the node ID. Default: -- \"@node_id\". + logThreshold :: LogLevel + -- ^ Logs with the level higher than or equal to this threshold + -- are printed. Default: 'LevelWarn'. + -- + -- @since 0.2.0.0 } defConfig :: Config n na fla @@ -57,6 +45,8 @@ Config { wsHost = "localhost", wsPort = 8182, - nodeIdKey = "@node_id" + nodeIdKey = "@node_id", + logThreshold = LevelWarn } + diff --git a/src/NetSpider/Spider/Internal/Graph.hs b/src/NetSpider/Spider/Internal/Graph.hs --- a/src/NetSpider/Spider/Internal/Graph.hs +++ b/src/NetSpider/Spider/Internal/Graph.hs @@ -20,8 +20,10 @@ gMakeFoundNode, gSelectFoundNode, gLatestFoundNode, + gFilterFoundNodeByTime, -- * EFinds - gFinds + gFinds, + gFindsTarget ) where import Control.Category ((<<<)) @@ -32,13 +34,16 @@ ( WalkType, AEdge, GTraversal, Filter, Transform, SideEffect, Walk, liftWalk, Binder, newBind, - source, sV, sV', sAddV, gHasLabel, gHasId, gHas2, gId, gProperty, gPropertyV, gV, - gAddE, gSideEffect, gTo, gFrom, gDrop, gOut, gOrder, gBy2, gValues, gOutE, + source, sV, sV', sAddV, gHasLabel, gHasId, gHas2, gHas2P, gId, gProperty, gPropertyV, gV, + gNot, gIdentity', + gAddE, gSideEffect, gTo, gFrom, gDrop, gOut, gOrder, gBy2, gValues, gOutE, gInV, ($.), (<*.>), (=:), ToGTraversal, - Key, oDecr, gLimit + Key, oDecr, gLimit, + pGt, pGte, pLt, pLte ) import Data.Int (Int64) +import Data.Interval (lowerBound', upperBound') import Data.Text (Text, pack) import Data.Time.LocalTime (TimeZone(..)) import Data.Traversable (traverse) @@ -48,8 +53,10 @@ LinkAttributes(..), NodeAttributes(..) ) import NetSpider.Found (FoundLink(..), LinkState(..), FoundNode(..), linkStateToText) -import NetSpider.Timestamp (Timestamp(..), fromEpochSecond) -import NetSpider.Spider.Config (Spider(..), Config(..)) +import NetSpider.Query (Interval, Extended(..)) +import NetSpider.Timestamp (Timestamp(..)) +import NetSpider.Spider.Config (Config(..)) +import NetSpider.Spider.Internal.Spider (Spider(..)) spiderNodeIdKey :: Spider n na fla -> Key VNode n spiderNodeIdKey = nodeIdKey . spiderConfig @@ -150,8 +157,25 @@ gLatestFoundNode :: Walk Transform (VFoundNode na) (VFoundNode na) gLatestFoundNode = gLimit 1 <<< gOrder [gBy2 keyTimestamp oDecr] +gFilterFoundNodeByTime :: Interval Timestamp -> Binder (Walk Filter (VFoundNode na) (VFoundNode na)) +gFilterFoundNodeByTime interval = do + fl <- filterLower + fh <- filterUpper + return (fh <<< fl) + where + filterLower = case lowerBound' interval of + (PosInf, _) -> return $ gNot gIdentity' + (NegInf, _) -> return $ gIdentity' + (Finite ts, False) -> fmap (gHas2P keyTimestamp) $ fmap pGt $ newBind $ epochTime ts + (Finite ts, True) -> fmap (gHas2P keyTimestamp) $ fmap pGte $ newBind $ epochTime ts + filterUpper = case upperBound' interval of + (PosInf, _) -> return $ gIdentity' + (NegInf, _) -> return $ gNot gIdentity' + (Finite ts, False) -> fmap (gHas2P keyTimestamp) $ fmap pLt $ newBind $ epochTime ts + (Finite ts, True) -> fmap (gHas2P keyTimestamp) $ fmap pLte $ newBind $ epochTime ts + gFinds :: Walk Transform (VFoundNode na) (EFinds la) gFinds = gOutE ["finds"] - - +gFindsTarget :: Walk Transform (EFinds la) VNode +gFindsTarget = gInV diff --git a/src/NetSpider/Spider/Internal/Log.hs b/src/NetSpider/Spider/Internal/Log.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Spider/Internal/Log.hs @@ -0,0 +1,36 @@ +-- | +-- Module: NetSpider.Spider.Internal.Log +-- Description: Logging functions related to Spider +-- Maintainer: Toshio Ito +-- +-- __this module is internal. End-users should not use it.__ +module NetSpider.Spider.Internal.Log + ( runLogger, + logLine, + logDebug, + logWarn + ) where + +import Control.Monad.Logger (LogLevel, LoggingT) +import qualified Control.Monad.Logger as Log +import Data.Functor.Identity (Identity, runIdentity) +import Data.Text (Text) + +import NetSpider.Log (LogLine) +import NetSpider.Spider.Internal.Spider (Spider(..)) +import NetSpider.Spider.Config (Config(..)) + +runLogger :: Spider n na fla -> LoggingT IO a -> IO a +runLogger spider act = Log.runStderrLoggingT $ Log.filterLogger fil act + where + fil _ level = level >= (logThreshold $ spiderConfig spider) + +logLine :: Spider n na fla -> LogLine -> IO () +logLine spider (loc, src, level, msg) = runLogger spider $ Log.monadLoggerLog loc src level msg + +logDebug :: Spider n na fla -> Text -> IO () +logDebug spider msg = runLogger spider $ Log.logDebugN msg + +logWarn :: Spider n na fla -> Text -> IO () +logWarn spider msg = runLogger spider $ Log.logWarnN msg + diff --git a/src/NetSpider/Spider/Internal/Spider.hs b/src/NetSpider/Spider/Internal/Spider.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Spider/Internal/Spider.hs @@ -0,0 +1,32 @@ +-- | +-- Module: NetSpider.Spider.Internal.Spider +-- Description: Spider type and its internal +-- Maintainer: Toshio Ito +-- +-- __this module is internal. End-users should not use it.__ +module NetSpider.Spider.Internal.Spider + ( Spider(..) + ) where + +import qualified Network.Greskell.WebSocket as Gr + +import NetSpider.Spider.Config (Config) + +-- | An IO agent of the NetSpider database. +-- +-- - Type @n@: node ID. Note that type of node ID has nothing to do +-- with type of vertex ID used by Gremlin implementation. Node ID +-- (in net-spider) is stored as a vertex property. See 'nodeIdKey' +-- config field. +-- - Type @na@: node attributes. It should implement +-- 'NetSpider.Graph.NodeAttributes' class. You can set this to @()@ +-- if you don't need node attributes. +-- - Type @fla@: attributes of found links. It should implement +-- 'NetSpider.Graph.LinkAttributes' class. You can set this to @()@ +-- if you don't need link attributes. +data Spider n na fla = + Spider + { spiderConfig :: Config n na fla, + spiderClient :: Gr.Client + } + diff --git a/src/NetSpider/Timestamp.hs b/src/NetSpider/Timestamp.hs --- a/src/NetSpider/Timestamp.hs +++ b/src/NetSpider/Timestamp.hs @@ -5,17 +5,45 @@ -- -- module NetSpider.Timestamp - ( Timestamp(..), - fromEpochSecond + ( -- * The type + Timestamp(..), + -- * Construction + fromEpochMillisecond, + now, + -- * Manipulation + addSec, + -- * Conversion + parseTimestamp, + fromS, + fromZonedTime, + fromUTCTime, + fromSystemTime, + fromLocalTime, + showEpochTime ) where +import Control.Applicative ((<$>), (<*>), (<*), (*>), optional) +import Data.Char (isDigit) import Data.Int (Int64) -import Data.Time.LocalTime (TimeZone) +import Data.List (sortOn) +import Data.Text (Text, pack) +import Data.Time.Calendar (Day, fromGregorian) +import Data.Time.LocalTime + ( TimeZone(..), getZonedTime, ZonedTime(..), zonedTimeToUTC, LocalTime(LocalTime), localTimeToUTC, + TimeOfDay(TimeOfDay) + ) +import qualified Data.Time.LocalTime as LocalTime +import Data.Time.Clock (UTCTime) +import Data.Time.Clock.System (utcToSystemTime, SystemTime(..)) +import qualified Text.ParserCombinators.ReadP as P +import Text.Read (readEither) -- | Timestamp when graph elements are observed. data Timestamp = Timestamp { epochTime :: !Int64, + -- ^ Milliseconds since the epoch. The epoch is usually the + -- beginning of year 1970. timeZone :: !(Maybe TimeZone) } deriving (Show,Eq) @@ -24,7 +52,157 @@ instance Ord Timestamp where compare l r = compare (epochTime l) (epochTime r) --- | Make 'Timestamp' from seconds from the epoch. 'timeZone' is +-- | Make 'Timestamp' from milliseconds from the epoch. 'timeZone' is -- 'Nothing'. -fromEpochSecond :: Int64 -> Timestamp -fromEpochSecond sec = Timestamp sec Nothing +-- +-- @since 0.2.0.0 +fromEpochMillisecond :: Int64 -> Timestamp +fromEpochMillisecond msec = Timestamp msec Nothing + +-- | Show 'epochTime' of 'Timestamp' as 'Text'. +-- +-- @since 0.2.0.0 +showEpochTime :: Timestamp -> Text +showEpochTime = pack . show . epochTime + +-- | Get the current system time. +-- +-- @since 0.2.0.0 +now :: IO Timestamp +now = fmap fromZonedTime $ getZonedTime + +-- | @since 0.2.0.0 +fromZonedTime :: ZonedTime -> Timestamp +fromZonedTime zt = + (fromUTCTime $ zonedTimeToUTC zt) { timeZone = Just $ zonedTimeZone zt } + +-- | @since 0.2.0.0 +fromUTCTime :: UTCTime -> Timestamp +fromUTCTime ut = (fromSystemTime $ utcToSystemTime ut) { timeZone = Just LocalTime.utc } + +-- | @since 0.2.0.0 +fromSystemTime :: SystemTime -> Timestamp +fromSystemTime stime = Timestamp { epochTime = epoch_time, + timeZone = Nothing + } + where + epoch_time = (systemSeconds stime * 1000) + + fromIntegral (systemNanoseconds stime `div` 1000000) + +-- | Covert 'LocalTime' to 'Timestamp' assuming it's in UTC time +-- zone. The 'timeZone' field is 'Nothing'. +-- +-- @since 0.2.0.0 +fromLocalTime :: LocalTime -> Timestamp +fromLocalTime lt = (fromUTCTime $ localTimeToUTC LocalTime.utc lt) { timeZone = Nothing } + +-- | Add time difference (in seconds) to the 'Timestamp'. +-- +-- @since 0.2.0.0 +addSec :: Int64 -> Timestamp -> Timestamp +addSec diff ts = ts { epochTime = (+ (diff * 1000)) $ epochTime ts } + +-- | Unsafe version of 'parseTimestamp'. +-- +-- @since 0.2.0.0 +fromS :: String -> Timestamp +fromS s = maybe (error msg) id $ parseTimestamp s + where + msg = "Fail to parse " ++ s + +-- | Parse a string into 'Timestamp'. The format is like ISO8601 with +-- a little relaxation. +-- +-- >>> let timeAndOffset ts = (epochTime ts, fmap timeZoneMinutes $ timeZone ts) +-- >>> fmap timeAndOffset $ parseTimestamp "2018-10-11T11:20:10" +-- Just (1539256810000,Nothing) +-- >>> fmap timeAndOffset $ parseTimestamp "2018-10-11 11:20:10" +-- Just (1539256810000,Nothing) +-- >>> fmap timeAndOffset $ parseTimestamp "2015-03-23 03:33Z" +-- Just (1427081580000,Just 0) +-- >>> fmap timeAndOffset $ parseTimestamp "1999-01-05 20:34:44.211+09:00" +-- Just (915536084211,Just 540) +-- >>> fmap timeAndOffset $ parseTimestamp "2007/08/20T22:25-07:00" +-- Just (1187673900000,Just (-420)) +-- +-- @since 0.2.0.0 +parseTimestamp :: String -> Maybe Timestamp +parseTimestamp s = toTs $ sortByLeftover $ P.readP_to_S parserTimestamp s + where + sortByLeftover = sortOn $ \(_, leftover) -> length leftover + toTs ((ret, _) : _) = Just ret + toTs [] = Nothing + +parserTimestamp :: P.ReadP Timestamp +parserTimestamp = do + day <- parserDay <* delim + time <- parserTime + mtz <- optional (parserUTC P.+++ parserOffset) + let ltime = LocalTime day time + case mtz of + Nothing -> return $ fromLocalTime ltime + Just tz -> return $ fromZonedTime $ ZonedTime ltime tz + where + delim = P.choice $ map P.char " T" + +parserRead :: Read a => String -> P.ReadP a +parserRead input = either fail return $ readEither input + +parserDec :: Read a => P.ReadP a +parserDec = parserRead =<< P.munch1 isDigit + +parserFracDec :: Read a => P.ReadP a +parserFracDec = do + int <- P.munch1 isDigit + frac <- fmap (maybe "" id) $ optional ((:) <$> P.char '.' <*> P.munch1 isDigit) + return $ read (int ++ frac) + +parserDay :: P.ReadP Day +parserDay = fromGregorian + <$> (parserDec <* delim) + <*> (parserDec <* delim) + <*> parserDec + where + delim = P.choice $ map P.char "-/" + +parserTime :: P.ReadP TimeOfDay +parserTime = TimeOfDay + <$> parserDec + <*> (delim *> parserDec) + <*> ((delim *> parserFracDec) P.<++ pure 0) + where + delim = P.char ':' + + +parserUTC :: P.ReadP TimeZone +parserUTC = do + s <- P.get + case s of + 'Z' -> return LocalTime.utc + c -> fail ("Not a UTC symbol: " ++ show c) + +data OffsetSign = OffsetPlus + | OffsetMinus + deriving (Show,Eq,Ord,Enum,Bounded) + +parserOffset :: P.ReadP TimeZone +parserOffset = offsetToTz <$> osign <*> (parserDec <* delim) <*> parserDec + where + osign = do + s <- P.get + case s of + '+' -> return OffsetPlus + '-' -> return OffsetMinus + c -> fail ("Not a sign symbol: " ++ show c) + delim = optional $ P.char ':' + +offsetToTz :: OffsetSign -> Int -> Int -> TimeZone +offsetToTz osign h m = TimeZone { timeZoneMinutes = intsign * (h * 60 + m), + timeZoneSummerOnly = False, + timeZoneName = "" + } + where + intsign = case osign of + OffsetPlus -> 1 + OffsetMinus -> -1 + diff --git a/src/NetSpider/Unify.hs b/src/NetSpider/Unify.hs --- a/src/NetSpider/Unify.hs +++ b/src/NetSpider/Unify.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} -- | -- Module: NetSpider.Unify -- Description: LinkSampleUnifier type @@ -21,13 +22,16 @@ defNegatesLinkSample ) where +import Control.Monad (mapM) import Data.Foldable (maximumBy) import Data.Function (on) import Data.Hashable (Hashable(hashWithSalt)) -import Data.Maybe (mapMaybe) +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) import GHC.Exts (groupWith) import NetSpider.Found (FoundLink, LinkState) +import NetSpider.Log (WriterLoggingM, logDebugW, spack) import NetSpider.Pair (Pair(..)) import NetSpider.Snapshot (SnapshotNode, nodeTimestamp, nodeId, SnapshotLink) import NetSpider.Timestamp (Timestamp) @@ -86,18 +90,18 @@ -- obtained from both of the end nodes to make the link attributes -- of 'SnapshotLink'. This function is supposed to convert the link -- attribute type. -type LinkSampleUnifier n na fla sla = SnapshotNode n na -> SnapshotNode n na -> [LinkSample n fla] -> [LinkSample n sla] +type LinkSampleUnifier n na fla sla = SnapshotNode n na -> SnapshotNode n na -> [LinkSample n fla] -> WriterLoggingM [LinkSample n sla] -- | Unify 'LinkSample's to one. This is the sensible unifier if there -- is at most one physical link for a given pair of nodes. -unifyToOne :: Eq n => LinkSampleUnifier n na la la +unifyToOne :: (Eq n, Show n) => LinkSampleUnifier n na la la unifyToOne = unifyStd defUnifyStdConfig -- | Unify 'LinkSample's to possibly multiple samples. The input -- samples are partitioned to groups based on the link sub-ID, defined -- by the given getter function. Each group represents one of the -- final samples. -unifyToMany :: (Eq n, Ord lsid) +unifyToMany :: (Eq n, Show n, Ord lsid) => (LinkSample n fla -> lsid) -- ^ Getter of the link sub-ID -> LinkSampleUnifier n na fla fla unifyToMany getKey = unifyStd conf @@ -147,16 +151,31 @@ -- 3. After merge, the link is checked against its end nodes. If -- 'negatesLinkSample' returns 'True' for either of the end nodes, -- the link is removed from the final result. -unifyStd :: (Eq n, Ord lsid) => UnifyStdConfig n na fla sla lsid -> LinkSampleUnifier n na fla sla -unifyStd conf lnode rnode = mapMaybe forGroup . groupWith (makeLinkSubId conf) +unifyStd :: (Eq n, Show n, Ord lsid) => UnifyStdConfig n na fla sla lsid -> LinkSampleUnifier n na fla sla +unifyStd conf lnode rnode input_samples = do + let groups = groupWith (makeLinkSubId conf) input_samples + logDebug ( "Group " <> (spack $ length input_samples) <> " samples into " + <> (spack $ length groups) <> " groups by link sub-ID." + ) + fmap catMaybes $ mapM forGroup $ zip groups ([0 ..] :: [Int]) where - forGroup samples = maybeNegates rnode - =<< maybeNegates lnode - =<< mergeSamples conf (samplesFor samples lnode) (samplesFor samples rnode) + logDebug msg = logDebugW ("unifyStd: " <> msg) samplesFor samples sn = filter (\s -> nodeId sn == (lsSubjectNode s)) samples - maybeNegates sn sample = if negatesLinkSample conf sn sample - then Nothing - else Just sample + forGroup (samples, group_i) = + case mergeSamples conf (samplesFor samples lnode) (samplesFor samples rnode) of + Nothing -> do + logDebugG ("No link after mergeSamples") + return Nothing + ml -> maybeNegates rnode =<< maybeNegates lnode ml + where + logDebugG msg = logDebug ("group " <> spack group_i <> ": " <> msg) + maybeNegates _ Nothing = return Nothing + maybeNegates sn (Just sample) = + if negatesLinkSample conf sn sample + then do + logDebugG ("Merged sample is negated by node " <> (spack $ nodeId sn)) + return Nothing + else return $ Just sample -- | Get the 'LinkSample' that has the latest (biggest) timestamp. latestLinkSample :: [LinkSample n la] -> Maybe (LinkSample n la) diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF doctest-discover #-} diff --git a/test/ServerTest/Attributes.hs b/test/ServerTest/Attributes.hs --- a/test/ServerTest/Attributes.hs +++ b/test/ServerTest/Attributes.hs @@ -25,7 +25,7 @@ import NetSpider.Spider.Config (Host, Port, Config(..), defConfig) import NetSpider.Snapshot (nodeTimestamp, linkTimestamp) import qualified NetSpider.Snapshot as S (nodeAttributes, linkAttributes) -import NetSpider.Timestamp (Timestamp(..), fromEpochSecond) +import NetSpider.Timestamp (Timestamp(..), fromS) main :: IO () main = hspec spec @@ -42,7 +42,7 @@ typeTestCase test_label conf n1_id n2_id node_attrs link_attrs = specify test_label $ withSpider' conf $ \spider -> do let n1 = FoundNode { subjectNode = n1_id, - foundAt = fromEpochSecond 128, + foundAt = fromS "2018-10-11T11:00:00", neighborLinks = return link1, nodeAttributes = node_attrs } diff --git a/test/ServerTest/Common.hs b/test/ServerTest/Common.hs --- a/test/ServerTest/Common.hs +++ b/test/ServerTest/Common.hs @@ -26,10 +26,10 @@ import NetSpider.Graph (NodeAttributes(..), LinkAttributes(..), VNode) import NetSpider.Pair (Pair(..)) import NetSpider.Spider.Config - ( Host, Port, Spider, Config(..), defConfig + ( Host, Port, Config(..), defConfig, LogLevel(..) ) import NetSpider.Spider - ( connectWith, close, clearAll + ( connectWith, close, clearAll, Spider ) import NetSpider.Snapshot ( SnapshotNode, SnapshotLink @@ -42,7 +42,7 @@ withServer = before $ needEnvHostPort Need "NET_SPIDER_TEST" withSpider :: Eq n => (Spider n na fla -> IO ()) -> (Host, Port) -> IO () -withSpider = withSpider' defConfig +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 diff --git a/test/ServerTest/Snapshot.hs b/test/ServerTest/Snapshot.hs --- a/test/ServerTest/Snapshot.hs +++ b/test/ServerTest/Snapshot.hs @@ -6,6 +6,7 @@ import Data.Aeson (Value(..)) import qualified Data.HashMap.Strict as HM import Data.List (sortOn, sort) +import Data.Maybe (isNothing) import Data.Monoid ((<>), mempty) import Data.Text (Text, unpack, pack) import qualified Data.Text.IO as TIO @@ -25,7 +26,10 @@ import NetSpider.Found ( FoundLink(..), LinkState(..), FoundNode(..) ) -import NetSpider.Query (Query, defQuery, startsFrom, unifyLinkSamples) +import NetSpider.Query + ( Query, defQuery, startsFrom, unifyLinkSamples, timeInterval, foundNodePolicy, + Extended(..), (<..<), (<..<=), (<=..<=), policyOverwrite, policyAppend + ) import NetSpider.Snapshot ( SnapshotLink, nodeId, linkNodeTuple, isDirected, linkTimestamp, @@ -36,8 +40,12 @@ ( Spider, addFoundNode, getSnapshotSimple, getSnapshot ) import NetSpider.Spider.Config (defConfig, Config, Host, Port) -import NetSpider.Unify (unifyStd, UnifyStdConfig(..), defUnifyStdConfig, lsLinkAttributes, latestLinkSample) -import NetSpider.Timestamp (fromEpochSecond) +import NetSpider.Unify + ( unifyStd, UnifyStdConfig(..), defUnifyStdConfig, + lsLinkAttributes, lsSubjectNode, + latestLinkSample + ) +import NetSpider.Timestamp (fromS, fromEpochMillisecond) main :: IO () main = hspec spec @@ -53,7 +61,7 @@ linkAttributes = () } nbs = FoundNode { subjectNode = "n1", - foundAt = fromEpochSecond 100, + foundAt = fromS "2018-12-01T10:00", neighborLinks = return link, nodeAttributes = () } @@ -76,6 +84,8 @@ spec_getSnapshot = withServer $ describe "getSnapshotSimple, getSnapshot" $ do spec_getSnapshot1 spec_getSnapshot2 + spec_getSnapshot_timeInterval + spec_getSnapshot_foundNodePolicy spec_getSnapshot1 :: SpecWith (Host,Port) @@ -88,7 +98,7 @@ _ -> error ("Unexpected result: got = " ++ show (got_ns, got_ls)) nodeId got_n1 `shouldBe` "n1" isOnBoundary got_n1 `shouldBe` False - nodeTimestamp got_n1 `shouldBe` Just (fromEpochSecond 100) + 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 @@ -96,12 +106,12 @@ 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` fromEpochSecond 100 + 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 = fromEpochSecond 200, + foundAt = fromS "2018-12-01T20:00", neighborLinks = mempty, nodeAttributes = () } @@ -112,7 +122,7 @@ _ -> error ("Unexpected result: got = " ++ show (got_ns, got_ls)) nodeId got_n1 `shouldBe` "n1" isOnBoundary got_n1 `shouldBe` False - nodeTimestamp got_n1 `shouldBe` Just (fromEpochSecond 200) + 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 @@ -130,12 +140,12 @@ linkAttributes = () } nbs1 = FoundNode { subjectNode = "n1", - foundAt = fromEpochSecond 100, + foundAt = fromS "2018-12-01T10:00", neighborLinks = return link_12, nodeAttributes = () } nbs2 = FoundNode { subjectNode = "n2", - foundAt = fromEpochSecond 200, + foundAt = fromS "2018-12-01T20:00", neighborLinks = return link_21, nodeAttributes = () } @@ -146,21 +156,21 @@ _ -> error ("Unexpected result: got = " ++ show (got_ns, got_ls)) nodeId got_n1 `shouldBe` "n1" isOnBoundary got_n1 `shouldBe` False - nodeTimestamp got_n1 `shouldBe` Just (fromEpochSecond 100) + 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 (fromEpochSecond 200) + 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` fromEpochSecond 200 + 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 = fromEpochSecond 200, + foundAt = fromS "2018-12-01T20:00", neighborLinks = [ FoundLink { targetNode = "n2", linkState = LinkToTarget, @@ -172,23 +182,23 @@ linkAttributes = () } ], - nodeAttributes = AText "at 200" + nodeAttributes = AText "at 20:00" }, FoundNode { subjectNode = "n1", - foundAt = fromEpochSecond 100, + foundAt = fromS "2018-12-01T10:00", neighborLinks = mempty, - nodeAttributes = AText "at 100" + nodeAttributes = AText "at 10:00" }, FoundNode { subjectNode = "n1", - foundAt = fromEpochSecond 150, + foundAt = fromS "2018-12-01T15:00", neighborLinks = return $ FoundLink { targetNode = "n2", linkState = LinkToTarget, linkAttributes = () }, - nodeAttributes = AText "at 150" + nodeAttributes = AText "at 15:00" } ] mapM_ (addFoundNode spider) fns @@ -198,8 +208,8 @@ _ -> error ("Unexpected patter: got = " ++ show (got_ns, got_ls)) nodeId got_n1 `shouldBe` "n1" isOnBoundary got_n1 `shouldBe` False - nodeTimestamp got_n1 `shouldBe` Just (fromEpochSecond 200) - S.nodeAttributes got_n1 `shouldBe` Just (AText "at 200") + 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 @@ -210,15 +220,15 @@ S.nodeAttributes got_n3 `shouldBe` Nothing linkNodeTuple got_l12 `shouldBe` ("n1", "n2") isDirected got_l12 `shouldBe` True - linkTimestamp got_l12 `shouldBe` fromEpochSecond 200 + linkTimestamp got_l12 `shouldBe` fromS "2018-12-01T20:00" linkNodeTuple got_l31 `shouldBe` ("n3", "n1") isDirected got_l31 `shouldBe` True - linkTimestamp got_l31 `shouldBe` fromEpochSecond 200 + 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 = fromEpochSecond 100, + foundAt = fromS "2018-12-01T10:00", neighborLinks = return $ FoundLink { targetNode = intToNodeId 2, linkState = LinkToTarget, @@ -226,12 +236,12 @@ }, nodeAttributes = () }, - middleNode 2 $ fromEpochSecond 50, - middleNode 3 $ fromEpochSecond 150, - middleNode 4 $ fromEpochSecond 200, + 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 = fromEpochSecond 150, + foundAt = fromS "2018-12-01T15:00", neighborLinks = return $ FoundLink { targetNode = intToNodeId 4, linkState = LinkToSubject, @@ -265,40 +275,40 @@ (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 (fromEpochSecond 100) + 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 (fromEpochSecond 50) + 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 (fromEpochSecond 150) + 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 (fromEpochSecond 200) + 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 (fromEpochSecond 150) + 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` fromEpochSecond 100 + 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` fromEpochSecond 150 + 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` fromEpochSecond 200 + 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` fromEpochSecond 200 + 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 @@ -308,7 +318,7 @@ let fns :: [FoundNode Text () ()] fns = [ FoundNode { subjectNode = "n1", - foundAt = fromEpochSecond 100, + foundAt = fromS "2018-12-01T10:00", neighborLinks = [ FoundLink { targetNode = "n2", linkState = LinkToTarget, @@ -319,7 +329,7 @@ }, FoundNode { subjectNode = "n2", - foundAt = fromEpochSecond 150, + foundAt = fromS "2018-12-01T15:00", neighborLinks = [ FoundLink { targetNode = "n1", linkState = LinkToSubject, @@ -335,7 +345,7 @@ }, FoundNode { subjectNode = "n3", - foundAt = fromEpochSecond 100, + foundAt = fromS "2018-12-01T10:00", neighborLinks = [ FoundLink { targetNode = "n1", linkState = LinkToTarget, @@ -354,28 +364,28 @@ (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 (fromEpochSecond 100) + 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 (fromEpochSecond 150) + 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 (fromEpochSecond 100) + 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` fromEpochSecond 150 + 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` fromEpochSecond 150 + 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` fromEpochSecond 100 + 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 = fromEpochSecond 200, + foundAt = fromS "2018-12-01T20:00", nodeAttributes = (), neighborLinks = [ FoundLink { targetNode = "n2", @@ -396,7 +406,7 @@ }, FoundNode { subjectNode = "n2", - foundAt = fromEpochSecond 100, + foundAt = fromS "2018-12-01T10:00", nodeAttributes = (), neighborLinks = [ FoundLink { targetNode = "n1", @@ -424,19 +434,19 @@ 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` fromEpochSecond 200 + 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` fromEpochSecond 200 + 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` fromEpochSecond 200 + 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 = fromEpochSecond 100, + foundAt = fromS "2018-12-01T10:00", nodeAttributes = (), neighborLinks = [ FoundLink { targetNode = "n2", @@ -447,7 +457,7 @@ }, FoundNode { subjectNode = "n2", - foundAt = fromEpochSecond 200, + foundAt = fromS "2018-12-01T20:00", nodeAttributes = (), neighborLinks = [] } @@ -464,7 +474,7 @@ let fns :: [FoundNode Text () ()] fns = [ FoundNode { subjectNode = "n1", - foundAt = fromEpochSecond 200, + foundAt = fromS "2018-12-01T20:00", nodeAttributes = (), neighborLinks = [ FoundLink { targetNode = "n2", @@ -475,7 +485,7 @@ }, FoundNode { subjectNode = "n2", - foundAt = fromEpochSecond 100, + foundAt = fromS "2018-12-01T10:00", nodeAttributes = (), neighborLinks = [] } @@ -487,7 +497,7 @@ V.length got_ns `shouldBe` 2 linkNodeTuple (got_ls ! 0) `shouldBe` ("n1", "n2") isDirected (got_ls ! 0) `shouldBe` False - linkTimestamp (got_ls ! 0) `shouldBe` fromEpochSecond 200 + 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 @@ -496,13 +506,13 @@ let fns :: [FoundNode Text () APorts] fns = [ FoundNode { subjectNode = "n2", - foundAt = fromEpochSecond 200, + foundAt = fromS "2018-12-01T20:00", nodeAttributes = (), neighborLinks = links2 }, FoundNode { subjectNode = "n1", - foundAt = fromEpochSecond 100, + foundAt = fromS "2018-12-01T10:00", nodeAttributes = (), neighborLinks = links1 } @@ -532,17 +542,17 @@ 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 $ fromEpochSecond 100) + nodeTimestamp (got_ns ! 0) `shouldBe` (Just $ fromS "2018-12-01T10:00") nodeId (got_ns ! 1) `shouldBe` "n2" - nodeTimestamp (got_ns ! 1) `shouldBe` (Just $ fromEpochSecond 200) + 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` fromEpochSecond 200 + 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` fromEpochSecond 200 + linkTimestamp (got_ls ! 1) `shouldBe` fromS "2018-12-01T20:00" V.length got_ls `shouldBe` 2 @@ -571,3 +581,176 @@ 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) + +spec_getSnapshot_timeInterval :: SpecWith (Host,Port) +spec_getSnapshot_timeInterval = do + let linkTo n = FoundLink + { targetNode = n, + linkState = LinkToTarget, + linkAttributes = () + } + linksTo ns = map linkTo ns + node n t ls = FoundNode + { subjectNode = n, + foundAt = fromS ("2018-12-01T01:" <> t), + neighborLinks = ls, + nodeAttributes = () + } + input_fns :: [FoundNode Text () ()] + input_fns = [ node "n1" "10" $ linksTo ["n2"], + node "n1" "20" $ linksTo ["n2", "n3"], + node "n1" "30" $ linksTo [], + node "n1" "40" $ linksTo ["n3"], + node "n2" "15" $ linksTo [], + node "n2" "25" $ linksTo ["n4"], + node "n2" "35" $ linksTo ["n4", "n3", "n5"], + node "n3" "10" $ linksTo ["n4", "n2"], + node "n3" "30" $ linksTo ["n4"], + node "n4" "05" $ linksTo [], + node "n4" "15" $ linksTo ["n1"], + node "n4" "25" $ linksTo ["n1", "n5"], + node "n4" "35" $ linksTo [] + ] + simple_unifier = unifyStd $ defUnifyStdConfig { negatesLinkSample = \_ _ -> False } + -- Disable negation to simplify the test. + specify "only lower bound" $ withSpider $ \spider -> do + mapM_ (addFoundNode spider) input_fns + let q = (defQuery ["n1", "n2"]) { unifyLinkSamples = simple_unifier, + timeInterval = (Finite $ fromS "2018-12-01T01:30") <..< PosInf + } + (got_nodes, got_edges) <- fmap sort2 $ getSnapshot spider q + map nodeId got_nodes `shouldBe` ["n1", "n2", "n3", "n4", "n5"] + map (isNothing . S.nodeAttributes) got_nodes `shouldBe` [False, False, True, False, True] + map linkNodeTuple got_edges `shouldBe` + [ ("n1", "n3"), + ("n2", "n3"), + ("n2", "n4"), + ("n2", "n5") + ] + map linkTimestamp got_edges `shouldBe` + map (\m -> fromS ("2018-12-01T01:" <> m)) ["40", "35", "35", "35"] + specify "only upper bound (exclusive)" $ withSpider $ \spider -> do + mapM_ (addFoundNode spider) input_fns + let q = (defQuery ["n1"]) { unifyLinkSamples = simple_unifier, + timeInterval = NegInf + <..< (Finite $ fromS "2018-12-01T01:30") + } + (got_nodes, got_edges) <- fmap sort2 $ getSnapshot spider q + map nodeId got_nodes `shouldBe` ["n1", "n2", "n3", "n4", "n5"] + map (isNothing . S.nodeAttributes) got_nodes `shouldBe` [False, False, False, False, True] + map linkNodeTuple got_edges `shouldBe` + [ ("n1", "n2"), + ("n1", "n3"), + ("n2", "n4"), + ("n3", "n2"), + ("n3", "n4"), + ("n4", "n1"), + ("n4", "n5") + ] + map linkTimestamp got_edges `shouldBe` + map (\m -> fromS ("2018-12-01T01:" <> m)) ["20", "20", "25", "10", "10", "25", "25"] + specify "only upper bound (inclusive)" $ withSpider $ \spider -> do + mapM_ (addFoundNode spider) input_fns + let q = (defQuery ["n3"]) { unifyLinkSamples = simple_unifier, + timeInterval = NegInf + <..<= (Finite $ fromS "2018-12-01T01:30") + } + (got_nodes, got_edges) <- fmap sort2 $ getSnapshot spider q + map nodeId got_nodes `shouldBe` ["n1", "n3", "n4", "n5"] + map (isNothing . S.nodeAttributes) got_nodes `shouldBe` [False, False, False, True] + map linkNodeTuple got_edges `shouldBe` + [ ("n3", "n4"), + ("n4", "n1"), + ("n4", "n5") + ] + map linkTimestamp got_edges `shouldBe` + map (\m -> fromS ("2018-12-01T01:" <> m)) ["30", "25", "25"] + specify "both bounded" $ withSpider $ \spider -> do + mapM_ (addFoundNode spider) input_fns + let q = (defQuery ["n2"]) { unifyLinkSamples = simple_unifier, + timeInterval = (Finite $ fromS "2018-12-01T01:20") + <..<= (Finite $ fromS "2018-12-01T01:25") + } + (got_nodes, got_edges) <- fmap sort2 $ getSnapshot spider q + map nodeId got_nodes `shouldBe` ["n1", "n2", "n4", "n5"] + map (isNothing . S.nodeAttributes) got_nodes `shouldBe` [True, False, False, True] + map linkNodeTuple got_edges `shouldBe` + [ ("n2", "n4"), + ("n4", "n1"), + ("n4", "n5") + ] + map linkTimestamp got_edges `shouldBe` + map (\m -> fromS ("2018-12-01T01:" <> m)) ["25", "25", "25"] + +spec_getSnapshot_foundNodePolicy :: SpecWith (Host,Port) +spec_getSnapshot_foundNodePolicy = do + let linkTo n = FoundLink + { targetNode = n, + linkState = LinkToTarget, + linkAttributes = () + } + linksTo = map linkTo + node n t ls = FoundNode + { subjectNode = n, + foundAt = fromEpochMillisecond t, + neighborLinks = ls, + nodeAttributes = () + } + input_fns :: [FoundNode Text () ()] + input_fns = [ node "n1" 10 $ linksTo ["n2"], + node "n1" 20 $ linksTo ["n3"], + node "n1" 30 $ linksTo ["n2"], + node "n2" 15 $ linksTo ["n1"], + node "n2" 25 $ linksTo ["n4"], + node "n2" 35 $ linksTo ["n4", "n1"], + node "n3" 17 $ linksTo [], + node "n3" 27 $ linksTo ["n1", "n4"], + node "n3" 37 $ linksTo [], + node "n4" 8 $ linksTo ["n2"], + node "n4" 18 $ linksTo [], + node "n4" 28 $ linksTo ["n2", "n3"] + ] + simple_unifier = unifyStd $ defUnifyStdConfig { makeLinkSubId = \ls -> lsSubjectNode ls, + negatesLinkSample = \_ _ -> False + } + specify "policyOverwrite with timeInterval" $ withSpider $ \spider -> do + mapM_ (addFoundNode spider) input_fns + let query = (defQuery ["n1"]) + { timeInterval = NegInf <..<= (Finite $ fromEpochMillisecond 27), + foundNodePolicy = policyOverwrite, + unifyLinkSamples = simple_unifier + } + (got_nodes, got_edges) <- fmap sort2 $ getSnapshot spider query + map linkNodeTuple got_edges `shouldBe` + [ ("n1", "n3"), + ("n3", "n1"), + ("n3", "n4") + ] + map linkTimestamp got_edges `shouldBe` map fromEpochMillisecond [20, 27, 27] + map nodeId got_nodes `shouldBe` ["n1", "n3", "n4"] + map (isNothing . S.nodeAttributes) got_nodes `shouldBe` [False, False, False] + specify "policyAppend with timeInterval" $ withSpider $ \spider -> do + mapM_ (addFoundNode spider) input_fns + let query = (defQuery ["n1"]) + { timeInterval = (Finite $ fromEpochMillisecond 15) <=..<= (Finite $ fromEpochMillisecond 30), + foundNodePolicy = policyAppend, + unifyLinkSamples = simple_unifier + } + (got_nodes, got_edges) <- fmap sort2 $ getSnapshot spider query + map linkNodeTuple got_edges `shouldBe` + [ ("n1", "n2"), + ("n1", "n3"), + ("n2", "n1"), + ("n2", "n4"), + ("n3", "n1"), + ("n3", "n4"), + ("n4", "n2"), + ("n4", "n3") + ] + map linkTimestamp got_edges `shouldBe` + map fromEpochMillisecond [30, 20, 15, 25, 27, 27, 28, 28] + map nodeId got_nodes `shouldBe` ["n1", "n2", "n3", "n4"] + map (isNothing . S.nodeAttributes) got_nodes `shouldBe` [False, False, False, False]