diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Revision history for net-spider-rpl +## 0.2.3.0 -- 2019-09-24 + +### ContikiNG module + +* Add `parseStream`, `parserFoundNodeDIO`, `parserFoundNodeDAO` functions. + + ## 0.2.2.0 -- 2019-09-23 ### RPL module 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.2.2.0 +version: 0.2.3.0 author: Toshio Ito maintainer: Toshio Ito license: BSD3 @@ -22,7 +22,7 @@ default-language: Haskell2010 hs-source-dirs: src ghc-options: -Wall -fno-warn-unused-imports - default-extensions: StrictData + default-extensions: StrictData, OverloadedStrings other-extensions: OverloadedStrings, DeriveGeneric exposed-modules: NetSpider.RPL, NetSpider.RPL.FindingID, @@ -38,7 +38,11 @@ text >=1.2.3.1 && <1.3, ip >=1.3.0 && <1.5, hashable >=1.2.7.0 && <1.3, - time >=1.8.0.2 && <1.9 + time >=1.8.0.2 && <1.9, + conduit-parse >=0.2.1.0 && <0.3, + conduit >=1.3.1 && <1.4, + mtl >=2.2.2 && <2.3, + safe-exceptions >=0.1.7.0 && <0.2 -- executable net-spider-rpl -- default-language: Haskell2010 diff --git a/src/NetSpider/RPL/ContikiNG.hs b/src/NetSpider/RPL/ContikiNG.hs --- a/src/NetSpider/RPL/ContikiNG.hs +++ b/src/NetSpider/RPL/ContikiNG.hs @@ -12,7 +12,13 @@ ( -- * Parser functions parseFile, parseFileHandle, + parseStream, -- * Parser components + -- ** Parsers for line stream + parserFoundNodeDIO, + parserFoundNodeDAO, + Line, + -- ** Parser for text Parser, pCoojaLogHead, pCoojaLogHead', @@ -20,23 +26,33 @@ ) where import Control.Applicative ((<|>), (<$>), (<*>), (*>), (<*), many, optional) -import Control.Exception (Exception, throwIO) +import Control.Exception.Safe (MonadThrow) import Control.Monad (void) +import Control.Monad.Except (throwError) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Data.Bifunctor (Bifunctor(first)) import Data.Bits (shift) import Data.Char (isDigit, isHexDigit, isSpace) +import Data.Conduit (ConduitT, mapOutput, yield, runConduit, (.|)) +import qualified Data.Conduit.List as CL +import Data.Conduit.Parser (ConduitParser) +import qualified Data.Conduit.Parser as CP +import Data.Either (partitionEithers) import Data.Int (Int64) import Data.List (sortOn, reverse) import Data.Maybe (listToMaybe) import Data.Monoid ((<>)) -import Data.Text (pack) +import Data.Text (Text, pack, unpack) +import qualified Data.Text.IO as TIO import qualified Data.Time as Time +import Data.Void (absurd) import Data.Word (Word16) import GHC.Exts (groupWith) import Net.IPv6 (IPv6) import qualified Net.IPv6 as IPv6 import NetSpider.Found (FoundNode(..), FoundLink(..), LinkState(LinkToTarget)) import NetSpider.Timestamp (Timestamp, fromEpochMillisecond, fromLocalTime, fromZonedTime) -import System.IO (withFile, IOMode(ReadMode), hGetLine, hIsEOF, Handle) +import System.IO (withFile, IOMode(ReadMode), hGetLine, hIsEOF, Handle, stderr) import qualified Text.ParserCombinators.ReadP as P import Text.Read (readEither) @@ -49,11 +65,6 @@ type Parser = P.ReadP -data ParseError = ParseError String - deriving (Show,Eq,Ord) - -instance Exception ParseError - runParser :: Parser a -> String -> Maybe a runParser p input = extract $ sortPairs $ P.readP_to_S p input where @@ -97,53 +108,83 @@ parseFileHandle :: Parser Timestamp -- ^ Parser for log prefix -> Handle -- ^ File handle to read -> IO ([FoundNodeDIO], [FoundNodeDAO]) -parseFileHandle pTimestamp handle = go ([], []) +parseFileHandle pTimestamp handle = + fmap partitionEithers $ runConduit (the_source .| parseStream pTimestamp .| CL.consume) where - go (acc_dio, acc_dao) = do - mentry <- parseOneEntry pTimestamp $ tryGetLine handle - case mentry of - Nothing -> return (reverse acc_dio, reverse acc_dao) - Just (PEDIO fl) -> go (fl : acc_dio, acc_dao) - Just (PEDAO srs) -> go (acc_dio, srs ++ acc_dao) - Just PEMisc -> go (acc_dio, acc_dao) - tryGetLine h = do - eof <- hIsEOF h + the_source = do + eof <- liftIO $ hIsEOF handle if eof - then return Nothing - else Just <$> hGetLine h + then return () + else do + yield =<< (liftIO $ TIO.hGetLine handle) + the_source data ParseEntry = PEDIO FoundNodeDIO | PEDAO [FoundNodeDAO] - | PEMisc + | PELine (Maybe Line) deriving (Show,Eq) --- | Return 'Nothing' when it finishes reading. -parseOneEntry :: Parser Timestamp -> IO (Maybe String) -> IO (Maybe ParseEntry) -parseOneEntry pTimestamp getL = impl +-- | Same as 'parseFile' but as an conduit. +-- +-- @since 0.2.3.0 +parseStream :: (MonadThrow m) + => Parser Timestamp -- ^ Parser for log prefix + -> ConduitT Line (Either FoundNodeDIO FoundNodeDAO) m () +parseStream pTimestamp = go where - impl = do - mline <- getL - case mline of - Nothing -> return Nothing - Just line -> - case runParser ((,) <$> pTimestamp <*> (pLogHead *> pHeading)) line of - Nothing -> return $ Just PEMisc - Just (ts, HDIO addr node) -> proceedDIO ts addr node - Just (ts, HDAO route_num) -> proceedDAO ts route_num + go = do + got <- mapOutput absurd $ CP.runConduitParser merged_parser + case got of + PEDIO dio -> yield (Left dio) >> go + PEDAO daos -> mapM_ (yield . Right) daos >> go + PELine Nothing -> return () + PELine (Just _) -> go + merged_parser = (PEDIO <$> parserFoundNodeDIO pTimestamp) + <|> (PEDAO <$> parserFoundNodeDAO pTimestamp) + <|> (PELine <$> awaitM) + +-- | One line text. +-- +-- @since 0.2.3.0 +type Line = Text + +-- | Parse stream of log lines for a 'FoundNodeDIO'. +-- +-- @since 0.2.3.0 +parserFoundNodeDIO :: Monad m + => Parser Timestamp -- ^ Text parser for log head. + -> ConduitParser Line m FoundNodeDIO +parserFoundNodeDIO pTimestamp = do + line <- CP.await + case runParser pDIOHead $ unpack line of + Nothing -> throwError $ CP.Unexpected ("Not a log line head of local findings about DIO.") + Just (ts, (self_addr, dio_node)) -> proceedDIO ts self_addr dio_node + where + pDIOHead = (,) <$> pTimestamp <*> (pLogHead *> pDIONode) withPrefix p = pTimestamp *> pLogHead *> p proceedDIO ts addr node = do - mlinks <- readUntil getL (withPrefix pDIONeighbor) (withPrefix pDIONeighborEnd) - case mlinks of - Nothing -> return Nothing - Just links -> return $ Just $ PEDIO $ makeFoundNodeDIO ts addr node $ map (setAddressPrefix addr) links + links <- readUntilCP (withPrefix pDIONeighbor) (withPrefix pDIONeighborEnd) + return $ makeFoundNodeDIO ts addr node $ map (first $ setNonLocalPrefix addr) links + +-- | Parse stream of log lines for a 'FoundNodeDAO'. +-- +-- @since 0.2.3.0 +parserFoundNodeDAO :: Monad m + => Parser Timestamp -- ^ Text parser for log head. + -> ConduitParser Line m [FoundNodeDAO] +parserFoundNodeDAO pTimestamp = do + line <- CP.await + case runParser pDAOHead $ unpack line of + Nothing -> throwError $ CP.Unexpected ("Not a log line head of local findings about DAO.") + Just (ts, r) -> proceedDAO ts r + where + withPrefix p = pTimestamp *> pLogHead *> p + pDAOHead = (,) <$> pTimestamp <*> (pLogHead *> pDAOLogHeader) proceedDAO ts route_num = do - mlinks <- readUntil getL (withPrefix pDAOLink) (withPrefix pDAOLinkEnd) - case mlinks of - Nothing -> return Nothing - Just links -> do - root_address <- maybe (throwIO $ ParseError "No root address found in SR log") return - $ getRootAddress links - return $ Just $ PEDAO $ map (makeDAONodeFromTuple root_address route_num ts) $ groupDAOLinks links + links <- readUntilCP (withPrefix pDAOLink) (withPrefix pDAOLinkEnd) + root_address <- maybe (throwError $ CP.Unexpected "No root address found in SR log") return + $ getRootAddress links + return $ map (makeDAONodeFromTuple root_address route_num ts) $ groupDAOLinks links getRootAddress :: [(IPv6, Maybe (IPv6, Word))] -> Maybe IPv6 getRootAddress links = fmap fst $ listToMaybe $ filter isRootEntry links where @@ -162,24 +203,29 @@ makeFoundNodeDAO ts (if parent_addr == root_addr then Just route_num else Nothing) parent_addr children - setAddressPrefix self_addr (neighbor_addr, ll) = (modified_addr, ll) - where - modified_addr = if isLinkLocal neighbor_addr - then setPrefix (getPrefix self_addr) neighbor_addr - else neighbor_addr -readUntil :: IO (Maybe String) -> Parser a -> Parser end -> IO (Maybe [a]) -readUntil getL pBody pEnd = go [] +setNonLocalPrefix :: IPv6 -> IPv6 -> IPv6 +setNonLocalPrefix prefix_addr orig_addr = + if isLinkLocal orig_addr + then setPrefix (getPrefix prefix_addr) orig_addr + else orig_addr + +awaitM :: Monad m => ConduitParser i m (Maybe i) +awaitM = do + mnext <- CP.peek + case mnext of + Nothing -> return Nothing + Just _ -> fmap Just $ CP.await + +readUntilCP :: Monad m => Parser a -> Parser end -> ConduitParser Line m [a] +readUntilCP pBody pEnd = go [] where go acc = do - mline <- getL - case mline of - Nothing -> return Nothing - Just line -> - case runParser ((Left <$> pEnd) <|> (Right <$> pBody)) line of - Nothing -> throwIO $ ParseError ("Parse error at line: " <> line) - Just (Left _) -> return $ Just $ reverse acc - Just (Right body) -> go (body : acc) + line <- CP.await + case runParser ((Left <$> pEnd) <|> (Right <$> pBody)) $ unpack line of + Nothing -> throwError $ CP.Unexpected ("Parse error at line: " <> line) + Just (Left _) -> return $ reverse acc + Just (Right body) -> go (body : acc) makeFoundNodeDIO :: Timestamp -> IPv6 -> DIO.DIONode -> [(IPv6, DIO.DIOLink)] -> FoundNodeDIO makeFoundNodeDIO ts self_addr node_attr neighbors = @@ -208,15 +254,6 @@ linkState = LinkToTarget, linkAttributes = DAO.DAOLink lifetime } - - -data Heading = HDIO IPv6 DIO.DIONode - | HDAO Word - deriving (Show,Eq,Ord) - -pHeading :: Parser Heading -pHeading = (fmap (uncurry HDIO) $ pDIONode) - <|> (HDAO <$> pDAOLogHeader) isAddressChar :: Char -> Bool isAddressChar c = isHexDigit c || c == ':'