{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, DataKinds, TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Database.PostgreSQL.Typed.Inet where
import Control.Monad (void, guard, liftM2)
import qualified Data.ByteString.Char8 as BSC
import Data.Bits (shiftL, (.|.))
import Data.Maybe (fromJust)
import Data.Word (Word8, Word16, Word32)
import Foreign.Marshal.Array (withArray)
import Foreign.Ptr (castPtr)
import Foreign.Storable (peek)
import qualified Network.Socket as Net
import Numeric (readDec, readHex)
import System.IO.Unsafe (unsafeDupablePerformIO)
import qualified Text.ParserCombinators.ReadP as RP
import qualified Text.ParserCombinators.ReadPrec as RP (lift)
import Text.Read (Read(readPrec))
import Database.PostgreSQL.Typed.Types
data PGInet
= PGInet
{ PGInet -> Word32
pgInetAddr :: !Net.HostAddress
, PGInet -> Word8
pgInetMask :: !Word8
}
| PGInet6
{ PGInet -> HostAddress6
pgInetAddr6 :: !Net.HostAddress6
, pgInetMask :: !Word8
}
deriving (PGInet -> PGInet -> Bool
(PGInet -> PGInet -> Bool)
-> (PGInet -> PGInet -> Bool) -> Eq PGInet
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PGInet -> PGInet -> Bool
== :: PGInet -> PGInet -> Bool
$c/= :: PGInet -> PGInet -> Bool
/= :: PGInet -> PGInet -> Bool
Eq)
sockAddrPGInet :: Net.SockAddr -> Maybe PGInet
sockAddrPGInet :: SockAddr -> Maybe PGInet
sockAddrPGInet (Net.SockAddrInet PortNumber
_ Word32
a) = PGInet -> Maybe PGInet
forall a. a -> Maybe a
Just (PGInet -> Maybe PGInet) -> PGInet -> Maybe PGInet
forall a b. (a -> b) -> a -> b
$ Word32 -> Word8 -> PGInet
PGInet Word32
a Word8
32
sockAddrPGInet (Net.SockAddrInet6 PortNumber
_ Word32
_ HostAddress6
a Word32
_) = PGInet -> Maybe PGInet
forall a. a -> Maybe a
Just (PGInet -> Maybe PGInet) -> PGInet -> Maybe PGInet
forall a b. (a -> b) -> a -> b
$ HostAddress6 -> Word8 -> PGInet
PGInet6 HostAddress6
a Word8
128
sockAddrPGInet SockAddr
_ = Maybe PGInet
forall a. Maybe a
Nothing
bton32 :: (Word8, Word8, Word8, Word8) -> Word32
bton32 :: (Word8, Word8, Word8, Word8) -> Word32
bton32 (Word8
b1, Word8
b2, Word8
b3, Word8
b4) = IO Word32 -> Word32
forall a. IO a -> a
unsafeDupablePerformIO (IO Word32 -> Word32) -> IO Word32 -> Word32
forall a b. (a -> b) -> a -> b
$
[Word8] -> (Ptr Word8 -> IO Word32) -> IO Word32
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [Word8
b1, Word8
b2, Word8
b3, Word8
b4] (Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek (Ptr Word32 -> IO Word32)
-> (Ptr Word8 -> Ptr Word32) -> Ptr Word8 -> IO Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Word8 -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr)
instance Show PGInet where
show :: PGInet -> String
show (PGInet Word32
a Word8
32) = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ (Maybe String, Maybe String) -> Maybe String
forall a b. (a, b) -> a
fst ((Maybe String, Maybe String) -> Maybe String)
-> (Maybe String, Maybe String) -> Maybe String
forall a b. (a -> b) -> a -> b
$ IO (Maybe String, Maybe String) -> (Maybe String, Maybe String)
forall a. IO a -> a
unsafeDupablePerformIO (IO (Maybe String, Maybe String) -> (Maybe String, Maybe String))
-> IO (Maybe String, Maybe String) -> (Maybe String, Maybe String)
forall a b. (a -> b) -> a -> b
$
[NameInfoFlag]
-> Bool -> Bool -> SockAddr -> IO (Maybe String, Maybe String)
Net.getNameInfo [NameInfoFlag
Net.NI_NUMERICHOST] Bool
True Bool
False (PortNumber -> Word32 -> SockAddr
Net.SockAddrInet PortNumber
0 Word32
a)
show (PGInet Word32
a Word8
m) = PGInet -> String
forall a. Show a => a -> String
show (Word32 -> Word8 -> PGInet
PGInet Word32
a Word8
32) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: Word8 -> String
forall a. Show a => a -> String
show Word8
m
show (PGInet6 HostAddress6
a Word8
128) = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ (Maybe String, Maybe String) -> Maybe String
forall a b. (a, b) -> a
fst ((Maybe String, Maybe String) -> Maybe String)
-> (Maybe String, Maybe String) -> Maybe String
forall a b. (a -> b) -> a -> b
$ IO (Maybe String, Maybe String) -> (Maybe String, Maybe String)
forall a. IO a -> a
unsafeDupablePerformIO (IO (Maybe String, Maybe String) -> (Maybe String, Maybe String))
-> IO (Maybe String, Maybe String) -> (Maybe String, Maybe String)
forall a b. (a -> b) -> a -> b
$
[NameInfoFlag]
-> Bool -> Bool -> SockAddr -> IO (Maybe String, Maybe String)
Net.getNameInfo [NameInfoFlag
Net.NI_NUMERICHOST] Bool
True Bool
False (PortNumber -> Word32 -> HostAddress6 -> Word32 -> SockAddr
Net.SockAddrInet6 PortNumber
0 Word32
0 HostAddress6
a Word32
0)
show (PGInet6 HostAddress6
a Word8
m) = PGInet -> String
forall a. Show a => a -> String
show (HostAddress6 -> Word8 -> PGInet
PGInet6 HostAddress6
a Word8
128) String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: Word8 -> String
forall a. Show a => a -> String
show Word8
m
instance Read PGInet where
readPrec :: ReadPrec PGInet
readPrec = ReadP PGInet -> ReadPrec PGInet
forall a. ReadP a -> ReadPrec a
RP.lift (ReadP PGInet -> ReadPrec PGInet)
-> ReadP PGInet -> ReadPrec PGInet
forall a b. (a -> b) -> a -> b
$ ReadP PGInet
r4 ReadP PGInet -> ReadP PGInet -> ReadP PGInet
forall a. ReadP a -> ReadP a -> ReadP a
RP.+++ ReadP PGInet
r6 where
r4i :: ReadP (Word8, Word8, Word8, Word8)
r4i = do
o1 <- ReadP Word8
rdec
_ <- RP.char '.'
o2 <- rdec
_ <- RP.char '.'
o3 <- rdec
_ <- RP.char '.'
o4 <- rdec
return (o1, o2, o3, o4)
r4 :: ReadP PGInet
r4 = do
q <- ReadP (Word8, Word8, Word8, Word8)
r4i
m <- mask 32
return $ PGInet (bton32 q) m
r64 :: ReadP [Word16]
r64 = do
(b1, b2, b3, b4) <- ReadP (Word8, Word8, Word8, Word8)
r4i
return [jb b1 b2, jb b3 b4]
r6l :: Int -> ReadP [Word16]
r6l Int
0 = [Word16] -> ReadP [Word16]
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return []
r6l Int
2 = ReadP ()
colon ReadP () -> ReadP [Word16] -> ReadP [Word16]
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ReadP [Word16]
r6lc Int
2 ReadP [Word16] -> ReadP [Word16] -> ReadP [Word16]
forall a. ReadP a -> ReadP a -> ReadP a
RP.+++ ReadP [Word16]
r64
r6l Int
n = ReadP ()
colon ReadP () -> ReadP [Word16] -> ReadP [Word16]
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ReadP [Word16]
r6lc Int
n
r6lc :: Int -> ReadP [Word16]
r6lc Int
n = Int -> ReadP [Word16]
r6lp Int
n ReadP [Word16] -> ReadP [Word16] -> ReadP [Word16]
forall a. ReadP a -> ReadP a -> ReadP a
RP.+++ Int -> ReadP [Word16]
r6b Int
n
r6lp :: Int -> ReadP [Word16]
r6lp Int
n = ReadP [Word16] -> ReadP [Word16]
r6w (Int -> ReadP [Word16]
r6l (Int -> Int
forall a. Enum a => a -> a
pred Int
n))
r6b :: Int -> ReadP [Word16]
r6b Int
n = do
ReadP ()
colon
r <- Int -> ReadP [Word16]
forall {a}. (Ord a, Enum a, Num a) => a -> ReadP [Word16]
r6rp (Int -> Int
forall a. Enum a => a -> a
pred Int
n) ReadP [Word16] -> ReadP [Word16] -> ReadP [Word16]
forall a. ReadP a -> ReadP a -> ReadP a
RP.<++ [Word16] -> ReadP [Word16]
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return []
let l = [Word16] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word16]
r
return $ replicate (n - l) 0 ++ r
r6r :: a -> ReadP [Word16]
r6r a
0 = [Word16] -> ReadP [Word16]
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return []
r6r a
n = (ReadP ()
colon ReadP () -> ReadP [Word16] -> ReadP [Word16]
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> ReadP [Word16]
r6rp a
n) ReadP [Word16] -> ReadP [Word16] -> ReadP [Word16]
forall a. ReadP a -> ReadP a -> ReadP a
RP.<++ [Word16] -> ReadP [Word16]
forall a. a -> ReadP a
forall (m :: * -> *) a. Monad m => a -> m a
return []
r6rp :: a -> ReadP [Word16]
r6rp a
n
| a
n a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
2 = a -> ReadP [Word16]
r6rc a
n ReadP [Word16] -> ReadP [Word16] -> ReadP [Word16]
forall a. ReadP a -> ReadP a -> ReadP a
RP.+++ ReadP [Word16]
r64
| Bool
otherwise = a -> ReadP [Word16]
r6rc a
n
r6rc :: a -> ReadP [Word16]
r6rc a
n = ReadP [Word16] -> ReadP [Word16]
r6w (a -> ReadP [Word16]
r6r (a -> a
forall a. Enum a => a -> a
pred a
n))
r6w :: ReadP [Word16] -> ReadP [Word16]
r6w = (Word16 -> [Word16] -> [Word16])
-> ReadP Word16 -> ReadP [Word16] -> ReadP [Word16]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (:) ReadP Word16
rhex
r6 :: ReadP PGInet
r6 = do
[w1, w2, w3, w4, w5, w6, w7, w8] <- Int -> ReadP [Word16]
r6lp Int
8 ReadP [Word16] -> ReadP [Word16] -> ReadP [Word16]
forall a. ReadP a -> ReadP a -> ReadP a
RP.<++ (ReadP ()
colon ReadP () -> ReadP [Word16] -> ReadP [Word16]
forall a b. ReadP a -> ReadP b -> ReadP b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ReadP [Word16]
r6b Int
8)
m <- mask 128
return $ PGInet6 (jw w1 w2, jw w3 w4, jw w5 w6, jw w7 w8) m
colon :: ReadP ()
colon = ReadP Char -> ReadP ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ReadP Char -> ReadP ()) -> ReadP Char -> ReadP ()
forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
RP.char Char
':'
mask :: Word8 -> ReadP Word8
mask Word8
m = Word8 -> ReadP Word8 -> ReadP Word8
forall a. a -> ReadP a -> ReadP a
RP.option Word8
m (ReadP Word8 -> ReadP Word8) -> ReadP Word8 -> ReadP Word8
forall a b. (a -> b) -> a -> b
$ do
_ <- Char -> ReadP Char
RP.char Char
'/'
n <- rdec
guard (n <= m)
return n
rdec :: RP.ReadP Word8
rdec :: ReadP Word8
rdec = ReadS Word8 -> ReadP Word8
forall a. ReadS a -> ReadP a
RP.readS_to_P ReadS Word8
forall a. (Eq a, Num a) => ReadS a
readDec
rhex :: RP.ReadP Word16
rhex :: ReadP Word16
rhex = ReadS Word16 -> ReadP Word16
forall a. ReadS a -> ReadP a
RP.readS_to_P ReadS Word16
forall a. (Eq a, Num a) => ReadS a
readHex
jw :: Word16 -> Word16 -> Word32
jw :: Word16 -> Word16 -> Word32
jw Word16
x Word16
y = Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
x Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
y
jb :: Word8 -> Word8 -> Word16
jb :: Word8 -> Word8 -> Word16
jb Word8
x Word8
y = Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
x Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.|. Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
y
instance PGType "inet" where
type PGVal "inet" = PGInet
instance PGType "cidr" where
type PGVal "cidr" = PGInet
instance PGParameter "inet" PGInet where
pgEncode :: PGTypeID "inet" -> PGInet -> PGTextValue
pgEncode PGTypeID "inet"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (PGInet -> String) -> PGInet -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGInet -> String
forall a. Show a => a -> String
show
instance PGParameter "cidr" PGInet where
pgEncode :: PGTypeID "cidr" -> PGInet -> PGTextValue
pgEncode PGTypeID "cidr"
_ = String -> PGTextValue
BSC.pack (String -> PGTextValue)
-> (PGInet -> String) -> PGInet -> PGTextValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGInet -> String
forall a. Show a => a -> String
show
instance PGColumn "inet" PGInet where
pgDecode :: PGTypeID "inet" -> PGTextValue -> PGInet
pgDecode PGTypeID "inet"
_ = String -> PGInet
forall a. Read a => String -> a
read (String -> PGInet)
-> (PGTextValue -> String) -> PGTextValue -> PGInet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack
instance PGColumn "cidr" PGInet where
pgDecode :: PGTypeID "cidr" -> PGTextValue -> PGInet
pgDecode PGTypeID "cidr"
_ = String -> PGInet
forall a. Read a => String -> a
read (String -> PGInet)
-> (PGTextValue -> String) -> PGTextValue -> PGInet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PGTextValue -> String
BSC.unpack