net-spider (empty) → 0.1.0.0

raw patch · 26 files changed

+2363/−0 lines, 26 filesdep +aesondep +basedep +containerssetup-changed

Dependencies added: aeson, base, containers, greskell, greskell-websocket, hashable, hspec, hspec-need-env, net-spider, safe-exceptions, text, time, unordered-containers, vector

Files

• ChangeLog.md +5/−0
• LICENSE +30/−0
• README.md +10/−0
• Setup.hs +2/−0
• net-spider.cabal +101/−0
• src/NetSpider.hs +39/−0
• src/NetSpider/Found.hs +82/−0
• src/NetSpider/Graph.hs +20/−0
• src/NetSpider/Graph/Internal.hs +158/−0
• src/NetSpider/Input.hs +20/−0
• src/NetSpider/Output.hs +24/−0
• src/NetSpider/Pair.hs +50/−0
• src/NetSpider/Query.hs +46/−0
• src/NetSpider/Queue.hs +35/−0
• src/NetSpider/Snapshot.hs +67/−0
• src/NetSpider/Snapshot/Internal.hs +62/−0
• src/NetSpider/Spider.hs +334/−0
• src/NetSpider/Spider/Config.hs +62/−0
• src/NetSpider/Spider/Internal/Graph.hs +157/−0
• src/NetSpider/Timestamp.hs +30/−0
• src/NetSpider/Unify.hs +183/−0
• test/ServerTest.hs +15/−0
• test/ServerTest/Attributes.hs +130/−0
• test/ServerTest/Common.hs +127/−0
• test/ServerTest/Snapshot.hs +573/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,5 @@+# Revision history for net-spider++## 0.1.0.0  -- 2018-09-24++* First version. Released on an unsuspecting world.

@@ -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.

@@ -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 <debug.ito@gmail.co>

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,101 @@+name:                   net-spider+version:                0.1.0.0+author:                 Toshio Ito <debug.ito@gmail.com>+maintainer:             Toshio Ito <debug.ito@gmail.com>+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

@@ -0,0 +1,39 @@+-- |+-- Module: NetSpider+-- Description: NetSpider top-level document+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- 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++

@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module: NetSpider.Found+-- Description: Types about local findings+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- +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)

@@ -0,0 +1,20 @@+-- |+-- Module: NetSpider.Graph+-- Description: Graph data models+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+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(..)+  )

@@ -0,0 +1,158 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, OverloadedStrings #-}+-- |+-- Module: NetSpider.Graph.Internal+-- Description: +-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- __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 ()+  

@@ -0,0 +1,20 @@+-- |+-- Module: NetSpider.Input+-- Description: Bundle module to input data to the database.+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- +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+

@@ -0,0 +1,24 @@+-- |+-- Module: NetSpider.Output+-- Description: Bundle module to output data from the database.+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- +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+

@@ -0,0 +1,50 @@+-- |+-- Module: NetSpider.Pair+-- Description: Swap-insensitive two-element homogeneous tuple+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- +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)+

@@ -0,0 +1,46 @@+-- |+-- Module: NetSpider.Query+-- Description: Query for snapshot graph+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- +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+              }+

@@ -0,0 +1,35 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Module: NetSpider.Queue+-- Description: +-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- __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)

@@ -0,0 +1,67 @@+-- |+-- Module: NetSpider.Snapshot+-- Description: Types about snapshot graph+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- 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

@@ -0,0 +1,62 @@+-- |+-- Module: NetSpider.Snapshot.Internal+-- Description: +-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- __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)

@@ -0,0 +1,334 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies #-}+-- |+-- Module: NetSpider.Spider+-- Description: Spider type.+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- +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+                   }+

@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module: NetSpider.Spider.Config+-- Description: Configuration of Spider+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- +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"+  }+

@@ -0,0 +1,157 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module: NetSpider.Spider.Internal.Graph+-- Description: Graph (greskell) operation for Spider+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- __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"]++  +        

@@ -0,0 +1,30 @@+-- |+-- Module: NetSpider.Timestamp+-- Description: Timestamp type+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- +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

@@ -0,0 +1,183 @@+-- |+-- Module: NetSpider.Unify+-- Description: LinkSampleUnifier type+-- Maintainer: Toshio Ito <debug.ito@gmail.com>+--+-- +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

@@ -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

@@ -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"+                               }+                  }+  

@@ -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

@@ -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)

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}