1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
|
-- |
-- 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 (Eq, Ord, Typeable, Hashable)
instance Show IPv4 where
show = toLString
instance NormalForm IPv4 where
toNormalForm !_ = ()
instance IsString IPv4 where
fromString = fromLString
instance Storable IPv4 where
peek ptr = IPv4 . fromBE <$> peek (castPtr ptr)
poke ptr (IPv4 w) = poke (castPtr ptr) (toBE w)
instance StorableFixed IPv4 where
size _ = size (Proxy :: Proxy Word32)
alignment _ = alignment (Proxy :: Proxy Word32)
-- | "0.0.0.0"
any :: IPv4
any = fromTuple (0,0,0,0)
-- | "127.0.0.1"
loopback :: IPv4
loopback = fromTuple (127,0,0,1)
toString :: IPv4 -> String
toString = fromList . toLString
fromLString :: [Char] -> IPv4
fromLString = either throw id . parseOnly ipv4Parser
toLString :: IPv4 -> [Char]
toLString ipv4 =
let (i1, i2, i3, i4) = toTuple ipv4
in show i1 <> "." <> show i2 <> "." <> show i3 <> "." <> show i4
fromTuple :: (Word8, Word8, Word8, Word8) -> IPv4
fromTuple (i1, i2, i3, i4) =
IPv4 $ (w1 .<<. 24) .&. 0xFF000000
.|. (w2 .<<. 16) .&. 0x00FF0000
.|. (w3 .<<. 8) .&. 0x0000FF00
.|. w4 .&. 0x000000FF
where
f = fromIntegral
w1, w2, w3, w4 :: Word32
w1 = f i1
w2 = f i2
w3 = f i3
w4 = f i4
toTuple :: IPv4 -> (Word8, Word8, Word8, Word8)
toTuple (IPv4 w) =
(f w1, f w2, f w3, f w4)
where
f = fromIntegral
w1, w2, w3, w4 :: Word32
w1 = w .>>. 24 .&. 0x000000FF
w2 = w .>>. 16 .&. 0x000000FF
w3 = w .>>. 8 .&. 0x000000FF
w4 = w .&. 0x000000FF
-- | Parse a IPv4 address
ipv4Parser :: ( ParserSource input, Element input ~ Char
, Sequential (Chunk input), Element input ~ Element (Chunk input)
)
=> Parser input IPv4
ipv4Parser = do
i1 <- takeAWord8 <* element '.'
i2 <- takeAWord8 <* element '.'
i3 <- takeAWord8 <* element '.'
i4 <- takeAWord8
return $ fromTuple (i1, i2, i3, i4)
where
takeAWord8 = do
maybeN <- readMaybe @Integer . toList <$> takeWhile isAsciiDecimal
case maybeN of
Nothing -> reportError $ Satisfy $ Just "expected integer"
Just n | n > 256 -> reportError $ Satisfy $ Just "expected smaller integer than 256"
| otherwise -> pure (fromIntegral n)
isAsciiDecimal = flip elem ['0'..'9']
|
