path: root/Haskell-book/24/ParserExercises/src/IPAddress.hs

module IPAddress where

import Numeric
import Control.Monad (join)
import Control.Applicative
import Data.Char
import Data.List
import Data.Maybe
import Data.Map (lookup, Map(..), fromList)
import Data.Word
import Data.Bits
import Text.Trifecta

-- 6. Write a parser for IPv4 addresses.

data IPAddress = IPAddress Word32 deriving (Eq, Ord)

parseIP4 :: Parser IPAddress
parseIP4 = do
    p1 <- natural
    _ <- char '.'
    p2 <- natural
    _ <- char '.'
    p3 <- natural
    _ <- char '.'
    p4 <- natural
    return $ IPAddress $ fromIntegral $ xor (xor (xor (shift p1 24) (shift p2 16)) (shift p3 8)) p4

-- A 32-bit word is a 32-bit unsigned int. Lowest value is 0 rahter than being
-- capable of representing negative numbers, but the highest possible value in
-- the same number of bits is twice as high.
--
-- Word32 is an appropriate and compact way to represent IPv4 addresses. You
-- are expected to figure out not only how to parse the typical IP address
-- format, but how IP addresses work numerically insofar as is required to
-- write a working parser. This will require using a search engine unless you
-- have an appropriate book on internet networking handy.

-- 7. Same as before, but IPv6.

data IPAddress6 = IPAddress6 Word64 Word64 deriving (Eq, Ord)

-- One of the trickier parts about IPv6 will be full vs. collapsed
-- addresses and the abbrevations. See this Q&A thread 13 about
-- IPv6 abbreviations for more.


newtype IPV6Normed = IPV6Normed String
  deriving (Eq, Ord, Show)

newtype IPV6Str = IPV6Str String
  deriving (Eq, Ord, Show)

spanList :: ([a] -> Bool) -> [a] -> ([a], [a])
spanList _ [] = ([],[])
spanList func list@(x:xs) =
    if func list
       then (x:ys,zs)
       else ([],list)
    where (ys,zs) = spanList func xs

breakList :: ([a] -> Bool) -> [a] -> ([a], [a])
breakList func = spanList (not . func)

split' :: Eq a => [a] -> [a] -> [[a]]
split' _ [] = []
split' delim str =
    let (firstline, remainder) = breakList (isPrefixOf delim) str
        in 
        firstline : case remainder of
                                   [] -> []
                                   x -> if x == delim
                                        then [] : []
                                        else split' delim 
                                                 (drop (length delim) x)

join :: [a] -> [[a]] -> [a]
join delim l = concat (intersperse delim l)

replace :: Eq a => [a] -> [a] -> [a] -> [a]
replace old new l = IPAddress.join new . split' old $ l

split :: Eq a => a -> [a] -> [[a]]
split d [] = []
split d s = x : split d (drop 1 y)
  where
    (x, y) = Data.List.span (/= d) s

twoRaised16Exp :: [Integer]
twoRaised16Exp = fmap ((2 ^ 16) ^) [0,1 ..]

validHexChars :: String
validHexChars = "0123456789abcdefABCDEF"

validHexCharsLowerOnly :: String
validHexCharsLowerOnly = "0123456789abcdef"

buildExpanded0s :: Int -> String
buildExpanded0s i = intersperse ':' (take i (repeat '0'))

ipv6NormedToIPAddress6 :: IPV6Normed -> IPAddress6
ipv6NormedToIPAddress6 (IPV6Normed str) = IPAddress6 quotient remainder
  where
    asSegs = split ':' str
    zippedWithExp = zip (reverse asSegs) twoRaised16Exp
    asInteger = foldr (\(s, exp) acc -> hexToDec s * exp + acc) 0 zippedWithExp
    (q, r) = quotRem asInteger word64Max
    quotient = fromIntegral q
    remainder = fromIntegral r

hexToDec :: String -> Integer
hexToDec s = toInteger asInt
  where
    asInt = baseNToDec 16 (\c -> fromMaybe 0 (Data.Map.lookup (toLower c) hexCharToValue)) s

baseNToDec :: Num i => i -> (a -> i) -> [a] -> i
baseNToDec base toInt = foldl' (\acc n -> base * acc + toInt n ) 0

hexCharToValue :: Map Char Int
hexCharToValue = Data.Map.fromList $ zip validHexCharsLowerOnly [0 ..]

word64Max :: Integer
word64Max = toInteger (maxBound :: Word64)

mkIPV6Normed :: String -> Either String IPV6Normed
mkIPV6Normed origS = result
  where
    expand s
      | s == "::" = IPV6Normed $ buildExpanded0s 8
      | isPrefixOf "::" s =
          let expandCnt = 8 - (length $ split ':' s) + 2
              filler = buildExpanded0s expandCnt ++ ":"
              replaced = replace "::" filler s
          in IPV6Normed replaced
      | isSuffixOf "::" s =
          let expandCnt = 8 - (length $ split ':' s) + 1
              filler = ':' : buildExpanded0s expandCnt
              replaced = replace "::" filler s
          in IPV6Normed replaced
      | isInfixOf "::" s =
          let expandCnt = 8 - (length $ split ':' s) + 1
              filler = ':' : buildExpanded0s expandCnt ++ ":"
              replaced = replace "::" filler s
          in IPV6Normed replaced
      | otherwise = IPV6Normed s
    expanded = expand origS
    IPV6Normed expandedStr = expanded
    result = if length (split ':' expandedStr) == 8
               then Right expanded
               else Left "invalid sections"

parseIPV6Section :: Parser String
parseIPV6Section = do
  mL <- optional (try $ string "::" <|> string ":")
  seq <- some (oneOf validHexChars)
  mR <- optional (try $ string "::" <|> string ":")
  let lowered = map toLower seq
      l = fromMaybe "" mL
      r = fromMaybe "" mR
  return $ l ++ lowered ++ r

parseIPV6Str :: Parser IPV6Str
parseIPV6Str = do
  s <- (try $ (fmap (: []) (string "::" <* eof))) <|> manyTill parseIPV6Section
                                                        eof
  if length s < 1
    then fail "Did not find valid sections"
    else return $ IPV6Str $ Control.Monad.join s

parseIPV6Normed :: Parser IPV6Normed
parseIPV6Normed = do
  str <- parseIPV6Str
  let IPV6Str (s) = str
      full = mkIPV6Normed s
  case full of
    Left err      -> fail err
    Right fullstr -> return fullstr

parseIP6 :: Parser IPAddress6
parseIP6 = do
    normed <- parseIPV6Normed
    return $ ipv6NormedToIPAddress6 normed

-- 8. Remove the derived Show instances from the IPAddress/IPAddress6
-- types, and write your own Show instance for each type that renders in the
-- typical textual format appropriate to each.

ipAddressToIPV4DotFields :: IPAddress -> [Integer]
ipAddressToIPV4DotFields (IPAddress word) = repr
  where
    asInteger = toInteger word
    repr = decToBaseN asInteger 0 [0 .. 255]

instance Show IPAddress where
  show ip = Control.Monad.join $ intersperse "." asStrings
    where
      repr = ipAddressToIPV4DotFields ip
      asStrings = fmap show repr

ipAddress6toInteger :: IPAddress6 -> Integer
ipAddress6toInteger (IPAddress6 q r) = toInteger q * word64Max + toInteger r

iPAddress6ToIPV6Normed :: IPAddress6 -> IPV6Normed
iPAddress6ToIPV6Normed ip = IPV6Normed s
  where
    asInteger = ipAddress6toInteger ip
    chopped = integerToChoppedUp asInteger
    ss = fmap integerToHexString chopped
    fillCnt = 8 - length ss
    filled = (take fillCnt (repeat "0")) ++ ss
    s = Control.Monad.join $ intersperse ":" filled

instance Show IPAddress6 where
  show ip = normed
    where IPV6Normed normed = iPAddress6ToIPV6Normed ip

-- 9. Write a function that converts between IPAddress and IPAddress6.

decToBaseN :: Integral a => a -> b -> [b] -> [b]
decToBaseN i zero digits = if base == 0
                                  then []
                                  else go i []
  where
    base = fromIntegral $ length digits
    go 0 [] = [zero]
    go 0 acc = acc
    go curr acc =
      let (q, r) = quotRem curr base
      in go q ((digits !! fromIntegral r) : acc)

integerToHexString :: Integer -> String
integerToHexString i = decToBaseN i '0' validHexCharsLowerOnly

integerToChoppedUp :: Integer -> [Integer]
integerToChoppedUp i = go i []
  where
    go 0 [] = [0]
    go 0 acc = acc
    go curr acc =
      let (q, r) = quotRem curr (2 ^ 16)
       in go q (r : acc)

ipV4ToIpV6Normed :: IPAddress -> IPV6Normed
ipV4ToIpV6Normed (IPAddress word) = normed
  where
    asInteger = toInteger word
    chopped = integerToChoppedUp asInteger
    ss = fmap integerToHexString chopped
    fillCnt = 8 - length ss - 1
    -- - ffff signifies an ip4 to ip6 conversion
    -- (http://www.tcpipguide.com/free/t_IPv6IPv4AddressEmbedding-2.htm)
    filled = (take fillCnt $ repeat "0") ++ ["ffff"] ++ ss
    s = Control.Monad.join $ intersperse ":" filled
    normed = IPV6Normed s

ipV4ToIpV6 :: IPAddress -> IPAddress6
ipV4ToIpV6 ip = ipv6
  where
    normed = ipV4ToIpV6Normed ip
    ipv6 = ipv6NormedToIPAddress6 normed