rws-0.1.1.2: src/IPv6.hs

{-# LANGUAGE CPP #-}
module IPv6 where

import Data.Binary.Put
import Data.Bits
import qualified Data.ByteString.Lazy as B
import Data.Word
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Perm

import Lexer
import Packet
import Util

#ifdef HRWS_TEST
import Debug.Trace
import Test.QuickCheck hiding ((.&.))
import Test.Framework (Test)
import Test.Framework.Providers.QuickCheck2 (testProperty)
#endif

parseIPv6Ver :: Parser Word8 
parseIPv6Ver = parseIntAttribute "ver"

parseIPv6Flow :: Parser Word32
parseIPv6Flow = parseIntAttribute "flow"

parseIPv6Tcl :: Parser Word8
parseIPv6Tcl = parseIntAttribute "tcl"

parseIPv6Len :: Parser Word16
parseIPv6Len = parseIntAttribute "len"

parseIPv6Hl :: Parser Word8
parseIPv6Hl = parseIntAttribute "hl"

parseIPv6Nh :: Parser Word8
parseIPv6Nh = parseIntAttribute "nh"

ipv6AddressDecl :: Parser IPv6Addr 
ipv6AddressDecl = do
    a0 <- integer
    char ':'
    a1 <- integer
    char ':'
    a2 <- integer
    char ':'
    a3 <- integer
    char ':'
    a4 <- integer
    char ':'
    a5 <- integer
    char ':'
    a6 <- integer
    char ':'
    a7 <- integer

    let fix a b = fromIntegral a `shiftL` 16 .|. b

    return (IPv6Addr (fromIntegral (fix a0 a1))
                     (fromIntegral (fix a2 a3))
                     (fromIntegral (fix a4 a5))
                     (fromIntegral (fix a6 a7)))

parseIPv6Address :: String -> Parser IPv6Addr
parseIPv6Address s = do
  symbol s
  symbol "="
  a <- ipv6AddressDecl
  whiteSpace
  return a

parseIPv6Pkt :: Parser Packet -> Parser IPv6Pkt
parseIPv6Pkt f = permute
  (tuple <$?> (IPv6Addr 0x2001000 0 0 1, parseIPv6Address "src")
         <|?> (IPv6Addr 0x2001000 0 0 2, parseIPv6Address "dst")
         <|?> (6, parseIPv6Ver)
         <|?> (0, try parseIPv6Tcl)
         <|?> (0, try parseIPv6Flow)
         <|?> (0, parseIPv6Len)
         <|?> (17, parseIPv6Nh)
         <|?> (64, parseIPv6Hl)
         <|?> ([PPayload defaultPayload], parsePayload f))
  where
    tuple s d v tcl fl l nh hl =
      IPv6Pkt (IPv6 v tcl fl l nh hl s d)

ipv6Decl :: Parser Packet -> Parser Packet
ipv6Decl f = do
 symbol "ipv6"
 p <- parseIPv6Pkt f
 return (PIPv6 p)

ipv6AddrWrite :: IPv6Addr -> Put
ipv6AddrWrite a = do
  putWord32be $ ipv6Addr0 a
  putWord32be $ ipv6Addr1 a
  putWord32be $ ipv6Addr2 a
  putWord32be $ ipv6Addr3 a

ipv6WriteHdr :: IPv6 -> Put
ipv6WriteHdr p = do
    -- pl_uint8_t vertcl
    putWord8 $ ipv6Ver p `shiftL` 4 .|. ipv6Tcl p `shiftR` 4
    -- pl_uint8_t tclflow XXX byte order of ipv6Flow!!!
    putWord8 $ ipv6Tcl p `shiftL` 4 .|. fromIntegral (ipv6Flow p `shiftR` 16)
    -- pl_uint16_t flow_id
    putWord16be $ fromIntegral $ ipv6Flow p .&. 0xffff
    putWord16be $ ipv6Length p
    putWord8 $ ipv6Nh p
    putWord8 $ ipv6Hl p
    ipv6AddrWrite $ ipv6Src p 
    ipv6AddrWrite $ ipv6Dst p

ipv6Write :: IPv6 -> Maybe Packet -> B.ByteString -> Put
ipv6Write h _ bs = do
  ipv6WriteHdr h {ipv6Length = fromIntegral $ B.length bs}
  putLazyByteString bs

pseudoIpv6Write :: IPv6 -> Word16 -> Put
pseudoIpv6Write p l = do
    ipv6AddrWrite $ ipv6Src p 
    ipv6AddrWrite $ ipv6Dst p
    putWord16be l
    putWord8 0
    putWord8 0
    putWord8 0
    putWord8 $ ipv6Nh p

instance PacketWriteable IPv6Pkt where packetWrite p = ipv6Write (ipv6PktHeader p)

#ifdef HRWS_TEST
{- Unit Tests -}

instance Arbitrary IPv6Addr where
  arbitrary = do
    a0 <- arbitrary
    a1 <- arbitrary
    a2 <- arbitrary
    a3 <- arbitrary
    return (IPv6Addr a0 a1 a2 a3)

instance Arbitrary IPv6 where
  arbitrary = do
    v    <- arbitrary
    tcl  <- arbitrary
    flow <- arbitrary
    len  <- arbitrary
    nh   <- arbitrary
    hl   <- arbitrary
    src  <- arbitrary
    dst  <- arbitrary
    return (IPv6 v tcl flow len nh hl src dst)

testValidParse :: String -> (IPv6 -> Bool) -> Bool
testValidParse str fn =
  case parse (dummyParsePacket ipv6Decl) "packet parse" str of
       Left  err -> trace (show err) False
       Right val -> fn $ testIPv6Pkt val

testIPv6Pkt :: Packet -> IPv6
testIPv6Pkt (PIPv6 p) = ipv6PktHeader p
testIPv6Pkt _ = error "Unexpected packet type"

testIPv6Default :: () -> Bool
testIPv6Default _ = let cmp f = defaultIPv6 == f in
  testValidParse "(ipv6)" cmp

ipv6ToPktStr :: IPv6 -> String
ipv6ToPktStr ip = "ipv6 ver=" ++ show (ipv6Ver ip) ++ " tcl=" ++ show (ipv6Tcl ip) ++
                  " flow=" ++ show (ipv6Flow ip) ++ " len=" ++ show (ipv6Length ip) ++
                  " nh=" ++ show (ipv6Nh ip) ++ " hl=" ++ show (ipv6Hl ip) ++
                  " src=" ++ show (ipv6Src ip) ++ " dst=" ++ show (ipv6Dst ip)


testIPv6Pkt0 :: IPv6 -> Bool
testIPv6Pkt0 ip = let cmp p = ip == p in
  testValidParse ("(" ++ ipv6ToPktStr ip ++ ")") cmp

testIPv6InIPv6 :: IPv6 -> Bool
testIPv6InIPv6 inner =
  let outer = inner {ipv6Nh = 41} in
  let cmp p = p == outer in
  testValidParse ("(" ++ ipv6ToPktStr outer ++ "(" ++ ipv6ToPktStr inner ++ "))") cmp
  

testIPv6Write :: () -> Bool
testIPv6Write _ =
  let expPkt = B.pack [0x60, 0xf0, 0xbe, 0xef, 0x00, 0x00, 0x04, 0x40,
                       0x07, 0xd1, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
                       0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01,
                       0x07, 0xd1, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
                       0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x02] in
   let cmp p = runPut (ipv6Write p Nothing B.empty) == expPkt in
   testValidParse "(ipv6 ver=6 tcl=0xf flow=0xbeef len=0 hl=64 src=2001:0:0:0:0:0:0:1 dst=2001:0:0:0:0:0:0:2 nh=4)" cmp

testIPv6PseudoWrite :: () -> Bool
testIPv6PseudoWrite _ =
  let expPkt = B.pack [0x07, 0xd1, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
                       0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01,
                       0x07, 0xd1, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00,
                       0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x02,
                       0x00, 0x54, 0x00, 0x00, 0x00, 0x04] in
   let cmp p = runPut (pseudoIpv6Write p 84) == expPkt in
   testValidParse "(ipv6 ver=6 tcl=0xf flow=0xbeef len=84 hl=64 src=2001:0:0:0:0:0:0:1 dst=2001:0:0:0:0:0:0:2 nh=4)" cmp

  


ipv6Tests :: [Test]
ipv6Tests = [
  testProperty "IPv6: Default" testIPv6Default,
  testProperty "IPv6 Packet 0" testIPv6Pkt0,
  testProperty "IPv6 in IPv6" testIPv6InIPv6,
  testProperty "IPv6 Write" testIPv6Write,
  testProperty "IPv6 Pesudo Write" testIPv6PseudoWrite
  ]

#endif