{-# 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)