gistfile1.hs

module Main (main) where

-- http://tools.ietf.org/html/rfc5952

import Data.Word (Word64)
import Data.Bits ((.|.), (.&.), shiftL, shiftR)
import Data.Maybe (listToMaybe)
import Numeric (showHex)
import Data.List (intercalate, isInfixOf)
import Data.List.Split (splitOn)
import Network.Socket (HostAddress, HostAddress6)

type IPv6 = (Word64, Word64)

showIPv4 :: HostAddress -> String
showIPv4 x = intercalate "." . map (show . (.&. 0xff) . shiftR x) $ [24, 16, 8, 0]

hostAddress6ToIPv6 :: HostAddress6 -> IPv6
hostAddress6ToIPv6 (a, b, c, d) = (e, f)
    where e = (fromIntegral a `shiftL` 32) .|. fromIntegral b
          f = (fromIntegral c `shiftL` 32) .|. fromIntegral d

test1 :: HostAddress6
test1 = (704850048,4027320832,4207849484,1)

test2 :: IPv6
test2 = (2595313635555608576,4114)

-- 21DA:D3:0:2F3B:2AA:FF:FE28:9C5A
test3 :: IPv6
test3 = (2439263054412656443, 191967033597402202)

test4 :: IPv6
test4 = (0, 1)

test5 :: IPv6
test5 = (18338657682652659712, 1)

test6 :: HostAddress6
test6 = (536939960,0,0,3221225985)

test7 :: HostAddress6
test7 = (0, 0, 0, 3221225985)

test8 :: IPv6
test8 = (0, 0)

-- this function compress the first-longest zero sequence
-- if you want to shorten a single block of 0s, use
--      zeros = scanl (++) ":0:" (repeat "0:")

compressZeros :: String -> String
compressZeros str = without . longest $ zeros
    where zeros   = scanl (++) ":0:0:" (repeat "0:")
          longest = listToMaybe . reverse . takeWhile ((== True) . fst) . map (\z -> (z `isInfixOf` str, z))
          without = dropWhile (== '0') . maybe str (\(_, z) -> intercalate "::" . splitOn z $ str)

showIPv6 :: IPv6 -> String
showIPv6 addr@(a, b)
  | a == 0x0 && b `shiftR` (64-32) == 0xffff = "::ffff:" ++ showIPv4 (fromIntegral $ b .&. 0xffffffff)
  | a == 0x0 && b `shiftR` (64-32) == 0x0 && b .&. 0xffffffff >= 0x10000 = "::" ++ showIPv4 (fromIntegral $ b .&. 0xffffffff)
  | otherwise = compressZeros $ formatIPv6 addr ""

formatIPv6 :: IPv6 -> ShowS
formatIPv6 (a, b) = showA1 . (':':) . showA2 . (':':) . showA3 . (':':). showA4 . (':':)
                  . showB1 . (':':) . showB2 . (':':) . showB3 . (':':) . showB4
    where showA1 = showHex (a `shiftR` (64-16))
          showA2 = showHex (a `shiftR` (64-32) .&. 0x0000ffff)
          showA3 = showHex (a `shiftR` (64-48) .&. 0x0000ffff)
          showA4 = showHex (a .&. 0x0000ffff)
          showB1 = showHex (b `shiftR` (64-16))
          showB2 = showHex (b `shiftR` (64-32) .&. 0x0000ffff)
          showB3 = showHex (b `shiftR` (64-48) .&. 0x0000ffff)
          showB4 = showHex (b .&. 0x0000ffff)

main :: IO ()
main = mapM_ (putStrLn . showIPv6) [hostAddress6ToIPv6 test1, test2, test3, test4, test5, hostAddress6ToIPv6 test6, hostAddress6ToIPv6 test7, test8]

{-- output:

2a03:2880:f00c:a00:face:b00c:0:1
2404:6800:4005:800::1012
21da:d3:0:2f3b:2aa:ff:fe28:9c5a
::1
fe80::1
2001:db8::c000:201
::192.0.2.1
::0

--}