module Text.IPv6Addr.Internal
( colon
, doubleColon
, sixteenBits
, ipv4Addr
, expandTokens
, maybeIPv6AddrToken
, maybeIPv6AddrTokens
, ipv4AddrToIPv6AddrTokens
, ipv6TokensToText
, ipv6TokensToIPv6Addr
, isIPv6Addr
, maybeTokIPv6Addr
, maybeTokPureIPv6Addr
, fromDoubleColon
, toDoubleColon
, networkInterfacesIPv6AddrList
) where
import Control.Monad (replicateM)
import Data.Char (isDigit,isHexDigit,toLower)
import Data.Function (on)
import Data.List (group,isSuffixOf,elemIndex,elemIndices,intersperse)
import Numeric (showHex)
import qualified Data.Text as T
import Data.Text.Read (decimal)
import Data.Maybe (fromJust,isJust)
import Network.Info
import Text.IPv6Addr.Types
tokdot = T.pack "."
tokcolon = T.pack ":"
tokdcolon = T.pack "::"
tok0 = T.pack "0"
tok4x0 = T.pack "0000"
tok1 = T.pack "1"
tokffff = T.pack "ffff"
tok64 = T.pack "64"
tokff9b = T.pack "ff9b"
tokfe80 = T.pack "fe80"
tok5efe = T.pack "5efe"
tok200 = T.pack "200"
tokenizedBy :: Char -> T.Text -> [T.Text]
tokenizedBy c = T.groupBy ((==) `on` (== c))
dot :: T.Text -> Maybe IPv4AddrToken
dot t
| t == tokdot = Just Dot
| otherwise = Nothing
colon :: T.Text -> Maybe IPv6AddrToken
colon t
| t == tokcolon = Just Colon
| otherwise = Nothing
doubleColon :: T.Text -> Maybe IPv6AddrToken
doubleColon t
| t == tokdcolon = Just DoubleColon
| otherwise = Nothing
sixteenBits:: T.Text -> Maybe IPv6AddrToken
eightBitsToken :: T.Text -> Maybe IPv4AddrToken
eightBitsToken t =
case decimal t of
Right p -> do let i = fst p
if i >= 0 && i <= 255 && snd p == T.empty
then Just (EightBits t) else Nothing
Left _ -> Nothing
ipv4Token :: T.Text -> Maybe IPv4AddrToken
ipv4Token t
| isJust(dot t) = Just Dot
| isJust(eightBitsToken t) = Just (EightBits t)
| otherwise = Nothing
ipv4Addr :: T.Text -> Maybe IPv6AddrToken
ipv4Addr t = do
let r = map ipv4Token $ tokenizedBy '.' t
if (Nothing `notElem` r) && (length r == 7)
then Just (IPv4Addr t) else Nothing
sixteenBits t =
if T.length t < 5
then do
let t'= T.dropWhile (=='0') t
if T.length t' < 5 && T.all isHexDigit t'
then
Just (if T.null t' then AllZeros else SixteenBits $ T.toLower t')
else Nothing
else Nothing
expandTokens :: [IPv6AddrToken] -> [IPv6AddrToken]
expandTokens =
map expTok
where expTok AllZeros = SixteenBits tok4x0
expTok (SixteenBits s) = do
let ls = T.length s
SixteenBits (if ls < 4 then T.replicate (4 ls) tok0 `T.append` s else s)
expTok t = t
maybeIPv6AddrToken :: T.Text -> Maybe IPv6AddrToken
maybeIPv6AddrToken t
| isJust t' = t'
| isJust(colon t) = Just Colon
| isJust(doubleColon t) = Just DoubleColon
| isJust(ipv4Addr t) = Just (IPv4Addr t)
| otherwise = Nothing
where t' = sixteenBits t
ipv6TokenToText :: IPv6AddrToken -> T.Text
ipv6TokenToText (SixteenBits s) = s
ipv6TokenToText Colon = tokcolon
ipv6TokenToText DoubleColon = tokdcolon
ipv6TokenToText AllZeros = tok0
ipv6TokenToText (IPv4Addr a) = a
ipv6TokensToText :: [IPv6AddrToken] -> T.Text
ipv6TokensToText l = T.concat $ map ipv6TokenToText l
isIPv6Addr :: [IPv6AddrToken] -> Bool
isIPv6Addr [] = False
isIPv6Addr [DoubleColon] = True
isIPv6Addr [DoubleColon,SixteenBits tok1] = True
isIPv6Addr tks =
diffNext tks && (do
let cdctks = countDoubleColon tks
let lentks = length tks
let lasttk = last tks
let lenconst = (lentks == 15 && cdctks == 0) || (lentks < 15 && cdctks == 1)
firstValidToken tks &&
(case countIPv4Addr tks of
0 -> case lasttk of
SixteenBits _ -> lenconst
DoubleColon -> lenconst
AllZeros -> lenconst
otherwise -> False
1 -> case lasttk of
IPv4Addr _ ->
(lentks == 13 && cdctks == 0) || (lentks < 12 && cdctks == 1)
otherwise -> False
otherwise -> False))
where diffNext [_] = True
diffNext [a,a'] = a /= a'
diffNext (a:as) = (a /= head as) && diffNext as
firstValidToken l =
case head l of
SixteenBits _ -> True
DoubleColon -> True
AllZeros -> True
otherwise -> False
countDoubleColon l = length $ elemIndices DoubleColon l
countIPv4Addr =
foldr oneMoreIPv4Addr 0
where oneMoreIPv4Addr t c = case t of
IPv4Addr _ -> c + 1
otherwise -> c
maybeIPv6AddrTokens :: T.Text -> Maybe [IPv6AddrToken]
maybeIPv6AddrTokens t = mapM maybeIPv6AddrToken $ tokenizedBy ':' t
maybeTokIPv6Addr :: T.Text -> Maybe [IPv6AddrToken]
maybeTokIPv6Addr t =
do ltks <- maybeIPv6AddrTokens t
if isIPv6Addr ltks
then Just $ (ipv4AddrReplacement . toDoubleColon . fromDoubleColon) ltks
else Nothing
where ipv4AddrReplacement ltks' =
if ipv4AddrRewrite ltks'
then init ltks' ++ ipv4AddrToIPv6AddrTokens (last ltks')
else ltks'
maybeTokPureIPv6Addr :: T.Text -> Maybe [IPv6AddrToken]
maybeTokPureIPv6Addr t =
do ltks <- maybeIPv6AddrTokens t
if isIPv6Addr ltks
then Just $ (toDoubleColon . ipv4AddrReplacement . fromDoubleColon) ltks
else Nothing
where ipv4AddrReplacement ltks' =
init ltks' ++ ipv4AddrToIPv6AddrTokens (last ltks')
ipv4AddrRewrite :: [IPv6AddrToken] -> Bool
ipv4AddrRewrite tks =
case last tks of
IPv4Addr _ -> do
let itks = init tks
not (itks == [DoubleColon]
|| itks == [DoubleColon,SixteenBits tokffff,Colon]
|| itks == [DoubleColon,SixteenBits tokffff,Colon,AllZeros,Colon]
|| itks == [SixteenBits tok64,Colon,SixteenBits tokff9b,DoubleColon]
|| [SixteenBits tok200,Colon,SixteenBits tok5efe,Colon] `isSuffixOf` itks
|| [AllZeros,Colon,SixteenBits tok5efe,Colon] `isSuffixOf` itks
|| [DoubleColon,SixteenBits tok5efe,Colon] `isSuffixOf` itks)
otherwise -> False
ipv4AddrToIPv6AddrTokens :: IPv6AddrToken -> [IPv6AddrToken]
ipv4AddrToIPv6AddrTokens t =
case t of
IPv4Addr a -> do
let m = toHex a
[fromJust $ sixteenBits ((!!) m 0 `T.append` addZero ((!!) m 1))
,Colon
,fromJust $ sixteenBits ((!!) m 2 `T.append` addZero ((!!) m 3))]
_ -> [t]
where toHex a = map (\x -> T.pack $ showHex (read (T.unpack x)::Int) "") $ T.split (=='.') a
addZero d = if T.length d == 1 then tok0 `T.append` d else d
fromDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken]
fromDoubleColon tks =
if DoubleColon `notElem` tks then tks
else do
let s = splitAt (fromJust $ elemIndex DoubleColon tks) tks
let fsts = fst s
let snds = if not (null (snd s)) then tail(snd s) else []
let fste = if null fsts then [] else fsts ++ [Colon]
let snde = if null snds then [] else Colon : snds
fste ++ allZerosTokensReplacement(quantityOfAllZerosTokenToReplace tks) ++ snde
where quantityOfAllZerosTokenToReplace x =
ntks tks foldl (\c x -> if (x /= DoubleColon) && (x /= Colon) then c+1 else c) 0 x
where
ntks tks = if countIPv4Addr tks == 1 then 7 else 8
allZerosTokensReplacement x = intersperse Colon (replicate x AllZeros)
toDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken]
toDoubleColon tks =
zerosToDoubleColon tks (zerosRunToReplace $ zerosRunsList tks)
where
zerosToDoubleColon :: [IPv6AddrToken] -> (Int,Int) -> [IPv6AddrToken]
zerosToDoubleColon ls (_,0) = ls
zerosToDoubleColon ls (_,1) = ls
zerosToDoubleColon ls (i,l) =
let ls' = filter (/= Colon) ls
in intersperse Colon (take i ls') ++ [DoubleColon] ++ intersperse Colon (drop (i+l) ls')
zerosRunToReplace t =
let l = longestLengthZerosRun t
in (firstLongestZerosRunIndex t l,l)
where firstLongestZerosRunIndex x y = sum . snd . unzip $ takeWhile (/=(True,y)) x
longestLengthZerosRun x =
maximum $ map longest x
where longest t = case t of
(True,i) -> i
otherwise -> 0
zerosRunsList x =
map helper $ groupZerosRuns x
where
helper h =
(head h == AllZeros, lh)
where lh = length h
groupZerosRuns = group . filter (/= Colon)
ipv6TokensToIPv6Addr :: [IPv6AddrToken] -> Maybe IPv6Addr
ipv6TokensToIPv6Addr l = Just $ IPv6Addr $ ipv6TokensToText l
networkInterfacesIPv6AddrList :: IO [(String,IPv6)]
networkInterfacesIPv6AddrList =
getNetworkInterfaces >>= \n -> return $ map networkInterfacesIPv6Addr n
where networkInterfacesIPv6Addr (NetworkInterface n _ a _) = (n,a)