1 files changed, 260 insertions, 0 deletions
diff --git a/Haskell-book/24/ParserExercises/src/IPAddress.hs b/Haskell-book/24/ParserExercises/src/IPAddress.hs
new file mode 100644
index 0000000..e6a7102
--- /dev/null
+++ b/Haskell-book/24/ParserExercises/src/IPAddress.hs
@@ -0,0 +1,260 @@
+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