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

module Foundation.Network.IPv4
    ( IPv4
    , any, loopback
    , fromString, toString
    , fromTuple, toTuple
    , ipv4Parser
    ) where

import Prelude (fromIntegral)

import Foundation.Class.Storable
import Foundation.Hashing.Hashable
import Basement.Compat.Base
import Data.Proxy
import Foundation.String (String)
import Foundation.Primitive
import Basement.Bits
import Foundation.Parser hiding (peek)
import Foundation.Collection (Sequential, Element, elem)
import Text.Read (readMaybe)

-- | IPv4 data type
newtype IPv4 = IPv4 Word32
    deriving (IPv4 -> IPv4 -> Bool
(IPv4 -> IPv4 -> Bool) -> (IPv4 -> IPv4 -> Bool) -> Eq IPv4
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IPv4 -> IPv4 -> Bool
== :: IPv4 -> IPv4 -> Bool
$c/= :: IPv4 -> IPv4 -> Bool
/= :: IPv4 -> IPv4 -> Bool
Eq, Eq IPv4
Eq IPv4
-> (IPv4 -> IPv4 -> Ordering)
-> (IPv4 -> IPv4 -> Bool)
-> (IPv4 -> IPv4 -> Bool)
-> (IPv4 -> IPv4 -> Bool)
-> (IPv4 -> IPv4 -> Bool)
-> (IPv4 -> IPv4 -> IPv4)
-> (IPv4 -> IPv4 -> IPv4)
-> Ord IPv4
IPv4 -> IPv4 -> Bool
IPv4 -> IPv4 -> Ordering
IPv4 -> IPv4 -> IPv4
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: IPv4 -> IPv4 -> Ordering
compare :: IPv4 -> IPv4 -> Ordering
$c< :: IPv4 -> IPv4 -> Bool
< :: IPv4 -> IPv4 -> Bool
$c<= :: IPv4 -> IPv4 -> Bool
<= :: IPv4 -> IPv4 -> Bool
$c> :: IPv4 -> IPv4 -> Bool
> :: IPv4 -> IPv4 -> Bool
$c>= :: IPv4 -> IPv4 -> Bool
>= :: IPv4 -> IPv4 -> Bool
$cmax :: IPv4 -> IPv4 -> IPv4
max :: IPv4 -> IPv4 -> IPv4
$cmin :: IPv4 -> IPv4 -> IPv4
min :: IPv4 -> IPv4 -> IPv4
Ord, Typeable, (forall st. Hasher st => IPv4 -> st -> st) -> Hashable IPv4
forall st. Hasher st => IPv4 -> st -> st
forall a. (forall st. Hasher st => a -> st -> st) -> Hashable a
$chashMix :: forall st. Hasher st => IPv4 -> st -> st
hashMix :: forall st. Hasher st => IPv4 -> st -> st
Hashable)
instance Show IPv4 where
    show :: IPv4 -> [Char]
show = IPv4 -> [Char]
toLString
instance NormalForm IPv4 where
    toNormalForm :: IPv4 -> ()
toNormalForm !IPv4
_ = ()
instance IsString IPv4 where
    fromString :: [Char] -> IPv4
fromString = [Char] -> IPv4
fromLString
instance Storable IPv4 where
    peek :: Ptr IPv4 -> IO IPv4
peek Ptr IPv4
ptr = Word32 -> IPv4
IPv4 (Word32 -> IPv4) -> (BE Word32 -> Word32) -> BE Word32 -> IPv4
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. BE Word32 -> Word32
forall a. ByteSwap a => BE a -> a
fromBE (BE Word32 -> IPv4) -> IO (BE Word32) -> IO IPv4
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ptr (BE Word32) -> IO (BE Word32)
forall a. Storable a => Ptr a -> IO a
peek (Ptr IPv4 -> Ptr (BE Word32)
forall a b. Ptr a -> Ptr b
castPtr Ptr IPv4
ptr)
    poke :: Ptr IPv4 -> IPv4 -> IO ()
poke Ptr IPv4
ptr (IPv4 Word32
w) = Ptr (BE Word32) -> BE Word32 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr IPv4 -> Ptr (BE Word32)
forall a b. Ptr a -> Ptr b
castPtr Ptr IPv4
ptr) (Word32 -> BE Word32
forall a. ByteSwap a => a -> BE a
toBE Word32
w)
instance StorableFixed IPv4 where
    size :: forall (proxy :: * -> *). proxy IPv4 -> CountOf Word8
size      proxy IPv4
_ = Proxy Word32 -> CountOf Word8
forall a (proxy :: * -> *).
StorableFixed a =>
proxy a -> CountOf Word8
forall (proxy :: * -> *). proxy Word32 -> CountOf Word8
size      (Proxy Word32
forall {k} (t :: k). Proxy t
Proxy :: Proxy Word32)
    alignment :: forall (proxy :: * -> *). proxy IPv4 -> CountOf Word8
alignment proxy IPv4
_ = Proxy Word32 -> CountOf Word8
forall a (proxy :: * -> *).
StorableFixed a =>
proxy a -> CountOf Word8
forall (proxy :: * -> *). proxy Word32 -> CountOf Word8
alignment (Proxy Word32
forall {k} (t :: k). Proxy t
Proxy :: Proxy Word32)

-- | "0.0.0.0"
any :: IPv4
any :: IPv4
any = (Word8, Word8, Word8, Word8) -> IPv4
fromTuple (Word8
0,Word8
0,Word8
0,Word8
0)

-- | "127.0.0.1"
loopback :: IPv4
loopback :: IPv4
loopback = (Word8, Word8, Word8, Word8) -> IPv4
fromTuple (Word8
127,Word8
0,Word8
0,Word8
1)

toString :: IPv4 -> String
toString :: IPv4 -> String
toString = [Char] -> String
[Item String] -> String
forall l. IsList l => [Item l] -> l
fromList ([Char] -> String) -> (IPv4 -> [Char]) -> IPv4 -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. IPv4 -> [Char]
toLString

fromLString :: [Char] -> IPv4
fromLString :: [Char] -> IPv4
fromLString = (ParseError [Char] -> IPv4)
-> (IPv4 -> IPv4) -> Either (ParseError [Char]) IPv4 -> IPv4
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ParseError [Char] -> IPv4
forall a e. Exception e => e -> a
throw IPv4 -> IPv4
forall a. a -> a
forall {k} (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id (Either (ParseError [Char]) IPv4 -> IPv4)
-> ([Char] -> Either (ParseError [Char]) IPv4) -> [Char] -> IPv4
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Parser [Char] IPv4 -> [Char] -> Either (ParseError [Char]) IPv4
forall input a.
(ParserSource input, Monoid (Chunk input)) =>
Parser input a -> input -> Either (ParseError input) a
parseOnly Parser [Char] IPv4
forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
Parser input IPv4
ipv4Parser

toLString :: IPv4 -> [Char]
toLString :: IPv4 -> [Char]
toLString IPv4
ipv4 =
    let (Word8
i1, Word8
i2, Word8
i3, Word8
i4) = IPv4 -> (Word8, Word8, Word8, Word8)
toTuple IPv4
ipv4
     in Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
i1 [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"." [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
i2 [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"." [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
i3 [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Char]
"." [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word8 -> [Char]
forall a. Show a => a -> [Char]
show Word8
i4

fromTuple :: (Word8, Word8, Word8, Word8) -> IPv4
fromTuple :: (Word8, Word8, Word8, Word8) -> IPv4
fromTuple (Word8
i1, Word8
i2, Word8
i3, Word8
i4) =
     Word32 -> IPv4
IPv4 (Word32 -> IPv4) -> Word32 -> IPv4
forall a b. (a -> b) -> a -> b
$     (Word32
w1 Word32 -> CountOf Bool -> Word32
forall bits. BitOps bits => bits -> CountOf Bool -> bits
.<<. CountOf Bool
24) Word32 -> Word32 -> Word32
forall bits. BitOps bits => bits -> bits -> bits
.&. Word32
0xFF000000
            Word32 -> Word32 -> Word32
forall bits. BitOps bits => bits -> bits -> bits
.|. (Word32
w2 Word32 -> CountOf Bool -> Word32
forall bits. BitOps bits => bits -> CountOf Bool -> bits
.<<. CountOf Bool
16) Word32 -> Word32 -> Word32
forall bits. BitOps bits => bits -> bits -> bits
.&. Word32
0x00FF0000
            Word32 -> Word32 -> Word32
forall bits. BitOps bits => bits -> bits -> bits
.|. (Word32
w3 Word32 -> CountOf Bool -> Word32
forall bits. BitOps bits => bits -> CountOf Bool -> bits
.<<.  CountOf Bool
8) Word32 -> Word32 -> Word32
forall bits. BitOps bits => bits -> bits -> bits
.&. Word32
0x0000FF00
            Word32 -> Word32 -> Word32
forall bits. BitOps bits => bits -> bits -> bits
.|.  Word32
w4          Word32 -> Word32 -> Word32
forall bits. BitOps bits => bits -> bits -> bits
.&. Word32
0x000000FF
  where
    f :: Word8 -> Word32
f = Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    w1, w2, w3, w4 :: Word32
    w1 :: Word32
w1 = Word8 -> Word32
f Word8
i1
    w2 :: Word32
w2 = Word8 -> Word32
f Word8
i2
    w3 :: Word32
w3 = Word8 -> Word32
f Word8
i3
    w4 :: Word32
w4 = Word8 -> Word32
f Word8
i4

toTuple :: IPv4 -> (Word8, Word8, Word8, Word8)
toTuple :: IPv4 -> (Word8, Word8, Word8, Word8)
toTuple (IPv4 Word32
w) =
    (Word32 -> Word8
f Word32
w1, Word32 -> Word8
f Word32
w2, Word32 -> Word8
f Word32
w3, Word32 -> Word8
f Word32
w4)
  where
    f :: Word32 -> Word8
f = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral
    w1, w2, w3, w4 :: Word32
    w1 :: Word32
w1 = Word32
w Word32 -> CountOf Bool -> Word32
forall bits. BitOps bits => bits -> CountOf Bool -> bits
.>>. CountOf Bool
24 Word32 -> Word32 -> Word32
forall bits. BitOps bits => bits -> bits -> bits
.&. Word32
0x000000FF
    w2 :: Word32
w2 = Word32
w Word32 -> CountOf Bool -> Word32
forall bits. BitOps bits => bits -> CountOf Bool -> bits
.>>. CountOf Bool
16 Word32 -> Word32 -> Word32
forall bits. BitOps bits => bits -> bits -> bits
.&. Word32
0x000000FF
    w3 :: Word32
w3 = Word32
w Word32 -> CountOf Bool -> Word32
forall bits. BitOps bits => bits -> CountOf Bool -> bits
.>>.  CountOf Bool
8 Word32 -> Word32 -> Word32
forall bits. BitOps bits => bits -> bits -> bits
.&. Word32
0x000000FF
    w4 :: Word32
w4 = Word32
w         Word32 -> Word32 -> Word32
forall bits. BitOps bits => bits -> bits -> bits
.&. Word32
0x000000FF

-- | Parse a IPv4 address
ipv4Parser :: ( ParserSource input, Element input ~ Char
              , Sequential (Chunk input), Element input ~ Element (Chunk input)
              )
           => Parser input IPv4
ipv4Parser :: forall input.
(ParserSource input, Element input ~ Char,
 Sequential (Chunk input), Element input ~ Element (Chunk input)) =>
Parser input IPv4
ipv4Parser = do
    Word8
i1 <- Parser input Word8
takeAWord8 Parser input Word8 -> Parser input () -> Parser input Word8
forall a b. Parser input a -> Parser input b -> Parser input a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Element input -> Parser input ()
forall input.
(ParserSource input, Eq (Element input),
 Element input ~ Element (Chunk input)) =>
Element input -> Parser input ()
element Char
Element input
'.'
    Word8
i2 <- Parser input Word8
takeAWord8 Parser input Word8 -> Parser input () -> Parser input Word8
forall a b. Parser input a -> Parser input b -> Parser input a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Element input -> Parser input ()
forall input.
(ParserSource input, Eq (Element input),
 Element input ~ Element (Chunk input)) =>
Element input -> Parser input ()
element Char
Element input
'.'
    Word8
i3 <- Parser input Word8
takeAWord8 Parser input Word8 -> Parser input () -> Parser input Word8
forall a b. Parser input a -> Parser input b -> Parser input a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Element input -> Parser input ()
forall input.
(ParserSource input, Eq (Element input),
 Element input ~ Element (Chunk input)) =>
Element input -> Parser input ()
element Char
Element input
'.'
    Word8
i4 <- Parser input Word8
takeAWord8
    IPv4 -> Parser input IPv4
forall a. a -> Parser input a
forall (m :: * -> *) a. Monad m => a -> m a
return (IPv4 -> Parser input IPv4) -> IPv4 -> Parser input IPv4
forall a b. (a -> b) -> a -> b
$ (Word8, Word8, Word8, Word8) -> IPv4
fromTuple (Word8
i1, Word8
i2, Word8
i3, Word8
i4)
  where
    takeAWord8 :: Parser input Word8
takeAWord8 = do
      Maybe Integer
maybeN <- forall a. Read a => [Char] -> Maybe a
readMaybe @Integer ([Char] -> Maybe Integer)
-> (Chunk input -> [Char]) -> Chunk input -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Chunk input -> [Char]
Chunk input -> [Item (Chunk input)]
forall l. IsList l => l -> [Item l]
toList (Chunk input -> Maybe Integer)
-> Parser input (Chunk input) -> Parser input (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Element input -> Bool) -> Parser input (Chunk input)
forall input.
(ParserSource input, Sequential (Chunk input)) =>
(Element input -> Bool) -> Parser input (Chunk input)
takeWhile Char -> Bool
Element input -> Bool
isAsciiDecimal
      case Maybe Integer
maybeN of
        Maybe Integer
Nothing -> ParseError input -> Parser input Word8
forall input a. ParseError input -> Parser input a
reportError (ParseError input -> Parser input Word8)
-> ParseError input -> Parser input Word8
forall a b. (a -> b) -> a -> b
$ Maybe String -> ParseError input
forall input. Maybe String -> ParseError input
Satisfy (Maybe String -> ParseError input)
-> Maybe String -> ParseError input
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
"expected integer"
        Just Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
256   -> ParseError input -> Parser input Word8
forall input a. ParseError input -> Parser input a
reportError (ParseError input -> Parser input Word8)
-> ParseError input -> Parser input Word8
forall a b. (a -> b) -> a -> b
$ Maybe String -> ParseError input
forall input. Maybe String -> ParseError input
Satisfy (Maybe String -> ParseError input)
-> Maybe String -> ParseError input
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
"expected smaller integer than 256"
               | Bool
otherwise -> Word8 -> Parser input Word8
forall a. a -> Parser input a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)

    isAsciiDecimal :: Char -> Bool
isAsciiDecimal = (Char -> [Char] -> Bool) -> [Char] -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> [Char] -> Bool
Element [Char] -> [Char] -> Bool
forall a.
(Eq a, a ~ Element [Char]) =>
Element [Char] -> [Char] -> Bool
forall c a.
(Collection c, Eq a, a ~ Element c) =>
Element c -> c -> Bool
elem [Char
'0'..Char
'9']