Ethernet.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Etherbunny.Ethernet
-- Copyright   :  (c) Nicholas Burlett 2007
-- License     :  GPL (see the file LICENSE)
--
-- Maintainer  :  nickburlett@mac.com
-- Stability   :  experimental
-- Portability :  ghc
--
-- Ethernet Packet access for Etherbunny.
-- 
-----------------------------------------------------------------------------

{-# OPTIONS_GHC -fglasgow-exts -funbox-strict-fields #-}

module Network.Etherbunny.Ethernet (
    -- * Types
    MACAddr,
    EthType,
    EtherPkt,
    
    -- * Functions
    getEtherPacket -- :: ByteString -> EthPkt
) where
    
import Network.Etherbunny.Ip
import Network.Etherbunny.Packet
    
import Data.Word
import qualified Data.ByteString as B
import Data.Binary.Get
import Numeric
import Bits

-- |
--   The MACAddr type gives a useful interface to MAC Addresses
--

newtype MACAddr = MACAddr Word64
    deriving (Eq, Ord, Bits, Num, Integral, Enum, Real)

instance Show MACAddr where
    showsPrec _ (MACAddr m) = 
        foldr (\i a -> showsHexByte (getWord m i)  ":" . a) (showsHexByte (getWord m 0)  "") $ [5,4..1]
        where
            getWord x i = (x `shiftR` (i*8)) .&. 0xff
            showsHexByte x a = showString $ tail $ showHex (16^2+x) a

macFromList :: [Word8] -> MACAddr
macFromList  = wordsToInt 6 


-- |
--   The EthType type is designed to show the type of payload in an Ethernet packet
--

newtype EthType = EthType Word16
    deriving (Num, Eq)

instance Show EthType where
    showsPrec _ (EthType e) =
        showString $ tail $ showHex (16^4+ 0x0800) $ " " ++ etherTypeName e

etherTypeName e 
    | e == 0x0800   = "IP"
    | otherwise     = "Unknown"

ethTypeFromList :: [Word8] -> EthType
ethTypeFromList [f, f2] = EthType $ (fromIntegral f) `shiftL` 8 .|. (fromIntegral f2) 


data EtherPayload = IPPkt IPPkt
    deriving (Show)

-- | 
--   The EthPkt type defines an Ethernet II packet with another Packet payload
--

data EtherPkt = EtherPkt { 
                 ethDestination :: !MACAddr,    -- ^ destination MAC address
                 ethSource      :: !MACAddr,    -- ^ source MAC address
                 ethType        :: !EthType,    -- ^ payload type
                 ethPayload     :: !(Maybe EtherPayload),      -- ^ payload
                 ethRemainder   :: !([Word8])     -- ^ anything remaining
               }

instance Show EtherPkt where
   showsPrec p pkt = 
       showString "Ethernet II dest: " . showsPrec p (ethDestination pkt)
           . showString " src: " . showsPrec p (ethSource pkt)
           . showString " type: " . showsPrec p (ethType pkt)
           . showsPrec p (ethPayload pkt)
           . showsPrec p (ethRemainder pkt)

getMacAddress = do
    mac <- getByteString 6 
    return $ macFromList $ B.unpackList mac

getEtherPacket :: Get EtherPkt
getEtherPacket = do
    dst <- getMacAddress
    src <- getMacAddress
    typ <- getWord16be
    payload <- do 
        case typ of
            0x0800    -> do 
                payload <- getIPPacket
                return $ Just $ IPPkt payload
            otherwise -> undefined
    numRemain <- remaining
    remaining <- getByteString $ fromIntegral numRemain
    return $ EtherPkt dst src (EthType typ) payload (B.unpack remaining)