@@ -0,0 +1,316 @@
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+
16+module 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+
31+import Debug.Trace
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)
43+
44+import QC.IPv6.Types
45+
46+tok0 = "0"
47+
48+-- | Returns the 'T.Text' of an IPv6 address.
49+fromIPv6Addr :: IPv6Addr -> T.Text
50+fromIPv6Addr (IPv6Addr t) = t
51+
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
55+
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
63+
64+-- | Returns 'True' if a list of 'IPv6AddrToken' constitutes a valid IPv6 Address.
65+isIPv6Addr :: [IPv6AddrToken] -> Bool
66+isIPv6Addr [] = False
67+isIPv6Addr [DoubleColon] = True
68+isIPv6Addr [DoubleColon,SixteenBit tok1] = True
69+isIPv6Addr 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+
109+countIPv4Addr = 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'.
118+maybeTokIPv6Addr :: T.Text -> Maybe [IPv6AddrToken]
119+maybeTokIPv6Addr 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.
133+maybeTokPureIPv6Addr :: T.Text -> Maybe [IPv6AddrToken]
134+maybeTokPureIPv6Addr 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'.
143+maybeIPv6AddrTokens :: T.Text -> Maybe [IPv6AddrToken]
144+maybeIPv6AddrTokens 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+--
166+ipv4AddrRewrite :: [IPv6AddrToken] -> Bool
167+ipv4AddrRewrite 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+--
187+ipv4AddrToIPv6AddrTokens :: IPv6AddrToken -> [IPv6AddrToken]
188+ipv4AddrToIPv6AddrTokens 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+
200+expandTokens :: [IPv6AddrToken] -> [IPv6AddrToken]
201+expandTokens = map expandToken
202+ where expandToken (SixteenBit s) = SixteenBit $ T.justifyRight 4 '0' s
203+ expandToken AllZeros = SixteenBit "0000"
204+ expandToken t = t
205+
206+fromDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken]
207+fromDoubleColon 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+
223+toDoubleColon :: [IPv6AddrToken] -> [IPv6AddrToken]
224+toDoubleColon 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+
250+ipv6TokensToIPv6Addr :: [IPv6AddrToken] -> Maybe IPv6Addr
251+ipv6TokensToIPv6Addr l = Just $ IPv6Addr $ ipv6TokensToText l
252+
253+fullSixteenBit :: T.Text -> Maybe IPv6AddrToken
254+fullSixteenBit 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+
259+macAddr :: Parser (Maybe [IPv6AddrToken])
260+macAddr = 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+
269+sixteenBit :: Parser IPv6AddrToken
270+sixteenBit = 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+
279+ipv4Addr :: Parser IPv6AddrToken
280+ipv4Addr = 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+
302+doubleColon :: Parser IPv6AddrToken
303+doubleColon = do
304+ string "::"
305+ return DoubleColon
306+
307+colon :: Parser IPv6AddrToken
308+colon = do
309+ string ":"
310+ return Colon
311+
312+ipv6AddrFullChunk :: Parser String
313+ipv6AddrFullChunk = count 4 hexaChar
314+
315+hexaChar :: Parser Char
316+hexaChar = satisfy (inClass "0-9a-fA-F")