{-# LANGUAGE OverloadedStrings #-}
module NetSpider.RPL.CLI.Analyze
( DODAGAttributes(..),
analyzeDIO,
analyzeDAO
) where
import Control.Applicative (empty)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.Graph.Inductive (LNode, LEdge, Gr)
import qualified Data.Graph.Inductive as FGL
import Data.List (sortOn, reverse)
import Data.Maybe (listToMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import NetSpider.Log (WriterLoggingM, logErrorW, spack, logDebugW)
import NetSpider.SeqID
(SeqIDMaker, newSeqIDMaker, convertGraph, originalIDFor)
import NetSpider.Snapshot
( SnapshotNode, SnapshotLink, SnapshotGraph,
nodeId, nodeAttributes, sourceNode, destinationNode, linkAttributes,
graphTimestamp
)
import NetSpider.Timestamp (Timestamp, showTimestamp)
import NetSpider.RPL.DIO (SnapshotGraphDIO)
import NetSpider.RPL.DAO (SnapshotGraphDAO)
import NetSpider.RPL.FindingID
( IPv6ID, FindingID, FindingType(..), ipv6Only, ipv6ToText)
data DODAGAttributes =
DODAGAttributes
{ DODAGAttributes -> Int
node_num :: Int,
DODAGAttributes -> Int
edge_num :: Int,
DODAGAttributes -> Int
depth :: Int,
DODAGAttributes -> IPv6ID
root :: IPv6ID,
DODAGAttributes -> Timestamp
time :: Timestamp
}
deriving (Int -> DODAGAttributes -> ShowS
[DODAGAttributes] -> ShowS
DODAGAttributes -> String
(Int -> DODAGAttributes -> ShowS)
-> (DODAGAttributes -> String)
-> ([DODAGAttributes] -> ShowS)
-> Show DODAGAttributes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DODAGAttributes] -> ShowS
$cshowList :: [DODAGAttributes] -> ShowS
show :: DODAGAttributes -> String
$cshow :: DODAGAttributes -> String
showsPrec :: Int -> DODAGAttributes -> ShowS
$cshowsPrec :: Int -> DODAGAttributes -> ShowS
Show,DODAGAttributes -> DODAGAttributes -> Bool
(DODAGAttributes -> DODAGAttributes -> Bool)
-> (DODAGAttributes -> DODAGAttributes -> Bool)
-> Eq DODAGAttributes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DODAGAttributes -> DODAGAttributes -> Bool
$c/= :: DODAGAttributes -> DODAGAttributes -> Bool
== :: DODAGAttributes -> DODAGAttributes -> Bool
$c== :: DODAGAttributes -> DODAGAttributes -> Bool
Eq,Eq DODAGAttributes
Eq DODAGAttributes
-> (DODAGAttributes -> DODAGAttributes -> Ordering)
-> (DODAGAttributes -> DODAGAttributes -> Bool)
-> (DODAGAttributes -> DODAGAttributes -> Bool)
-> (DODAGAttributes -> DODAGAttributes -> Bool)
-> (DODAGAttributes -> DODAGAttributes -> Bool)
-> (DODAGAttributes -> DODAGAttributes -> DODAGAttributes)
-> (DODAGAttributes -> DODAGAttributes -> DODAGAttributes)
-> Ord DODAGAttributes
DODAGAttributes -> DODAGAttributes -> Bool
DODAGAttributes -> DODAGAttributes -> Ordering
DODAGAttributes -> DODAGAttributes -> DODAGAttributes
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DODAGAttributes -> DODAGAttributes -> DODAGAttributes
$cmin :: DODAGAttributes -> DODAGAttributes -> DODAGAttributes
max :: DODAGAttributes -> DODAGAttributes -> DODAGAttributes
$cmax :: DODAGAttributes -> DODAGAttributes -> DODAGAttributes
>= :: DODAGAttributes -> DODAGAttributes -> Bool
$c>= :: DODAGAttributes -> DODAGAttributes -> Bool
> :: DODAGAttributes -> DODAGAttributes -> Bool
$c> :: DODAGAttributes -> DODAGAttributes -> Bool
<= :: DODAGAttributes -> DODAGAttributes -> Bool
$c<= :: DODAGAttributes -> DODAGAttributes -> Bool
< :: DODAGAttributes -> DODAGAttributes -> Bool
$c< :: DODAGAttributes -> DODAGAttributes -> Bool
compare :: DODAGAttributes -> DODAGAttributes -> Ordering
$ccompare :: DODAGAttributes -> DODAGAttributes -> Ordering
$cp1Ord :: Eq DODAGAttributes
Ord)
analyzeDIO :: SnapshotGraphDIO -> WriterLoggingM (Maybe DODAGAttributes)
analyzeDIO :: SnapshotGraphDIO -> WriterLoggingM (Maybe DODAGAttributes)
analyzeDIO = RootType
-> FindingType
-> SnapshotGraphDIO
-> WriterLoggingM (Maybe DODAGAttributes)
forall na la.
RootType
-> FindingType
-> SnapshotGraph FindingID na la
-> WriterLoggingM (Maybe DODAGAttributes)
analyzeGeneric RootType
RootDest FindingType
FindingDIO
analyzeDAO :: SnapshotGraphDAO -> WriterLoggingM (Maybe DODAGAttributes)
analyzeDAO :: SnapshotGraphDAO -> WriterLoggingM (Maybe DODAGAttributes)
analyzeDAO = RootType
-> FindingType
-> SnapshotGraphDAO
-> WriterLoggingM (Maybe DODAGAttributes)
forall na la.
RootType
-> FindingType
-> SnapshotGraph FindingID na la
-> WriterLoggingM (Maybe DODAGAttributes)
analyzeGeneric RootType
RootSource FindingType
FindingDAO
analyzeGeneric :: RootType -> FindingType -> SnapshotGraph FindingID na la -> WriterLoggingM (Maybe DODAGAttributes)
analyzeGeneric :: RootType
-> FindingType
-> SnapshotGraph FindingID na la
-> WriterLoggingM (Maybe DODAGAttributes)
analyzeGeneric RootType
rtype FindingType
ftype SnapshotGraph FindingID na la
graph = MaybeT (WriterLoggingT Identity) DODAGAttributes
-> WriterLoggingM (Maybe DODAGAttributes)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT (WriterLoggingT Identity) DODAGAttributes
-> WriterLoggingM (Maybe DODAGAttributes))
-> MaybeT (WriterLoggingT Identity) DODAGAttributes
-> WriterLoggingM (Maybe DODAGAttributes)
forall a b. (a -> b) -> a -> b
$ MaybeT (WriterLoggingT Identity) DODAGAttributes
go
where
maybeLog :: Maybe b -> Text -> t (WriterLoggingT Identity) b
maybeLog Maybe b
m Text
err_log =
case Maybe b
m of
Maybe b
Nothing -> do
WriterLoggingT Identity () -> t (WriterLoggingT Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterLoggingT Identity () -> t (WriterLoggingT Identity) ())
-> WriterLoggingT Identity () -> t (WriterLoggingT Identity) ()
forall a b. (a -> b) -> a -> b
$ Text -> WriterLoggingT Identity ()
logErrorW Text
err_log
t (WriterLoggingT Identity) b
forall (f :: * -> *) a. Alternative f => f a
empty
Just b
v -> b -> t (WriterLoggingT Identity) b
forall (m :: * -> *) a. Monad m => a -> m a
return b
v
eitherLog :: Either Text b -> t (WriterLoggingT Identity) b
eitherLog Either Text b
e =
case Either Text b
e of
Left Text
err_log -> Maybe b -> Text -> t (WriterLoggingT Identity) b
forall (t :: (* -> *) -> * -> *) b.
(Monad (t (WriterLoggingT Identity)), MonadTrans t,
Alternative (t (WriterLoggingT Identity))) =>
Maybe b -> Text -> t (WriterLoggingT Identity) b
maybeLog Maybe b
forall a. Maybe a
Nothing Text
err_log
Right b
v -> b -> t (WriterLoggingT Identity) b
forall (m :: * -> *) a. Monad m => a -> m a
return b
v
(SeqIDMaker FindingID Int
seqid, Gr (Maybe na) la
gr) = SnapshotGraph FindingID na la
-> (SeqIDMaker FindingID Int, Gr (Maybe na) la)
forall na la.
SnapshotGraph FindingID na la
-> (SeqIDMaker FindingID Int, Gr (Maybe na) la)
toGr SnapshotGraph FindingID na la
graph
ft_str :: Text
ft_str =
case FindingType
ftype of
FindingType
FindingDIO -> Text
"DIO"
FindingType
FindingDAO -> Text
"DAO"
logRootIP :: IPv6ID -> t (WriterLoggingT Identity) ()
logRootIP IPv6ID
root_ip = do
WriterLoggingT Identity () -> t (WriterLoggingT Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterLoggingT Identity () -> t (WriterLoggingT Identity) ())
-> WriterLoggingT Identity () -> t (WriterLoggingT Identity) ()
forall a b. (a -> b) -> a -> b
$ Text -> WriterLoggingT Identity ()
logDebugW (Text
"Root of the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ft_str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" graph: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> IPv6ID -> Text
ipv6ToText IPv6ID
root_ip)
logTS :: Timestamp -> t (WriterLoggingT Identity) ()
logTS Timestamp
ts = do
WriterLoggingT Identity () -> t (WriterLoggingT Identity) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterLoggingT Identity () -> t (WriterLoggingT Identity) ())
-> WriterLoggingT Identity () -> t (WriterLoggingT Identity) ()
forall a b. (a -> b) -> a -> b
$ Text -> WriterLoggingT Identity ()
logDebugW (Text
"Timestamp of the " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ft_str Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" graph: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Timestamp -> Text
showTimestamp Timestamp
ts)
go :: MaybeT (WriterLoggingT Identity) DODAGAttributes
go = do
Int
root_node <- ((Int, Maybe na) -> Int)
-> MaybeT (WriterLoggingT Identity) (Int, Maybe na)
-> MaybeT (WriterLoggingT Identity) Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, Maybe na) -> Int
forall a b. (a, b) -> a
fst (MaybeT (WriterLoggingT Identity) (Int, Maybe na)
-> MaybeT (WriterLoggingT Identity) Int)
-> MaybeT (WriterLoggingT Identity) (Int, Maybe na)
-> MaybeT (WriterLoggingT Identity) Int
forall a b. (a -> b) -> a -> b
$ Either Text (Int, Maybe na)
-> MaybeT (WriterLoggingT Identity) (Int, Maybe na)
forall (t :: (* -> *) -> * -> *) b.
(Monad (t (WriterLoggingT Identity)), MonadTrans t,
Alternative (t (WriterLoggingT Identity))) =>
Either Text b -> t (WriterLoggingT Identity) b
eitherLog (Either Text (Int, Maybe na)
-> MaybeT (WriterLoggingT Identity) (Int, Maybe na))
-> Either Text (Int, Maybe na)
-> MaybeT (WriterLoggingT Identity) (Int, Maybe na)
forall a b. (a -> b) -> a -> b
$ RootType -> Gr (Maybe na) la -> Either Text (Int, Maybe na)
forall na la. RootType -> Gr na la -> Either Text (LNode na)
getRoot RootType
rtype Gr (Maybe na) la
gr
IPv6ID
root_ip <- (FindingID -> IPv6ID)
-> MaybeT (WriterLoggingT Identity) FindingID
-> MaybeT (WriterLoggingT Identity) IPv6ID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FindingID -> IPv6ID
ipv6Only (MaybeT (WriterLoggingT Identity) FindingID
-> MaybeT (WriterLoggingT Identity) IPv6ID)
-> MaybeT (WriterLoggingT Identity) FindingID
-> MaybeT (WriterLoggingT Identity) IPv6ID
forall a b. (a -> b) -> a -> b
$ Maybe FindingID
-> Text -> MaybeT (WriterLoggingT Identity) FindingID
forall (t :: (* -> *) -> * -> *) b.
(Monad (t (WriterLoggingT Identity)), MonadTrans t,
Alternative (t (WriterLoggingT Identity))) =>
Maybe b -> Text -> t (WriterLoggingT Identity) b
maybeLog
(SeqIDMaker FindingID Int -> Int -> Maybe FindingID
forall i n. (Eq i, Hashable i) => SeqIDMaker n i -> i -> Maybe n
originalIDFor SeqIDMaker FindingID Int
seqid Int
root_node)
(Text
"Cannot find the FindingID for root node " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Int -> Text
forall a. Show a => a -> Text
spack Int
root_node) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
".")
IPv6ID -> MaybeT (WriterLoggingT Identity) ()
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
IPv6ID -> t (WriterLoggingT Identity) ()
logRootIP IPv6ID
root_ip
Timestamp
graph_ts <- Maybe Timestamp
-> Text -> MaybeT (WriterLoggingT Identity) Timestamp
forall (t :: (* -> *) -> * -> *) b.
(Monad (t (WriterLoggingT Identity)), MonadTrans t,
Alternative (t (WriterLoggingT Identity))) =>
Maybe b -> Text -> t (WriterLoggingT Identity) b
maybeLog (SnapshotGraph FindingID na la -> Maybe Timestamp
forall n na la. SnapshotGraph n na la -> Maybe Timestamp
graphTimestamp SnapshotGraph FindingID na la
graph) (Text
"The graph has no timestamp.")
Timestamp -> MaybeT (WriterLoggingT Identity) ()
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
Timestamp -> t (WriterLoggingT Identity) ()
logTS Timestamp
graph_ts
DODAGAttributes -> MaybeT (WriterLoggingT Identity) DODAGAttributes
forall (m :: * -> *) a. Monad m => a -> m a
return DODAGAttributes :: Int -> Int -> Int -> IPv6ID -> Timestamp -> DODAGAttributes
DODAGAttributes { node_num :: Int
node_num = Gr (Maybe na) la -> Int
forall na la. Gr na la -> Int
nodeNum Gr (Maybe na) la
gr,
edge_num :: Int
edge_num = Gr (Maybe na) la -> Int
forall na la. Gr na la -> Int
edgeNum Gr (Maybe na) la
gr,
depth :: Int
depth = Int -> RootType -> Gr (Maybe na) la -> Int
forall na la. Int -> RootType -> Gr na la -> Int
getDepth Int
root_node RootType
rtype Gr (Maybe na) la
gr,
root :: IPv6ID
root = IPv6ID
root_ip,
time :: Timestamp
time = Timestamp
graph_ts
}
toLNode :: SnapshotNode Int na -> LNode (Maybe na)
toLNode :: SnapshotNode Int na -> LNode (Maybe na)
toLNode SnapshotNode Int na
n = (SnapshotNode Int na -> Int
forall n na. SnapshotNode n na -> n
nodeId SnapshotNode Int na
n, SnapshotNode Int na -> Maybe na
forall n na. SnapshotNode n na -> Maybe na
nodeAttributes SnapshotNode Int na
n)
toLEdge :: SnapshotLink Int la -> LEdge la
toLEdge :: SnapshotLink Int la -> LEdge la
toLEdge SnapshotLink Int la
l = (SnapshotLink Int la -> Int
forall n la. SnapshotLink n la -> n
sourceNode SnapshotLink Int la
l, SnapshotLink Int la -> Int
forall n la. SnapshotLink n la -> n
destinationNode SnapshotLink Int la
l, SnapshotLink Int la -> la
forall n la. SnapshotLink n la -> la
linkAttributes SnapshotLink Int la
l)
toGr :: SnapshotGraph FindingID na la -> (SeqIDMaker FindingID FGL.Node, Gr (Maybe na) la)
toGr :: SnapshotGraph FindingID na la
-> (SeqIDMaker FindingID Int, Gr (Maybe na) la)
toGr SnapshotGraph FindingID na la
graph = (SeqIDMaker FindingID Int
got_maker, [LNode (Maybe na)] -> [LEdge la] -> Gr (Maybe na) la
forall (gr :: * -> * -> *) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
FGL.mkGraph [LNode (Maybe na)]
lnodes [LEdge la]
ledges)
where
(SeqIDMaker FindingID Int
got_maker, ([SnapshotNode Int na]
new_nodes, [SnapshotLink Int la]
new_links)) = SeqIDMaker FindingID Int
-> SnapshotGraph FindingID na la
-> (SeqIDMaker FindingID Int,
([SnapshotNode Int na], [SnapshotLink Int la]))
forall n i na la.
(Eq n, Hashable n, Enum i, Eq i, Hashable i) =>
SeqIDMaker n i
-> SnapshotGraph n na la -> (SeqIDMaker n i, SnapshotGraph i na la)
convertGraph (Int -> SeqIDMaker FindingID Int
forall i n. i -> SeqIDMaker n i
newSeqIDMaker Int
0) SnapshotGraph FindingID na la
graph
lnodes :: [LNode (Maybe na)]
lnodes = (SnapshotNode Int na -> LNode (Maybe na))
-> [SnapshotNode Int na] -> [LNode (Maybe na)]
forall a b. (a -> b) -> [a] -> [b]
map SnapshotNode Int na -> LNode (Maybe na)
forall na. SnapshotNode Int na -> LNode (Maybe na)
toLNode [SnapshotNode Int na]
new_nodes
ledges :: [LEdge la]
ledges = (SnapshotLink Int la -> LEdge la)
-> [SnapshotLink Int la] -> [LEdge la]
forall a b. (a -> b) -> [a] -> [b]
map SnapshotLink Int la -> LEdge la
forall la. SnapshotLink Int la -> LEdge la
toLEdge [SnapshotLink Int la]
new_links
nodeNum :: Gr na la -> Int
nodeNum :: Gr na la -> Int
nodeNum = Gr na la -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int
FGL.order
edgeNum :: Gr na la -> Int
edgeNum :: Gr na la -> Int
edgeNum = Gr na la -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int
FGL.size
data RootType = RootSource
| RootDest
getRoot :: RootType -> Gr na la -> Either Text (LNode na)
getRoot :: RootType -> Gr na la -> Either Text (LNode na)
getRoot RootType
rt Gr na la
gr = [LNode na] -> Either Text (LNode na)
forall a b. IsString a => [(Int, b)] -> Either a (Int, b)
toEither
([LNode na] -> Either Text (LNode na))
-> [LNode na] -> Either Text (LNode na)
forall a b. (a -> b) -> a -> b
$ [LNode na] -> [LNode na]
forall a. [a] -> [a]
reverse
([LNode na] -> [LNode na]) -> [LNode na] -> [LNode na]
forall a b. (a -> b) -> a -> b
$ (LNode na -> Int) -> [LNode na] -> [LNode na]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn LNode na -> Int
forall b. (Int, b) -> Int
childNum
([LNode na] -> [LNode na]) -> [LNode na] -> [LNode na]
forall a b. (a -> b) -> a -> b
$ (LNode na -> Bool) -> [LNode na] -> [LNode na]
forall a. (a -> Bool) -> [a] -> [a]
filter (\LNode na
n -> LNode na -> Int
forall b. (Int, b) -> Int
parentNum LNode na
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)
([LNode na] -> [LNode na]) -> [LNode na] -> [LNode na]
forall a b. (a -> b) -> a -> b
$ Gr na la -> [LNode na]
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> [LNode a]
FGL.labNodes Gr na la
gr
where
((Int, b) -> Int
parentNum, (Int, b) -> Int
childNum) =
case RootType
rt of
RootType
RootSource -> ((Gr na la -> Int -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> Int
FGL.indeg Gr na la
gr (Int -> Int) -> ((Int, b) -> Int) -> (Int, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> Int
forall a b. (a, b) -> a
fst), (Gr na la -> Int -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> Int
FGL.outdeg Gr na la
gr (Int -> Int) -> ((Int, b) -> Int) -> (Int, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> Int
forall a b. (a, b) -> a
fst))
RootType
RootDest -> ((Gr na la -> Int -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> Int
FGL.outdeg Gr na la
gr (Int -> Int) -> ((Int, b) -> Int) -> (Int, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> Int
forall a b. (a, b) -> a
fst), (Gr na la -> Int -> Int
forall (gr :: * -> * -> *) a b. Graph gr => gr a b -> Int -> Int
FGL.indeg Gr na la
gr (Int -> Int) -> ((Int, b) -> Int) -> (Int, b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, b) -> Int
forall a b. (a, b) -> a
fst))
toEither :: [(Int, b)] -> Either a (Int, b)
toEither [] = a -> Either a (Int, b)
forall a b. a -> Either a b
Left (a
"The graph has no node that has no parent.")
toEither [(Int, b)
n] = (Int, b) -> Either a (Int, b)
forall a b. b -> Either a b
Right (Int, b)
n
toEither ((Int, b)
rnode : [(Int, b)]
others) =
if (Int, b) -> Int
forall b. (Int, b) -> Int
childNum (Int, b)
rnode Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 Bool -> Bool -> Bool
&& (((Int, b) -> Bool) -> [(Int, b)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\(Int, b)
n -> (Int, b) -> Int
forall b. (Int, b) -> Int
childNum (Int, b)
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) [(Int, b)]
others)
then (Int, b) -> Either a (Int, b)
forall a b. b -> Either a b
Right (Int, b)
rnode
else if (Int, b) -> Int
forall b. (Int, b) -> Int
childNum (Int, b)
rnode Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then a -> Either a (Int, b)
forall a b. a -> Either a b
Left (a
"The graph contains orphan nodes only.")
else a -> Either a (Int, b)
forall a b. a -> Either a b
Left (a
"The graph contains multiple root candidates.")
getDepth :: FGL.Node
-> RootType
-> Gr na la
-> Int
getDepth :: Int -> RootType -> Gr na la -> Int
getDepth Int
root_node RootType
rtype Gr na la
gr = [Int] -> Int
forall p. (Num p, Ord p) => [p] -> p
maximum' ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (LPath Int -> Int) -> [LPath Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map LPath Int -> Int
forall a. LPath a -> Int
toPathLen ([LPath Int] -> [Int]) -> [LPath Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> Gr na Int -> [LPath Int]
forall (gr :: * -> * -> *) b a.
(Graph gr, Real b) =>
Int -> gr a b -> LRTree b
FGL.spTree Int
root_node (Gr na Int -> [LPath Int]) -> Gr na Int -> [LPath Int]
forall a b. (a -> b) -> a -> b
$ Gr na la -> Gr na Int
forall c p. Gr c p -> Gr c Int
convertGr Gr na la
gr
where
convertGr :: Gr c p -> Gr c Int
convertGr = (Context c Int -> Context c Int) -> Gr c Int -> Gr c Int
forall (gr :: * -> * -> *) a b c d.
DynGraph gr =>
(Context a b -> Context c d) -> gr a b -> gr c d
FGL.gmap Context c Int -> Context c Int
forall a b c. (a, b, c, a) -> (a, b, c, a)
setEdgeDir (Gr c Int -> Gr c Int)
-> (Gr c p -> Gr c Int) -> Gr c p -> Gr c Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (p -> Int) -> Gr c p -> Gr c Int
forall (gr :: * -> * -> *) b c a.
DynGraph gr =>
(b -> c) -> gr a b -> gr a c
FGL.emap p -> Int
forall p. p -> Int
setEdgeLabel
where
setEdgeLabel :: p -> Int
setEdgeLabel p
_ = (Int
1 :: Int)
setEdgeDir :: (a, b, c, a) -> (a, b, c, a)
setEdgeDir orig :: (a, b, c, a)
orig@(a
inedges, b
n, c
nlabel, a
outedges) =
case RootType
rtype of
RootType
RootSource -> (a, b, c, a)
orig
RootType
RootDest -> (a
outedges, b
n, c
nlabel, a
inedges)
toPathLen :: LPath a -> Int
toPathLen (FGL.LP [LNode a]
nodes) = [LNode a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [LNode a]
nodes Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
maximum' :: [p] -> p
maximum' [] = p
0
maximum' [p]
l = [p] -> p
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [p]
l