module Text.IPv6Addr
( IPv6Addr (IPv6Addr)
, maybeIPv6Addr
, maybePureIPv6Addr
, maybeFullIPv6Addr
, sameIPv6Addr
, fromIPv6Addr
, toIPv6
, toHostName
, toIP6ARPA
, toUNC
, getIPv6AddrOf
, randIPv6Addr
, randIPv6AddrWithPrefix
, randIPv6AddrChunk
, randPartialIPv6Addr
, macAddrToIPv6AddrTokens
, getTokIPv6AddrOf
, getTokMacAddrOf ) where
import Control.Applicative ((<|>))
import Control.Monad (replicateM, guard)
import Data.Aeson
import Data.Attoparsec.Text as A
import Data.Char (intToDigit, isDigit)
import Data.IP (IPv6)
import Data.List (elemIndex, elemIndices, group,
intersperse, isSuffixOf)
import Data.Maybe (fromJust, isNothing)
import Data.Monoid ((<>))
import qualified Data.Text as T
import qualified Data.Text.Read as R (decimal)
import Network (HostName)
import Network.Info
import Numeric (showHex)
import System.Random (randomRIO)
data IPv6Addr = IPv6Addr !T.Text
instance Show IPv6Addr where
show (IPv6Addr a) = T.unpack a
data IPv6AddrToken
= SixteenBit !T.Text
| AllZeros
| Colon
| DoubleColon
| IPv4Addr !T.Text
deriving (Eq, Show)
instance Eq IPv6Addr where
(==) (IPv6Addr a) (IPv6Addr b) =
show (maybePureIPv6Addr a) == show (maybePureIPv6Addr b)
instance ToJSON IPv6Addr where
toJSON (IPv6Addr a) = String a
instance FromJSON IPv6Addr where
parseJSON (String s) =
case maybeIPv6Addr s of
Just a -> pure a
Nothing -> fail "Not An IPv6 Address"
parseJSON _ = fail "JSON String Expected"
maybeIPv6Addr :: T.Text -> Maybe IPv6Addr
maybeIPv6Addr t = maybeTokIPv6Addr t >>= ipv6TokensToIPv6Addr
maybePureIPv6Addr :: T.Text -> Maybe IPv6Addr
maybePureIPv6Addr t = maybeTokPureIPv6Addr t >>= ipv6TokensToIPv6Addr
maybeFullIPv6Addr :: T.Text -> Maybe IPv6Addr
maybeFullIPv6Addr t =
maybeTokPureIPv6Addr t >>=
(ipv6TokensToIPv6Addr . expandTokens . fromDoubleColon)
sameIPv6Addr :: T.Text -> T.Text -> Bool
sameIPv6Addr a b =
case maybePureIPv6Addr a of
Nothing -> False
Just a' ->
case maybePureIPv6Addr b of
Nothing -> False
Just b' -> a' == b'
toIP6ARPA :: IPv6Addr -> T.Text
toIP6ARPA a =
T.reverse (T.concatMap trans $ fromIPv6Addr $ fromJust $ maybeFullIPv6Addr $ fromIPv6Addr a) <> "IP6.ARPA."
where
trans ':' = T.empty
trans c = "." <> T.pack [c]
toUNC :: IPv6Addr -> T.Text
toUNC a =
(T.concatMap trans $ fromIPv6Addr $ fromJust $ maybePureIPv6Addr $ fromIPv6Addr a) <> ".ipv6-literal.net"
where
trans ':' = "-"
trans c = T.pack [c]
toHostName :: IPv6Addr -> HostName
toHostName = show
toIPv6 :: IPv6Addr -> Data.IP.IPv6
toIPv6 a = read $ show a
getIPv6AddrOf :: String -> IO (Maybe IPv6Addr)
getIPv6AddrOf s =
maybe Nothing (maybeIPv6Addr . T.pack . show) <$>
(lookup s <$> networkInterfacesIPv6AddrList)
randIPv6Addr :: IO IPv6Addr
randIPv6Addr = fromJust <$> randIPv6AddrWithPrefix Nothing
randIPv6AddrWithPrefix :: Maybe T.Text -> IO (Maybe IPv6Addr)
randIPv6AddrWithPrefix p =
if isNothing p
then do
r <- randomRIO (1,8)
tks <-
case r of
8 -> randPartialIPv6Addr 8
_ -> do
r' <- randomRIO (1,8r)
case r + r' of
7 -> concat <$>
sequence [ randPartialIPv6Addr r
, pure [Colon,AllZeros,Colon]
, randPartialIPv6Addr r'
]
8 -> randPartialIPv6Addr 8
_ -> concat <$>
sequence [ randPartialIPv6Addr r
, pure [DoubleColon]
, randPartialIPv6Addr r'
]
return $ ipv6TokensToIPv6Addr tks
else
case maybeIPv6AddrTokens (fromJust p) of
Just tks -> do
ntks <- do let ctks = countChunks tks
case (snd ctks :: Int) of
0 -> return $ 8 fst ctks
1 -> return $ 6 fst ctks
_ -> return 0
guard (ntks > 0)
rtks <- randPartialIPv6Addr ntks
let tks' = addColon tks ++ rtks
guard (isIPv6Addr tks')
return $ ipv6TokensToIPv6Addr $
(toDoubleColon . fromDoubleColon) tks'
Nothing -> return Nothing
where
countChunks =
foldr go (0,0)
where
go c (a,b) =
case c of
SixteenBit _ -> (a+1,b)
AllZeros -> (a+1,b)
DoubleColon -> (a,b+1)
_ -> (a,b)
addColon ts =
case last ts of
SixteenBit _ -> ts ++ [Colon]
AllZeros -> ts ++ [Colon]
_ -> ts
randIPv6AddrChunk :: String -> IO IPv6AddrToken
randIPv6AddrChunk m =
mapM getHex m >>= \g -> return $ SixteenBit $ T.dropWhile (=='0') $ T.pack g
where
getHex c
| c == '_' = getDigit
| otherwise = pure c
randPartialIPv6Addr :: Int -> IO [IPv6AddrToken]
randPartialIPv6Addr n =
if n > 0 && n < 9
then
intersperse Colon <$>
replicateM n (SixteenBit . T.pack <$> replicateM 4 getDigit)
else pure []
macAddrToIPv6AddrTokens :: T.Text -> Maybe [IPv6AddrToken]
macAddrToIPv6AddrTokens t =
case parse macAddr t of
Done a b ->
if a == T.empty
then intersperse Colon <$> b
else Nothing
_ -> Nothing
getTokIPv6AddrOf :: String -> IO (Maybe [IPv6AddrToken])
getTokIPv6AddrOf s =
maybe Nothing (maybeTokIPv6Addr. T.pack . show) <$>
(lookup s <$> networkInterfacesIPv6AddrList)
getTokMacAddrOf :: String -> IO (Maybe [IPv6AddrToken])
getTokMacAddrOf s =
maybe Nothing (macAddrToIPv6AddrTokens . T.pack . show) <$>
(lookup s <$> networkInterfacesMacAddrList)
where
networkInterfacesMacAddrList = getNetworkInterfaces >>=
\n -> return (networkInterfacesMac <$> n)
where networkInterfacesMac (NetworkInterface n _ _ m) = (n,m)
getDigit :: IO Char
getDigit = intToDigit <$> randomRIO (0,15)
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,Network.Info.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")