traceroute.hs

#!/usr/bin/env runhaskell

-- Haskell traceroute over icmp 

import Control.Monad
import Data.Bits(complement)
import Data.Char (chr,ord)
import Data.List
import Data.Monoid
import Data.Time
import Data.Word
import Network.BSD(getProtocolNumber)
import Network.Socket
import System.Environment
import System.Process
import System.Timeout
import Text.Printf

sec = (*) 1000000

main = withSocketsDo $
    do 
        s <- fmap head getArgs  
        addrinfos <- getAddrInfo Nothing (Just s) (Just "0")
        let serveraddr = head addrinfos
        let targetAddress = addrAddress serveraddr
        proto <- getProtocolNumber "icmp"
        sock <- socket AF_INET Raw proto
        setSocketOption sock ReuseAddr 1
        myAddress <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) Nothing (Just "3000")
        bindSocket sock (addrAddress . head $ myAddress)
        try_ttl sock 1 targetAddress
        sClose sock
    where
        try_ttl sock ttl addr = do
                                setSocketOption sock TimeToLive ttl
                                let checksum = fromIntegral . complement $ ((  fromIntegral (14322 + ttl) ) :: Word16) -- no carry ... unless ttl is way too large
                                let msg = map chr $ [8,0,div checksum 256,mod checksum 256,47,242,div ttl 256, mod ttl 256] -- id is hardcoded
                                info <-  replicateM 3 $ measure msg sock addr -- try 3 times
				let ans = msum $ map (\(_,a,_)->a) info
                                case ans of
                                    Just (msg,_,foundAddress) ->    do 
                                                                        let (t:c:_) = drop 20 . map ord $ msg -- should also look at id
                                                                        let time = intercalate "  " $ map prepare_time info
                                                                        printf "#%i  %s  %s\n" ttl (takeWhile (/=':') $ show foundAddress) time
                                                                        case (t,c) of
                                                                            (11,0) -> try_ttl sock (succ ttl) addr -- Type: 11 (Time-to-live exceeded)
                                                                            (3,0) -> printf "Destination network unreachable!\n"
                                                                            (3,1) -> printf "Destination host unreachable!\n"
                                                                            _ -> return ()
                                    _ -> printf "Timeout!\n"
        measure msg sock addr    = 	do
                                    sendTo sock msg addr
                                    start <- getCurrentTime
                                    ans <- timeout (sec 2) $ recvFrom sock 1024 -- timeout after 2 seconds
                                    stop <- getCurrentTime
                                    return (start,ans,stop)
        prepare_time (start,Just _,stop) = (++"ms") . init . show $ diffUTCTime stop start * 1000
        prepare_time _ = "*"