hsns-0.5.1: Hsns.hs

--run as root, otherwise you'll fail with an device error
module Main where
import System.Console.GetOpt
import System.Environment
import System.Process
import qualified Network.Pcap as PCap
import Control.Monad
import Text.Printf
import System.Exit
import Data.Maybe
import System.IO
import Data.List
import Data.Char
import Options
import Foreign



-- our packet output format
data PacketFmt = PacketFmt {
                   ascii       :: String,
                   hexadecimal :: [Word8]
                 }
 deriving (Eq,Show)

initPktFmt a h = 
  PacketFmt {
    ascii       = a,
    hexadecimal = h
}

hsnsVersion = "hsns: the haskell network sniffer, version 0.5.1"

formatData :: PacketFmt -> IO ()
formatData pf = do
  let (x,x') = splitAt 10 a
      (y,y') = splitAt 10 h
  unless (x' == [] && y' == []) $ do
    mapM_ (printf "%02.2x ") (fmtHex y)
    printf "\t\t%s\n" x
    formatData (initPktFmt x' y')
  return ()
 where
  a = ascii pf
  h = hexadecimal pf
  fmtHex :: [Word8] -> [Int]
  fmtHex bytes = [ (read $ show y) | y <- bytes] :: [Int]
  
captcha :: PCap.PktHdr -> Ptr Word8 -> IO ()
captcha pkth datap = do
  a  <- peekArray (fromIntegral (PCap.caplen pkth)) datap
  s  <- return $ map (\x -> if (x >= 32 && x <= 126) then x else 46) a
  s' <- return $ map (\x -> chr (read $ show x)) s
  formatData (initPktFmt s' a)
  printf "\n"
  hFlush stdout

starter :: HsnsOpts -> IO ()
starter o = do

  -- options that don't depend on anything else
  if (help o)    == "True" then putStrLn (usageInfo "hsns: \"filter program\" [OPTIONS]..." options) >> exitWith ExitSuccess 
   else return ()
  if (version o) == "True" then (putStrLn hsnsVersion >> (exitWith ExitSuccess)) else return ()   
  if (buffered o) == "True" then hSetBuffering stdout LineBuffering else return ()

  -- list devices
  devs <- PCap.findAllDevs
  let devnames = map (\i -> (PCap.ifName i)) devs

  if (iflist o)  == "True" then do
    putStrLn "interfaces:" 
    mapM_ (printf " -- %s\n") devnames
    exitWith ExitSuccess
   else return ()

  -- variables that depend on root access
  let dev      = (interface o)
  net  <- PCap.lookupNet dev
  spy  <- PCap.openLive dev (read $ snarflen o) (if (nopromiscuous o) == "True" then True else False) 100000
    
  withForeignPtr spy $ \ptr -> do
    -- set our filter, it must happen in this context as spy is
    -- a ForeignPtr, rather than a Ptr like we need for
    -- setFilter/loop

    if (bpf o) == "" then return () else PCap.setFilter ptr (bpf o) False (PCap.netMask net)
    -- loop and capture
    PCap.loop ptr (read $ count o) captcha
    --print statistics
    s <- PCap.statistics ptr
    putStrLn ("Packets recieved: " ++ (show $ PCap.recv s))
    putStrLn ("Packets dropped: " ++ (show $ PCap.drop s))
    putStrLn ("Packets dropped by interface: " ++ (show $ PCap.ifdrop s))



main = do
  (o,n)  <- parseOpts -- our options and filter in a pair, we assume the filter is the first thing
                      -- on the command line

  starter (create o n)
  return ()
 where
  parseOpts     = (getArgs >>= hsnsOptions)
  create x f =
    let y = construct x in
    Opts {count         = fromMaybe "5"        (lookup "count"     y),
          snarflen      = fromMaybe "68"       (lookup "snarf"     y),
          interface     = fromMaybe "eth0"     (lookup "listen"    y),
          version       = fromMaybe "False"    (lookup "version"   y),
          nopromiscuous = fromMaybe "False"    (lookup "nopromisc" y),
          iflist        = fromMaybe "False"    (lookup "ifList"    y),
          buffered      = fromMaybe "False"    (lookup "buffered"  y),
          help          = fromMaybe "False"    (lookup "help"      y),
          bpf           = if f == [] then "" else (f !! 0)
         }

  construct   f = map construct' f
   where
     construct' x = case x of
       Help          -> ("help","True")
       Count    s    -> ("count",s)
       SnarfLen s    -> ("snarf",s)
       Listen   s    -> ("listen",s)
       NoPromiscuous -> ("nopromisc","True")
       IfList        -> ("ifList","True")
       LineBuffered  -> ("buffered","True")
       Version       -> ("version","True")