Haskell traceroute over icmp

traceroute.hs

#!/usr/bin/env runhaskell

-- Haskell traceroute over icmp
-- now with ByteString to avoid new errors produced
-- by the deprecated recvFrom from Network.Socket

import Control.Monad
import Data.Bits(complement)
import Data.ByteString(unpack,pack)
import Data.List
import Data.Monoid
import Data.Time
import Data.Word
import Network.BSD(getProtocolNumber)
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import Network.Socket.ByteString
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
        printf "Haskell traceroute to target Adress: %s\n" $ show targetAddress
        proto <- getProtocolNumber "icmp"
        sock <- socket AF_INET Raw proto
        setSocketOption sock ReuseAddr 1
        myAddress <- getAddrInfo (Just (defaultHints {addrFlags = [AI_PASSIVE]})) Nothing (Just "3000")
        bind sock (addrAddress . head $ myAddress)
        try_ttl sock 1 targetAddress
        close 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 msga = pack $  [8,0,fromIntegral $ div checksum 256,fromIntegral $ mod checksum 256,47,242,fromIntegral $ div ttl 256, fromIntegral $ mod ttl 256] -- id is hardcoded
                                info <-  replicateM 3 $ measure msga sock addr -- try 3 times
                                let ans = msum $ map (\(_,a,_)->a) info
                                case ans of
                                    Just (msg,foundAddress) ->    do
                                                                        let (t:c:_) = map toInteger $ drop 20 $  unpack $ 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 msga sock addr    =         do
                                    sendTo sock msga 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 _ = "*"