import Data.List (isInfixOf)
import Numeric (showHex)
import Data.Char (isDigit)

data IPChunk = IPv6Chunk String | IPv4Chunk (String, String) |
    IPv6WithPort [IPChunk] String | IPv6NoPort [IPChunk] |
    IPv4WithPort IPChunk String | IPv4NoPort IPChunk |
    IPInvalid | IPZeroSection | IPUndefinedWithPort String |
    IPUndefinedNoPort

instance Show IPChunk where
    show (IPv6Chunk a) = a
    show (IPv4Chunk (a,b)) = a ++ b
    show (IPv6WithPort a p) = "IPv6 " ++ concatMap show a ++ " port " ++ p
    show (IPv6NoPort a) = "IPv6 " ++ concatMap show a ++ " no port"
    show (IPv4WithPort a p) = "IPv4 " ++ show a ++ " port " ++ p
    show (IPv4NoPort a) = "IPv4 " ++ show a
    show IPInvalid = "Invalid IP address"

isIPInvalid IPInvalid = True
isIPInvalid _ = False

isIPZeroSection IPZeroSection = True
isIPZeroSection _ = False

splitOn _ [] = []
splitOn x xs = let (a, b) = break (== x) xs in a : splitOn x (drop 1 b)

count x = length . filter (== x)

between a b x = x >= a && x <= b

none f = all (not . f)

parse1 [] = IPInvalid
parse1 "::" = IPUndefinedNoPort
parse1 ('[':':':':':']':':':ps) = if portIsValid ps then IPUndefinedWithPort ps else IPInvalid
parse1 ('[':xs) = if "]:" `isInfixOf` xs
    then let (a, b) = break (== ']') xs in
            if tail b == ":" then IPInvalid else IPv6WithPort (map chunk (splitOn ':' a)) (drop 2 b)
    else IPInvalid
parse1 xs
    | count ':' xs <= 1 && count '.' xs == 3 =
        let (a, b) = break (== ':') xs in case b of
                "" -> IPv4NoPort (chunk a)
                (':':ps) -> IPv4WithPort (chunk a) ps
                _ -> IPInvalid
    | count ':' xs > 1 && count '.' xs <= 3 =
        IPv6NoPort (map chunk (splitOn ':' xs))

chunk [] = IPZeroSection
chunk xs
    | '.' `elem` xs = case splitOn '.' xs of
        [a,b,c,d] -> let [e,f,g,h] = map read [a,b,c,d]
                     in if all (between 0 255) [e,f,g,h]
                            then let [i,j,k,l] = map (\n -> fill 2 $ showHex n "") [e,f,g,h]
                                 in IPv4Chunk (i ++ j, k ++ l)
                            else IPInvalid
    | ':' `notElem` xs && between 1 4 (length xs) && all (`elem` "0123456789abcdef") xs = IPv6Chunk (fill 4 xs)
    | otherwise = IPInvalid

fill n xs = replicate (n - length xs) '0' ++ xs

parse2 IPInvalid = IPInvalid
parse2 (IPUndefinedWithPort p) = IPv6WithPort (replicate 8 zeroChunk) p
parse2 IPUndefinedNoPort = IPv6NoPort (replicate 8 zeroChunk)
parse2 a = case a of
    IPv6WithPort xs p -> if none isIPInvalid xs && portIsValid p
        then let ys = complete xs
             in  if countChunks ys == 8
                     then IPv6WithPort ys p
                     else IPInvalid
        else IPInvalid
    IPv6NoPort xs -> if none isIPInvalid xs
        then let ys = complete xs
             in  if countChunks ys == 8
                     then IPv6NoPort ys
                     else IPInvalid
        else IPInvalid
    IPv4WithPort (IPv4Chunk a) p -> if portIsValid p
        then IPv4WithPort (IPv4Chunk a) p
        else IPInvalid
    IPv4NoPort (IPv4Chunk a) -> IPv4NoPort (IPv4Chunk a)
    _ -> IPInvalid

zeroChunk = IPv6Chunk "0000"

portIsValid a = all isDigit a && between 0 65535 (read a)

complete xs = case break isIPZeroSection xs of
    (_, [IPZeroSection]) -> []
    (ys, []) -> ys
    ([], (IPZeroSection:IPZeroSection:ys)) -> if any isIPZeroSection ys || countChunks ys > 7
        then []
        else replicate (8 - countChunks ys) zeroChunk ++ ys
    (ys, (IPZeroSection:zs)) -> if any isIPZeroSection zs || countChunks ys + countChunks zs > 7
        then []
        else ys ++ replicate (8 - countChunks ys - countChunks zs) zeroChunk ++ zs
    _ -> []

countChunks xs = foldl f 0 xs
    where f n (IPv4Chunk _) = n + 2
          f n (IPv6Chunk _) = n + 1

ip = parse2 . parse1

main = mapM_ (putStrLn . show . ip)
    ["127.0.0.1",                                  -- loop back
     "127.0.0.1:80",                               -- loop back +port
     "::1",                                        -- loop back
     "[::1]:80",                                   -- loop back +port
     "2605:2700:0:3::4713:93e3",                   -- Rosetta Code
     "[2605:2700:0:3::4713:93e3]:80"]              -- Rosetta Code