diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,15 @@ # Revision history for net-spider-rpl +## 0.4.0.0 -- 2019-12-28 + +* [BREAKING CHANGE] Changes instances of `LinkAttributes` and + `NodeAttributes` because their signature are changed in + `net-spider-0.4.0.0`. +* This also leads to a bug fix. Before, it could not write or parse + attribute values of 'Nothing'. +* Add `FromGraphSON` and `ToJSON` instances to `NeighborType`. + + ## 0.3.1.0 -- 2019-10-04 * Expose an internal module `NetSpider.RPL.IPv6`. diff --git a/net-spider-rpl.cabal b/net-spider-rpl.cabal --- a/net-spider-rpl.cabal +++ b/net-spider-rpl.cabal @@ -1,5 +1,5 @@ name: net-spider-rpl -version: 0.3.1.0 +version: 0.4.0.0 author: Toshio Ito maintainer: Toshio Ito license: BSD3 @@ -34,8 +34,8 @@ NetSpider.RPL.IPv6 build-depends: base >=4.11.1.0 && <4.13, aeson >=1.3.1.1 && <1.5, - greskell >=0.2.3.0 && <0.3, - net-spider >=0.3.1.0 && <0.4, + greskell >=1.0.0.0 && <1.1, + net-spider >=0.4.0.0 && <0.5, text >=1.2.3.1 && <1.3, ip >=1.3.0 && <1.7, hashable >=1.2.7.0 && <1.4, @@ -70,6 +70,27 @@ hspec >=2.5.5, bytestring >=0.10.8.2 && <0.11, fast-logger >=2.4.11 && <2.5 + +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 + default-extensions: OverloadedStrings + if flag(server-test) + build-depends: base, hspec, net-spider-rpl, net-spider, text, + hspec-need-env >=0.1.0.0 && <0.2 + else + buildable: False source-repository head type: git diff --git a/src/NetSpider/RPL/DAO.hs b/src/NetSpider/RPL/DAO.hs --- a/src/NetSpider/RPL/DAO.hs +++ b/src/NetSpider/RPL/DAO.hs @@ -23,12 +23,12 @@ import Control.Applicative ((<$>), (<*>)) import Data.Aeson (ToJSON(..)) import Data.Greskell - ( parseOneValue, parseListValues + ( lookupAs', Key, pMapToFail, lookupAs, keyText ) -import Data.Greskell.Extra (writePropertyKeyValues) +import Data.Greskell.Extra (writeKeyValues, (<=:>), (<=?>)) import Data.Maybe (listToMaybe) import NetSpider.Found (FoundNode) -import NetSpider.Graph (NodeAttributes(..), LinkAttributes(..)) +import NetSpider.Graph (NodeAttributes(..), LinkAttributes(..), VFoundNode, EFinds) import qualified NetSpider.GraphML.Writer as GraphML import qualified NetSpider.Query as Query import NetSpider.Snapshot (SnapshotGraph) @@ -58,20 +58,18 @@ } deriving (Show,Eq,Ord) +keyDaoRouteNum :: Key VFoundNode (Maybe Word) +keyDaoRouteNum = "dao_route_num" + instance NodeAttributes DAONode where - writeNodeAttributes dn = writePropertyKeyValues pairs - where - pairs = - case daoRouteNum dn of - Nothing -> [] - Just n -> [("dao_route_num", toJSON n)] - parseNodeAttributes ps = fmap (DAONode . listToMaybe) $ parseListValues "dao_route_num" ps + writeNodeAttributes dn = fmap writeKeyValues $ sequence [keyDaoRouteNum <=?> daoRouteNum dn] + parseNodeAttributes ps = DAONode <$> (pMapToFail $ lookupAs' keyDaoRouteNum ps) instance GraphML.ToAttributes DAONode where toAttributes dn = case daoRouteNum dn of Nothing -> [] - Just p -> [("dao_route_num", GraphML.AttrInt $ fromIntegral $ p)] + Just p -> [(keyText keyDaoRouteNum, GraphML.AttrInt $ fromIntegral $ p)] -- | Link attributes about DAO. @@ -91,15 +89,18 @@ } deriving (Show,Eq,Ord) +keyPathLifetimeSec :: Key EFinds Word +keyPathLifetimeSec = "path_lifetime_sec" + instance LinkAttributes DAOLink where - writeLinkAttributes dl = writePropertyKeyValues pairs + writeLinkAttributes dl = fmap writeKeyValues $ sequence pairs where - pairs = [ ("path_lifetime_sec", toJSON $ pathLifetimeSec dl) + pairs = [ keyPathLifetimeSec <=:> pathLifetimeSec dl ] - parseLinkAttributes ps = DAOLink <$> parseOneValue "path_lifetime_sec" ps + parseLinkAttributes ps = DAOLink <$> (pMapToFail $ lookupAs keyPathLifetimeSec ps) instance GraphML.ToAttributes DAOLink where - toAttributes dl = [ ("path_lifetime_sec", GraphML.AttrInt $ fromIntegral $ pathLifetimeSec dl) ] + toAttributes dl = [ (keyText keyPathLifetimeSec, GraphML.AttrInt $ fromIntegral $ pathLifetimeSec dl) ] -- | Default 'Query.Query' for DAO nodes. daoDefQuery :: [FindingID] -- ^ 'Query.startsFrom' field. @@ -110,6 +111,6 @@ Query.unifyLinkSamples = Unify.unifyStd daoUnifierConf } --- | 'UnifyStdConfig' for RPL DAO data. Used in 'defQuery'. +-- | 'UnifyStdConfig' for RPL DAO data. Used in 'daoDefQuery'. daoUnifierConf :: UnifyStdConfig FindingID DAONode DAOLink DAOLink () daoUnifierConf = Unify.defUnifyStdConfig { Unify.negatesLinkSample = \_ _ -> False } diff --git a/src/NetSpider/RPL/DIO.hs b/src/NetSpider/RPL/DIO.hs --- a/src/NetSpider/RPL/DIO.hs +++ b/src/NetSpider/RPL/DIO.hs @@ -27,15 +27,17 @@ import Data.Aeson (ToJSON(..)) import Data.Bifunctor (bimap) import Data.Greskell - ( PropertyMap, Property, GValue, parseOneValue, - Binder, Walk, SideEffect, Element, Parser + ( Property, GValue, + Binder, Walk, SideEffect, Element, Parser, + Key, pMapToFail, lookupAs, lookupAs', keyText, + FromGraphSON(..) ) -import Data.Greskell.Extra (writePropertyKeyValues) +import Data.Greskell.Extra (writeKeyValues, (<=:>), (<=?>)) import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Data.Word (Word32) import NetSpider.Found (FoundNode, LinkState(..)) -import NetSpider.Graph (NodeAttributes(..), LinkAttributes(..)) +import NetSpider.Graph (NodeAttributes(..), LinkAttributes(..), VFoundNode, EFinds) import qualified NetSpider.GraphML.Writer as GraphML import qualified NetSpider.Query as Query import NetSpider.Snapshot (SnapshotGraph) @@ -70,19 +72,25 @@ } deriving (Show,Eq,Ord) +keyRank :: Key VFoundNode Rank +keyRank = "rank" + +keyDioInterval :: Key VFoundNode TrickleInterval +keyDioInterval = "dio_interval" + instance NodeAttributes DIONode where - writeNodeAttributes ln = writePropertyKeyValues pairs + writeNodeAttributes ln = fmap writeKeyValues $ sequence pairs where - pairs = [ ("rank", toJSON $ rank ln), - ("dio_interval", toJSON $ dioInterval ln) + pairs = [ keyRank <=:> rank ln, + keyDioInterval <=:> dioInterval ln ] - parseNodeAttributes ps = DIONode - <$> parseOneValue "rank" ps - <*> parseOneValue "dio_interval" ps + parseNodeAttributes ps = pMapToFail $ DIONode + <$> lookupAs keyRank ps + <*> lookupAs keyDioInterval ps instance GraphML.ToAttributes DIONode where - toAttributes ln = [ ("rank", GraphML.AttrInt $ fromIntegral $ rank ln), - ("dio_interval", GraphML.AttrInt $ fromIntegral $ dioInterval ln) + toAttributes ln = [ (keyText keyRank, GraphML.AttrInt $ fromIntegral $ rank ln), + (keyText keyDioInterval, GraphML.AttrInt $ fromIntegral $ dioInterval ln) ] -- | Classification of RPL neighbors. @@ -112,12 +120,23 @@ adaptWalk :: (Element e1, Element e2) => Walk SideEffect e1 e1 -> Walk SideEffect e2 e2 adaptWalk = bimap undefined undefined -instance LinkAttributes NeighborType where - writeLinkAttributes nt = writePropertyKeyValues [("neighbor_type", neighborTypeToText nt)] - parseLinkAttributes ps = fromT =<< parseOneValue "neighbor_type" ps +keyNeighborType :: Key EFinds NeighborType +keyNeighborType = "neighbor_type" + +-- | @since 0.4.0.0 +instance FromGraphSON NeighborType where + parseGraphSON gv = fromT =<< parseGraphSON gv where fromT t = maybe (fail ("Unknown neighbor type: " <> unpack t)) return $ neighborTypeFromText t +-- | @since 0.4.0.0 +instance ToJSON NeighborType where + toJSON n = toJSON $ neighborTypeToText n + +instance LinkAttributes NeighborType where + writeLinkAttributes nt = fmap writeKeyValues $ sequence [keyNeighborType <=:> nt] + parseLinkAttributes ps = pMapToFail $ lookupAs keyNeighborType ps + -- | Link attributes about DIO. -- -- Basically this represents information of a neighbor learned from @@ -135,20 +154,26 @@ } deriving (Show,Eq,Ord) +keyNeighborRank :: Key EFinds Rank +keyNeighborRank = "neighbor_rank" + +keyMetric :: Key EFinds (Maybe Rank) +keyMetric = "metric" + instance LinkAttributes DIOLink where writeLinkAttributes ll = do nt_steps <- writeLinkAttributes $ neighborType ll - other <- writePropertyKeyValues pairs + other <- fmap writeKeyValues $ sequence pairs return (adaptWalk nt_steps <> other) where - pairs = [ ("neighbor_rank", toJSON $ neighborRank ll), - ("metric", toJSON $ metric ll) + pairs = [ keyNeighborRank <=:> neighborRank ll, + keyMetric <=?> metric ll ] parseLinkAttributes ps = DIOLink <$> parseLinkAttributes ps - <*> parseOneValue "neighbor_rank" ps - <*> parseOneValue "metric" ps + <*> (pMapToFail $ lookupAs keyNeighborRank ps) + <*> (pMapToFail $ lookupAs' keyMetric ps) -- | 'LinkState' that should be set for given 'DIOLink'. dioLinkState :: DIOLink -> LinkState @@ -158,15 +183,15 @@ _ -> LinkUnused instance GraphML.ToAttributes DIOLink where - toAttributes ll = [ ("neighbor_type", GraphML.AttrString $ neighborTypeToText $ neighborType ll), - ("neighbor_rank", GraphML.AttrInt $ fromIntegral $ neighborRank ll) + toAttributes ll = [ (keyText keyNeighborType, GraphML.AttrString $ neighborTypeToText $ neighborType ll), + (keyText keyNeighborRank, GraphML.AttrInt $ fromIntegral $ neighborRank ll) ] ++ at_metric where at_metric = case metric ll of Nothing -> [] - Just m -> [("metric", GraphML.AttrInt $ fromIntegral m)] + Just m -> [(keyText keyMetric, GraphML.AttrInt $ fromIntegral m)] -- | Link attributes merging two 'DIOLink's from the two end nodes diff --git a/test/ServerTest.hs b/test/ServerTest.hs new file mode 100644 --- /dev/null +++ b/test/ServerTest.hs @@ -0,0 +1,162 @@ +module Main (main,spec) where + +import Control.Monad (mapM_) +import Data.List (sort) +import Data.Maybe (fromJust) +import Data.Text (Text) +import NetSpider.Found (FoundNode(..), FoundLink(..), LinkState(..)) +import qualified NetSpider.Snapshot as Sn +import NetSpider.Spider (Spider, withSpider, addFoundNode, clearAll, getSnapshot) +import NetSpider.Spider.Config (Host, Port, defConfig, wsHost, wsPort) +import NetSpider.Timestamp (fromEpochMillisecond) +import Test.Hspec +import Test.Hspec.NeedEnv (needEnvHostPort, EnvMode(Need)) + +import NetSpider.RPL.DAO + ( DAONode(..), DAOLink(..), daoDefQuery + ) +import NetSpider.RPL.DIO + ( DIONode(..), DIOLink(..), NeighborType(..), dioDefQuery, + MergedDIOLink(..) + ) +import NetSpider.RPL.FindingID (FindingID, idFromText) + +main :: IO () +main = hspec spec + +withSpider' :: (Spider FindingID na fla -> IO ()) -> (Host, Port) -> IO () +withSpider' act (h, p) = withSpider conf act + where + conf = defConfig { wsHost = h, wsPort = p } + +sortBoth :: (Ord a, Ord b) => ([a], [b]) -> ([a], [b]) +sortBoth (as, bs) = (sort as, sort bs) + +idBoth :: (Text, Text) -> (FindingID, FindingID) +idBoth (a, b) = (fromJust $ idFromText a, fromJust $ idFromText b) + +spec :: Spec +spec = before (needEnvHostPort Need "NET_SPIDER_TEST") $ describe "server test" $ do + specify "DIONode and DIOLink" $ withSpider' $ \spider -> do + let input = [ FoundNode + { subjectNode = fromJust $ idFromText "dio://[fd00::1]", + foundAt = fromEpochMillisecond 120, + nodeAttributes = DIONode { rank = 256, dioInterval = 5 }, + neighborLinks = [] + }, + FoundNode + { subjectNode = fromJust $ idFromText "dio://[fd00::2]", + foundAt = fromEpochMillisecond 125, + nodeAttributes = DIONode { rank = 556, dioInterval = 7 }, + neighborLinks = + [ FoundLink + { targetNode = fromJust $ idFromText "dio://[fd00::1]", + linkState = LinkToTarget, + linkAttributes = + DIOLink + { neighborType = PreferredParent, + neighborRank = 256, + metric = Just 300 + } + } + ] + }, + FoundNode + { subjectNode = fromJust $ idFromText "dio://[fd00::3]", + foundAt = fromEpochMillisecond 122, + nodeAttributes = DIONode { rank = 618 , dioInterval = 7 }, + neighborLinks = + [ FoundLink + { targetNode = fromJust $ idFromText "dio://[fd00::1]", + linkState = LinkToTarget, + linkAttributes = + DIOLink + { neighborType = PreferredParent, + neighborRank = 256, + metric = Nothing + } + } + ] + } + ] + clearAll spider + mapM_ (addFoundNode spider) input + let query = dioDefQuery $ map (fromJust . idFromText) ["dio://[fd00::2]", "dio://[fd00::3]"] + (got_nodes, got_links) <- fmap sortBoth $ getSnapshot spider query + map Sn.nodeId got_nodes `shouldBe` + map (fromJust . idFromText) [ "dio://[fd00::1]", + "dio://[fd00::2]", + "dio://[fd00::3]" + ] + map Sn.nodeAttributes got_nodes `shouldBe` + [ Just $ DIONode { rank = 256, dioInterval = 5 }, + Just $ DIONode { rank = 556, dioInterval = 7 }, + Just $ DIONode { rank = 618, dioInterval = 7 } + ] + map Sn.linkNodeTuple got_links `shouldBe` + [ idBoth ("dio://[fd00::2]", "dio://[fd00::1]"), + idBoth ("dio://[fd00::3]", "dio://[fd00::1]") + ] + map Sn.linkAttributes got_links `shouldBe` + [ MergedDIOLink + ( DIOLink + { neighborType = PreferredParent, + neighborRank = 256, + metric = Just 300 + } + ) + Nothing, + MergedDIOLink + ( DIOLink + { neighborType = PreferredParent, + neighborRank = 256, + metric = Nothing + } + ) + Nothing + ] + specify "DAONode and DAOLink" $ withSpider' $ \spider -> do + let input = + [ FoundNode + { subjectNode = fromJust $ idFromText "dao://[fd00::1]", + foundAt = fromEpochMillisecond 100, + nodeAttributes = DAONode { daoRouteNum = Just 1 }, + neighborLinks = [] + }, + FoundNode + { subjectNode = fromJust $ idFromText "dao://[fd00::2]", + foundAt = fromEpochMillisecond 100, + nodeAttributes = DAONode { daoRouteNum = Nothing }, + neighborLinks = + [ FoundLink + { targetNode = fromJust $ idFromText "dao://[fd00::1]", + linkState = LinkToTarget, + linkAttributes = + DAOLink + { pathLifetimeSec = 1200 + } + } + ] + } + ] + clearAll spider + mapM_ (addFoundNode spider) input + let query = daoDefQuery $ map (fromJust . idFromText) ["dao://[fd00::2]"] + (got_nodes, got_links) <- fmap sortBoth $ getSnapshot spider query + map Sn.nodeId got_nodes `shouldBe` + map (fromJust . idFromText) [ "dao://[fd00::1]", + "dao://[fd00::2]" + ] + map Sn.nodeAttributes got_nodes `shouldBe` + [ Just $ DAONode { daoRouteNum = Just 1 }, + Just $ DAONode { daoRouteNum = Nothing } + ] + map Sn.linkNodeTuple got_links `shouldBe` + [ idBoth ("dao://[fd00::2]", "dao://[fd00::1]") + ] + map Sn.linkAttributes got_links `shouldBe` + [ DAOLink + { pathLifetimeSec = 1200 + } + ] +