-- |
-- Module      : Foundation.Network.IPv6
-- License     : BSD-style
-- Maintainer  : Nicolas Di Prima <nicolas@primetype.co.uk>
-- Stability   : experimental
-- Portability : portable
--
-- IPv6 data type
--
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Foundation.Network.IPv6
    ( IPv6
    , any, loopback
    , fromString, toString
    , fromTuple, toTuple
      -- * parsers
    , ipv6Parser
    , ipv6ParserPreferred
    , ipv6ParserCompressed
    , ipv6ParserIpv4Embedded
    ) where

import Prelude (fromIntegral, replicate, read)
import qualified Text.Printf as Base
import Data.Char (isHexDigit, isDigit)
import Numeric (readHex)
import Control.Monad (when)

import Foundation.Class.Storable
import Foundation.Hashing.Hashable
import Foundation.Numerical.Additive (scale)
import Foundation.Internal.Base
import Foundation.Internal.Proxy
import Foundation.Primitive
import Foundation.Numerical
import Foundation.Collection (Sequential, Element, length, intercalate, null)
import Foundation.Parser
import Foundation.String (String)
import Foundation.Bits

-- | IPv6 data type
data IPv6 = IPv6 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
    deriving (Eq, Ord, Typeable)
instance NormalForm IPv6 where
    toNormalForm !_ = ()
instance Hashable IPv6 where
    hashMix (IPv6 w1 w2) = hashMix w1 . hashMix w2
instance Show IPv6 where
    show = toLString
instance IsString IPv6 where
    fromString = fromLString
instance Storable IPv6 where
    peek ptr = fromTuple <$>
        (   (,,,,,,,)
        <$> (fromBE <$> peekOff ptr' 0)
        <*> (fromBE <$> peekOff ptr' 1)
        <*> (fromBE <$> peekOff ptr' 2)
        <*> (fromBE <$> peekOff ptr' 3)
        <*> (fromBE <$> peekOff ptr' 4)
        <*> (fromBE <$> peekOff ptr' 5)
        <*> (fromBE <$> peekOff ptr' 6)
        <*> (fromBE <$> peekOff ptr' 7)
        )
      where
        ptr' :: Ptr (BE Word16)
        ptr' = castPtr ptr
    poke ptr ipv6 = do
        let (i1,i2,i3,i4,i5,i6,i7,i8) = toTuple ipv6
         in pokeOff ptr' 0 (toBE i1)
         >> pokeOff ptr' 1 (toBE i2)
         >> pokeOff ptr' 2 (toBE i3)
         >> pokeOff ptr' 3 (toBE i4)
         >> pokeOff ptr' 4 (toBE i5)
         >> pokeOff ptr' 5 (toBE i6)
         >> pokeOff ptr' 6 (toBE i7)
         >> pokeOff ptr' 7 (toBE i8)
      where
        ptr' :: Ptr (BE Word16)
        ptr' = castPtr ptr
instance StorableFixed IPv6 where
    size      _ = (size      (Proxy :: Proxy Word64)) `scale` 2
    alignment _ = alignment (Proxy :: Proxy Word64)

-- | equivalent to `::`
any :: IPv6
any = fromTuple (0,0,0,0,0,0,0,0)

-- | equivalent to `::1`
loopback :: IPv6
loopback = fromTuple (0,0,0,0,0,0,0,1)

-- | serialise to human readable IPv6
--
-- >>> toString (fromString "0:0:0:0:0:0:0:1" :: IPv6)
toString :: IPv6 -> String
toString = fromList . toLString

toLString :: IPv6 -> [Char]
toLString ipv4 =
    let (i1,i2,i3,i4,i5,i6,i7,i8) = toTuple ipv4
     in intercalate ":" $ showHex4 <$> [i1,i2,i3,i4,i5,i6,i7,i8]

showHex4 :: Word16 -> [Char]
showHex4 = showHex

showHex :: Word16 -> [Char]
showHex = Base.printf "%04x"

fromLString :: [Char] -> IPv6
fromLString = parseOnly ipv6Parser


-- | create an IPv6 from the given tuple
fromTuple :: (Word16, Word16, Word16, Word16, Word16, Word16, Word16, Word16)
          -> IPv6
fromTuple (i1, i2, i3, i4, i5, i6, i7, i8) = IPv6 hi low
  where
    f :: Word16 -> Word64
    f = fromIntegral
    hi, low :: Word64
    hi =    (f i1 .<<. 48)
        .|. (f i2 .<<. 32)
        .|. (f i3 .<<. 16)
        .|. (f i4        )
    low =   (f i5 .<<. 48)
        .|. (f i6 .<<. 32)
        .|. (f i7 .<<. 16)
        .|. (f i8        )

-- | decompose an IPv6 into a tuple
toTuple :: IPv6 -> (Word16,Word16,Word16,Word16,Word16,Word16,Word16,Word16)
toTuple (IPv6 hi low) =
    (f w1, f w2, f w3, f w4, f w5, f w6, f w7, f w8)
  where
    f :: Word64 -> Word16
    f = fromIntegral
    w1, w2, w3, w4, w5, w6, w7, w8 :: Word64
    w1 = hi  .>>. 48
    w2 = hi  .>>. 32
    w3 = hi  .>>. 16
    w4 = hi
    w5 = low .>>. 48
    w6 = low .>>. 32
    w7 = low .>>. 16
    w8 = low

-- | IPv6 Parser as described in RFC4291
--
-- for more details: https://tools.ietf.org/html/rfc4291.html#section-2.2
--
-- which is exactly:
--
-- ```
--     ipv6ParserPreferred
-- <|> ipv6ParserIPv4Embedded
-- <|> ipv6ParserCompressed
-- ```
--
ipv6Parser :: (Sequential input, Element input ~ Char)
           => Parser input IPv6
ipv6Parser =  ipv6ParserPreferred
          <|> ipv6ParserIpv4Embedded
          <|> ipv6ParserCompressed

-- | IPv6 parser as described in RFC4291 section 2.2.1
--
-- The preferred form is x:x:x:x:x:x:x:x, where the 'x's are one to
-- four hexadecimal digits of the eight 16-bit pieces of the address.
--
-- * `ABCD:EF01:2345:6789:ABCD:EF01:2345:6789`
-- * `2001:DB8:0:0:8:800:200C:417A`
--
ipv6ParserPreferred :: (Sequential input, Element input ~ Char)
                    => Parser input IPv6
ipv6ParserPreferred = do
    i1 <- takeAWord16 <* skipColon
    i2 <- takeAWord16 <* skipColon
    i3 <- takeAWord16 <* skipColon
    i4 <- takeAWord16 <* skipColon
    i5 <- takeAWord16 <* skipColon
    i6 <- takeAWord16 <* skipColon
    i7 <- takeAWord16 <* skipColon
    i8 <- takeAWord16
    return $ fromTuple (i1,i2,i3,i4,i5,i6,i7,i8)

-- | IPv6 address with embedded IPv4 address
--
-- when dealing with a mixed environment of IPv4 and IPv6 nodes is
-- x:x:x:x:x:x:d.d.d.d, where the 'x's are the hexadecimal values of
-- the six high-order 16-bit pieces of the address, and the 'd's are
-- the decimal values of the four low-order 8-bit pieces of the
-- address (standard IPv4 representation).
--
-- * `0:0:0:0:0:0:13.1.68.3`
-- * `0:0:0:0:0:FFFF:129.144.52.38`
-- * `::13.1.68.3`
-- * `::FFFF:129.144.52.38`
--
ipv6ParserIpv4Embedded :: (Sequential input, Element input ~ Char)
                       => Parser input IPv6
ipv6ParserIpv4Embedded = do
    bs1 <- repeat (Between Never (toEnum 6)) $
              takeAWord16 <* skipColon
    _ <- optional skipColon
    _ <- optional skipColon
    bs2 <- repeat (Between Never (toEnum $ 6 - length bs1)) $
              takeAWord16 <* skipColon
    _ <- optional skipColon
    [i1,i2,i3,i4,i5,i6] <- format 6 bs1 bs2
    m1 <- takeAWord8 <* skipDot
    m2 <- takeAWord8 <* skipDot
    m3 <- takeAWord8 <* skipDot
    m4 <- takeAWord8
    return $ fromTuple ( i1,i2,i3,i4,i5,i6
                       , m1 `shiftL` 8 .|. m2
                       , m3 `shiftL` 8 .|. m4
                       )

-- | IPv6 parser as described in RFC4291 section 2.2.2
--
-- The use of "::" indicates one or more groups of 16 bits of zeros.
-- The "::" can only appear once in an address.  The "::" can also be
-- used to compress leading or trailing zeros in an address.
--
-- * `2001:DB8::8:800:200C:417A`
-- * `FF01::101`
-- * `::1`
-- * `::`
--
ipv6ParserCompressed :: (Sequential input, Element input ~ Char)
                     => Parser input IPv6
ipv6ParserCompressed = do
    bs1 <- repeat (Between Never (toEnum 8)) $
              takeAWord16 <* skipColon
    when (null bs1) skipColon
    bs2 <- repeat (Between Never (toEnum $ 8 - length bs1)) $
              skipColon *> takeAWord16
    [i1,i2,i3,i4,i5,i6,i7,i8] <- format 8 bs1 bs2
    return $ fromTuple (i1,i2,i3,i4,i5,i6,i7,i8)

format :: (Integral a, Monad m) => Int -> [a] -> [a] -> m [a]
format sz bs1 bs2 = do
    let len = sz - length bs1 - length bs2
    when (len < 1) $ fail "invalid compressed IPv6 addressed"
    return $ bs1 <> replicate len 0 <> bs2

skipColon :: (Sequential input, Element input ~ Char)
          => Parser input ()
skipColon = element ':'
skipDot :: (Sequential input, Element input ~ Char)
        => Parser input ()
skipDot = element '.'
takeAWord8 :: (Sequential input, Element input ~ Char)
           => Parser input Word16
takeAWord8 = do
    read <$> repeat (Between Once (toEnum 3)) (satisfy isDigit)
takeAWord16 :: (Sequential input, Element input ~ Char)
            => Parser input Word16
takeAWord16 = do
    l <- repeat (Between Once (toEnum 4)) (satisfy isHexDigit)
    let lhs = readHex l
     in case lhs of
          [(w, [])] -> return w
          _ -> fail "can't fall here"