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