{-# LANGUAGE OverloadedStrings #-}
module NetSpider.RPL.DIO
(
FoundNodeDIO,
SnapshotGraphDIO,
DIONode(..),
DIOLink(..),
dioLinkState,
MergedDIOLink(..),
Rank,
TrickleInterval,
NeighborType(..),
neighborTypeToText,
neighborTypeFromText,
dioDefQuery,
dioUnifierConf
) where
import Control.Applicative ((<$>), (<*>))
import Data.Aeson (ToJSON(..))
import Data.Bifunctor (bimap)
import Data.Greskell
( PropertyMap, Property, GValue, parseOneValue,
Binder, Walk, SideEffect, Element, Parser
)
import Data.Greskell.Extra (writePropertyKeyValues)
import Data.Monoid ((<>))
import Data.Text (Text, unpack)
import Data.Word (Word32)
import NetSpider.Found (FoundNode, LinkState(..))
import NetSpider.Graph (NodeAttributes(..), LinkAttributes(..))
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)
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)
instance NodeAttributes DIONode where
writeNodeAttributes ln = writePropertyKeyValues pairs
where
pairs = [ ("rank", toJSON $ rank ln),
("dio_interval", toJSON $ dioInterval ln)
]
parseNodeAttributes ps = DIONode
<$> parseOneValue "rank" ps
<*> parseOneValue "dio_interval" ps
instance GraphML.ToAttributes DIONode where
toAttributes ln = [ ("rank", GraphML.AttrInt $ fromIntegral $ rank ln),
("dio_interval", GraphML.AttrInt $ fromIntegral $ dioInterval ln)
]
data NeighborType = PreferredParent
| ParentCandidate
| OtherNeighbor
deriving (Show,Eq,Ord,Enum,Bounded)
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
instance LinkAttributes NeighborType where
writeLinkAttributes nt = writePropertyKeyValues [("neighbor_type", neighborTypeToText nt)]
parseLinkAttributes ps = fromT =<< parseOneValue "neighbor_type" ps
where
fromT t = maybe (fail ("Unknown neighbor type: " <> unpack t)) return $ neighborTypeFromText t
data DIOLink =
DIOLink
{ neighborType :: NeighborType,
neighborRank :: Rank,
metric :: Maybe Rank
}
deriving (Show,Eq,Ord)
instance LinkAttributes DIOLink where
writeLinkAttributes ll = do
nt_steps <- writeLinkAttributes $ neighborType ll
other <- writePropertyKeyValues pairs
return (adaptWalk nt_steps <> other)
where
pairs = [ ("neighbor_rank", toJSON $ neighborRank ll),
("metric", toJSON $ metric ll)
]
parseLinkAttributes ps =
DIOLink
<$> parseLinkAttributes ps
<*> parseOneValue "neighbor_rank" ps
<*> parseOneValue "metric" ps
dioLinkState :: DIOLink -> LinkState
dioLinkState l =
case neighborType l of
PreferredParent -> LinkToTarget
_ -> LinkUnused
instance GraphML.ToAttributes DIOLink where
toAttributes ll = [ ("neighbor_type", GraphML.AttrString $ neighborTypeToText $ neighborType ll),
("neighbor_rank", GraphML.AttrInt $ fromIntegral $ neighborRank ll)
]
++ at_metric
where
at_metric =
case metric ll of
Nothing -> []
Just m -> [("metric", GraphML.AttrInt $ fromIntegral m)]
data MergedDIOLink =
MergedDIOLink
{ fromSource :: DIOLink,
fromDest :: Maybe DIOLink
}
deriving (Show,Eq,Ord)
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
)