@@ -1,316 +0,0 @@
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")