@@ -0,0 +1,316 @@
1+-- -----------------------------------------------------------------------------
4+-- Module : Text.IPv6Addr
5+-- Copyright : Copyright © Michel Boucey 2011-2015
7+-- Maintainer : michel.boucey@gmail.com
9+-- Dealing with IPv6 address text representations, canonization and manipulations.
12+-- -----------------------------------------------------------------------------
14+{-# LANGUAGE OverloadedStrings #-}
16+module QC.IPv6.Internal where {-
19+ , maybeIPv6AddrTokens
20+ , ipv4AddrToIPv6AddrTokens
22+ , ipv6TokensToIPv6Addr
25+ , maybeTokPureIPv6Addr
32+import Control.Monad (replicateM)
33+import Data.Attoparsec.Text
34+import Data.Char (isDigit,isHexDigit,toLower)
35+import Data.Monoid ((<>))
36+import Control.Applicative ((<|>),(<*))
37+import Data.List (group,isSuffixOf,elemIndex,elemIndices,intersperse)
38+import Data.Word (Word32)
39+import Numeric (showHex)
40+import qualified Data.Text as T
41+import qualified Data.Text.Read as R (decimal)
42+import Data.Maybe (fromJust)
48+-- | Returns the 'T.Text' of an IPv6 address.
49+fromIPv6Addr :: IPv6Addr -> T.Text
50+fromIPv6Addr (IPv6Addr t) = t
52+-- | Given an arbitrary list of 'IPv6AddrToken', returns the corresponding 'T.Text'.
53+ipv6TokensToText :: [IPv6AddrToken] -> T.Text
54+ipv6TokensToText l = T.concat $ map ipv6TokenToText l
56+-- | Returns the corresponding 'T.Text' of an IPv6 address token.
57+ipv6TokenToText :: IPv6AddrToken -> T.Text
58+ipv6TokenToText (SixteenBit s) = s
59+ipv6TokenToText Colon = ":"
60+ipv6TokenToText DoubleColon = "::"
61+ipv6TokenToText AllZeros = tok0 -- "A single 16-bit 0000 field MUST be represented as 0" (RFC 5952, 4.1)
62+ipv6TokenToText (IPv4Addr a) = a
64+-- | Returns 'True' if a list of 'IPv6AddrToken' constitutes a valid IPv6 Address.
65+isIPv6Addr :: [IPv6AddrToken] -> Bool
67+isIPv6Addr [DoubleColon] = True
68+isIPv6Addr [DoubleColon,SixteenBit tok1] = True
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
78+ SixteenBit _ -> lenconst
79+ DoubleColon -> lenconst
83+ IPv4Addr _ -> (lentks == 13 && cdctks == 0) || (lentks < 12 && cdctks == 1)
86+ where diffNext [] = False
91+ SixteenBit _ -> case h of
92+ SixteenBit _ -> False
95+ AllZeros -> case h of
96+ SixteenBit _ -> False
102+ SixteenBit _ -> True
106+ countDoubleColon l = length $ elemIndices DoubleColon l
109+countIPv4Addr = foldr oneMoreIPv4Addr 0
111+ oneMoreIPv4Addr t c = case t of
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'.
118+maybeTokIPv6Addr :: T.Text -> Maybe [IPv6AddrToken]
120+ case maybeIPv6AddrTokens t of
121+ Just ltks -> if isIPv6Addr ltks
122+ then Just $ (ipv4AddrReplacement . toDoubleColon . fromDoubleColon) ltks
126+ ipv4AddrReplacement ltks =
127+ if ipv4AddrRewrite ltks
128+ then init ltks ++ ipv4AddrToIPv6AddrTokens (last ltks)
131+-- | Returns 'Just' the list of tokenized pure IPv6 address, always rewriting an
132+-- embedded IPv4 address if present.
133+maybeTokPureIPv6Addr :: T.Text -> Maybe [IPv6AddrToken]
134+maybeTokPureIPv6Addr t = do
135+ ltks <- maybeIPv6AddrTokens t
137+ then Just $ (toDoubleColon . ipv4AddrReplacement . fromDoubleColon) ltks
140+ ipv4AddrReplacement ltks' = init ltks' ++ ipv4AddrToIPv6AddrTokens (last ltks')
142+-- | Tokenize a 'T.Text' into 'Just' a list of 'IPv6AddrToken', or 'Nothing'.
143+maybeIPv6AddrTokens :: T.Text -> Maybe [IPv6AddrToken]
144+maybeIPv6AddrTokens s =
146+ Done r l -> traceShow (r,l) $ if r==T.empty then Just l else Nothing
149+ readText s = feed (parse (many1 $ ipv4Addr <|> sixteenBit <|> doubleColon <|> colon) s) T.empty
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):
156+-- IPv4-compatible IPv6 address like "::1.2.3.4"
158+-- IPv4-mapped IPv6 address like "::ffff:1.2.3.4"
160+-- IPv4-translated address like "::ffff:0:1.2.3.4"
162+-- IPv4-translatable address like "64:ff9b::1.2.3.4"
164+-- ISATAP address like "fe80::5efe:1.2.3.4"
166+ipv4AddrRewrite :: [IPv6AddrToken] -> Bool
167+ipv4AddrRewrite 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)
183+-- | Rewrites an embedded 'IPv4Addr' into the corresponding list of pure 'IPv6Addr' tokens.
185+-- > ipv4AddrToIPv6AddrTokens (IPv4Addr "127.0.0.1") == [SixteenBits "7f0",Colon,SixteenBits "1"]
187+ipv4AddrToIPv6AddrTokens :: IPv6AddrToken -> [IPv6AddrToken]
188+ipv4AddrToIPv6AddrTokens t =
192+ [ SixteenBit ((!!) m 0 <> addZero ((!!) m 1))
194+ , SixteenBit ((!!) m 2 <> addZero ((!!) m 3)) ]
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
200+expandTokens :: [IPv6AddrToken] -> [IPv6AddrToken]
201+expandTokens = map expandToken
202+ where expandToken (SixteenBit s) = SixteenBit $ T.justifyRight 4 '0' s
203+ expandToken AllZeros = SixteenBit "0000"
206+fromDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken]
207+fromDoubleColon tks =
208+ if DoubleColon `notElem` tks
210+ else do let s = splitAt (fromJust $ elemIndex DoubleColon tks) tks
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
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
221+ ntks tks = if countIPv4Addr tks == 1 then 7 else 8
223+toDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken]
225+ zerosToDoubleColon tks (zerosRunToReplace $ zerosRunsList tks)
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)
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
245+ zerosRunsList x = map helper $ groupZerosRuns x
247+ helper h = (head h == AllZeros, lh) where lh = length h
248+ groupZerosRuns = group . filter (/= Colon)
250+ipv6TokensToIPv6Addr :: [IPv6AddrToken] -> Maybe IPv6Addr
251+ipv6TokensToIPv6Addr l = Just $ IPv6Addr $ ipv6TokensToText l
253+fullSixteenBit :: T.Text -> Maybe IPv6AddrToken
255+ case parse ipv6AddrFullChunk t of
256+ Done a b -> if a==T.empty then Just $ SixteenBit $ T.pack b else Nothing
259+macAddr :: Parser (Maybe [IPv6AddrToken])
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]
269+sixteenBit :: Parser IPv6AddrToken
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'
276+ -- Hexadecimal digits MUST be in lowercase (RFC 5952 4.3)
277+ else SixteenBit $ T.toLower r'
279+ipv4Addr :: Parser IPv6AddrToken
281+ n1 <- manyDigits <* "."
283+ then do n2 <- manyDigits <* "."
285+ then do n3 <- manyDigits <* "."
287+ then do n4 <- manyDigits
289+ then return $ IPv4Addr $ T.intercalate "." [n1,n2,n3,n4]
295+ parserFailure = fail "ipv4Addr parsing failure"
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
302+doubleColon :: Parser IPv6AddrToken
307+colon :: Parser IPv6AddrToken
312+ipv6AddrFullChunk :: Parser String
313+ipv6AddrFullChunk = count 4 hexaChar
315+hexaChar :: Parser Char
316+hexaChar = satisfy (inClass "0-9a-fA-F")