1-- ----------------------------------------------------------------------------- 2 3-- | 4-- Module : Text.IPv6Addr 5-- Copyright : Copyright © Michel Boucey 2011-2015 6-- License : BSD-Style 7-- Maintainer : michel.boucey@gmail.com 8-- 9-- Dealing with IPv6 address text representations, canonization and manipulations. 10-- 11 12-- ----------------------------------------------------------------------------- 13 14{-# LANGUAGE OverloadedStrings #-} 15 16module QC.IPv6.Internal where {- 17 ( expandTokens 18 , macAddr 19 , maybeIPv6AddrTokens 20 , ipv4AddrToIPv6AddrTokens 21 , ipv6TokensToText 22 , ipv6TokensToIPv6Addr 23 , isIPv6Addr 24 , maybeTokIPv6Addr 25 , maybeTokPureIPv6Addr 26 , fromDoubleColon 27 , fromIPv6Addr 28 , toDoubleColon 29 ) where -} 30 31import Debug.Trace 32import Control.Monad (replicateM) 33import Data.Attoparsec.Text 34import Data.Char (isDigit,isHexDigit,toLower) 35import Data.Monoid ((<>)) 36import Control.Applicative ((<|>),(<*)) 37import Data.List (group,isSuffixOf,elemIndex,elemIndices,intersperse) 38import Data.Word (Word32) 39import Numeric (showHex) 40import qualified Data.Text as T 41import qualified Data.Text.Read as R (decimal) 42import Data.Maybe (fromJust) 43 44import QC.IPv6.Types 45 46tok0 = "0" 47 48-- | Returns the 'T.Text' of an IPv6 address. 49fromIPv6Addr :: IPv6Addr -> T.Text 50fromIPv6Addr (IPv6Addr t) = t 51 52-- | Given an arbitrary list of 'IPv6AddrToken', returns the corresponding 'T.Text'. 53ipv6TokensToText :: [IPv6AddrToken] -> T.Text 54ipv6TokensToText l = T.concat $ map ipv6TokenToText l 55 56-- | Returns the corresponding 'T.Text' of an IPv6 address token. 57ipv6TokenToText :: IPv6AddrToken -> T.Text 58ipv6TokenToText (SixteenBit s) = s 59ipv6TokenToText Colon = ":" 60ipv6TokenToText DoubleColon = "::" 61ipv6TokenToText AllZeros = tok0 -- "A single 16-bit 0000 field MUST be represented as 0" (RFC 5952, 4.1) 62ipv6TokenToText (IPv4Addr a) = a 63 64-- | Returns 'True' if a list of 'IPv6AddrToken' constitutes a valid IPv6 Address. 65isIPv6Addr :: [IPv6AddrToken] -> Bool 66isIPv6Addr [] = False 67isIPv6Addr [DoubleColon] = True 68isIPv6Addr [DoubleColon,SixteenBit tok1] = True 69isIPv6Addr tks = 70 diffNext tks && (do 71 let cdctks = countDoubleColon tks 72 let lentks = length tks 73 let lasttk = last tks 74 let lenconst = (lentks == 15 && cdctks == 0) || (lentks < 15 && cdctks == 1) 75 firstValidToken tks && 76 (case countIPv4Addr tks of 77 0 -> case lasttk of 78 SixteenBit _ -> lenconst 79 DoubleColon -> lenconst 80 AllZeros -> lenconst 81 _ -> False 82 1 -> case lasttk of 83 IPv4Addr _ -> (lentks == 13 && cdctks == 0) || (lentks < 12 && cdctks == 1) 84 _ -> False 85 otherwise -> False)) 86 where diffNext [] = False 87 diffNext [_] = True 88 diffNext (t:ts) = do 89 let h = head ts 90 case t of 91 SixteenBit _ -> case h of 92 SixteenBit _ -> False 93 AllZeros -> False 94 _ -> diffNext ts 95 AllZeros -> case h of 96 SixteenBit _ -> False 97 AllZeros -> False 98 _ -> diffNext ts 99 _ -> diffNext ts 100 firstValidToken l = 101 case head l of 102 SixteenBit _ -> True 103 DoubleColon -> True 104 AllZeros -> True 105 _ -> False 106 countDoubleColon l = length $ elemIndices DoubleColon l 107 tok1 = "1" 108 109countIPv4Addr = foldr oneMoreIPv4Addr 0 110 where 111 oneMoreIPv4Addr t c = case t of 112 IPv4Addr _ -> c + 1 113 otherwise -> c 114 115-- | This is the main function which returns 'Just' the list of a tokenized IPv6 116-- address text representation validated against RFC 4291 and canonized 117-- in conformation with RFC 5952, or 'Nothing'. 118maybeTokIPv6Addr :: T.Text -> Maybe [IPv6AddrToken] 119maybeTokIPv6Addr t = 120 case maybeIPv6AddrTokens t of 121 Just ltks -> if isIPv6Addr ltks 122 then Just $ (ipv4AddrReplacement . toDoubleColon . fromDoubleColon) ltks 123 else Nothing 124 Nothing -> Nothing 125 where 126 ipv4AddrReplacement ltks = 127 if ipv4AddrRewrite ltks 128 then init ltks ++ ipv4AddrToIPv6AddrTokens (last ltks) 129 else ltks 130 131-- | Returns 'Just' the list of tokenized pure IPv6 address, always rewriting an 132-- embedded IPv4 address if present. 133maybeTokPureIPv6Addr :: T.Text -> Maybe [IPv6AddrToken] 134maybeTokPureIPv6Addr t = do 135 ltks <- maybeIPv6AddrTokens t 136 if isIPv6Addr ltks 137 then Just $ (toDoubleColon . ipv4AddrReplacement . fromDoubleColon) ltks 138 else Nothing 139 where 140 ipv4AddrReplacement ltks' = init ltks' ++ ipv4AddrToIPv6AddrTokens (last ltks') 141 142-- | Tokenize a 'T.Text' into 'Just' a list of 'IPv6AddrToken', or 'Nothing'. 143maybeIPv6AddrTokens :: T.Text -> Maybe [IPv6AddrToken] 144maybeIPv6AddrTokens s = 145 case readText s of 146 Done r l -> traceShow (r,l) $ if r==T.empty then Just l else Nothing 147 Fail {} -> Nothing 148 where 149 readText s = feed (parse (many1 $ ipv4Addr <|> sixteenBit <|> doubleColon <|> colon) s) T.empty 150 151-- | An embedded IPv4 address have to be rewritten to output a pure IPv6 Address 152-- text representation in hexadecimal digits. But some well-known prefixed IPv6 153-- addresses have to keep visible in their text representation the fact that 154-- they deals with IPv4 to IPv6 transition process (RFC 5952 Section 5): 155-- 156-- IPv4-compatible IPv6 address like "::1.2.3.4" 157-- 158-- IPv4-mapped IPv6 address like "::ffff:1.2.3.4" 159-- 160-- IPv4-translated address like "::ffff:0:1.2.3.4" 161-- 162-- IPv4-translatable address like "64:ff9b::1.2.3.4" 163-- 164-- ISATAP address like "fe80::5efe:1.2.3.4" 165-- 166ipv4AddrRewrite :: [IPv6AddrToken] -> Bool 167ipv4AddrRewrite tks = 168 case last tks of 169 IPv4Addr _ -> do 170 let itks = init tks 171 not (itks == [DoubleColon] 172 || itks == [DoubleColon,SixteenBit tokffff,Colon] 173 || itks == [DoubleColon,SixteenBit tokffff,Colon,AllZeros,Colon] 174 || itks == [SixteenBit "64",Colon,SixteenBit "ff9b",DoubleColon] 175 || [SixteenBit "200",Colon,SixteenBit tok5efe,Colon] `isSuffixOf` itks 176 || [AllZeros,Colon,SixteenBit tok5efe,Colon] `isSuffixOf` itks 177 || [DoubleColon,SixteenBit tok5efe,Colon] `isSuffixOf` itks) 178 _ -> False 179 where 180 tokffff = "ffff" 181 tok5efe = "5efe" 182 183-- | Rewrites an embedded 'IPv4Addr' into the corresponding list of pure 'IPv6Addr' tokens. 184-- 185-- > ipv4AddrToIPv6AddrTokens (IPv4Addr "127.0.0.1") == [SixteenBits "7f0",Colon,SixteenBits "1"] 186-- 187ipv4AddrToIPv6AddrTokens :: IPv6AddrToken -> [IPv6AddrToken] 188ipv4AddrToIPv6AddrTokens t = 189 case t of 190 IPv4Addr a -> do 191 let m = toHex a 192 [ SixteenBit ((!!) m 0 <> addZero ((!!) m 1)) 193 , Colon 194 , SixteenBit ((!!) m 2 <> addZero ((!!) m 3)) ] 195 _ -> [t] 196 where 197 toHex a = map (\x -> T.pack $ showHex (read (T.unpack x)::Int) "") $ T.split (=='.') a 198 addZero d = if T.length d == 1 then tok0 <> d else d 199 200expandTokens :: [IPv6AddrToken] -> [IPv6AddrToken] 201expandTokens = map expandToken 202 where expandToken (SixteenBit s) = SixteenBit $ T.justifyRight 4 '0' s 203 expandToken AllZeros = SixteenBit "0000" 204 expandToken t = t 205 206fromDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken] 207fromDoubleColon tks = 208 if DoubleColon `notElem` tks 209 then tks 210 else do let s = splitAt (fromJust $ elemIndex DoubleColon tks) tks 211 let fsts = fst s 212 let snds = if not (null (snd s)) then tail(snd s) else [] 213 let fste = if null fsts then [] else fsts ++ [Colon] 214 let snde = if null snds then [] else Colon : snds 215 fste ++ allZerosTokensReplacement(quantityOfAllZerosTokenToReplace tks) ++ snde 216 where 217 allZerosTokensReplacement x = intersperse Colon (replicate x AllZeros) 218 quantityOfAllZerosTokenToReplace x = 219 ntks tks - foldl (\c x -> if (x /= DoubleColon) && (x /= Colon) then c+1 else c) 0 x 220 where 221 ntks tks = if countIPv4Addr tks == 1 then 7 else 8 222 223toDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken] 224toDoubleColon tks = 225 zerosToDoubleColon tks (zerosRunToReplace $ zerosRunsList tks) 226 where 227 zerosToDoubleColon :: [IPv6AddrToken] -> (Int,Int) -> [IPv6AddrToken] 228 -- No all zeros token, so no double colon replacement... 229 zerosToDoubleColon ls (_,0) = ls 230 -- "The symbol '::' MUST NOT be used to shorten just one 16-bit 0 field" (RFC 5952 4.2.2) 231 zerosToDoubleColon ls (_,1) = ls 232 zerosToDoubleColon ls (i,l) = 233 let ls' = filter (/= Colon) ls 234 in intersperse Colon (Prelude.take i ls') ++ [DoubleColon] ++ intersperse Colon (drop (i+l) ls') 235 zerosRunToReplace t = 236 let l = longestLengthZerosRun t 237 in (firstLongestZerosRunIndex t l,l) 238 where 239 firstLongestZerosRunIndex x y = sum . snd . unzip $ Prelude.takeWhile (/=(True,y)) x 240 longestLengthZerosRun x = 241 maximum $ map longest x 242 where longest t = case t of 243 (True,i) -> i 244 _ -> 0 245 zerosRunsList x = map helper $ groupZerosRuns x 246 where 247 helper h = (head h == AllZeros, lh) where lh = length h 248 groupZerosRuns = group . filter (/= Colon) 249 250ipv6TokensToIPv6Addr :: [IPv6AddrToken] -> Maybe IPv6Addr 251ipv6TokensToIPv6Addr l = Just $ IPv6Addr $ ipv6TokensToText l 252 253fullSixteenBit :: T.Text -> Maybe IPv6AddrToken 254fullSixteenBit t = 255 case parse ipv6AddrFullChunk t of 256 Done a b -> if a==T.empty then Just $ SixteenBit $ T.pack b else Nothing 257 _ -> Nothing 258 259macAddr :: Parser (Maybe [IPv6AddrToken]) 260macAddr = do 261 n1 <- count 2 hexaChar <* ":" 262 n2 <- count 2 hexaChar <* ":" 263 n3 <- count 2 hexaChar <* ":" 264 n4 <- count 2 hexaChar <* ":" 265 n5 <- count 2 hexaChar <* ":" 266 n6 <- count 2 hexaChar 267 return $ maybeIPv6AddrTokens $ T.pack $ concat [n1,n2,n3,n4,n5,n6] 268 269sixteenBit :: Parser IPv6AddrToken 270sixteenBit = do 271 r <- ipv6AddrFullChunk <|> count 3 hexaChar <|> count 2 hexaChar <|> count 1 hexaChar 272 -- "Leading zeros MUST be suppressed" (RFC 5952, 4.1) 273 let r' = T.dropWhile (=='0') $ T.pack r 274 return $ if T.null r' 275 then AllZeros 276 -- Hexadecimal digits MUST be in lowercase (RFC 5952 4.3) 277 else SixteenBit $ T.toLower r' 278 279ipv4Addr :: Parser IPv6AddrToken 280ipv4Addr = do 281 n1 <- manyDigits <* "." 282 if n1 /= T.empty 283 then do n2 <- manyDigits <* "." 284 if n2 /= T.empty 285 then do n3 <- manyDigits <* "." 286 if n3 /= T.empty 287 then do n4 <- manyDigits 288 if n4 /= T.empty 289 then return $ IPv4Addr $ T.intercalate "." [n1,n2,n3,n4] 290 else parserFailure 291 else parserFailure 292 else parserFailure 293 else parserFailure 294 where 295 parserFailure = fail "ipv4Addr parsing failure" 296 manyDigits = do 297 ds <- takeWhile1 isDigit 298 case R.decimal ds of 299 Right (n,_) -> return (if n < 256 then T.pack $ show n else T.empty) 300 Left _ -> return T.empty 301 302doubleColon :: Parser IPv6AddrToken 303doubleColon = do 304 string "::" 305 return DoubleColon 306 307colon :: Parser IPv6AddrToken 308colon = do 309 string ":" 310 return Colon 311 312ipv6AddrFullChunk :: Parser String 313ipv6AddrFullChunk = count 4 hexaChar 314 315hexaChar :: Parser Char 316hexaChar = satisfy (inClass "0-9a-fA-F") 317