ip6addr-0.3: src/IPv6Addr.hs
module IPv6Addr (maybeIPv6Addr) where
import Data.Char (isDigit,isHexDigit,toLower)
import Data.List (group,groupBy,intercalate,intersperse,elemIndex)
import Data.Function (on)
import Data.Maybe
tokenizedBy :: String -> Char -> [String]
tokenizedBy s c = groupBy ((==) `on` ( == c)) s
-- Parsing embedded IPv4 address
data IPv4AddrToken = Dot | EightBits String deriving (Eq,Show)
dot :: String -> Maybe IPv4AddrToken
dot s = if s == "." then Just Dot else Nothing
eightBitsToken :: String -> Maybe IPv4AddrToken
eightBitsToken s =
let t = read s::Int
in
if not(null s) && all isDigit s && t >= 0 && t <= 255
then Just (EightBits s) else Nothing
ipv4Token :: String -> Maybe IPv4AddrToken
ipv4Token s
| isJust(dot s) = Just Dot
| isJust(eightBitsToken s) = Just (EightBits s)
| otherwise = Nothing
ipv4Addr :: String -> Maybe IPv6AddrToken
ipv4Addr s =
do
let r = map ipv4Token (s `tokenizedBy` '.')
if (Nothing `notElem` r) && (length r == 7)
then Just (IPv4Addr s) else Nothing
-- Parsing IPv6 Address
type IPv6Addr = String
data IPv6AddrToken = SixteenBits String | AllZeros | Colon | DoubleColon
| IPv4Addr String deriving (Eq,Show)
colon :: String -> Maybe IPv6AddrToken
colon s = if s == ":" then Just Colon else Nothing
doubleColon :: String -> Maybe IPv6AddrToken
doubleColon s = if s == "::" then Just DoubleColon else Nothing
sixteenBits:: String -> Maybe IPv6AddrToken
sixteenBits s =
if length s < 5 then
do
-- "Leading zeros MUST be suppressed" (RFC 5952, 4.1)
let s'= dropWhile (=='0') s
if length s' < 5 && all isHexDigit s'
then case s' of
"" -> Just AllZeros
-- Hexadecimal digits MUST be in lowercase (RFC 4.3)
otherwise -> Just (SixteenBits (map toLower s'))
else Nothing
else Nothing
ipv6AddrToken :: String -> Maybe IPv6AddrToken
ipv6AddrToken s
| isJust s' = s'
| isJust(colon s) = Just Colon
| isJust(doubleColon s) = Just DoubleColon
| isJust(ipv4Addr s) = Just (IPv4Addr s)
| otherwise = Nothing
where s' = sixteenBits s
ipv6TokenToString :: IPv6AddrToken -> String
ipv6TokenToString (SixteenBits t) = t
ipv6TokenToString Colon = ":"
ipv6TokenToString DoubleColon = "::"
-- "A single 16-bit 0000 field MUST be represented as 0" (RFC 5952, 4.1)
ipv6TokenToString AllZeros = "0"
ipv6TokenToString (IPv4Addr i) = i
countIPv4Addr :: [Maybe IPv6AddrToken] -> Int
countIPv4Addr ts =
foldr oneMoreIPv4Token 0 ts
where
oneMoreIPv4Token t c =
case t of
Just (IPv4Addr _) -> c + 1
otherwise -> c
countDoubleColon :: [Maybe IPv6AddrToken] -> Int
countDoubleColon ts =
foldr oneMoreDoubleColon 0 ts
where
oneMoreDoubleColon t c =
case t of
Just DoubleColon -> c + 1
otherwise -> c
firstValidToken :: [Maybe IPv6AddrToken] -> Bool
firstValidToken ts =
case head ts of
Just (SixteenBits _) -> True
Just DoubleColon -> True
Just AllZeros -> True
otherwise -> False
ipv6AddrConstraints :: [Maybe IPv6AddrToken] -> Bool
ipv6AddrConstraints [] = False
ipv6AddrConstraints [Just DoubleColon] = True
ipv6AddrConstraints [Just DoubleColon,Just (SixteenBits "1")] = True
ipv6AddrConstraints ts =
do
let cdcts = countDoubleColon ts
let lents = length ts
let lastt = last ts
let lenconst = ( (lents == 15 && cdcts <= 0) || (lents < 15 && cdcts == 1) )
((firstValidToken ts && all isJust ts) &&
(case countIPv4Addr ts of
0 -> case lastt of
Just (SixteenBits _) -> lenconst
Just DoubleColon -> lenconst
Just AllZeros -> lenconst
otherwise -> False
1 -> case lastt of
Just (IPv4Addr _) -> (lents == 13 && cdcts <= 0) || (lents < 13 && cdcts == 1)
otherwise -> False
otherwise -> False))
maybeIPv6Addr :: String -> Maybe IPv6Addr
maybeIPv6Addr "::" = Just "::"
maybeIPv6Addr s =
do
let s' = map ipv6AddrToken (s `tokenizedBy` ':')
if ipv6AddrConstraints s'
then
(if Just DoubleColon `notElem` s' then
Just (replaceTheLongestZerosRun s') else
Just (replaceTheLongestZerosRun (expendDoubleColon s')))
else Nothing
expendDoubleColon :: [Maybe IPv6AddrToken] -> [Maybe IPv6AddrToken]
expendDoubleColon mit = do
let s = splitAt (fromJust $ elemIndex (Just DoubleColon) mit) mit
let fsts = fst s
let snds = if length(snd s) >= 1 then tail(snd s) else []
let fste = if null fsts then [] else fsts ++ [Just Colon]
let snde = if null snds then [] else Just Colon : snds
fste ++ allZerosTokensReplacement(quantityOfAllZerosTokenToReplace mit) ++ snde
quantityOfAllZerosTokenToReplace x =
8 - foldl (\c x -> if (x /= Just DoubleColon) && (x /= Just Colon)
then c+1 else c) 0 x
allZerosTokensReplacement x = intersperse (Just Colon) (replicate x (Just AllZeros))
-- "the longest run of consecutive 16-bit 0 fields MUST be shortened" (RFC 5952, 4.2.3)
-- All the stuff to deal with replacement of the longest zeros run by a double colon
longestLengthZerosRun x = maximum $ map longest x
where
longest t =
case t of
(True,i) -> i
otherwise -> 0
firstLongestZerosRunIndex :: (Num b) => [(Bool, b)] -> b -> b
firstLongestZerosRunIndex x y = sum $ snd $ unzip $ takeWhile (/=(True,y)) x
zerosRunsList :: [Maybe IPv6AddrToken] -> [(Bool, Int)]
zerosRunsList x = map helper $ groupZerosRuns x
where
helper h =
if head h == "0"
then (True,lh)
else (False,lh)
where lh = length h
groupZerosRuns :: [Maybe IPv6AddrToken] -> [[String]]
groupZerosRuns lts = group $ filter (/=":") $ map ipv6TokenToString $ catMaybes lts
onlyStringTokens :: [Maybe IPv6AddrToken] -> [String]
onlyStringTokens x = filter (/=":") $ map ipv6TokenToString $ catMaybes x
replaceTheLongestZerosRun :: [Maybe IPv6AddrToken] -> IPv6Addr
replaceTheLongestZerosRun s' = zerosToDoubleColon (onlyStringTokens s') (zerosRunToReplace $ zerosRunsList s')
zerosRunToReplace :: [(Bool, Int)] -> (Int, Int)
zerosRunToReplace t =
let l = longestLengthZerosRun t
in (firstLongestZerosRunIndex t l,l)
zerosToDoubleColon :: [String] -> (Int,Int) -> IPv6Addr
-- No all zeros token, so no double colon replacement...
zerosToDoubleColon ls (_,0) = intercalate ":" ls
-- "The symbol '::' MUST NOT be used to shorten just one 16-bit 0 field" (RFC 4.2.2)
zerosToDoubleColon ls (_,1) = intercalate ":" ls
zerosToDoubleColon ls (i,l) =
concat $ intersperse ":" (take i ls) ++ ["::"] ++ intersperse ":" (drop (i+l) ls)