module Text.IPv6Addr(
IPv6Addr,
IPv6AddrToken(..),
isIPv6Addr,
maybeIPv6Addr,
maybeTokIPv6Addr,
maybeExpIPv6Addr,
getIPv6AddrOf,
maybeIPv6AddrTokens,
macAddrToIPv6AddrTokens,
getTokIPv6AddrOf,
getTokMacAddrOf,
sixteenBitsRand,
ipv4AddrToIPv6AddrTokens,
ipv6TokensToText,
) where
import Control.Monad (replicateM)
import Data.Char (intToDigit,isDigit,isHexDigit,toLower)
import Data.Function (on)
import Data.List (group,isSuffixOf,elemIndex,elemIndices,intersperse)
import Data.Maybe (fromJust,isJust)
import qualified Data.Text as T
import Data.Text.Read (decimal)
import Network.Info
import Numeric (showIntAtBase)
import System.Random (randomRIO)
type IPv6Addr = T.Text
data IPv6AddrToken
= SixteenBits T.Text
| AllZeros
| Colon
| DoubleColon
| IPv4Addr T.Text
deriving (Eq,Show)
data IPv4AddrToken
= Dot
| EightBits T.Text deriving (Eq,Show)
tokdot = T.pack "."
tokcolon = T.pack ":"
tokdcolon = T.pack "::"
tok0 = T.pack "0"
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"
tokenizeBy :: Char -> T.Text -> [T.Text]
tokenizeBy c = T.groupBy ((==) `on` (==c))
dot :: T.Text -> Maybe IPv4AddrToken
dot s = if s == tokdot then Just Dot else Nothing
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 $ tokenizeBy '.' t
if (Nothing `notElem` r) && (length r == 7)
then Just (IPv4Addr t) else Nothing
colon :: T.Text -> Maybe IPv6AddrToken
colon t = if t == tokcolon then Just Colon else Nothing
doubleColon :: T.Text -> Maybe IPv6AddrToken
doubleColon t = if t == tokdcolon then Just DoubleColon else Nothing
sixteenBits:: T.Text -> Maybe IPv6AddrToken
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
if T.null t'
then Just AllZeros
else Just $ SixteenBits $ T.toLower t'
else Nothing
else Nothing
sixteenBitsRand :: String -> IO IPv6AddrToken
sixteenBitsRand s =
if all isHexDigit s && l < 4
then do
a <- replicateM (4l) hexRand
return $ SixteenBits $ T.toLower $ T.pack $ s ++ a
else return $ SixteenBits tok0
where
l = length s
hexRand = do r <- randomRIO(0,15)
return $ intToDigit r
maybeIPv6Addr :: T.Text -> Maybe IPv6Addr
maybeIPv6Addr t =
case maybeTokIPv6Addr t of
Just a -> Just $ ipv6TokensToText a
Nothing -> Nothing
maybeExpIPv6Addr :: T.Text -> Maybe IPv6Addr
maybeExpIPv6Addr t =
case maybeTokIPv6Addr t of
Just a -> Just $ ipv6TokensToText $ fromDoubleColon a
Nothing -> Nothing
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 tks =
foldr oneMoreIPv4Addr 0 tks
where oneMoreIPv4Addr t c =
case t of
IPv4Addr _ -> c + 1
otherwise -> c
maybeIPv6AddrTokens :: T.Text -> Maybe [IPv6AddrToken]
maybeIPv6AddrTokens t = mapM maybeIPv6AddrToken (tokenizeBy ':' t)
maybeTokIPv6Addr :: T.Text -> Maybe [IPv6AddrToken]
maybeTokIPv6Addr t =
case maybeIPv6AddrTokens t of
Nothing -> Nothing
Just a ->
if isIPv6Addr a
then Just $ (toDoubleColon . ipv4AddrReplacement . fromDoubleColon) a
else Nothing
where
ipv4AddrReplacement tks =
if ipv4AddrRewrite tks then init tks ++ ipv4AddrToIPv6AddrTokens (last tks) else tks
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))]
otherwise -> []
where
toHex a = map (\x -> T.pack $ showIntAtBase 16 intToDigit (read (T.unpack x)::Int) "") $ T.split (=='.') a
addZero d = if T.length d == 1 then T.pack "0" `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 length(snd s) >= 1 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 =
if head h == AllZeros
then (True,lh) else (False,lh)
where lh = length h
groupZerosRuns = group . filter (/= Colon)
macAddrToIPv6AddrTokens :: T.Text -> [IPv6AddrToken]
macAddrToIPv6AddrTokens mac =
if T.length mac == 17 then do
let p = snd $ trans (T.split (==':') mac,[])
if length p == 3 then
intersperse Colon $ map (fromJust . maybeIPv6AddrToken) p
else []
else []
where trans ([],l) = ([],l)
trans (l1,l2) = do let s = splitAt 2 l1
trans (snd s,l2 ++ [T.concat $ fst s])
networkInterfacesIPv6AddrList :: IO [(String,IPv6)]
networkInterfacesIPv6AddrList = do
n <- getNetworkInterfaces
return $ map networkInterfacesIPv6Addr n
where networkInterfacesIPv6Addr (NetworkInterface n _ a _) = (n,a)
networkInterfacesMacAddrList :: IO [(String,MAC)]
networkInterfacesMacAddrList = do
n <- getNetworkInterfaces
return $ map networkInterfacesMac n
where networkInterfacesMac (NetworkInterface n _ _ m) = (n,m)
getIPv6AddrOf :: String -> IO (Maybe IPv6Addr)
getIPv6AddrOf s = do
l <- networkInterfacesIPv6AddrList
case lookup s l of
Just a -> return $ maybeIPv6Addr $ T.pack $ show a
Nothing -> return Nothing
getTokIPv6AddrOf :: String -> IO (Maybe [IPv6AddrToken])
getTokIPv6AddrOf s = do
l <- networkInterfacesIPv6AddrList
case lookup s l of
Just a -> return $ maybeTokIPv6Addr $ T.pack $ show a
Nothing -> return Nothing
getTokMacAddrOf :: String -> IO (Maybe [IPv6AddrToken])
getTokMacAddrOf s = do
l <-networkInterfacesMacAddrList
case lookup s l of
Just a -> return $ Just $ macAddrToIPv6AddrTokens $ T.pack $ show a
Nothing -> return Nothing