diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for net-spider + +## 0.1.0.0 -- 2018-09-24 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Toshio Ito + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Toshio Ito nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ + +# net-spider + +net-spider is a graph database middleware to maintain a time-varying graph. + +See [project README](https://github.com/debug-ito/net-spider) for detail. + +## Author + +Toshio Ito diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/net-spider.cabal b/net-spider.cabal new file mode 100644 --- /dev/null +++ b/net-spider.cabal @@ -0,0 +1,101 @@ +name: net-spider +version: 0.1.0.0 +author: Toshio Ito +maintainer: Toshio Ito +license: BSD3 +license-file: LICENSE +synopsis: A graph database middleware to maintain a time-varying graph. +description: A graph database middleware to maintain a time-varying graph. See the [project README](https://github.com/debug-ito/net-spider) for detail. +category: Database +cabal-version: >= 1.10 +build-type: Simple +extra-source-files: README.md, ChangeLog.md +homepage: https://github.com/debug-ito/net-spider +bug-reports: https://github.com/debug-ito/net-spider/issues + +library + default-language: Haskell2010 + hs-source-dirs: src + ghc-options: -Wall -fno-warn-unused-imports + -- default-extensions: + other-extensions: OverloadedStrings, + GeneralizedNewtypeDeriving, + TypeFamilies + exposed-modules: NetSpider, + NetSpider.Input, + NetSpider.Output, + NetSpider.Found, + NetSpider.Timestamp, + NetSpider.Spider, + NetSpider.Spider.Config, + NetSpider.Unify, + NetSpider.Snapshot, + NetSpider.Graph, + NetSpider.Pair, + NetSpider.Query + 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, + vector >=0.12.0.1 && <0.13, + greskell-websocket >=0.1.1 && <0.2, + greskell >=0.2.1 && <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 + +-- executable net-spider +-- default-language: Haskell2010 +-- hs-source-dirs: app +-- main-is: Main.hs +-- ghc-options: -Wall -fno-warn-unused-imports +-- -- other-modules: +-- -- default-extensions: +-- -- other-extensions: +-- build-depends: base + +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m" + main-is: Spec.hs + -- default-extensions: + -- other-extensions: + -- other-modules: + build-depends: base, net-spider, vector, + hspec >=2.4.4 + +flag server-test + description: Do test with Gremlin Server. + Note that this test clears ALL CONTENT of the server. + Note also that this test should not be run in parallel with other server-tests. + Use --jobs=1 option when running stack test. + default: False + manual: True + +test-suite server-test-suite + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: test + ghc-options: -Wall -fno-warn-unused-imports "-with-rtsopts=-M512m" + main-is: ServerTest.hs + other-modules: ServerTest.Common, + ServerTest.Snapshot, + ServerTest.Attributes + if flag(server-test) + build-depends: base, hspec, net-spider, vector, text, greskell-websocket, greskell, + aeson, unordered-containers, text, hashable, time, safe-exceptions, + hspec-need-env >=0.1.0.0 && <0.2 + else + buildable: False + + +source-repository head + type: git + location: https://github.com/debug-ito/net-spider.git diff --git a/src/NetSpider.hs b/src/NetSpider.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider.hs @@ -0,0 +1,39 @@ +-- | +-- Module: NetSpider +-- Description: NetSpider top-level document +-- Maintainer: Toshio Ito +-- +-- This module is just for documentation. +-- +-- For tutorial, see the [project README](https://github.com/debug-ito/net-spider). +-- +-- = NetSpider module layout +-- +-- == Bundle modules for the user +-- +-- * "NetSpider.Input": Functions to input local findings to the +-- history graph. +-- * "NetSpider.Output": Functions to get snapshot graphs from the +-- history graph. +-- +-- == Spider and query +-- +-- * "NetSpider.Spider" +-- * "NetSpider.Spider.Config" +-- * "NetSpider.Query" +-- * "NetSpider.Unify" +-- +-- == Data models +-- +-- * "NetSpider.Found" +-- * "NetSpider.Timestamp" +-- * "NetSpider.Graph" +-- * "NetSpider.Snapshot" +-- +-- == Utility +-- +-- * "NetSpider.Pair" +module NetSpider + () where + + diff --git a/src/NetSpider/Found.hs b/src/NetSpider/Found.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Found.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module: NetSpider.Found +-- Description: Types about local findings +-- Maintainer: Toshio Ito +-- +-- +module NetSpider.Found + ( FoundNode(..), + FoundLink(..), + LinkState(..), + linkStateToText, + linkStateFromText + ) where + +import Data.Greskell (FromGraphSON(..)) +import Data.Text (Text, unpack) + +import NetSpider.Timestamp (Timestamp) + +-- | State of the found link. +data LinkState = + LinkUnused + -- ^ Link is possible, but not used. + | LinkToTarget + -- ^ Link is directional. It's from subject to target. + | LinkToSubject + -- ^ Link is directional. It's from target to subject. + | LinkBidirectional + -- ^ Link is bidirectional. + deriving (Show,Eq,Ord,Bounded,Enum) + +linkStateToText :: LinkState -> Text +linkStateToText ls = case ls of + LinkUnused -> "unused" + LinkToTarget -> "to_target" + LinkToSubject -> "to_subject" + LinkBidirectional -> "bidirectional" + +linkStateFromText :: Text -> Maybe LinkState +linkStateFromText t = case t of + "unused" -> Just LinkUnused + "to_target" -> Just LinkToTarget + "to_subject" -> Just LinkToSubject + "bidirectional" -> Just LinkBidirectional + _ -> Nothing + +instance FromGraphSON LinkState where + parseGraphSON gv = fromText =<< parseGraphSON gv + where + fromText t = case linkStateFromText t of + Just ls -> return ls + Nothing -> fail ("Unrecognized LinkState: " ++ unpack t) + +-- | A link found at a 'FoundNode'. The link connects from the subject +-- node (the found node) to the target node. The link may be +-- directional or non-directional. +-- +-- - type @n@: node ID. +-- - type @la@: link attributes. +data FoundLink n la = + FoundLink + { targetNode :: !n, + linkState :: !LinkState, + linkAttributes :: !la + } + deriving (Show,Eq,Ord) + +-- | 'FoundNode' is a node (the subject node) observed at a specific +-- time. It has a set of neighbor links found at the moment. +-- +-- - type @n@: node ID. +-- - type @na@: node attributes. +-- - type @la@: link attributes. +data FoundNode n na la = + FoundNode + { subjectNode :: !n, + foundAt :: !Timestamp, + neighborLinks :: ![FoundLink n la], + nodeAttributes :: !na + } + deriving (Show,Eq) diff --git a/src/NetSpider/Graph.hs b/src/NetSpider/Graph.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Graph.hs @@ -0,0 +1,20 @@ +-- | +-- Module: NetSpider.Graph +-- Description: Graph data models +-- Maintainer: Toshio Ito +-- +module NetSpider.Graph + ( -- * Attributes classes + NodeAttributes(..), + LinkAttributes(..), + -- * Graph element types + EID, + VNode, + VFoundNode, + EFinds + ) where + +import NetSpider.Graph.Internal + ( EID, VNode, VFoundNode, NodeAttributes(..), + EFinds, LinkAttributes(..) + ) diff --git a/src/NetSpider/Graph/Internal.hs b/src/NetSpider/Graph/Internal.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Graph/Internal.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, OverloadedStrings #-} +-- | +-- Module: NetSpider.Graph.Internal +-- Description: +-- Maintainer: Toshio Ito +-- +-- __this module is internal. End-users should not use it.__ +module NetSpider.Graph.Internal + ( -- * EID + EID, + -- * VNode + VNode, + -- * VFoundNode + VFoundNode(..), + NodeAttributes(..), + -- * EFinds + EFinds(..), + LinkAttributes(..) + ) where + +import Data.Aeson (ToJSON(..), FromJSON(..), Value(..)) +import Data.Greskell + ( FromGraphSON(..), parseOneValue, lookupOne, lookupOneValue, + Element(..), Vertex, Edge(..), + AVertexProperty(..), AVertex(..), AProperty, AEdge(..), + Walk, SideEffect, + Binder, Parser, PropertyMapList, PropertyMapSingle, GValue, + gIdentity + ) +import Data.Text (Text, unpack) +import Data.Time.LocalTime (TimeZone(..)) + +import NetSpider.Timestamp (Timestamp(..)) +import NetSpider.Found (LinkState) + +-- | Generic element ID used in the graph DB. +newtype EID = EID (Either Int Text) + deriving (Show,Eq,Ord,FromGraphSON) + +instance ToJSON EID where + toJSON (EID e) = either toJSON toJSON e + +instance FromJSON EID where + parseJSON (String s) = return $ EID $ Right s + parseJSON v = fmap (EID . Left) $ parseJSON v + + +-- | The \"node\" vertex. +data VNode + +instance Element VNode where + type ElementID VNode = EID + type ElementProperty VNode = AVertexProperty + +instance Vertex VNode + +-- | The \"found_node\" vertex. +data VFoundNode na = + VFoundNode + { vfnId :: !EID, + vfnTimestamp :: !Timestamp, + vfnAttributes :: !na + } + deriving (Show) + +instance Element (VFoundNode na) where + type ElementID (VFoundNode na) = EID + type ElementProperty (VFoundNode na) = AVertexProperty + +instance Vertex (VFoundNode na) + +instance NodeAttributes na => FromGraphSON (VFoundNode na) where + parseGraphSON gv = fromAVertex =<< parseGraphSON gv + where + fromAVertex av = do + eid <- parseGraphSON $ avId av + ts_prop <- case lookupOne "@timestamp" $ avProperties av of + Nothing -> fail ("Cannot find property named @timestamp") + Just p -> return p + epoch_ts <- parseGraphSON $ avpValue ts_prop + mtz <- parseTimeZone ts_prop + attrs <- parseNodeAttributes $ avProperties av + return $ VFoundNode { vfnId = eid, + vfnTimestamp = Timestamp { epochTime = epoch_ts, + timeZone = mtz + }, + vfnAttributes = attrs + } + parseTimeZone ts_prop = + case (get "@tz_offset_min", get "@tz_summer_only", get "@tz_name") of + (Left _, Left _, Left _) -> return Nothing + (eo, es, en) -> do + offset <- parseE eo + is_summer_only <- parseE es + name <- parseE en + return $ Just $ TimeZone { timeZoneMinutes = offset, + timeZoneSummerOnly = is_summer_only, + timeZoneName = unpack name + } + where + get k = maybe (Left ("Cannot find property " ++ unpack k)) Right $ lookupOneValue k $ avpProperties ts_prop + parseE :: (FromGraphSON a) => Either String GValue -> Parser a + parseE = either fail parseGraphSON + +-- | \"finds\" edge. +data EFinds la = + EFinds + { efId :: !EID, + efTargetId :: !EID, + efLinkState :: !LinkState, + efLinkAttributes :: !la + } + deriving (Show) + +instance Element (EFinds la) where + type ElementID (EFinds la) = EID + type ElementProperty (EFinds la) = AProperty + +instance Edge (EFinds la) where + type EdgeVertexID (EFinds la) = EID + +instance LinkAttributes la => FromGraphSON (EFinds la) where + parseGraphSON gv = fromAEdge =<< parseGraphSON gv + where + fromAEdge ae = EFinds + <$> (parseGraphSON $ aeId ae) + <*> (parseGraphSON $ aeInV ae) + <*> (parseOneValue "@link_state" ps) + <*> (parseLinkAttributes ps) + where + ps = aeProperties ae + +-- | Class of user-defined types for node attributes. Its content is +-- stored in the NetSpider database. +class NodeAttributes ps where + writeNodeAttributes :: ps -> Binder (Walk SideEffect (VFoundNode ps) (VFoundNode ps)) + -- ^ Return 'Walk' to write the attributes to the 'VFoundNode'. + parseNodeAttributes :: PropertyMapList AVertexProperty GValue -> Parser ps + -- ^ Parse the vertex proprerties into the attributes. + +-- | No attributes. +instance NodeAttributes () where + writeNodeAttributes _ = return gIdentity + parseNodeAttributes _ = return () + +-- | Class of user-defined types for link attributes. Its content is +-- stored in the NetSpider database. +class LinkAttributes ps where + writeLinkAttributes :: ps -> Binder (Walk SideEffect (EFinds ps) (EFinds ps)) + -- ^ Return 'Walk' to write the attributes to the 'EFinds'. + parseLinkAttributes :: PropertyMapSingle AProperty GValue -> Parser ps + -- ^ Parse the edge proprerties into the attributes. + +-- | No attributes. +instance LinkAttributes () where + writeLinkAttributes _ = return gIdentity + parseLinkAttributes _ = return () + diff --git a/src/NetSpider/Input.hs b/src/NetSpider/Input.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Input.hs @@ -0,0 +1,20 @@ +-- | +-- Module: NetSpider.Input +-- Description: Bundle module to input data to the database. +-- Maintainer: Toshio Ito +-- +-- +module NetSpider.Input + ( module NetSpider.Found, + module NetSpider.Graph, + module NetSpider.Spider, + module NetSpider.Spider.Config, + module NetSpider.Timestamp + ) where + +import NetSpider.Found +import NetSpider.Graph +import NetSpider.Spider +import NetSpider.Spider.Config +import NetSpider.Timestamp + diff --git a/src/NetSpider/Output.hs b/src/NetSpider/Output.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Output.hs @@ -0,0 +1,24 @@ +-- | +-- Module: NetSpider.Output +-- Description: Bundle module to output data from the database. +-- Maintainer: Toshio Ito +-- +-- +module NetSpider.Output + ( module NetSpider.Snapshot, + module NetSpider.Graph, + module NetSpider.Spider, + module NetSpider.Spider.Config, + module NetSpider.Timestamp, + module NetSpider.Unify, + module NetSpider.Query + ) where + +import NetSpider.Snapshot +import NetSpider.Graph +import NetSpider.Spider +import NetSpider.Spider.Config +import NetSpider.Timestamp +import NetSpider.Unify +import NetSpider.Query + diff --git a/src/NetSpider/Pair.hs b/src/NetSpider/Pair.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Pair.hs @@ -0,0 +1,50 @@ +-- | +-- Module: NetSpider.Pair +-- Description: Swap-insensitive two-element homogeneous tuple +-- Maintainer: Toshio Ito +-- +-- +module NetSpider.Pair + ( Pair(..), + sortPair + ) where + +import Control.Applicative (Applicative(..)) +import Data.Foldable (Foldable(..)) +import Data.Hashable (Hashable(hashWithSalt)) +import Data.Traversable (Traversable(..)) + +-- | 'Pair' is a two-element tuple of the same type that is +-- insensitive to swapping. 'Eq', 'Ord' and 'Hashable' instances treat +-- 'Pair's with swapped elements as equivalent. +newtype Pair a = Pair { unPair :: (a,a) } + deriving (Show) + +instance Eq a => Eq (Pair a) where + (Pair (al, ar)) == (Pair (bl, br)) = (al == bl && ar == br) || (al == br && ar == bl) + +instance Ord a => Ord (Pair a) where + compare l r = compare (unPair $ sortPair l) (unPair $ sortPair r) + +instance (Ord a, Hashable a) => Hashable (Pair a) where + hashWithSalt s p = hashWithSalt s $ unPair $ sortPair p + +instance Functor Pair where + fmap f (Pair (l,r)) = Pair (f l, f r) + +instance Applicative Pair where + pure a = Pair (a,a) + (Pair (fl,fr)) <*> (Pair (al,ar)) = Pair (fl al, fr ar) + +instance Foldable Pair where + foldr f start (Pair (l,r)) = foldr f start [l,r] + +instance Traversable Pair where + traverse f (Pair (l,r)) = fmap Pair $ (,) <$> (f l) <*> (f r) + +-- | Sort the elements in the 'Pair'. +sortPair :: Ord a => Pair a -> Pair a +sortPair p@(Pair (l,r)) = if l <= r + then p + else Pair (r,l) + diff --git a/src/NetSpider/Query.hs b/src/NetSpider/Query.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Query.hs @@ -0,0 +1,46 @@ +-- | +-- Module: NetSpider.Query +-- Description: Query for snapshot graph +-- Maintainer: Toshio Ito +-- +-- +module NetSpider.Query + ( -- * Query type + Query, + defQuery, + -- ** accessor functions + startsFrom, + unifyLinkSamples + ) where + +import NetSpider.Unify (LinkSampleUnifier, unifyToOne) + +-- | Query for snapshot graph. You can get the default 'Query' by +-- 'defQuery' function, and customize its fields by the accessor +-- functions. +-- +-- - Type @n@: node ID +-- - Type @na@: node attributes +-- - Type @fla@: attributes of found links. +-- - Type @sla@: attributes of snapshot links. Converted from @fla@ by +-- 'unifyLinkSamples'. +data Query n na fla sla = + Query + { startsFrom :: [n], + -- ^ Nodes from which the Spider starts traversing the history + -- graph. + unifyLinkSamples :: LinkSampleUnifier n na fla sla + -- ^ See the document of 'LinkSampleUnifier'. + -- + -- Default: 'unifyToOne'. + } + +-- | The default 'Query'. +defQuery :: Eq n + => [n] -- ^ 'startsFrom' field. + -> Query n na fla fla +defQuery ns = Query + { startsFrom = ns, + unifyLinkSamples = unifyToOne + } + diff --git a/src/NetSpider/Queue.hs b/src/NetSpider/Queue.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Queue.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | +-- Module: NetSpider.Queue +-- Description: +-- Maintainer: Toshio Ito +-- +-- __this module is internal. End-users should not use it.__ +module NetSpider.Queue + ( Queue, + newQueue, + pushQueue, + popQueue + ) where + +import Data.Foldable (Foldable) +import Data.Monoid (Monoid) +import Data.Semigroup (Semigroup) +import Data.Sequence (Seq, (|>), viewl, ViewL(..), fromList) +import Data.Traversable (Traversable) + +-- | Pure FIFO queue. +newtype Queue a = Queue (Seq a) + deriving (Show,Eq,Ord,Semigroup,Monoid,Foldable,Functor,Applicative,Monad) + +newQueue :: [a] -> Queue a +newQueue = Queue . fromList + +pushQueue :: a -> Queue a -> Queue a +pushQueue item (Queue s) = Queue (s |> item) + +popQueue :: Queue a -> (Maybe a, Queue a) +popQueue q@(Queue s) = + case viewl s of + EmptyL -> (Nothing, q) + (item :< rest) -> (Just item, Queue rest) diff --git a/src/NetSpider/Snapshot.hs b/src/NetSpider/Snapshot.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Snapshot.hs @@ -0,0 +1,67 @@ +-- | +-- Module: NetSpider.Snapshot +-- Description: Types about snapshot graph +-- Maintainer: Toshio Ito +-- +-- A snapshot graph is a graph constructed from the NetSpider +-- database. It reprensents a graph at specific time. +module NetSpider.Snapshot + ( -- * SnapshotNode + SnapshotNode, + nodeId, + isOnBoundary, + nodeTimestamp, + nodeAttributes, + -- * SnapshotLink + SnapshotLink, + sourceNode, + destinationNode, + linkNodeTuple, + linkNodePair, + isDirected, + linkTimestamp, + linkAttributes + ) where + +import NetSpider.Snapshot.Internal + ( SnapshotNode(..), + SnapshotLink(..), + linkNodeTuple, + linkNodePair + ) +import NetSpider.Timestamp (Timestamp) + + +nodeId :: SnapshotNode n na -> n +nodeId = _nodeId + +-- | This property is 'True' if the node is on the boundary of the +-- query. This means that nodes adjacent to this node may not be +-- included in the query result. +isOnBoundary :: SnapshotNode n na -> Bool +isOnBoundary = _isOnBoundary + +-- | If the node is not observed yet or 'isOnBoundary' is 'True', its +-- timestamp is 'Nothing'. +nodeTimestamp :: SnapshotNode n na -> Maybe Timestamp +nodeTimestamp = _nodeTimestamp + +-- | If the node is not observed yet or 'isOnBoundary' is 'True', its +-- node attributes is 'Nothing'. +nodeAttributes :: SnapshotNode n na -> Maybe na +nodeAttributes = _nodeAttributes + +sourceNode :: SnapshotLink n la -> n +sourceNode = _sourceNode + +destinationNode :: SnapshotLink n la -> n +destinationNode = _destinationNode + +isDirected :: SnapshotLink n la -> Bool +isDirected = _isDirected + +linkTimestamp :: SnapshotLink n la -> Timestamp +linkTimestamp = _linkTimestamp + +linkAttributes :: SnapshotLink n la -> la +linkAttributes = _linkAttributes diff --git a/src/NetSpider/Snapshot/Internal.hs b/src/NetSpider/Snapshot/Internal.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Snapshot/Internal.hs @@ -0,0 +1,62 @@ +-- | +-- Module: NetSpider.Snapshot.Internal +-- Description: +-- Maintainer: Toshio Ito +-- +-- __this module is internal. End-users should not use this.__ +module NetSpider.Snapshot.Internal + ( SnapshotLink(..), + linkNodeTuple, + linkNodePair, + SnapshotNode(..) + ) where + +import NetSpider.Pair (Pair(..)) +import NetSpider.Timestamp (Timestamp) + +-- | A link in the snapshot graph. +-- +-- 'SnapshotLink' is summary of one or more link observations by +-- different subject nodes. Basically the latest of these observations +-- is used to make 'SnapshotLink'. +-- +-- - type @n@: node ID. +-- - type @la@: link attributes. +data SnapshotLink n la = + SnapshotLink + { _sourceNode :: !n, + _destinationNode :: !n, + _isDirected :: !Bool, + _linkTimestamp :: !Timestamp, + _linkAttributes :: !la + + -- Maybe it's a good idea to include 'observationLogs', which can + -- contain warnings or other logs about making this SnapshotLink. + } + deriving (Show,Eq) + +-- | Comparison by node-tuple (source node, destination node). +instance (Ord n, Eq la) => Ord (SnapshotLink n la) where + compare l r = compare (linkNodeTuple l) (linkNodeTuple r) + +-- | Node-tuple (source node, destination node) of the link. +linkNodeTuple :: SnapshotLink n la -> (n, n) +linkNodeTuple link = (_sourceNode link, _destinationNode link) + +-- | Like 'linkNodeTuple', but this returns a 'Pair'. +linkNodePair :: SnapshotLink n la -> Pair n +linkNodePair = Pair . linkNodeTuple + +-- | A node in the snapshot graph. +data SnapshotNode n na = + SnapshotNode + { _nodeId :: !n, + _isOnBoundary :: !Bool, + _nodeTimestamp :: !(Maybe Timestamp), + _nodeAttributes :: !(Maybe na) + } + deriving (Show,Eq) + +-- | Comparison by node ID. +instance (Ord n, Eq na) => Ord (SnapshotNode n na) where + compare l r = compare (_nodeId l) (_nodeId r) diff --git a/src/NetSpider/Spider.hs b/src/NetSpider/Spider.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Spider.hs @@ -0,0 +1,334 @@ +{-# LANGUAGE OverloadedStrings, TypeFamilies #-} +-- | +-- Module: NetSpider.Spider +-- Description: Spider type. +-- Maintainer: Toshio Ito +-- +-- +module NetSpider.Spider + ( -- * Spider type + Spider, + -- * Make Spider + connectWS, + connectWith, + -- * Close Spider + close, + -- * Graph operations + addFoundNode, + getSnapshotSimple, + getSnapshot, + clearAll + ) where + +import Control.Exception.Safe (throwString) +import Control.Monad (void) +import Data.Aeson (ToJSON) +import Data.Foldable (foldr', toList) +import Data.Hashable (Hashable) +import Data.Greskell + ( runBinder, ($.), (<$.>), (<*.>), + Binder, ToGreskell(GreskellReturn), AsIterator(IteratorItem), FromGraphSON, + liftWalk, gLimit, gIdentity + ) +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HM +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.Vector (Vector) +import qualified Data.Vector as V +import Network.Greskell.WebSocket (Host, Port) +import qualified Network.Greskell.WebSocket as Gr + +import NetSpider.Graph (EID, LinkAttributes, NodeAttributes) +import NetSpider.Graph.Internal (VFoundNode(..), EFinds(..)) +import NetSpider.Found (FoundNode(..), FoundLink(..), LinkState(..)) +import NetSpider.Pair (Pair) +import NetSpider.Queue (Queue, newQueue, popQueue, pushQueue) +import NetSpider.Query (Query, defQuery, startsFrom, unifyLinkSamples) +import NetSpider.Snapshot.Internal (SnapshotNode(..), SnapshotLink(..)) +import NetSpider.Spider.Config (Spider(..), Config(..), defConfig) +import NetSpider.Spider.Internal.Graph + ( gMakeFoundNode, gAllNodes, gHasNodeID, gHasNodeEID, gNodeEID, gNodeID, gMakeNode, gClearAll, + gLatestFoundNode, gSelectFoundNode, gFinds, gHasFoundNodeEID, gAllFoundNode + ) +import NetSpider.Unify (LinkSampleUnifier, LinkSample(..), LinkSampleID, linkSampleId) + +-- | Connect to the WebSocket endpoint of Tinkerpop Gremlin Server +-- that hosts the NetSpider database. +connectWS :: Eq n => Host -> Port -> IO (Spider n na la) +connectWS host port = connectWith $ defConfig { wsHost = host, + wsPort = port + } + +-- | Connect to the server with the given 'Config'. +connectWith :: Config n na fla -> IO (Spider n na fla) +connectWith conf = do + client <- Gr.connect (wsHost conf) (wsPort conf) + return $ Spider { spiderConfig = conf, + spiderClient = client + } + +-- | Close and release the 'Spider' object. +close :: Spider n na fla -> IO () +close sp = Gr.close $ spiderClient sp + +submitB :: (ToGreskell g, r ~ GreskellReturn g, AsIterator r, v ~ IteratorItem r, FromGraphSON v) + => Spider n na fla -> Binder g -> IO (Gr.ResultHandle v) +submitB sp b = Gr.submit (spiderClient sp) script mbs + where + (script, bs) = runBinder b + mbs = Just bs + +-- | Clear all content in the NetSpider database. This is mainly for +-- testing. +clearAll :: Spider n na fla -> IO () +clearAll spider = Gr.drainResults =<< submitB spider (return gClearAll) + +-- | Add a 'FoundNode' (observation of a node) to the NetSpider +-- database. +addFoundNode :: (ToJSON n, LinkAttributes fla, NodeAttributes na) => Spider n na fla -> FoundNode n na fla -> IO () +addFoundNode spider found_node = do + subject_vid <- getOrMakeNode spider $ subjectNode found_node + link_pairs <- traverse linkAndTargetVID $ neighborLinks found_node + makeFoundNodeVertex subject_vid link_pairs + where + linkAndTargetVID link = do + target_vid <- getOrMakeNode spider $ targetNode link + return (link, target_vid) + makeFoundNodeVertex subject_vid link_pairs = + Gr.drainResults =<< submitB spider (fmap void $ gMakeFoundNode subject_vid link_pairs found_node) + +vToMaybe :: Vector a -> Maybe a +vToMaybe v = v V.!? 0 + +getNode :: (ToJSON n) => Spider n na fla -> n -> IO (Maybe EID) +getNode spider nid = fmap vToMaybe $ Gr.slurpResults =<< submitB spider gt + where + gt = gNodeEID <$.> gHasNodeID spider nid <*.> pure gAllNodes + +getOrMakeNode :: (ToJSON n) => Spider n na fla -> n -> IO EID +getOrMakeNode spider nid = do + mvid <- getNode spider nid + case mvid of + Just vid -> return vid + Nothing -> makeNode + where + makeNode = expectOne =<< Gr.slurpResults =<< submitB spider (liftWalk gNodeEID <$.> gMakeNode spider nid) + expectOne v = case vToMaybe v of + Just e -> return e + Nothing -> throwString "Expects at least single result, but got nothing." + -- TODO: make decent exception spec. + +-- | Simple version of 'getSnapshot'. It builds the snapshot graph by +-- traversing the history graph from the given starting node. +-- +-- 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) + => Spider n na fla + -> n -- ^ ID of the node where it starts traversing. + -> IO ([SnapshotNode n na], [SnapshotLink n fla]) +getSnapshotSimple spider start_nid = getSnapshot spider $ defQuery [start_nid] + + +-- | 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) + => 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 :: (ToJSON n, Ord n, Hashable n, FromGraphSON n, LinkAttributes fla, NodeAttributes na) + => Spider n na fla + -> IORef (SnapshotState n na fla) + -> IO () +recurseVisitNodesForSnapshot spider 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 + go + getNextVisit = atomicModifyIORef' ref_state popUnvisitedNode + -- TODO: limit number of steps. + +visitNodeForSnapshot :: (ToJSON n, Ord n, Hashable n, FromGraphSON n, LinkAttributes fla, NodeAttributes na) + => Spider n na fla + -> 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 + where + markAsVisited mvfn = modifyIORef ref_state $ addVisitedNode visit_nid mvfn + 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 + +-- | The state kept while making the snapshot graph. +data SnapshotState n na fla = + SnapshotState + { ssUnvisitedNodes :: !(Queue n), + ssVisitedNodes :: !(HashMap n (Maybe (VFoundNode na))), + -- ^ If the visited node has no observation yet, its node + -- attributes 'Nothing'. + ssVisitedLinks :: !(HashMap (LinkSampleID n) [LinkSample n fla]) + } + deriving (Show) + +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 } + +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 } + +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 = HM.member target_nid $ ssVisitedNodes state + 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 + +popUnvisitedNode :: SnapshotState n na fla -> (SnapshotState n na fla, Maybe n) +popUnvisitedNode state = (updated, popped) + where + updated = state { ssUnvisitedNodes = updatedUnvisited } + (popped, updatedUnvisited) = popQueue $ ssUnvisitedNodes state + +makeSnapshot :: (Eq n, Hashable n) + => LinkSampleUnifier n na fla sla + -> SnapshotState n na fla + -> ([SnapshotNode n na], [SnapshotLink n sla]) +makeSnapshot unifier state = (nodes, links) + 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 + +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 + } + where + (on_boundary, mvfn) = + case HM.lookup nid $ ssVisitedNodes state of + Nothing -> (True, Nothing) + Just mv -> (False, mv) + +-- | 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) + => 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 + where + makeEndNode getter = makeSnapshotNode state $ getter $ head_sample + doUnify = unifier (makeEndNode lsSubjectNode) (makeEndNode lsTargetNode) + 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/src/NetSpider/Spider/Config.hs b/src/NetSpider/Spider/Config.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Spider/Config.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module: NetSpider.Spider.Config +-- Description: Configuration of Spider +-- Maintainer: Toshio Ito +-- +-- +module NetSpider.Spider.Config + ( Spider(..), + Config(..), + defConfig, + Host, + Port + ) where + +import Data.Greskell (Key) +import Network.Greskell.WebSocket (Host, Port) + +import qualified Network.Greskell.WebSocket as Gr + +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 + { wsHost :: Gr.Host, + -- ^ Host of WebSocket endpoint of Tinkerpop Gremlin + -- Server. Default: \"localhost\". + wsPort :: Gr.Port, + -- ^ Port of WebSocket endpoint of Tinkerpop Gremlin + -- Server. Default: 8182 + nodeIdKey :: Key VNode n + -- ^ Name of vertex property that stores the node ID. Default: + -- \"@node_id\". + } + +defConfig :: Config n na fla +defConfig = + Config + { wsHost = "localhost", + wsPort = 8182, + nodeIdKey = "@node_id" + } + diff --git a/src/NetSpider/Spider/Internal/Graph.hs b/src/NetSpider/Spider/Internal/Graph.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Spider/Internal/Graph.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module: NetSpider.Spider.Internal.Graph +-- Description: Graph (greskell) operation for Spider +-- Maintainer: Toshio Ito +-- +-- __this module is internal. End-users should not use it.__ +module NetSpider.Spider.Internal.Graph + ( gClearAll, + -- * VNode + gAllNodes, + gHasNodeID, + gHasNodeEID, + gNodeEID, + gNodeID, + gMakeNode, + -- * VFoundNode + gAllFoundNode, + gHasFoundNodeEID, + gMakeFoundNode, + gSelectFoundNode, + gLatestFoundNode, + -- * EFinds + gFinds + ) where + +import Control.Category ((<<<)) +import Control.Monad (void) +import Data.Aeson (ToJSON(..), FromJSON(..), Value(..)) +import Data.Foldable (fold) +import Data.Greskell + ( 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, + ($.), (<*.>), (=:), + ToGTraversal, + Key, oDecr, gLimit + ) +import Data.Int (Int64) +import Data.Text (Text, pack) +import Data.Time.LocalTime (TimeZone(..)) +import Data.Traversable (traverse) + +import NetSpider.Graph + ( EID, VNode, VFoundNode, EFinds, + LinkAttributes(..), NodeAttributes(..) + ) +import NetSpider.Found (FoundLink(..), LinkState(..), FoundNode(..), linkStateToText) +import NetSpider.Timestamp (Timestamp(..), fromEpochSecond) +import NetSpider.Spider.Config (Spider(..), Config(..)) + +spiderNodeIdKey :: Spider n na fla -> Key VNode n +spiderNodeIdKey = nodeIdKey . spiderConfig + +gNodeEID :: Walk Transform VNode EID +gNodeEID = gId + +gNodeID :: Spider n na fla -> Walk Transform VNode n +gNodeID spider = gValues [spiderNodeIdKey spider] + +gAllNodes :: GTraversal Transform () VNode +gAllNodes = gHasLabel "node" $. sV [] $ source "g" + +gHasNodeID :: (ToJSON n, WalkType c) => Spider n na fla -> n -> Binder (Walk c VNode VNode) +gHasNodeID spider nid = do + var_nid <- newBind nid + return $ gHas2 (spiderNodeIdKey spider) var_nid + +gHasNodeEID :: (WalkType c) => EID -> Binder (Walk c VNode VNode) +gHasNodeEID eid = do + var_eid <- newBind eid + return $ gHasId var_eid + +gMakeNode :: ToJSON n => Spider n na fla -> n -> Binder (GTraversal SideEffect () VNode) +gMakeNode spider nid = do + var_nid <- newBind nid + return $ gProperty (spiderNodeIdKey spider) var_nid $. sAddV "node" $ source "g" + +gGetNodeByEID :: EID -> Binder (Walk Transform s VNode) +gGetNodeByEID vid = do + f <- gHasNodeEID vid + return (f <<< gV []) + + +gAllFoundNode :: GTraversal Transform () (VFoundNode na) +gAllFoundNode = gHasLabel "found_node" $. sV [] $ source "g" + +gHasFoundNodeEID :: WalkType c => EID -> Binder (Walk c (VFoundNode na) (VFoundNode na)) +gHasFoundNodeEID eid = do + var_eid <- newBind eid + return $ gHasId var_eid + +gMakeFoundNode :: (LinkAttributes la, NodeAttributes na) + => EID -- ^ subject node EID + -> [(FoundLink n la, EID)] -- ^ (link, target node EID) + -> FoundNode n na la + -> Binder (GTraversal SideEffect () (VFoundNode na)) +gMakeFoundNode subject_vid link_pairs fnode = + mAddFindsEdges + <*.> writeNodeAttributes (nodeAttributes fnode) + <*.> gSetTimestamp (foundAt fnode) + <*.> mAddObservedEdge + <*.> pure $ sAddV "found_node" $ source "g" + where + mAddObservedEdge :: Binder (Walk SideEffect (VFoundNode na) (VFoundNode na)) + mAddObservedEdge = do + v <- gGetNodeByEID subject_vid + return $ gSideEffect $ emitsAEdge $ gAddE "is_observed_as" $ gFrom v + mAddFindsEdges = fmap fold $ traverse mAddFindsEdgeFor link_pairs + mAddFindsEdgeFor :: LinkAttributes la => (FoundLink n la, EID) -> Binder (Walk SideEffect (VFoundNode na) (VFoundNode na)) + mAddFindsEdgeFor (link, target_vid) = do + v <- gGetNodeByEID target_vid + var_ls <- newBind $ linkStateToText $ linkState link + addAttrs <- writeLinkAttributes $ linkAttributes link + return $ gSideEffect ( addAttrs + <<< gProperty "@link_state" var_ls + <<< gAddE "finds" (gTo v) + ) + +keyTimestamp :: Key (VFoundNode na) Int64 +keyTimestamp = "@timestamp" + +gSetTimestamp :: Timestamp -> Binder (Walk SideEffect (VFoundNode na) (VFoundNode na)) +gSetTimestamp ts = do + var_epoch <- newBind $ epochTime ts + meta_props <- makeMetaProps $ timeZone ts + return $ gPropertyV Nothing keyTimestamp var_epoch meta_props + where + makeMetaProps Nothing = return [] + makeMetaProps (Just tz) = do + offset <- newBind $ timeZoneMinutes tz + summer <- newBind $ timeZoneSummerOnly tz + name <- newBind $ pack $ timeZoneName tz + return $ [ "@tz_offset_min" =: offset, + "@tz_summer_only" =: summer, + "@tz_name" =: name + ] + +emitsAEdge :: ToGTraversal g => g c s AEdge -> g c s AEdge +emitsAEdge = id + +gClearAll :: GTraversal SideEffect () () +gClearAll = void $ gDrop $. liftWalk $ sV' [] $ source "g" + +gSelectFoundNode :: Walk Filter (VFoundNode na) (VFoundNode na) -> Walk Transform VNode (VFoundNode na) +gSelectFoundNode filterFoundNode = liftWalk filterFoundNode <<< gOut ["is_observed_as"] + +gLatestFoundNode :: Walk Transform (VFoundNode na) (VFoundNode na) +gLatestFoundNode = gLimit 1 <<< gOrder [gBy2 keyTimestamp oDecr] + +gFinds :: Walk Transform (VFoundNode na) (EFinds la) +gFinds = gOutE ["finds"] + + + diff --git a/src/NetSpider/Timestamp.hs b/src/NetSpider/Timestamp.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Timestamp.hs @@ -0,0 +1,30 @@ +-- | +-- Module: NetSpider.Timestamp +-- Description: Timestamp type +-- Maintainer: Toshio Ito +-- +-- +module NetSpider.Timestamp + ( Timestamp(..), + fromEpochSecond + ) where + +import Data.Int (Int64) +import Data.Time.LocalTime (TimeZone) + +-- | Timestamp when graph elements are observed. +data Timestamp = + Timestamp + { epochTime :: !Int64, + timeZone :: !(Maybe TimeZone) + } + deriving (Show,Eq) + +-- | Compare by 'epochTime' only. 'timeZone' is not used. +instance Ord Timestamp where + compare l r = compare (epochTime l) (epochTime r) + +-- | Make 'Timestamp' from seconds from the epoch. 'timeZone' is +-- 'Nothing'. +fromEpochSecond :: Int64 -> Timestamp +fromEpochSecond sec = Timestamp sec Nothing diff --git a/src/NetSpider/Unify.hs b/src/NetSpider/Unify.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/Unify.hs @@ -0,0 +1,183 @@ +-- | +-- Module: NetSpider.Unify +-- Description: LinkSampleUnifier type +-- Maintainer: Toshio Ito +-- +-- +module NetSpider.Unify + ( -- * Types + LinkSampleUnifier, + LinkSample(..), + LinkSampleID, + linkSampleId, + -- * Standard unifiers + unifyToOne, + unifyToMany, + unifyStd, + UnifyStdConfig(..), + defUnifyStdConfig, + -- * Building blocks + latestLinkSample, + defNegatesLinkSample + ) where + +import Data.Foldable (maximumBy) +import Data.Function (on) +import Data.Hashable (Hashable(hashWithSalt)) +import Data.Maybe (mapMaybe) +import GHC.Exts (groupWith) + +import NetSpider.Found (FoundLink, LinkState) +import NetSpider.Pair (Pair(..)) +import NetSpider.Snapshot (SnapshotNode, nodeTimestamp, nodeId, SnapshotLink) +import NetSpider.Timestamp (Timestamp) + + +-- | 'LinkSample' is an intermediate type between +-- 'NetSpider.Found.FoundLink' and +-- 'NetSpider.Snapshot.SnapshotLink'. 'LinkSample's are collected from +-- the history graph, and are unified into +-- 'NetSpider.Snapshot.SnapshotLink's. +data LinkSample n la = + LinkSample + { lsSubjectNode :: !n, + lsTargetNode :: !n, + lsLinkState :: !LinkState, + lsTimestamp :: !Timestamp, + lsLinkAttributes :: !la + } + deriving (Show,Eq,Ord) + +-- | Link ID of the 'LinkSample'. It's the 'Pair' of 'lsSubjectNode' +-- and 'lsTargetNode'. +type LinkSampleID n = Pair n + +-- | Get 'LinkSampleID' of the 'LinkSample'. +linkSampleId :: LinkSample n la -> LinkSampleID n +linkSampleId l = Pair (lsSubjectNode l, lsTargetNode l) + + + +-- | Function to unify 'LinkSample's collected for the given pair of +-- nodes and return 'LinkSample' per physical link. The returned +-- 'LinkSample's will be directly converted to 'SnapshotLink's in the +-- snapshot graph. +-- +-- This function has a number of important roles during construction +-- of the snapshot graph. +-- +-- - Because a link can be observed from both of its end nodes, there +-- can be multiple 'LinkSample's for one physical link. This +-- function is supposed to return one reasonable link sample for the +-- physical link from those input link samples. +-- - There can be multiple physical links for a given pair of nodes, +-- but the 'Spider' has no way to distinguish them. So, this +-- function is supposed to distinguish 'LinkSample's for different +-- physical links, and return one or more 'LinkSample's, each of +-- which corresponds to a physical link. +-- - Sometimes a link is found by one end node but not found by the +-- other end node. Should 'Spider' treats the link is available or +-- not? This function is supposed to answer that question by +-- returning non-empty result (if the link is available) or empty +-- result (if the link is not available.) +-- - Sometimes it is natural to have different data models of link +-- attributes for 'FoundLink's (@fla@) and for 'SnapshotLink's +-- (@sla@). For example, when you want to combine link attributes +-- 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] + +-- | 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 = 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) + => (LinkSample n fla -> lsid) -- ^ Getter of the link sub-ID + -> LinkSampleUnifier n na fla fla +unifyToMany getKey = unifyStd conf + where + conf = defUnifyStdConfig { makeLinkSubId = getKey } + +-- | Configuration of 'unifyStd'. See 'unifyStd' for detail. +data UnifyStdConfig n na fla sla lsid = + UnifyStdConfig + { makeLinkSubId :: LinkSample n fla -> lsid, + -- ^ Function to create the link sub-ID from + -- 'LinkSample'. + -- + -- Default: always return @()@. All 'LinkSample's have the same + -- link sub-ID. + mergeSamples :: [LinkSample n fla] -> [LinkSample n fla] -> Maybe (LinkSample n sla), + -- ^ Function to merge 'LinkSample's for a physical link. The + -- input is 'LinkSample's found by each of the end nodes. This + -- function optionally converts the link attributes from @fla@ to + -- @sla@. + -- + -- Default: Concatenate the input 'LinkSample's and get + -- 'latestLinkSample'. + + negatesLinkSample :: SnapshotNode n na -> LinkSample n sla -> Bool + -- ^ This function is supposed to return 'True' if the + -- 'SnapshotNode' negates the presence of the 'LinkSample'. + -- + -- Default: 'defNegatesLinkSample'. + } + +-- | Default of 'UnifyStdConfig'. +defUnifyStdConfig :: Eq n => UnifyStdConfig n na fla fla () +defUnifyStdConfig = UnifyStdConfig + { makeLinkSubId = const (), + mergeSamples = \ls rs -> latestLinkSample (ls ++ rs), + negatesLinkSample = defNegatesLinkSample + } + +-- | The standard unifier. This unifier does the following. +-- +-- 1. It partitions 'LinkSample's based on their link sub-IDs. The +-- link sub-ID is defined by 'makeLinkSubId' function. Each link +-- sub-ID corresponds to a physical link. +-- 2. For each partition, 'LinkSample's are merged to one using +-- 'mergeSamples' function. +-- 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) + where + forGroup samples = maybeNegates rnode + =<< maybeNegates lnode + =<< mergeSamples conf (samplesFor samples lnode) (samplesFor samples rnode) + samplesFor samples sn = filter (\s -> nodeId sn == (lsSubjectNode s)) samples + maybeNegates sn sample = if negatesLinkSample conf sn sample + then Nothing + else Just sample + +-- | Get the 'LinkSample' that has the latest (biggest) timestamp. +latestLinkSample :: [LinkSample n la] -> Maybe (LinkSample n la) +latestLinkSample [] = Nothing +latestLinkSample samples = Just $ maximumBy comp samples + where + comp = compare `on` lsTimestamp + +-- | Default of 'negatesLinkSample'. This function returns 'True' if +-- all of the following conditions are met. +-- +-- - The 'SnapshotNode' has 'nodeTimestamp'. +-- - The 'nodeTimestamp' is greater (newer) than the link's timestamp. +-- - The 'lsSubjectNode' is not the node ID of the 'SnapshotNode'. +-- +-- If the above conditions are met, it implies that the 'LinkSample' +-- is found by the other end node, but the given 'SnapshotNode' does +-- not find it. This is possibly because the link has just +-- disappeared, so the link should be negated. +defNegatesLinkSample :: Eq n => SnapshotNode n na -> LinkSample n la -> Bool +defNegatesLinkSample sn l = + case nodeTimestamp sn of + Nothing -> False + Just t -> lsTimestamp l < t && lsSubjectNode l /= nodeId sn diff --git a/test/ServerTest.hs b/test/ServerTest.hs new file mode 100644 --- /dev/null +++ b/test/ServerTest.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main,spec) where + +import Test.Hspec + +import qualified ServerTest.Snapshot as Snapshot +import qualified ServerTest.Attributes as Attributes + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + Snapshot.spec + Attributes.spec diff --git a/test/ServerTest/Attributes.hs b/test/ServerTest/Attributes.hs new file mode 100644 --- /dev/null +++ b/test/ServerTest/Attributes.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE OverloadedStrings #-} +module ServerTest.Attributes (main,spec) where + +import Data.Aeson (ToJSON) +import Data.List (sort) +import Data.Hashable (Hashable) +import Data.Greskell + ( FromGraphSON, + Key + ) +import Data.Text (Text) +import Data.Time.LocalTime (TimeZone(..)) +import Test.Hspec + +import ServerTest.Common + ( withServer, withSpider', withSpider, + AText(..), AInt(..) + ) + +import NetSpider.Found (FoundNode(..), FoundLink(..), LinkState(..)) +import NetSpider.Graph (NodeAttributes(..), LinkAttributes(..), VNode) +import NetSpider.Spider + ( addFoundNode, getSnapshotSimple + ) +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) + +main :: IO () +main = hspec spec + + +typeTestCase :: (FromGraphSON n, ToJSON n, Ord n, Hashable n, Show n, NodeAttributes na, Eq na, Show na, LinkAttributes la, Eq la, Show la) + => String + -> Config n na la + -> n + -> n + -> na + -> la + -> SpecWith (Host,Port) +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, + neighborLinks = return link1, + nodeAttributes = node_attrs + } + link1 = FoundLink { targetNode = n2_id, + linkState = LinkToSubject, + linkAttributes = link_attrs + } + addFoundNode spider n1 + (got_ns, got_ls) <- getSnapshotSimple spider n1_id + let (got_n1, got_n2, got_l) = case (sort got_ns, sort got_ls) of + ([a,b], [c]) -> (a,b,c) + _ -> error ("Unexpected pattern: got = " ++ show (got_ns, got_ls)) + S.nodeAttributes got_n1 `shouldBe` Just node_attrs + S.nodeAttributes got_n2 `shouldBe` Nothing + S.linkAttributes got_l `shouldBe` link_attrs + +attributeTestCase :: (NodeAttributes na, Eq na, Show na, LinkAttributes la, Eq la, Show la) + => String + -> na + -> la + -> SpecWith (Host,Port) +attributeTestCase type_label na la = typeTestCase (type_label ++ " attributes") defConfig + ("n1" :: Text) ("n2" :: Text) na la + +nodeIdTestCase :: (FromGraphSON n, ToJSON n, Ord n, Hashable n, Show n) + => String + -> Key VNode n + -> n -> n -> SpecWith (Host,Port) +nodeIdTestCase label node_id_key n1 n2 = typeTestCase (label ++ " nodeID") conf n1 n2 () () + where + conf = defConfig { nodeIdKey = node_id_key + } + +timestampTestCase :: String -> Timestamp -> SpecWith (Host, Port) +timestampTestCase label ts = specify label $ withSpider $ \spider -> do + let fn :: FoundNode Text () () + fn = FoundNode + { subjectNode = "n1", + foundAt = ts, + nodeAttributes = (), + neighborLinks = return $ FoundLink + { targetNode = "n2", + linkState = LinkToTarget, + linkAttributes = () + } + } + addFoundNode spider fn + (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 pattern: got = " ++ show (got_ns, got_ls)) + nodeTimestamp got_n1 `shouldBe` Just ts + nodeTimestamp got_n2 `shouldBe` Nothing + linkTimestamp got_l `shouldBe` ts + +spec :: Spec +spec = withServer $ do + describe "node and link attributes" $ do + attributeTestCase "Text" (AText "node attrs") (AText "link attrs") + attributeTestCase "Int" (AInt 128) (AInt 64) + describe "nodeId" $ do + nodeIdTestCase "Text" "@node_id_text" ("n1" :: Text) ("n2" :: Text) + nodeIdTestCase "Int" "@node_id_int" (100 :: Int) (255 :: Int) + -- We need to use different property keys for different NodeID + -- types, because the graph database (at least JanusGraph) + -- automatically fixes the schema (internal data type) for a + -- property key when some data is given for it for the first time. + describe "timestamp with timezone" $ do + timestampTestCase "positive timezone" + $ Timestamp { epochTime = 200, + timeZone = Just $ TimeZone + { timeZoneMinutes = 9*60, + timeZoneSummerOnly = False, + timeZoneName = "Asia/Tokyo" + } + } + timestampTestCase "negative timezone" + $ Timestamp { epochTime = 150, + timeZone = Just $ TimeZone + { timeZoneMinutes = (-5)*60, + timeZoneSummerOnly = True, + timeZoneName = "America/Chicago" + } + } + diff --git a/test/ServerTest/Common.hs b/test/ServerTest/Common.hs new file mode 100644 --- /dev/null +++ b/test/ServerTest/Common.hs @@ -0,0 +1,127 @@ +{-# 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.Greskell (parseOneValue, gProperty, newBind) +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, Spider, Config(..), defConfig + ) +import NetSpider.Spider + ( connectWith, close, clearAll + ) +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 + +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) + +instance NodeAttributes AText where + writeNodeAttributes (AText t) = gProperty "text" <$> newBind t + parseNodeAttributes ps = AText <$> parseOneValue "text" ps + +instance LinkAttributes AText where + writeLinkAttributes (AText t) = gProperty "text" <$> newBind t + parseLinkAttributes ps = AText <$> parseOneValue "text" ps + +newtype AInt = AInt Int + deriving (Show,Eq,Ord) + +instance NodeAttributes AInt where + writeNodeAttributes (AInt n) = gProperty "integer" <$> newBind n + parseNodeAttributes ps = AInt <$> parseOneValue "integer" ps + +instance LinkAttributes AInt where + writeLinkAttributes (AInt n) = gProperty "integer" <$> newBind n + parseLinkAttributes ps = AInt <$> parseOneValue "integer" 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) + +instance LinkAttributes APorts where + writeLinkAttributes ap = do + writeSource <- gProperty "subject_port" <$> newBind (apFst ap) + writeDest <- gProperty "target_port" <$> newBind (apSnd ap) + return (writeDest <<< writeSource) + parseLinkAttributes ps = APorts + <$> parseOneValue "subject_port" ps + <*> parseOneValue "target_port" 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/Snapshot.hs b/test/ServerTest/Snapshot.hs new file mode 100644 --- /dev/null +++ b/test/ServerTest/Snapshot.hs @@ -0,0 +1,573 @@ +{-# LANGUAGE OverloadedStrings #-} +module ServerTest.Snapshot (main, spec) where + +import Control.Exception.Safe (withException) +import Control.Monad (mapM_) +import Data.Aeson (Value(..)) +import qualified Data.HashMap.Strict as HM +import Data.List (sortOn, sort) +import Data.Monoid ((<>), mempty) +import Data.Text (Text, unpack, pack) +import qualified Data.Text.IO as TIO +import Data.Vector (Vector, (!)) +import qualified Data.Vector as V +import qualified Network.Greskell.WebSocket as Gr +import qualified Network.Greskell.WebSocket.Response as Res +import System.IO (stderr) +import Test.Hspec + +import ServerTest.Common + ( withServer, withSpider, sortSnapshotElements, + AText(..), APorts(..), subIdWithAPorts, + alignAPortsToLinkDirection + ) + +import NetSpider.Found + ( FoundLink(..), LinkState(..), FoundNode(..) + ) +import NetSpider.Query (Query, defQuery, startsFrom, unifyLinkSamples) +import NetSpider.Snapshot + ( SnapshotLink, + nodeId, linkNodeTuple, isDirected, linkTimestamp, + isOnBoundary, nodeTimestamp + ) +import qualified NetSpider.Snapshot as S (nodeAttributes, linkAttributes) +import NetSpider.Spider + ( Spider, addFoundNode, getSnapshotSimple, getSnapshot + ) +import NetSpider.Spider.Config (defConfig, Config, Host, Port) +import NetSpider.Unify (unifyStd, UnifyStdConfig(..), defUnifyStdConfig, lsLinkAttributes, latestLinkSample) +import NetSpider.Timestamp (fromEpochSecond) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + spec_getSnapshot + +makeOneNeighborExample :: Spider Text () () -> IO () +makeOneNeighborExample spider = do + let link = FoundLink { targetNode = "n2", + linkState = LinkToTarget, + linkAttributes = () + } + nbs = FoundNode { subjectNode = "n1", + foundAt = fromEpochSecond 100, + 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 + + +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 (fromEpochSecond 100) + 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` fromEpochSecond 100 + S.linkAttributes got_link `shouldBe` () + specify "no neighbor" $ withSpider $ \spider -> do + let nbs :: FoundNode Text () () + nbs = FoundNode { subjectNode = "n1", + foundAt = fromEpochSecond 200, + 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 (fromEpochSecond 200) + 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 = fromEpochSecond 100, + neighborLinks = return link_12, + nodeAttributes = () + } + nbs2 = FoundNode { subjectNode = "n2", + foundAt = fromEpochSecond 200, + 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 (fromEpochSecond 100) + S.nodeAttributes got_n1 `shouldBe` Just () + nodeId got_n2 `shouldBe` "n2" + isOnBoundary got_n2 `shouldBe` False + nodeTimestamp got_n2 `shouldBe` Just (fromEpochSecond 200) + S.nodeAttributes got_n2 `shouldBe` Just () + linkNodeTuple got_l `shouldBe` ("n2", "n1") + isDirected got_l `shouldBe` True + linkTimestamp got_l `shouldBe` fromEpochSecond 200 + 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, + neighborLinks = [ FoundLink + { targetNode = "n2", + linkState = LinkToTarget, + linkAttributes = () + }, + FoundLink + { targetNode = "n3", + linkState = LinkToSubject, + linkAttributes = () + } + ], + nodeAttributes = AText "at 200" + }, + FoundNode + { subjectNode = "n1", + foundAt = fromEpochSecond 100, + neighborLinks = mempty, + nodeAttributes = AText "at 100" + }, + FoundNode + { subjectNode = "n1", + foundAt = fromEpochSecond 150, + neighborLinks = return $ FoundLink + { targetNode = "n2", + linkState = LinkToTarget, + linkAttributes = () + }, + nodeAttributes = AText "at 150" + } + ] + 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 (fromEpochSecond 200) + S.nodeAttributes got_n1 `shouldBe` Just (AText "at 200") + 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` fromEpochSecond 200 + linkNodeTuple got_l31 `shouldBe` ("n3", "n1") + isDirected got_l31 `shouldBe` True + linkTimestamp got_l31 `shouldBe` fromEpochSecond 200 + specify "multi-hop neighbors" $ withSpider $ \spider -> do + let fns :: [FoundNode Text () AText] + fns = [ FoundNode + { subjectNode = intToNodeId 1, + foundAt = fromEpochSecond 100, + neighborLinks = return $ FoundLink + { targetNode = intToNodeId 2, + linkState = LinkToTarget, + linkAttributes = AText "first" + }, + nodeAttributes = () + }, + middleNode 2 $ fromEpochSecond 50, + middleNode 3 $ fromEpochSecond 150, + middleNode 4 $ fromEpochSecond 200, + FoundNode + { subjectNode = intToNodeId 5, + foundAt = fromEpochSecond 150, + 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 (fromEpochSecond 100) + 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) + 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) + 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) + 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) + 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 + 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 + 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 + 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 + 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 = fromEpochSecond 100, + neighborLinks = [ FoundLink + { targetNode = "n2", + linkState = LinkToTarget, + linkAttributes = () + } + ], + nodeAttributes = () + }, + FoundNode + { subjectNode = "n2", + foundAt = fromEpochSecond 150, + neighborLinks = [ FoundLink + { targetNode = "n1", + linkState = LinkToSubject, + linkAttributes = () + }, + FoundLink + { targetNode = "n3", + linkState = LinkBidirectional, + linkAttributes = () + } + ], + nodeAttributes = () + }, + FoundNode + { subjectNode = "n3", + foundAt = fromEpochSecond 100, + 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 (fromEpochSecond 100) + nodeId (got_ns ! 1) `shouldBe` "n2" + isOnBoundary (got_ns ! 1) `shouldBe` False + nodeTimestamp (got_ns ! 1) `shouldBe` Just (fromEpochSecond 150) + nodeId (got_ns ! 2) `shouldBe` "n3" + isOnBoundary (got_ns ! 2) `shouldBe` False + nodeTimestamp (got_ns ! 2) `shouldBe` Just (fromEpochSecond 100) + 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 + linkNodeTuple (got_ls ! 1) `shouldBe` ("n2", "n3") + isDirected (got_ls ! 1) `shouldBe` False + linkTimestamp (got_ls ! 1) `shouldBe` fromEpochSecond 150 + linkNodeTuple (got_ls ! 2) `shouldBe` ("n3", "n1") + isDirected (got_ls ! 2) `shouldBe` True + linkTimestamp (got_ls ! 2) `shouldBe` fromEpochSecond 100 + specify "multiple links between two nodes" $ withSpider $ \spider -> do + let fns :: [FoundNode Text () APorts] + fns = [ FoundNode + { subjectNode = "n1", + foundAt = fromEpochSecond 200, + 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 = fromEpochSecond 100, + 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` fromEpochSecond 200 + linkNodeTuple (got_ls ! 1) `shouldBe` ("n1", "n2") + S.linkAttributes (got_ls ! 1) `shouldBe` APorts "p4" "p8" + linkTimestamp (got_ls ! 1) `shouldBe` fromEpochSecond 200 + linkNodeTuple (got_ls ! 2) `shouldBe` ("n1", "n2") + S.linkAttributes (got_ls ! 2) `shouldBe` APorts "p5" "p10" + linkTimestamp (got_ls ! 2) `shouldBe` fromEpochSecond 200 + V.length got_ls `shouldBe` 3 + specify "link disappears" $ withSpider $ \spider -> do + let fns :: [FoundNode Text () ()] + fns = [ FoundNode + { subjectNode = "n1", + foundAt = fromEpochSecond 100, + nodeAttributes = (), + neighborLinks = [ FoundLink + { targetNode = "n2", + linkState = LinkBidirectional, + linkAttributes = () + } + ] + }, + FoundNode + { subjectNode = "n2", + foundAt = fromEpochSecond 200, + 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 = fromEpochSecond 200, + nodeAttributes = (), + neighborLinks = [ FoundLink + { targetNode = "n2", + linkState = LinkBidirectional, + linkAttributes = () + } + ] + }, + FoundNode + { subjectNode = "n2", + foundAt = fromEpochSecond 100, + 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` fromEpochSecond 200 + 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 = fromEpochSecond 200, + nodeAttributes = (), + neighborLinks = links2 + }, + FoundNode + { subjectNode = "n1", + foundAt = fromEpochSecond 100, + 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 $ fromEpochSecond 100) + nodeId (got_ns ! 1) `shouldBe` "n2" + nodeTimestamp (got_ns ! 1) `shouldBe` (Just $ fromEpochSecond 200) + 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 + 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 + 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 + +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) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}