{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies, DataKinds, TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module: Database.PostgreSQL.Typed.Inet
-- Copyright: 2015 Dylan Simon
-- 
-- Representaion of PostgreSQL's inet/cidr types using "Network.Socket".
-- We don't (yet) supply PGColumn (parsing) instances.

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 -> HostAddress
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
/= :: PGInet -> PGInet -> Bool
$c/= :: PGInet -> PGInet -> Bool
== :: PGInet -> PGInet -> Bool
$c== :: PGInet -> PGInet -> Bool
Eq)

sockAddrPGInet :: Net.SockAddr -> Maybe PGInet
sockAddrPGInet :: SockAddr -> Maybe PGInet
sockAddrPGInet (Net.SockAddrInet PortNumber
_ HostAddress
a) = PGInet -> Maybe PGInet
forall a. a -> Maybe a
Just (PGInet -> Maybe PGInet) -> PGInet -> Maybe PGInet
forall a b. (a -> b) -> a -> b
$ HostAddress -> Word8 -> PGInet
PGInet HostAddress
a Word8
32
sockAddrPGInet (Net.SockAddrInet6 PortNumber
_ HostAddress
_ HostAddress6
a HostAddress
_) = 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

-- |Convert four bytes to network byte order, using unsafe casting.
-- 'Data.Word.byteSwap32' would be better, but I couldn't find a good way to determine host byte order.
bton32 :: (Word8, Word8, Word8, Word8) -> Word32
bton32 :: (Word8, Word8, Word8, Word8) -> HostAddress
bton32 (Word8
b1, Word8
b2, Word8
b3, Word8
b4) = IO HostAddress -> HostAddress
forall a. IO a -> a
unsafeDupablePerformIO (IO HostAddress -> HostAddress) -> IO HostAddress -> HostAddress
forall a b. (a -> b) -> a -> b
$
  [Word8] -> (Ptr Word8 -> IO HostAddress) -> IO HostAddress
forall a b. Storable a => [a] -> (Ptr a -> IO b) -> IO b
withArray [Word8
b1, Word8
b2, Word8
b3, Word8
b4] (Ptr HostAddress -> IO HostAddress
forall a. Storable a => Ptr a -> IO a
peek (Ptr HostAddress -> IO HostAddress)
-> (Ptr Word8 -> Ptr HostAddress) -> Ptr Word8 -> IO HostAddress
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Word8 -> Ptr HostAddress
forall a b. Ptr a -> Ptr b
castPtr)

instance Show PGInet where
  -- This is how Network.Socket's Show SockAddr does it:
  show :: PGInet -> String
show (PGInet HostAddress
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 -> HostAddress -> SockAddr
Net.SockAddrInet PortNumber
0 HostAddress
a)
  show (PGInet HostAddress
a Word8
m) = PGInet -> String
forall a. Show a => a -> String
show (HostAddress -> Word8 -> PGInet
PGInet HostAddress
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
-> HostAddress -> HostAddress6 -> HostAddress -> SockAddr
Net.SockAddrInet6 PortNumber
0 HostAddress
0 HostAddress6
a HostAddress
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
  -- This is even less pleasant, but we only have to deal with representations pg generates
  -- Not at all efficient, since in ReadP, but should get us by
  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
      Word8
o1 <- ReadP Word8
rdec
      Char
_ <- Char -> ReadP Char
RP.char Char
'.'
      Word8
o2 <- ReadP Word8
rdec
      Char
_ <- Char -> ReadP Char
RP.char Char
'.'
      Word8
o3 <- ReadP Word8
rdec
      Char
_ <- Char -> ReadP Char
RP.char Char
'.'
      Word8
o4 <- ReadP Word8
rdec
      (Word8, Word8, Word8, Word8) -> ReadP (Word8, Word8, Word8, Word8)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8
o1, Word8
o2, Word8
o3, Word8
o4)
    -- ipv4
    r4 :: ReadP PGInet
r4 = do
      (Word8, Word8, Word8, Word8)
q <- ReadP (Word8, Word8, Word8, Word8)
r4i
      Word8
m <- Word8 -> ReadP Word8
mask Word8
32
      PGInet -> ReadP PGInet
forall (m :: * -> *) a. Monad m => a -> m a
return (PGInet -> ReadP PGInet) -> PGInet -> ReadP PGInet
forall a b. (a -> b) -> a -> b
$ HostAddress -> Word8 -> PGInet
PGInet ((Word8, Word8, Word8, Word8) -> HostAddress
bton32 (Word8, Word8, Word8, Word8)
q) Word8
m

    -- trailing ipv4 in ipv6
    r64 :: ReadP [Word16]
r64 = do
      (Word8
b1, Word8
b2, Word8
b3, Word8
b4) <- ReadP (Word8, Word8, Word8, Word8)
r4i
      [Word16] -> ReadP [Word16]
forall (m :: * -> *) a. Monad m => a -> m a
return [Word8 -> Word8 -> Word16
jb Word8
b1 Word8
b2, Word8 -> Word8 -> Word16
jb Word8
b3 Word8
b4]
    -- ipv6 pre-double-colon
    r6l :: Int -> ReadP [Word16]
r6l Int
0 = [Word16] -> ReadP [Word16]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    r6l Int
2 = ReadP ()
colon ReadP () -> ReadP [Word16] -> ReadP [Word16]
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 (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))
    -- ipv6 double-colon
    r6b :: Int -> ReadP [Word16]
r6b Int
n = do
      ReadP ()
colon
      [Word16]
r <- Int -> ReadP [Word16]
forall a. (Ord a, Num a, Enum 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 (m :: * -> *) a. Monad m => a -> m a
return []
      let l :: Int
l = [Word16] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Word16]
r
      [Word16] -> ReadP [Word16]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Word16] -> ReadP [Word16]) -> [Word16] -> ReadP [Word16]
forall a b. (a -> b) -> a -> b
$ Int -> Word16 -> [Word16]
forall a. Int -> a -> [a]
replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l) Word16
0 [Word16] -> [Word16] -> [Word16]
forall a. [a] -> [a] -> [a]
++ [Word16]
r
    -- ipv6 post-double-colon
    r6r :: a -> ReadP [Word16]
r6r a
0 = [Word16] -> ReadP [Word16]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    r6r a
n = (ReadP ()
colon ReadP () -> ReadP [Word16] -> ReadP [Word16]
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 (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
    -- ipv6
    r6 :: ReadP PGInet
r6 = do
      [Word16
w1, Word16
w2, Word16
w3, Word16
w4, Word16
w5, Word16
w6, Word16
w7, Word16
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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> ReadP [Word16]
r6b Int
8)
      Word8
m <- Word8 -> ReadP Word8
mask Word8
128
      PGInet -> ReadP PGInet
forall (m :: * -> *) a. Monad m => a -> m a
return (PGInet -> ReadP PGInet) -> PGInet -> ReadP PGInet
forall a b. (a -> b) -> a -> b
$ HostAddress6 -> Word8 -> PGInet
PGInet6 (Word16 -> Word16 -> HostAddress
jw Word16
w1 Word16
w2, Word16 -> Word16 -> HostAddress
jw Word16
w3 Word16
w4, Word16 -> Word16 -> HostAddress
jw Word16
w5 Word16
w6, Word16 -> Word16 -> HostAddress
jw Word16
w7 Word16
w8) Word8
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
_ <- Char -> ReadP Char
RP.char Char
'/'
      Word8
n <- ReadP Word8
rdec
      Bool -> ReadP ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Word8
n Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
m)
      Word8 -> ReadP Word8
forall (m :: * -> *) a. Monad m => a -> m a
return Word8
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 -> HostAddress
jw Word16
x Word16
y = Word16 -> HostAddress
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
x HostAddress -> Int -> HostAddress
forall a. Bits a => a -> Int -> a
`shiftL` Int
16 HostAddress -> HostAddress -> HostAddress
forall a. Bits a => a -> a -> a
.|. Word16 -> HostAddress
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