diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,20 @@ # Revision history for net-spider-rpl +## 0.4.1.0 -- 2020-01-26 + +* Add `FromJSON` and `ToJSON` instances to the following + types. + * `DIONode` + * `DIOLink` + * `NeighborType` + * `MergedDIOLink` + * `DAONode` + * `DAOLink` + * `CombinedNode` + * `CombinedLink` + * `FindingType` +* Add `ToJSON` instance to `IPv6ID`. + ## 0.4.0.1 -- 2019-12-29 * Confirm `ip-1.7.0` and `fast-logger-3.0.0`. 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.4.0.1 +version: 0.4.1.0 author: Toshio Ito maintainer: Toshio Ito license: BSD3 @@ -32,6 +32,7 @@ NetSpider.RPL.Combined, NetSpider.RPL.ContikiNG, NetSpider.RPL.IPv6 + other-modules: NetSpider.RPL.JSONUtil build-depends: base >=4.11.1.0 && <4.13, aeson >=1.3.1.1 && <1.5, greskell >=1.0.0.0 && <1.1, @@ -44,7 +45,8 @@ conduit >=1.3.1 && <1.4, mtl >=2.2.2 && <2.3, safe-exceptions >=0.1.7.0 && <0.2, - monad-logger >=0.3.28.1 && <0.4 + monad-logger >=0.3.28.1 && <0.4, + regex-applicative >=0.3.3 && <0.4 -- executable net-spider-rpl -- default-language: Haskell2010 @@ -65,8 +67,12 @@ -- default-extensions: other-extensions: OverloadedStrings other-modules: NetSpider.RPL.ContikiNGSpec, - NetSpider.RPL.IPv6Spec - build-depends: base, net-spider-rpl, net-spider, text, monad-logger, ip, + NetSpider.RPL.IPv6Spec, + NetSpider.RPL.DIOSpec, + NetSpider.RPL.DAOSpec, + NetSpider.RPL.CombinedSpec, + JSONUtil + build-depends: base, net-spider-rpl, net-spider, text, monad-logger, ip, aeson, hspec >=2.5.5, bytestring >=0.10.8.2 && <0.11, fast-logger >=2.4.11 && <3.1 diff --git a/src/NetSpider/RPL/Combined.hs b/src/NetSpider/RPL/Combined.hs --- a/src/NetSpider/RPL/Combined.hs +++ b/src/NetSpider/RPL/Combined.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} -- | -- Module: NetSpider.RPL.Combined -- Description: Snapshot graph combining DIO and DAO graphs @@ -19,12 +19,15 @@ combinedLinkType ) where +import Data.Aeson (FromJSON(..), ToJSON(..)) +import qualified Data.Aeson as Aeson import Data.Bifunctor (bimap, second) import Data.List (sortOn, reverse) import Data.Semigroup (Semigroup(..)) import Data.Maybe (isJust) import Data.Monoid (Monoid(..), First(..)) import GHC.Exts (groupWith) +import GHC.Generics (Generic) import qualified NetSpider.GraphML.Writer as GraphML import NetSpider.Snapshot ( SnapshotNode, SnapshotLink, SnapshotGraph, @@ -34,6 +37,7 @@ import NetSpider.RPL.FindingID (FindingID(..), FindingType(..), IPv6ID, ipv6Only) import NetSpider.RPL.DIO (DIONode, MergedDIOLink, SnapshotGraphDIO) import NetSpider.RPL.DAO (DAONode, DAOLink, SnapshotGraphDAO) +import NetSpider.RPL.JSONUtil (optCombinedNode, optCombinedLink) -- | Node attributes combining 'DIONode' and 'DAONode'. data CombinedNode = @@ -41,7 +45,7 @@ { attrsDIO :: Maybe DIONode, attrsDAO :: Maybe DAONode } - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic) -- | Based on instance of 'First'. instance Semigroup CombinedNode where @@ -59,16 +63,34 @@ toAttributes cn = (GraphML.toAttributes $ attrsDIO cn) ++ (GraphML.toAttributes $ attrsDAO cn) +-- | @since 0.4.1.0 +instance FromJSON CombinedNode where + parseJSON = Aeson.genericParseJSON optCombinedNode + +-- | @since 0.4.1.0 +instance ToJSON CombinedNode where + toJSON = Aeson.genericToJSON optCombinedNode + toEncoding = Aeson.genericToEncoding optCombinedNode + -- | Link attribute combining 'MergedDIOLink' and 'DAOLink'. data CombinedLink = CombinedDIOLink MergedDIOLink | CombinedDAOLink DAOLink - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic) instance GraphML.ToAttributes CombinedLink where toAttributes (CombinedDIOLink ll) = ("link_type", GraphML.AttrString "dio") : GraphML.toAttributes ll toAttributes (CombinedDAOLink ll) = ("link_type", GraphML.AttrString "dao") : GraphML.toAttributes ll + +-- | @since 0.4.1.0 +instance FromJSON CombinedLink where + parseJSON = Aeson.genericParseJSON optCombinedLink + +-- | @since 0.4.1.0 +instance ToJSON CombinedLink where + toJSON = Aeson.genericToJSON optCombinedLink + toEncoding = Aeson.genericToEncoding optCombinedLink combinedLinkType :: CombinedLink -> FindingType combinedLinkType (CombinedDIOLink _) = FindingDIO 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} -- | -- Module: NetSpider.RPL.DAO -- Description: Node and link information based on DAO (Destination Advertisement Object) @@ -21,12 +21,14 @@ ) import Control.Applicative ((<$>), (<*>)) -import Data.Aeson (ToJSON(..)) +import Data.Aeson (ToJSON(..), FromJSON(..)) +import qualified Data.Aeson as Aeson import Data.Greskell ( lookupAs', Key, pMapToFail, lookupAs, keyText ) import Data.Greskell.Extra (writeKeyValues, (<=:>), (<=?>)) import Data.Maybe (listToMaybe) +import GHC.Generics (Generic) import NetSpider.Found (FoundNode) import NetSpider.Graph (NodeAttributes(..), LinkAttributes(..), VFoundNode, EFinds) import qualified NetSpider.GraphML.Writer as GraphML @@ -36,6 +38,7 @@ import qualified NetSpider.Unify as Unify import NetSpider.RPL.FindingID (FindingID) +import NetSpider.RPL.JSONUtil (optSnake) -- | 'FoundNode' for a network described by DAOs. type FoundNodeDAO = FoundNode FindingID DAONode DAOLink @@ -56,7 +59,7 @@ -- supposed to be 'Nothing', because they don't have a downward -- routing table. } - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic) keyDaoRouteNum :: Key VFoundNode (Maybe Word) keyDaoRouteNum = "dao_route_num" @@ -71,7 +74,15 @@ Nothing -> [] Just p -> [(keyText keyDaoRouteNum, GraphML.AttrInt $ fromIntegral $ p)] +-- | @since 0.4.1.0 +instance FromJSON DAONode where + parseJSON = Aeson.genericParseJSON optSnake +-- | @since 0.4.1.0 +instance ToJSON DAONode where + toJSON = Aeson.genericToJSON optSnake + toEncoding = Aeson.genericToEncoding optSnake + -- | Link attributes about DAO. -- -- In Storing mode of RPL, a 'DAOLink' represents a link between the @@ -87,7 +98,7 @@ -- Lifetime is advertised in Transit Information Option in DAO, -- and managed in the routing table. } - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic) keyPathLifetimeSec :: Key EFinds Word keyPathLifetimeSec = "path_lifetime_sec" @@ -101,6 +112,15 @@ instance GraphML.ToAttributes DAOLink where toAttributes dl = [ (keyText keyPathLifetimeSec, GraphML.AttrInt $ fromIntegral $ pathLifetimeSec dl) ] + +-- | @since 0.4.1.0 +instance FromJSON DAOLink where + parseJSON = Aeson.genericParseJSON optSnake + +-- | @since 0.4.1.0 +instance ToJSON DAOLink where + toJSON = Aeson.genericToJSON optSnake + toEncoding = Aeson.genericToEncoding optSnake -- | Default 'Query.Query' for DAO nodes. daoDefQuery :: [FindingID] -- ^ 'Query.startsFrom' field. 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings, DeriveGeneric #-} -- | -- Module: NetSpider.RPL.DIO -- Description: Node and link information based on DIO (DODAG Information Object) @@ -23,8 +23,9 @@ dioUnifierConf ) where -import Control.Applicative ((<$>), (<*>)) -import Data.Aeson (ToJSON(..)) +import Control.Applicative ((<$>), (<*>), empty) +import Data.Aeson (ToJSON(..), FromJSON(..)) +import qualified Data.Aeson as Aeson import Data.Bifunctor (bimap) import Data.Greskell ( Property, GValue, @@ -36,6 +37,7 @@ import Data.Monoid ((<>)) import Data.Text (Text, unpack) import Data.Word (Word32) +import GHC.Generics (Generic) import NetSpider.Found (FoundNode, LinkState(..)) import NetSpider.Graph (NodeAttributes(..), LinkAttributes(..), VFoundNode, EFinds) import qualified NetSpider.GraphML.Writer as GraphML @@ -45,6 +47,7 @@ import qualified NetSpider.Unify as Unify import NetSpider.RPL.FindingID (FindingID) +import NetSpider.RPL.JSONUtil (optSnake) -- | 'FoundNode' for a network described by DIOs. type FoundNodeDIO = FoundNode FindingID DIONode DIOLink @@ -70,7 +73,7 @@ dioInterval :: TrickleInterval -- ^ Current interval of Trickle timer for DIO transmission. } - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic) keyRank :: Key VFoundNode Rank keyRank = "rank" @@ -93,6 +96,15 @@ (keyText keyDioInterval, GraphML.AttrInt $ fromIntegral $ dioInterval ln) ] +-- | @since 0.4.1.0 +instance FromJSON DIONode where + parseJSON = Aeson.genericParseJSON optSnake + +-- | @since 0.4.1.0 +instance ToJSON DIONode where + toJSON = Aeson.genericToJSON optSnake + toEncoding = Aeson.genericToEncoding optSnake + -- | Classification of RPL neighbors. data NeighborType = PreferredParent -- ^ The neighbor is the preferred parent. @@ -101,7 +113,7 @@ -- is in the parent set. | OtherNeighbor -- ^ The neighbor is not in the parent set. - deriving (Show,Eq,Ord,Enum,Bounded) + deriving (Show,Eq,Ord,Enum,Bounded,Generic) neighborTypeToText :: NeighborType -> Text neighborTypeToText nt = case nt of @@ -129,10 +141,21 @@ where fromT t = maybe (fail ("Unknown neighbor type: " <> unpack t)) return $ neighborTypeFromText t --- | @since 0.4.0.0 +-- | Encode to a JSON string. +-- +-- @since 0.4.0.0 instance ToJSON NeighborType where toJSON n = toJSON $ neighborTypeToText n +-- | Decode from a JSON string. +-- +-- @since 0.4.1.0 +instance FromJSON NeighborType where + parseJSON (Aeson.String t) = maybe (fail err_msg) return $ neighborTypeFromText t + where + err_msg = "Invalid string for NeighborType: " <> show t + parseJSON _ = empty + instance LinkAttributes NeighborType where writeLinkAttributes nt = fmap writeKeyValues $ sequence [keyNeighborType <=:> nt] parseLinkAttributes ps = pMapToFail $ lookupAs keyNeighborType ps @@ -152,7 +175,7 @@ -- Rank computation is up to the Objective Function, this field is -- optional. } - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic) keyNeighborRank :: Key EFinds Rank keyNeighborRank = "neighbor_rank" @@ -192,8 +215,16 @@ case metric ll of Nothing -> [] Just m -> [(keyText keyMetric, GraphML.AttrInt $ fromIntegral m)] - +-- | @since 0.4.1.0 +instance FromJSON DIOLink where + parseJSON = Aeson.genericParseJSON optSnake + +-- | @since 0.4.1.0 +instance ToJSON DIOLink where + toJSON = Aeson.genericToJSON optSnake + toEncoding = Aeson.genericToEncoding optSnake + -- | Link attributes merging two 'DIOLink's from the two end nodes -- of the link. data MergedDIOLink = @@ -201,7 +232,7 @@ { fromSource :: DIOLink, fromDest :: Maybe DIOLink } - deriving (Show,Eq,Ord) + deriving (Show,Eq,Ord,Generic) withKeyPrefix :: Monoid k => k @@ -255,3 +286,12 @@ Nothing -> [] Just dl -> withKeyPrefix "dest_" $ GraphML.toAttributes dl ) + +-- | @since 0.4.1.0 +instance FromJSON MergedDIOLink where + parseJSON = Aeson.genericParseJSON optSnake + +-- | @since 0.4.1.0 +instance ToJSON MergedDIOLink where + toJSON = Aeson.genericToJSON optSnake + toEncoding = Aeson.genericToEncoding optSnake diff --git a/src/NetSpider/RPL/FindingID.hs b/src/NetSpider/RPL/FindingID.hs --- a/src/NetSpider/RPL/FindingID.hs +++ b/src/NetSpider/RPL/FindingID.hs @@ -21,7 +21,7 @@ ipv6Only ) where -import Control.Applicative ((<$>), (<*>)) +import Control.Applicative ((<$>), (<*>), empty) import Control.Monad.Fail (MonadFail) import Data.Bits (shiftL, (.|.)) import Data.Monoid ((<>)) @@ -61,6 +61,17 @@ "dao" -> Just FindingDAO _ -> Nothing +-- | @since 0.4.1.0 +instance FromJSON FindingType where + parseJSON (Aeson.String t) = maybe (fail err_msg) return $ typeFromText t + where + err_msg = "Invalid string as FindingType: " <> show t + parseJSON _ = empty + +-- | @since 0.4.1.0 +instance ToJSON FindingType where + toJSON = Aeson.String . typeToText + -- | The node ID. -- -- Basically a node is identified by its IPv6 address in RPL @@ -136,6 +147,10 @@ instance FromJSON IPv6ID where parseJSON v = parseIPv6IDFromText =<< parseJSON v + +-- | @since 0.4.1.0 +instance ToJSON IPv6ID where + toJSON = Aeson.String . ipv6ToText instance FromGraphSON IPv6ID where parseGraphSON gv = parseIPv6IDFromText =<< parseGraphSON gv diff --git a/src/NetSpider/RPL/JSONUtil.hs b/src/NetSpider/RPL/JSONUtil.hs new file mode 100644 --- /dev/null +++ b/src/NetSpider/RPL/JSONUtil.hs @@ -0,0 +1,41 @@ +-- | +-- Module: NetSpider.RPL.JSONUtil +-- Description: +-- Maintainer: Toshio Ito +-- +-- __This is an internal module. End-users should not use it.__ +module NetSpider.RPL.JSONUtil + ( optSnake, + optCombinedNode, + optCombinedLink + ) where + +import Control.Applicative ((*>), (<*), (<|>)) +import qualified Data.Aeson as Aeson +import Data.Char (isUpper, toLower) +import qualified Text.Regex.Applicative as RE + +toSnake :: String -> String +toSnake = RE.replace $ RE.msym (\c -> if isUpper c then Just ['_', toLower c] else Nothing) + +optSnake :: Aeson.Options +optSnake = Aeson.defaultOptions { Aeson.fieldLabelModifier = toSnake } + +optCombinedNode :: Aeson.Options +optCombinedNode = Aeson.defaultOptions { Aeson.fieldLabelModifier = modifier } + where + modifier = map toLower . RE.replace (fmap (const "") $ RE.string "attrs") + +optCombinedLink :: Aeson.Options +optCombinedLink = + Aeson.defaultOptions + { Aeson.constructorTagModifier = tag_modifier, + Aeson.sumEncoding = + Aeson.TaggedObject + { Aeson.tagFieldName = "link_type", + Aeson.contentsFieldName = "link" + } + } + where + tag_modifier = RE.replace regex + regex = fmap (map toLower) (RE.string "Combined" *> (RE.string "DIO" <|> RE.string "DAO") <* RE.string "Link") diff --git a/test/JSONUtil.hs b/test/JSONUtil.hs new file mode 100644 --- /dev/null +++ b/test/JSONUtil.hs @@ -0,0 +1,24 @@ +module JSONUtil + ( specJSONFromTo + ) where + +import Data.Aeson (FromJSON, ToJSON) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as BSL +import Data.Either (isRight) +import Test.Hspec + +specJSONFromTo :: (FromJSON a, ToJSON a, Show a, Eq a) + => String -- ^ spec name + -> BSL.ByteString -- ^ JSON document + -> a -- ^ expected data + -> Spec +specJSONFromTo spec_name json_doc exp_data = do + specify ("JSONFromTo: " ++ spec_name) $ do + let got_dec = Aeson.eitherDecode json_doc + got_enc_v :: Either String Aeson.Value + got_enc_v = Aeson.eitherDecode $ Aeson.encode exp_data + exp_enc = Aeson.eitherDecode json_doc + got_dec `shouldBe` Right exp_data + isRight exp_enc `shouldBe` True + got_enc_v `shouldBe` exp_enc diff --git a/test/NetSpider/RPL/CombinedSpec.hs b/test/NetSpider/RPL/CombinedSpec.hs new file mode 100644 --- /dev/null +++ b/test/NetSpider/RPL/CombinedSpec.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} +module NetSpider.RPL.CombinedSpec (main,spec) where + +import Data.Monoid ((<>)) +import Test.Hspec + +import JSONUtil (specJSONFromTo) + +import NetSpider.RPL.DIO (DIONode(..), MergedDIOLink(..), DIOLink(..), NeighborType(..)) +import NetSpider.RPL.DAO (DAONode(..), DAOLink(..)) +import NetSpider.RPL.Combined (CombinedNode(..), CombinedLink(..)) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "CombinedNode" $ do + specJSONFromTo + "non-empty DIO and DAO attributes" + "{\"dio\": {\"rank\": 256, \"dio_interval\": 12}, \"dao\": {\"dao_route_num\": null}}" + CombinedNode + { attrsDIO = Just $ DIONode { rank = 256, dioInterval = 12 }, + attrsDAO = Just $ DAONode { daoRouteNum = Nothing } + } + describe "CombinedLink" $ do + specJSONFromTo + "case DIOLink" + ( "{\"link_type\": \"dio\", \"link\": " + <> " {\"from_dest\": null, \"from_source\": {\"neighbor_type\": \"preferred_parent\", \"neighbor_rank\": 332, \"metric\": 183}}}" + ) + ( CombinedDIOLink $ + MergedDIOLink + { fromDest = Nothing, + fromSource = + DIOLink + { neighborType = PreferredParent, + neighborRank = 332, + metric = Just 183 + } + } + ) + specJSONFromTo + "case DAOLink" + ( "{\"link_type\": \"dao\", \"link\": " + <> " {\"path_lifetime_sec\": 1990}}" + ) + ( CombinedDAOLink $ + DAOLink + { pathLifetimeSec = 1990 + } + ) + diff --git a/test/NetSpider/RPL/DAOSpec.hs b/test/NetSpider/RPL/DAOSpec.hs new file mode 100644 --- /dev/null +++ b/test/NetSpider/RPL/DAOSpec.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} +module NetSpider.RPL.DAOSpec (main,spec) where + +import Test.Hspec + +import JSONUtil (specJSONFromTo) + +import NetSpider.RPL.DAO (DAONode(..), DAOLink(..)) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "DAONode" $ do + specJSONFromTo + "non-empty daoRouteNum" + "{\"dao_route_num\": 25}" + DAONode { daoRouteNum = Just 25 } + describe "DAOLink" $ do + specJSONFromTo + "normal" + "{\"path_lifetime_sec\": 2560}" + (DAOLink 2560) diff --git a/test/NetSpider/RPL/DIOSpec.hs b/test/NetSpider/RPL/DIOSpec.hs new file mode 100644 --- /dev/null +++ b/test/NetSpider/RPL/DIOSpec.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +module NetSpider.RPL.DIOSpec (main,spec) where + +import Test.Hspec + +import JSONUtil (specJSONFromTo) + +import NetSpider.RPL.DIO + ( DIONode(..), NeighborType(..), DIOLink(..), MergedDIOLink(..) + ) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + describe "DIONode" $ do + specJSONFromTo + "DIONode" + "{\"rank\": 355, \"dio_interval\": 5}" + (DIONode 355 5) + describe "NeighborType" $ do + specJSONFromTo "PreferredParent" "\"preferred_parent\"" PreferredParent + specJSONFromTo "ParentCandidate" "\"parent_candidate\"" ParentCandidate + specJSONFromTo "OtherNeighbor" "\"other_neighbor\"" OtherNeighbor + describe "DIOLink" $ do + specJSONFromTo + "DIOLink with non-empty metric" + "{\"neighbor_type\": \"parent_candidate\", \"neighbor_rank\": 590, \"metric\": 132}" + DIOLink + { neighborType = ParentCandidate, + neighborRank = 590, + metric = Just 132 + } + describe "MergedDIOLink" $ do + specJSONFromTo + "MergedDIOLink with non-empty fromDest" + ( "{\"from_source\": {\"neighbor_type\": \"preferred_parent\", \"neighbor_rank\": 590, \"metric\": 132}," + <> " \"from_dest\": {\"neighbor_type\": \"other_neighbor\", \"neighbor_rank\": 722, \"metric\": null}}" + ) + MergedDIOLink + { fromSource = DIOLink PreferredParent 590 (Just 132), + fromDest = Just $ DIOLink OtherNeighbor 722 Nothing + }