{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}
module NetSpider.RPL.DIO
(
FoundNodeDIO,
SnapshotGraphDIO,
DIONode(..),
DIOLink(..),
dioLinkState,
MergedDIOLink(..),
Rank,
TrickleInterval,
NeighborType(..),
neighborTypeToText,
neighborTypeFromText,
dioDefQuery,
dioUnifierConf
) where
import Control.Applicative ((<$>), (<*>), empty)
import Data.Aeson (ToJSON(..), FromJSON(..))
import qualified Data.Aeson as Aeson
import Data.Bifunctor (bimap)
import Data.Greskell
( Property, GValue,
Binder, Walk, SideEffect, Element, Parser,
Key, pMapToFail, lookupAs, lookupAs', keyText,
FromGraphSON(..)
)
import Data.Greskell.Extra (writeKeyValues, (<=:>), (<=?>))
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
import qualified NetSpider.Query as Query
import NetSpider.Snapshot (SnapshotGraph)
import NetSpider.Unify (UnifyStdConfig, lsLinkAttributes, latestLinkSample)
import qualified NetSpider.Unify as Unify
import NetSpider.RPL.FindingID (FindingID)
import NetSpider.RPL.JSONUtil (optSnake)
type FoundNodeDIO = FoundNode FindingID DIONode DIOLink
type SnapshotGraphDIO = SnapshotGraph FindingID DIONode MergedDIOLink
type Rank = Word
type TrickleInterval = Word
data DIONode =
DIONode
{ rank :: Rank,
dioInterval :: TrickleInterval
}
deriving (Show,Eq,Ord,Generic)
keyRank :: Key VFoundNode Rank
keyRank = "rank"
keyDioInterval :: Key VFoundNode TrickleInterval
keyDioInterval = "dio_interval"
instance NodeAttributes DIONode where
writeNodeAttributes ln = fmap writeKeyValues $ sequence pairs
where
pairs = [ keyRank <=:> rank ln,
keyDioInterval <=:> dioInterval ln
]
parseNodeAttributes ps = pMapToFail $ DIONode
<$> lookupAs keyRank ps
<*> lookupAs keyDioInterval ps
instance GraphML.ToAttributes DIONode where
toAttributes ln = [ (keyText keyRank, GraphML.AttrInt $ fromIntegral $ rank ln),
(keyText keyDioInterval, GraphML.AttrInt $ fromIntegral $ dioInterval ln)
]
instance FromJSON DIONode where
parseJSON = Aeson.genericParseJSON optSnake
instance ToJSON DIONode where
toJSON = Aeson.genericToJSON optSnake
toEncoding = Aeson.genericToEncoding optSnake
data NeighborType = PreferredParent
| ParentCandidate
| OtherNeighbor
deriving (Show,Eq,Ord,Enum,Bounded,Generic)
neighborTypeToText :: NeighborType -> Text
neighborTypeToText nt = case nt of
PreferredParent -> "preferred_parent"
ParentCandidate -> "parent_candidate"
OtherNeighbor -> "other_neighbor"
neighborTypeFromText :: Text -> Maybe NeighborType
neighborTypeFromText t = case t of
"preferred_parent" -> return PreferredParent
"parent_candidate" -> return ParentCandidate
"other_neighbor" -> return OtherNeighbor
_ -> Nothing
adaptWalk :: (Element e1, Element e2) => Walk SideEffect e1 e1 -> Walk SideEffect e2 e2
adaptWalk = bimap undefined undefined
keyNeighborType :: Key EFinds NeighborType
keyNeighborType = "neighbor_type"
instance FromGraphSON NeighborType where
parseGraphSON gv = fromT =<< parseGraphSON gv
where
fromT t = maybe (fail ("Unknown neighbor type: " <> unpack t)) return $ neighborTypeFromText t
instance ToJSON NeighborType where
toJSON n = toJSON $ neighborTypeToText n
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
data DIOLink =
DIOLink
{ neighborType :: NeighborType,
neighborRank :: Rank,
metric :: Maybe Rank
}
deriving (Show,Eq,Ord,Generic)
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 <- fmap writeKeyValues $ sequence pairs
return (adaptWalk nt_steps <> other)
where
pairs = [ keyNeighborRank <=:> neighborRank ll,
keyMetric <=?> metric ll
]
parseLinkAttributes ps =
DIOLink
<$> parseLinkAttributes ps
<*> (pMapToFail $ lookupAs keyNeighborRank ps)
<*> (pMapToFail $ lookupAs' keyMetric ps)
dioLinkState :: DIOLink -> LinkState
dioLinkState l =
case neighborType l of
PreferredParent -> LinkToTarget
_ -> LinkUnused
instance GraphML.ToAttributes DIOLink where
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 -> [(keyText keyMetric, GraphML.AttrInt $ fromIntegral m)]
instance FromJSON DIOLink where
parseJSON = Aeson.genericParseJSON optSnake
instance ToJSON DIOLink where
toJSON = Aeson.genericToJSON optSnake
toEncoding = Aeson.genericToEncoding optSnake
data MergedDIOLink =
MergedDIOLink
{ fromSource :: DIOLink,
fromDest :: Maybe DIOLink
}
deriving (Show,Eq,Ord,Generic)
withKeyPrefix :: Monoid k
=> k
-> [(k, v)]
-> [(k, v)]
withKeyPrefix prefix = map prependPrefix
where
prependPrefix (k, v) = (prefix <> k, v)
dioDefQuery :: [FindingID]
-> Query.Query FindingID DIONode DIOLink MergedDIOLink
dioDefQuery start =
(Query.defQuery start)
{ Query.startsFrom = start,
Query.unifyLinkSamples = Unify.unifyStd dioUnifierConf
}
dioUnifierConf :: UnifyStdConfig FindingID DIONode DIOLink MergedDIOLink ()
dioUnifierConf = Unify.UnifyStdConfig
{ Unify.makeLinkSubId = const (),
Unify.mergeSamples = merger,
Unify.negatesLinkSample = \_ _ -> False
}
where
merger llinks rlinks =
case (latestLinkSample llinks, latestLinkSample rlinks) of
(Nothing, Nothing) -> Nothing
(Just ll, Nothing) -> Just $ doMerge ll Nothing
(Nothing, Just rl) -> Just $ doMerge rl Nothing
(Just ll, Just rl) -> Just $ doMerge ll $ Just rl
doMerge main_link msub_link =
case msub_link of
Nothing -> main_link
{ lsLinkAttributes = MergedDIOLink main_ll Nothing }
Just sub_link ->
if neighborType main_ll <= neighborType sub_ll
then main_link { lsLinkAttributes = MergedDIOLink main_ll $ Just sub_ll }
else sub_link { lsLinkAttributes = MergedDIOLink sub_ll $ Just main_ll }
where
sub_ll = lsLinkAttributes sub_link
where
main_ll = lsLinkAttributes main_link
instance GraphML.ToAttributes MergedDIOLink where
toAttributes ml =
(withKeyPrefix "source_" $ GraphML.toAttributes $ fromSource ml)
++
( case fromDest ml of
Nothing -> []
Just dl -> withKeyPrefix "dest_" $ GraphML.toAttributes dl
)
instance FromJSON MergedDIOLink where
parseJSON = Aeson.genericParseJSON optSnake
instance ToJSON MergedDIOLink where
toJSON = Aeson.genericToJSON optSnake
toEncoding = Aeson.genericToEncoding optSnake