module Data.IP.Addr where import Control.Monad import Data.Bits import Data.Char import Data.List (foldl') import Data.String import Data.Word import Network.Socket import System.ByteOrder import Text.Appar.String import Text.Printf ---------------------------------------------------------------- {-| A unified IP data for 'IPv4' and 'IPv6'. To create this, use the data constructors. Or use 'read' @\"192.0.2.1\"@ :: 'IP', for example. Also, @\"192.0.2.1\"@ can be used as literal with OverloadedStrings. >>> (read "192.0.2.1" :: IP) == IPv4 (read "192.0.2.1" :: IPv4) True >>> (read "2001:db8:00:00:00:00:00:01" :: IP) == IPv6 (read "2001:db8:00:00:00:00:00:01" :: IPv6) True -} data IP = IPv4 { ipv4 :: IPv4 } | IPv6 { ipv6 :: IPv6 } deriving (Eq) instance Show IP where show (IPv4 ip) = show ip show (IPv6 ip) = show ip ---------------------------------------------------------------- -- This is host byte order type IPv4Addr = Word32 type IPv6Addr = (Word32,Word32,Word32,Word32) {-| The abstract data type to express an IPv4 address. To create this, use 'toIPv4'. Or use 'read' @\"192.0.2.1\"@ :: 'IPv4', for example. Also, @\"192.0.2.1\"@ can be used as literal with OverloadedStrings. >>> read "192.0.2.1" :: IPv4 192.0.2.1 -} newtype IPv4 = IP4 IPv4Addr deriving (Eq, Ord) {-| The abstract data type to express an IPv6 address. To create this, use 'toIPv6'. Or use 'read' @\"2001:DB8::1\"@ :: 'IPv6', for example. Also, @\"2001:DB8::1\"@ can be used as literal with OverloadedStrings. >>> read "2001:db8:00:00:00:00:00:01" :: IPv6 2001:db8:00:00:00:00:00:01 >>> read "2001:db8:11e:c00::101" :: IPv6 2001:db8:11e:c00:00:00:00:101 >>> read "2001:db8:11e:c00:aa:bb:192.0.2.1" :: IPv6 2001:db8:11e:c00:aa:bb:c000:201 >>> read "2001:db8::192.0.2.1" :: IPv6 2001:db8:00:00:00:00:c000:201 -} newtype IPv6 = IP6 IPv6Addr deriving (Eq, Ord) ---------------------------------------------------------------- -- -- Show -- instance Show IPv4 where show = showIPv4 instance Show IPv6 where show = showIPv6 showIPv4 :: IPv4 -> String showIPv4 (IP4 a) = show4 a where remQuo x = (x `mod` 256, x `div` 256) show4 q = printf "%d.%d.%d.%d" a1 a2 a3 a4 where (a4,q4) = remQuo q (a3,q3) = remQuo q4 (a2,q2) = remQuo q3 (a1, _) = remQuo q2 showIPv6 :: IPv6 -> String showIPv6 (IP6 (a1,a2,a3,a4)) = show6 a1 ++ ":" ++ show6 a2 ++ ":" ++ show6 a3 ++ ":" ++ show6 a4 where remQuo x = (x `mod` 65536, x `div` 65536) show6 q = printf "%02x:%02x" r1 r2 where (r2,q2) = remQuo q (r1, _) = remQuo q2 ---------------------------------------------------------------- -- -- IntToIP -- {-| The 'toIPv4' function takes a list of 'Int' and returns 'IPv4'. >>> toIPv4 [192,0,2,1] 192.0.2.1 -} toIPv4 :: [Int] -> IPv4 toIPv4 = IP4 . toWord32 where toWord32 [a1,a2,a3,a4] = fromIntegral $ shift a1 24 + shift a2 16 + shift a3 8 + a4 toWord32 _ = error "toWord32" {-| The 'toIPv6' function takes a list of 'Int' and returns 'IPv6'. >>> toIPv6 [0x2001,0xDB8,0,0,0,0,0,1] 2001:db8:00:00:00:00:00:01 -} toIPv6 :: [Int] -> IPv6 toIPv6 ad = IP6 (x1,x2,x3,x4) where [x1,x2,x3,x4] = map toWord32 $ split2 ad split2 [] = [] split2 x = take 2 x : split2 (drop 2 x) toWord32 [a1,a2] = fromIntegral $ shift a1 16 + a2 toWord32 _ = error "toWord32" ---------------------------------------------------------------- -- -- IPToInt -- {-| The 'fromIPv4' function converts 'IPv4' to a list of 'Int'. >>> fromIPv4 (toIPv4 [192,0,2,1]) [192,0,2,1] -} fromIPv4 :: IPv4 -> [Int] fromIPv4 (IP4 w) = map (\n -> fromEnum $ (w `shiftR` n) .&. 0xff) [0o30, 0o20, 0o10, 0o00] {-| The 'toIPv6' function converts 'IPv6' to a list of 'Int'. >>> fromIPv6 (toIPv6 [0x2001,0xDB8,0,0,0,0,0,1]) [8193,3512,0,0,0,0,0,1] -} fromIPv6 :: IPv6 -> [Int] fromIPv6 (IP6 (w1, w2, w3, w4)) = map fromEnum (concatMap split [w1,w2,w3,w4]) where split :: Word32 -> [Word32] split n = [n `shiftR` 0x10 .&. 0xffff, n .&. 0xffff] ---------------------------------------------------------------- -- -- Read -- instance Read IP where readsPrec _ = parseIP instance Read IPv4 where readsPrec _ = parseIPv4 instance Read IPv6 where readsPrec _ = parseIPv6 parseIP :: String -> [(IP,String)] parseIP cs = case runParser ip4 cs of (Just ip,rest) -> [(IPv4 ip,rest)] (Nothing,_) -> case runParser ip6 cs of (Just ip,rest) -> [(IPv6 ip,rest)] (Nothing,_) -> [] parseIPv4 :: String -> [(IPv4,String)] parseIPv4 cs = case runParser ip4 cs of (Nothing,_) -> [] (Just a4,rest) -> [(a4,rest)] parseIPv6 :: String -> [(IPv6,String)] parseIPv6 cs = case runParser ip6 cs of (Nothing,_) -> [] (Just a6,rest) -> [(a6,rest)] ---------------------------------------------------------------- -- -- IsString -- instance IsString IP where fromString = read instance IsString IPv4 where fromString = read instance IsString IPv6 where fromString = read ---------------------------------------------------------------- -- -- IPv4 Parser -- dig :: Parser Int dig = 0 <$ char '0' <|> toInt <$> oneOf ['1'..'9'] <*> many digit where toInt n ns = foldl' (\x y -> x * 10 + y) 0 . map digitToInt $ n : ns ip4 :: Parser IPv4 ip4 = skipSpaces >> toIPv4 <$> ip4' ip4' :: Parser [Int] ip4' = do as <- dig `sepBy1` char '.' check as return as where test errmsg adr = when (adr < 0 || 255 < adr) (fail errmsg) check as = do let errmsg = "IPv4 adddress" when (length as /= 4) (fail errmsg) mapM_ (test errmsg) as skipSpaces :: Parser () skipSpaces = void $ many (char ' ') ---------------------------------------------------------------- -- -- IPv6 Parser (RFC 4291) -- hex :: Parser Int hex = do ns <- some hexDigit check ns let ms = map digitToInt ns val = foldl' (\x y -> x * 16 + y) 0 ms return val where check ns = when (length ns > 4) (fail "IPv6 address -- more than 4 hex") colon2 :: Parser () colon2 = void $ string "::" format :: [Int] -> [Int] -> Parser [Int] format bs1 bs2 = do let len1 = length bs1 len2 = length bs2 when (len1 > 7) (fail "IPv6 address1") when (len2 > 7) (fail "IPv6 address2") let len = 8 - len1 - len2 when (len <= 0) (fail "IPv6 address3") let spring = replicate len 0 return $ bs1 ++ spring ++ bs2 ip6 :: Parser IPv6 ip6 = skipSpaces >> toIPv6 <$> ip6' ip6' :: Parser [Int] ip6' = ip4Embedded <|> do colon2 bs <- option [] hexcolon format [] bs <|> try (do rs <- hexcolon check rs return rs) <|> do bs1 <- hexcolon2 bs2 <- option [] hexcolon format bs1 bs2 where hexcolon = hex `sepBy1` char ':' hexcolon2 = manyTill (hex <* char ':') (char ':') check bs = when (length bs /= 8) (fail "IPv6 address4") ip4Embedded :: Parser [Int] ip4Embedded = try (do colon2 bs <- beforeEmbedded embedded <- ip4' format [] (bs ++ ip4ToIp6 embedded)) -- matches 2001:db8::192.0.2.1 <|> try (do bs1 <- manyTill (try $ hex <* char ':') (char ':') bs2 <- option [] beforeEmbedded embedded <- ip4' format bs1 (bs2 ++ ip4ToIp6 embedded)) -- matches 2001:db8:11e:c00:aa:bb:192.0.2.1 <|> try (do bs <- beforeEmbedded embedded <- ip4' let rs = bs ++ ip4ToIp6 embedded check rs return rs) where beforeEmbedded = many $ try $ hex <* char ':' ip4ToIp6 [a,b,c,d] = [ a `shiftL` 8 .|. b , c `shiftL` 8 .|. d ] ip4ToIp6 _ = error "ip4ToIp6" check bs = when (length bs /= 8) (fail "IPv6 address4") ---------------------------------------------------------------- -- -- HostAddress and HostAddress6 -- -- | The 'fromHostAddress' function converts 'HostAddress' to 'IPv4'. fromHostAddress :: HostAddress -> IPv4 fromHostAddress addr4 | byteOrder == LittleEndian = IP4 $ fixByteOrder addr4 | otherwise = IP4 addr4 -- | The 'toHostAddress' function converts 'IPv4' to 'HostAddress'. toHostAddress :: IPv4 -> HostAddress toHostAddress (IP4 addr4) | byteOrder == LittleEndian = fixByteOrder addr4 | otherwise = addr4 -- | The 'fromHostAddress6' function converts 'HostAddress6' to 'IPv6'. fromHostAddress6 :: HostAddress6 -> IPv6 fromHostAddress6 = IP6 -- | The 'toHostAddress6' function converts 'IPv6' to 'HostAddress6'. toHostAddress6 :: IPv6 -> HostAddress6 toHostAddress6 (IP6 addr6) = addr6 fixByteOrder :: Word32 -> Word32 fixByteOrder s = d1 .|. d2 .|. d3 .|. d4 where d1 = shiftL s 24 d2 = shiftL s 8 .&. 0x00ff0000 d3 = shiftR s 8 .&. 0x0000ff00 d4 = shiftR s 24 .&. 0x000000ff