linkchk-0.0.2: Linkchk.hs
{-# LANGUAGE ImplicitParams #-}
-- linkchk - a network link monitor
--
-- Author : Jens-Ulrik Petersen <juhp@01.246.ne.jp>
-- Created: May 2001
--
-- Version: $Revision: 1.17 $ from $Date: 2001/11/09 09:03:56 $
--
-- Copyright (c) 2001 Jens-Ulrik Holger Petersen
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License
-- as published by the Free Software Foundation, version 2.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- General Public License for more details.
--
-- Description ----------------------------------------------------------------
--
-- A network link monitor that displays ping times
--
-- Todo -----------------------------------------------------------------------
--
-- * graphic chart output
-- * C-c in controlling tty usually doesn't terminate program
-- * use "do let" more
-- * use broadcast/multicast for tunnels
-- * pass args to Gtk.init
-- * move version to "Version.hs.in"
-- * separate options that can appear multiply from those that can't.
-- * i18n of messages
-- * font sizing
-- * typing of option flags
-- * move network commands to separate module
-- * popup menu
-- * bps output?
-- * display multiple hosts and interfaces
-- * simplify ping error message ("ping: unknown host host HOST", "connect: Network is unreachable")
import System.Console.GetOpt (getOpt, usageInfo, ArgDescr(..), OptDescr(..), ArgOrder(..))
import Graphics.UI.Gtk hiding (initGUI, mainGUI)
import qualified Graphics.UI.Gtk as Gtk (initGUI, mainGUI)
import System.IO.Unsafe (unsafePerformIO)
-- import Data.IORef
import List (find, elemIndex)
import Maybe (listToMaybe, fromMaybe, mapMaybe)
import Numeric (readDec, readFloat, showFFloat)
import System.Posix.POpen (popen)
import System.Posix (ProcessStatus(..), getProcessStatus, sleep)
import Text.Regex (mkRegex, matchRegex)
import System (getArgs, getEnv, getProgName, ExitCode(..), exitWith)
data FlagNullary = Verbose | Version | Help | Tty | IPv6 | Debug
deriving (Show, Eq)
data FlagUnary = Delay | Interface | Host | Width | Wait
deriving (Show, Eq)
data Flag = FNull FlagNullary | FUni FlagUnary String
deriving (Show, Eq)
options :: [OptDescr Flag]
options =
[ Option [] ["verbose"] (NoArg (FNull Verbose)) "chatty output on stderr",
Option ['v'] ["version"] (NoArg (FNull Version)) "show version number",
Option ['t'] ["tty"] (NoArg (FNull Tty)) "use tty even if X available",
Option ['6'] ["inet6"] (NoArg (FNull IPv6)) "use IPv6",
Option [] ["help"] (NoArg (FNull Help)) "show this message",
Option [] ["debug"] (NoArg (FNull Debug)) "debug output",
Option ['i'] ["interface"] (ReqArg (FUni Interface) "IFACE") "interface",
Option ['h'] ["host"] (ReqArg (FUni Host) "HOST") "hostname or address",
Option ['w'] ["width"] (ReqArg (FUni Width) "WIDTH") "width of gtk window",
Option ['d'] ["delay"] (ReqArg (FUni Delay) "SECONDS") "delay between pings",
Option ['d'] ["wait"] (ReqArg (FUni Wait) "SECONDS") "how long ping waits for each reply"]
unaryValList :: (?opts :: [Flag]) => FlagUnary -> [String]
unaryValList c =
mapMaybe (chkOpt c) ?opts
where
chkOpt :: FlagUnary -> Flag -> Maybe String
chkOpt d f =
case f of
FUni d' s | d' == d -> Just s
_ -> Nothing
unaryVal :: (?opts :: [Flag]) => FlagUnary -> Maybe String
unaryVal = listToMaybe . unaryValList
unaryOpt :: (?opts :: [Flag]) => FlagUnary -> Bool
unaryOpt c =
or $ map (chkOpt c) ?opts
where
chkOpt :: FlagUnary -> Flag -> Bool
chkOpt d f =
case f of
FUni d' _ | d' == d -> True
_ -> False
nullaryOpt :: (?opts :: [Flag]) => FlagNullary -> Bool
nullaryOpt c =
(FNull c) `elem` ?opts
type Interface = String
type Address = String
type Result = String
main :: IO ()
main =
do
cmdline <- getArgs
case (getOpt Permute options cmdline) of
([FNull Help], [], []) -> putStr (usageInfo header options)
([FNull Version], [], []) -> putStrLn "linkchk version 0.02"
(opts, [], [])
| let ?opts = opts in optsOk
-> let ?opts = opts in start
| otherwise -> putStr $ usageInfo header options
(_,_,errs) -> error (concat errs ++ usageInfo header options)
where optsOk :: (?opts :: [Flag]) => Bool
optsOk = not (nullaryOpt Version && nullaryOpt Help)
&&
not (unaryOpt Interface && unaryOpt Host)
header :: String
header = "Usage: " ++ (unsafePerformIO $ getProgName)
++ " [OPTION...]"
start :: (?opts :: [Flag]) => IO ()
start =
if nullaryOpt Tty
then do startTty 0
else do startGtk
startTty :: (?opts :: [Flag]) => Int -> IO ()
startTty count =
do
st <- hopchk
putStrLn (labeltxt ++ ": " ++ st)
debug count
doSleep
startTty (count+1)
startGtk :: (?opts :: [Flag]) => IO ()
startGtk =
do
dsply <- catch (do
d <- getEnv "DISPLAY"
return $ Just $ d)
(\_ -> (return Nothing))
case dsply of
Just _ ->
do
gtksetup
Nothing ->
do
startTty 0
gtksetup :: (?opts :: [Flag]) => IO ()
gtksetup =
do
args <- Gtk.initGUI
window <- windowNew -- WindowToplevel
windowSetTitle window ("linkchk " ++ labeltxt)
-- windowSetPolicy window False False True -- auto_skrink
-- let winDelHdl = WidgetDeleteEventHandler $ \_ _ -> do
-- mainQuit
-- return False
-- signalConnect window winDelHdl
containerSetBorderWidth window 3
frame <- frameNew -- labeltxt
frameSetShadowType frame ShadowEtchedIn
containerAdd window frame
lbl <- labelNew $ Just "..."
-- functions no longer exist?
-- widgetSetUSize lbl width 0
-- labelSetLineWrap lbl True
containerAdd frame lbl
-- type sig changed
-- idleAdd (IdleHandler $ idleHandler lbl )
widgetShowAll window
Gtk.mainGUI
exitWith ExitSuccess
where
idleHandler :: (?opts :: [Flag]) => Label -> IO Bool
idleHandler lbl =
do
st <- hopchk
labelSetLabel lbl st
doSleep
return True
width :: (?opts :: [Flag]) => Int
width =
case unaryVal Width
of
Just w ->
case maybeRead readDec w
of
Just n -> n
Nothing -> error ("WIDTH must be non-neg int.\n"
++ usageInfo header options)
Nothing -> 50
interface :: (?opts :: [Flag]) => Maybe Interface
interface = unaryVal Interface
labeltxt :: (?opts :: [Flag]) => String
labeltxt =
fromMaybe ifname $ unaryVal Host
where
ifname :: (?opts :: [Flag]) => String
ifname = fromMaybe "default" interface
doSleep :: (?opts :: [Flag]) => IO ()
doSleep =
let delaytime =
case unaryVal Delay
of
Just ds ->
case maybeRead readDec ds
of
Just t -> t
Nothing -> error ("DELAY must be non-neg int.\n"
++ usageInfo header options)
Nothing -> 1
in
do sleep delaytime >> return ()
hopchk :: (?opts :: [Flag]) => IO Result
hopchk =
do
debug "hopchk:"
ifDown <- ifaceDown
if ifDown then
return "down"
else
do
addrIface <- peeraddr
debug addrIface
case addrIface
of
Nothing -> return "no route"
Just (addr,iface) ->
do
(out, err, status) <- popen2 ping $ pingOpts iface addr
case status
of
Just (Exited ExitSuccess) ->
return $ reportTime out
Just (Exited (ExitFailure _)) | null err ->
return "dropped"
_ ->
do
return err
where
ping :: (?opts :: [Flag]) => String
ping =
if nullaryOpt IPv6
then "ping6"
else "ping"
pingOpts :: (?opts :: [Flag]) => Maybe Interface -> Address -> [String]
pingOpts iface addr =
case iface
of
Nothing -> []
Just ifc ->
if nullaryOpt IPv6 && linklocal addr
then ["-I", ifc]
else []
++ ["-c", "1",
"-w", (fromMaybe "1" $ unaryVal Wait),
addr]
reportTime :: String -> String
reportTime str =
let re = mkRegex ".*\n.*time=([0-9\\.]+) (us|ms|s)ec"
sigfig :: String -> String
sigfig time =
let wholeDigits = elemIndex '.' time
in
case wholeDigits
of
Just d ->
case maybeRead readFloat time
of
Just t ->
showFFloat (Just (3 - d)) t ""
Nothing -> time
Nothing -> time
in
case matchRegex re str
of
Just (time:unit:_) -> sigfig time ++ " " ++ unit
_ -> "> 1 s"
ifaceDown :: (?opts :: [Flag]) => IO Bool
ifaceDown =
case interface
of
Nothing -> return False
Just ifce ->
do
res <- ifconfig ifce
case res
of
Just out ->
let re = mkRegex "(.*\n)+ *(UP) " in
case matchRegex re out
of
Just _ -> return False
Nothing -> return True
Nothing -> return True
ifconfig :: (?opts :: [Flag]) => Interface -> IO (Maybe String)
ifconfig ifc =
do
(out, err, status) <- popen2 "ifconfig" [ifc]
case status
of
Just (Exited ExitSuccess) | null err -> return $ Just out
_ -> return Nothing
peeraddr :: (?opts :: [Flag]) => IO (Maybe (Address, Maybe Interface))
peeraddr =
case unaryVal Host
of
Just h -> return $ Just $ (h, Nothing)
Nothing ->
do
debug "peeraddr:"
peerAddr <- ptpAddress
case peerAddr
of
Just a -> return $ Just $ (a, interface)
Nothing ->
do
rt <- readRtGwys
debug rt
case (find (case interface
of
-- look for default route
Nothing ->
\ x -> (rteDest x) == defaultRoute
-- look for gateway for interface
Just iface ->
\ x -> (rteIface x) == iface)
rt)
of
Just x ->
return $ Just $ (rteGtwy x, Just $ rteIface x)
_ -> return Nothing
ptpAddress :: (?opts :: [Flag]) => IO (Maybe Address)
ptpAddress =
case interface
of
Nothing -> return Nothing
Just ifc ->
do
res <- ifconfig ifc
case res
of
Just out ->
case matchRegex re out
of
Just (addr:_) -> return $ Just addr
_ -> return Nothing
_ ->
return Nothing
where
re = mkRegex ".*\n.*P-t-P:([0-9\\.]+) "
maybeRead :: ReadS a -> String -> Maybe a
maybeRead rd str =
case rd str
of
[(t, "")] -> Just t
_ -> Nothing
linklocal :: Address -> Bool
linklocal addr =
(take 5 addr) == "fe80:"
data RtEntry = RtEntry {rteIface :: Interface, rteDest, rteGtwy :: Address}
deriving (Show)
readRtGwys :: (?opts :: [Flag]) => IO [RtEntry]
readRtGwys =
do
rt <- parseRT
return $ filter gtwyHost $ rt
where
gtwyHost :: (?opts :: [Flag]) => RtEntry -> Bool
gtwyHost x = (rteGtwy x) /= defaultRoute
parseRT :: (?opts :: [Flag]) => IO [RtEntry]
parseRT =
do
(out, err, status) <- popen2 "netstat" ["-r", "-n", afOpt]
case status
of
Just (Exited ExitSuccess) | null err ->
return $ map doParseRTE $ drop 2 $ lines out
_ ->
return []
afOpt :: (?opts :: [Flag]) => String
afOpt =
if nullaryOpt IPv6
then "--inet6"
else "--inet"
doParseRTE :: (?opts :: [Flag]) => String -> RtEntry
doParseRTE l =
case (words l)
of
dest:gtwy:_:_:_:_:iface:_ | nullaryOpt IPv6 ->
(RtEntry iface (cleanAddr dest) (cleanAddr gtwy))
dest:gtwy:_:_:_:_:_:iface:_ ->
(RtEntry iface dest gtwy)
_ -> error ("Can't parse routing table line:\n" ++ l)
cleanAddr :: String -> Address
cleanAddr addr =
takeWhile (/= '/') addr
defaultRoute :: (?opts :: [Flag]) => Address
defaultRoute =
if nullaryOpt IPv6
then "::"
else "0.0.0.0"
debug :: (?opts :: [Flag], Show a) => a -> IO ()
debug v =
if nullaryOpt Debug then
do
print v
else
return ()
popen2 :: (?opts :: [Flag]) => String -> [String] ->
IO (String, String, Maybe ProcessStatus)
popen2 cmd opts =
do
debug ("popen " ++ cmd ++ " " ++ show opts)
(out, err, pid) <- popen cmd opts Nothing
status <- getProcessStatus True False pid
debug status
debug out
debug err
return (out, err, status)
-- return $ (out, err, pid)