module Database.PostgreSQL.Parser
       ( Parser, runParser, evalParser
       , eof

       , netAddress
       , v4HostAddress, decMask4
       , v6HostAddress, decMask6
       ) where

import Control.Applicative ((<$>), pure, (<*>), (<*), (*>), (<|>), many, some, optional)
import Control.Monad (guard, replicateM)
import Data.Maybe (listToMaybe, fromMaybe)
import Data.Char (isDigit, isHexDigit)
import Data.Word (Word8, Word16)
import Numeric (readDec, readHex)

import Text.Parser.List (runParser, evalParser, eof, noteP, satisfy', satisfy)
import qualified Text.Parser.List as P
import Data.PostgreSQL.NetworkAddress (NetAddress (..), V4HostAddress, V6HostAddress)
import qualified Data.PostgreSQL.NetworkAddress as D


type Parser = P.Parser Char

digit :: Parser Char
digit = satisfy' "digit" (const "must be digit.") isDigit

hexDigit :: Parser Char
hexDigit = satisfy' "hexDigit" (const "must be hex-digit.") isHexDigit

readNat :: String -> Maybe Integer
readNat s = listToMaybe [ i | (i, "") <- readDec s ] -- readDec accept only positive

readHexNat :: String -> Maybe Integer
readHexNat s = listToMaybe [ i | (i, "") <- readHex s ]

nat :: Parser Integer
nat = do
  xs <- some digit
  noteP "nat: invalid input" $ readNat xs

hexNat :: Parser Integer
hexNat = do
  xs <- some hexDigit
  noteP "hexNat: invalid input" $ readHexNat xs

rangedNat :: (Integral a, Show a) => a -> a -> Integer -> Parser a
rangedNat n x i = do
  noteP (concat ["rangedNat: out of range: ", show i, ": [", show n, ", ", show x, "]"])
    . guard $ (fromIntegral n <= i && i <= fromIntegral x)
  pure $ fromIntegral i

decW8 :: Parser Word8
decW8 = rangedNat minBound maxBound =<< nat

hexW16 :: Parser Word16
hexW16 = rangedNat minBound maxBound =<< hexNat

char :: Char -> Parser Char
char c = satisfy (== c)

dot :: Parser Char
dot = char '.'

colon :: Parser Char
colon = char ':'

slash :: Parser Char
slash = char '/'

v4HostAddress :: Parser V4HostAddress
v4HostAddress = D.V4HostAddress <$> decW8 <* dot <*> decW8 <* dot <*> decW8 <* dot <*> decW8

_exampleHostAddress :: [Either String V4HostAddress]
_exampleHostAddress =
  [ evalParser (v4HostAddress <* eof) s
  | s <- [ "0.0.0.0", "192.168.0.1" ]
  ]

mask4bits :: Word8
mask4bits = 32

decMask4 :: Parser Word8
decMask4 = rangedNat 0 mask4bits =<< nat

v6words :: Parser [Word16]
v6words =
  (:) <$> hexW16 <*> many (colon *> hexW16)   <|>
  pure []

doubleColon6 :: Parser V6HostAddress
doubleColon6 = do
  m6  <-  D.v6HostAddress <$> v6words <* replicateM 2 colon <*> v6words
  noteP "v6HostAddress: Too many numbers of 16-bit words." m6

v6HostAddress :: Parser V6HostAddress
v6HostAddress =
  doubleColon6                             <|>
  D.v6HostAddressLong
  <$> hexW16 <* colon <*> hexW16 <* colon
  <*> hexW16 <* colon <*> hexW16 <* colon
  <*> hexW16 <* colon <*> hexW16 <* colon
  <*> hexW16 <* colon <*> hexW16

_exampleHostAddress6 :: [Either String V6HostAddress]
_exampleHostAddress6 =
  [ evalParser (v6HostAddress <* eof) s
  | s <- [ "::", "0:0:0:0:0:0:0:0", "2001:1::1:a2", "1:1:1:1:1:1:1:a1" ]
  ]

mask6bits :: Word8
mask6bits = 128

decMask6 :: Parser Word8
decMask6 = rangedNat 0 mask6bits =<< nat

optional' :: a -> Parser a -> Parser a
optional' x p =
  fromMaybe x <$> optional p

netAddress :: Parser NetAddress
netAddress =
  NetAddress4 <$> v4HostAddress <*> optional' mask4bits (slash *> decMask4) <|>
  NetAddress6 <$> v6HostAddress <*> optional' mask6bits (slash *> decMask6)

_exampleNetAddress :: [Either String NetAddress]
_exampleNetAddress =
  [ evalParser (netAddress <* eof) s
  | s <- [ "2001:1::a0:a2/64", "172.16.0.0" ]
  ]