{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Database.HDBC.PostgreSQL.Instances
-- Copyright   : 2015-2018 Kei Hibino
-- License     : BSD3
--
-- Maintainer  : ex8k.hibino@gmail.com
-- Stability   : experimental
-- Portability : unknown
--
-- This module defines HDBC instances and SQL-literal instances for
-- PostgreSQL types
module Database.HDBC.PostgreSQL.Instances () where

import Control.Applicative ((<$>), pure, (<*))
import Data.String (IsString, fromString)
import Data.Monoid ((<>))
import Data.DList ()
import Data.ByteString.Char8 (unpack)
import Data.Convertible (Convertible (..), ConvertResult, ConvertError (..))
import Data.PostgreSQL.NetworkAddress (NetAddress, Inet (..), Cidr (..))
import Database.HDBC (SqlValue (..))
import Database.HDBC.Record.Persistable ()
import Database.Relational (LiteralSQL (..))
import Database.PostgreSQL.Parser (evalParser)
import qualified Database.PostgreSQL.Parser as Parser
import Database.PostgreSQL.Printer (execPrinter)
import qualified Database.PostgreSQL.Printer as Printer


note :: a -> Maybe b -> Either a b
note :: a -> Maybe b -> Either a b
note e :: a
e = Either a b -> (b -> Either a b) -> Maybe b -> Either a b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Either a b
forall a b. a -> Either a b
Left a
e) b -> Either a b
forall a b. b -> Either a b
Right

mapConvert :: Show a => String -> String -> a -> Either String b -> ConvertResult b
mapConvert :: String -> String -> a -> Either String b -> ConvertResult b
mapConvert srcT :: String
srcT destT :: String
destT sv :: a
sv = (String -> ConvertResult b)
-> (b -> ConvertResult b) -> Either String b -> ConvertResult b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ConvertError -> ConvertResult b
forall a b. a -> Either a b
Left (ConvertError -> ConvertResult b)
-> (String -> ConvertError) -> String -> ConvertResult b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ConvertError
mke) b -> ConvertResult b
forall a b. b -> Either a b
Right  where
  mke :: String -> ConvertError
mke em :: String
em =
    ConvertError :: String -> String -> String -> String -> ConvertError
ConvertError
    { convSourceValue :: String
convSourceValue   =  a -> String
forall a. Show a => a -> String
show a
sv
    , convSourceType :: String
convSourceType    =  String
srcT
    , convDestType :: String
convDestType      =  String
destT
    , convErrorMessage :: String
convErrorMessage  =  String
em
    }

takeAddressString :: SqlValue -> Maybe String
takeAddressString :: SqlValue -> Maybe String
takeAddressString = SqlValue -> Maybe String
d  where
  d :: SqlValue -> Maybe String
d (SqlString s :: String
s)      =  String -> Maybe String
forall a. a -> Maybe a
Just String
s
  d (SqlByteString s :: ByteString
s)  =  String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
unpack ByteString
s
  d  _                 =  Maybe String
forall a. Maybe a
Nothing

toNetAddress :: SqlValue -> ConvertResult NetAddress
toNetAddress :: SqlValue -> ConvertResult NetAddress
toNetAddress qv :: SqlValue
qv = String
-> String
-> SqlValue
-> Either String NetAddress
-> ConvertResult NetAddress
forall a b.
Show a =>
String -> String -> a -> Either String b -> ConvertResult b
mapConvert "SqlValue" "NetAddress" SqlValue
qv (Either String NetAddress -> ConvertResult NetAddress)
-> Either String NetAddress -> ConvertResult NetAddress
forall a b. (a -> b) -> a -> b
$ do
  String
s  <-  String -> Maybe String -> Either String String
forall a b. a -> Maybe b -> Either a b
note "Fail to take address string from the column value."
         (Maybe String -> Either String String)
-> Maybe String -> Either String String
forall a b. (a -> b) -> a -> b
$ SqlValue -> Maybe String
takeAddressString SqlValue
qv
  Parser Char NetAddress -> String -> Either String NetAddress
forall t a. Parser t a -> [t] -> Either String a
evalParser (Parser Char NetAddress
Parser.netAddress Parser Char NetAddress
-> StateT String (Except Error) () -> Parser Char NetAddress
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT String (Except Error) ()
forall t. Parser t ()
Parser.eof) String
s

instance Convertible SqlValue Inet where
  safeConvert :: SqlValue -> ConvertResult Inet
safeConvert = (NetAddress -> Inet
Inet (NetAddress -> Inet)
-> ConvertResult NetAddress -> ConvertResult Inet
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (ConvertResult NetAddress -> ConvertResult Inet)
-> (SqlValue -> ConvertResult NetAddress)
-> SqlValue
-> ConvertResult Inet
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlValue -> ConvertResult NetAddress
toNetAddress

instance Convertible SqlValue Cidr where
  safeConvert :: SqlValue -> ConvertResult Cidr
safeConvert = (NetAddress -> Cidr
Cidr (NetAddress -> Cidr)
-> ConvertResult NetAddress -> ConvertResult Cidr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (ConvertResult NetAddress -> ConvertResult Cidr)
-> (SqlValue -> ConvertResult NetAddress)
-> SqlValue
-> ConvertResult Cidr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SqlValue -> ConvertResult NetAddress
toNetAddress

fromNetAddress :: NetAddress -> ConvertResult SqlValue
fromNetAddress :: NetAddress -> ConvertResult SqlValue
fromNetAddress = SqlValue -> ConvertResult SqlValue
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SqlValue -> ConvertResult SqlValue)
-> (NetAddress -> SqlValue) -> NetAddress -> ConvertResult SqlValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> SqlValue
SqlString (String -> SqlValue)
-> (NetAddress -> String) -> NetAddress -> SqlValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Printer Char NetAddress -> NetAddress -> String
forall t a. Printer t a -> a -> [t]
execPrinter Printer Char NetAddress
Printer.netAddress

instance Convertible Inet SqlValue where
  safeConvert :: Inet -> ConvertResult SqlValue
safeConvert (Inet n :: NetAddress
n) = NetAddress -> ConvertResult SqlValue
fromNetAddress NetAddress
n

instance Convertible Cidr SqlValue where
  safeConvert :: Cidr -> ConvertResult SqlValue
safeConvert (Cidr n :: NetAddress
n) = NetAddress -> ConvertResult SqlValue
fromNetAddress NetAddress
n

qstringNetAddr :: IsString s => NetAddress -> s
qstringNetAddr :: NetAddress -> s
qstringNetAddr = String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> (NetAddress -> String) -> NetAddress -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("'" String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (NetAddress -> String) -> NetAddress -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String -> String
forall a. [a] -> [a] -> [a]
++ "'") (String -> String)
-> (NetAddress -> String) -> NetAddress -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Printer Char NetAddress -> NetAddress -> String
forall t a. Printer t a -> a -> [t]
execPrinter Printer Char NetAddress
Printer.netAddress

instance LiteralSQL Inet where
  showLiteral' :: Inet -> DList StringSQL
showLiteral' (Inet na :: NetAddress
na) = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL) -> StringSQL -> DList StringSQL
forall a b. (a -> b) -> a -> b
$ "INET" StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
<> NetAddress -> StringSQL
forall s. IsString s => NetAddress -> s
qstringNetAddr NetAddress
na

instance LiteralSQL Cidr where
  showLiteral' :: Cidr -> DList StringSQL
showLiteral' (Cidr na :: NetAddress
na) = StringSQL -> DList StringSQL
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StringSQL -> DList StringSQL) -> StringSQL -> DList StringSQL
forall a b. (a -> b) -> a -> b
$ "CIDR" StringSQL -> StringSQL -> StringSQL
forall a. Semigroup a => a -> a -> a
<> NetAddress -> StringSQL
forall s. IsString s => NetAddress -> s
qstringNetAddr NetAddress
na