NetMonitor.hs

{-----------------------------------------------------------------------------
    reactive-banana-wx
    
    Example: Minuscule network monitor
------------------------------------------------------------------------------}

import Data.Char
import Data.List
import Data.Maybe

import System.Process

import Graphics.UI.WX hiding (Event)
import Reactive.Banana
import Reactive.Banana.WX

{-----------------------------------------------------------------------------
    Main
------------------------------------------------------------------------------}
main :: IO ()
main = start $ do
    f        <- frame    [text := "Network Monitor"]
    out1     <- staticText f []
    out2     <- staticText f []
    
    set f [layout := minsize (sz 250 70) $ margin 10 $
            column 10 [label "TCP network statistics",
                       grid 5 5 [[label "Packets sent: ", widget out1]
                                ,[label "Packets received: ", widget out2]]
                      ]
          ]
    
    t <- timer f [ interval := 500 ] -- timer every 500 ms

    let networkDescription :: MomentIO ()
        networkDescription = do
            -- The network statistics are polled when and only when
            -- the event network handles an event.
            bnetwork <- fromPoll getNetworkStatistics
            -- That's why we need a timer that generates regular events to handle.
            etick    <- event0 t command
        
            let showSent     = maybe "parse error" show . fst
                showReceived = maybe "parse error" show . snd
        
            sink out1 [ text :== showSent     <$> bnetwork ]
            sink out2 [ text :== showReceived <$> bnetwork ]
    
    network <- compile networkDescription
    actuate network

-- Obtain network statistics from the  netstat  utility
type NetworkStatistics = (Maybe Int, Maybe Int)

getNetworkStatistics :: IO NetworkStatistics
getNetworkStatistics = do
    s <- readProcess "netstat" ["-s", "-p","tcp"] ""
    return (readField "packets sent" s
           ,readField "packets received" s)

readField :: String -> String -> Maybe Int
readField fieldname = id
    . fmap (read . filter isDigit) . listToMaybe
    . filter (fieldname `isSuffixOf`) . lines