module Text.IPv6Addr.Internal
( expandTokens
, macAddr
, maybeIPv6AddrTokens
, ipv4AddrToIPv6AddrTokens
, ipv6TokensToText
, ipv6TokensToIPv6Addr
, isIPv6Addr
, maybeTokIPv6Addr
, maybeTokPureIPv6Addr
, fromDoubleColon
, fromIPv6Addr
, toDoubleColon
, networkInterfacesIPv6AddrList
) where
import Control.Applicative ((<|>))
import Control.Monad (guard)
import Data.Attoparsec.Text
import Data.Char (isDigit)
import Data.List (elemIndex, elemIndices, group,
intersperse, isSuffixOf)
import Data.Maybe (fromJust)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.Read as R (decimal)
import Network.Info
import Numeric (showHex)
import Text.IPv6Addr.Types
fromIPv6Addr :: IPv6Addr -> T.Text
fromIPv6Addr (IPv6Addr t) = t
ipv6TokensToText :: [IPv6AddrToken] -> T.Text
ipv6TokensToText l = T.concat $ map ipv6TokenToText l
ipv6TokenToText :: IPv6AddrToken -> T.Text
ipv6TokenToText (SixteenBit s) = s
ipv6TokenToText Colon = ":"
ipv6TokenToText DoubleColon = "::"
ipv6TokenToText AllZeros = "0"
ipv6TokenToText (IPv4Addr a) = a
isIPv6Addr :: [IPv6AddrToken] -> Bool
isIPv6Addr [] = False
isIPv6Addr [DoubleColon] = True
isIPv6Addr [DoubleColon,SixteenBit "1"] = True
isIPv6Addr tks =
diffNext tks && (do
let cdctks = countDoubleColon tks
lentks = length tks
lasttk = last tks
lenconst = (lentks == 15 && cdctks == 0) || (lentks < 15 && cdctks == 1)
firstValidToken tks &&
(case countIPv4Addr tks :: Int of
0 -> case lasttk of
SixteenBit _ -> lenconst
DoubleColon -> lenconst
AllZeros -> lenconst
_ -> False
1 -> case lasttk of
IPv4Addr _ -> (lentks == 13 && cdctks == 0) || (lentks < 12 && cdctks == 1)
_ -> False
_ -> False))
where
diffNext [] = False
diffNext [_] = True
diffNext (t:ts) = do
let h = head ts
case t of
SixteenBit _ ->
case h of
SixteenBit _ -> False
AllZeros -> False
_ -> diffNext ts
AllZeros ->
case h of
SixteenBit _ -> False
AllZeros -> False
_ -> diffNext ts
_ -> diffNext ts
firstValidToken l =
case head l of
SixteenBit _ -> True
DoubleColon -> True
AllZeros -> True
_ -> False
countDoubleColon l = length $ elemIndices DoubleColon l
countIPv4Addr :: [IPv6AddrToken] -> Int
countIPv4Addr =
foldr oneMoreIPv4Addr 0
where
oneMoreIPv4Addr t c =
case t of
IPv4Addr _ -> c + 1
_ -> c
maybeTokIPv6Addr :: T.Text -> Maybe [IPv6AddrToken]
maybeTokIPv6Addr t =
case maybeIPv6AddrTokens t of
Just ltks -> do
guard (isIPv6Addr ltks)
Just $ (ipv4AddrReplacement . toDoubleColon . fromDoubleColon) ltks
Nothing -> 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
guard (isIPv6Addr ltks)
return $ (toDoubleColon . ipv4AddrReplacement . fromDoubleColon) ltks
where
ipv4AddrReplacement ltks' =
init ltks' ++ ipv4AddrToIPv6AddrTokens (last ltks')
maybeIPv6AddrTokens :: T.Text -> Maybe [IPv6AddrToken]
maybeIPv6AddrTokens s =
case readText s of
Done r l -> if r==T.empty then Just l else Nothing
Fail {} -> Nothing
Partial _ -> Nothing
where
readText _s =
feed
(parse (many1 $ ipv4Addr <|> sixteenBit <|> doubleColon <|> colon) _s)
T.empty
ipv4AddrRewrite :: [IPv6AddrToken] -> Bool
ipv4AddrRewrite tks =
case last tks of
IPv4Addr _ -> do
let itks = init tks
not (itks == [DoubleColon]
|| itks == [DoubleColon,SixteenBit tokffff,Colon]
|| itks == [DoubleColon,SixteenBit tokffff,Colon,AllZeros,Colon]
|| itks == [SixteenBit "64",Colon,SixteenBit "ff9b",DoubleColon]
|| [SixteenBit "200",Colon,SixteenBit tok5efe,Colon] `isSuffixOf` itks
|| [AllZeros,Colon,SixteenBit tok5efe,Colon] `isSuffixOf` itks
|| [DoubleColon,SixteenBit tok5efe,Colon] `isSuffixOf` itks)
_ -> False
where
tokffff = "ffff"
tok5efe = "5efe"
ipv4AddrToIPv6AddrTokens :: IPv6AddrToken -> [IPv6AddrToken]
ipv4AddrToIPv6AddrTokens t =
case t of
IPv4Addr a -> do
let m = toHex a
[ SixteenBit ((!!) m 0 <> addZero ((!!) m 1))
, Colon
, SixteenBit ((!!) m 2 <> 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 "0" <> d else d
expandTokens :: [IPv6AddrToken] -> [IPv6AddrToken]
expandTokens =
map expandToken
where
expandToken (SixteenBit s) = SixteenBit $ T.justifyRight 4 '0' s
expandToken AllZeros = SixteenBit "0000"
expandToken t = t
fromDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken]
fromDoubleColon tks =
if DoubleColon `notElem` tks
then tks
else do
let s = splitAt (fromJust $ elemIndex DoubleColon tks) tks
fsts = fst s
snds = if not (null (snd s)) then tail(snd s) else []
fste = if null fsts then [] else fsts ++ [Colon]
snde = if null snds then [] else Colon : snds
fste ++ allZerosTokensReplacement(quantityOfAllZerosTokenToReplace tks) ++ snde
where
allZerosTokensReplacement x = intersperse Colon (replicate x AllZeros)
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
toDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken]
toDoubleColon tks =
zerosToDoubleColon tks (zerosRunToReplace $ zerosRunsList tks)
where
zerosToDoubleColon ls (_,0) = ls
zerosToDoubleColon ls (_,1) = ls
zerosToDoubleColon ls (i,l) =
let ls' = filter (/= Colon) ls
in intersperse Colon (Prelude.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 $ Prelude.takeWhile (/=(True,y)) x
longestLengthZerosRun x =
maximum $ map longest x
where
longest _t =
case _t of
(True,i) -> i
_ -> 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 =
fmap networkInterfacesIPv6Addr <$> getNetworkInterfaces
where
networkInterfacesIPv6Addr (NetworkInterface n _ a _) = (n,a)
macAddr :: Parser (Maybe [IPv6AddrToken])
macAddr = do
n1 <- count 2 hexaChar <* ":"
n2 <- count 2 hexaChar <* ":"
n3 <- count 2 hexaChar <* ":"
n4 <- count 2 hexaChar <* ":"
n5 <- count 2 hexaChar <* ":"
n6 <- count 2 hexaChar
return $ maybeIPv6AddrTokens $ T.pack $ concat [n1,n2,n3,n4,n5,n6]
sixteenBit :: Parser IPv6AddrToken
sixteenBit = do
r <- ipv6AddrFullChunk <|> count 3 hexaChar <|> count 2 hexaChar <|> count 1 hexaChar
let r' = T.dropWhile (=='0') $ T.pack r
return $
if T.null r'
then AllZeros
else SixteenBit $ T.toLower r'
ipv4Addr :: Parser IPv6AddrToken
ipv4Addr = do
n1 <- manyDigits <* "."
guard (n1 /= T.empty)
n2 <- manyDigits <* "."
guard (n2 /= T.empty)
n3 <- manyDigits <* "."
guard (n3 /= T.empty)
n4 <- manyDigits
guard (n4 /= T.empty)
return $ IPv4Addr $ T.intercalate "." [n1,n2,n3,n4]
where
manyDigits = do
ds <- takeWhile1 isDigit
case R.decimal ds :: Either String (Integer, T.Text) of
Right (n,_) -> return $ if n < 256 then T.pack $ show n else T.empty
Left _ -> return T.empty
doubleColon :: Parser IPv6AddrToken
doubleColon = do
_ <- string "::"
return DoubleColon
colon :: Parser IPv6AddrToken
colon = do
_ <- string ":"
return Colon
ipv6AddrFullChunk :: Parser String
ipv6AddrFullChunk = count 4 hexaChar
hexaChar :: Parser Char
hexaChar = satisfy (inClass "0-9a-fA-F")