module Database.PostgreSQL.PQTypes.Internal.Utils (
    MkConstraint
  , mread
  , safePeekCString
  , safePeekCString'
  , cStringLenToBytea
  , byteaToCStringLen
  , textToCString
  , verifyPQTRes
  , withPGparam
  , throwLibPQError
  , throwLibPQTypesError
  , rethrowWithArrayError
  , hpqTypesError
  , unexpectedNULL
  ) where

import Control.Monad
import Data.ByteString.Unsafe
import Data.Kind (Type)
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable
import GHC.Exts
import qualified Control.Exception as E
import qualified Data.Text as T
import qualified Data.Text.Encoding as T

import Database.PostgreSQL.PQTypes.Internal.C.Interface
import Database.PostgreSQL.PQTypes.Internal.C.Types
import Database.PostgreSQL.PQTypes.Internal.Error

type family MkConstraint (m :: Type -> Type)
                         (cs :: [(Type -> Type) -> Constraint]) :: Constraint where
  MkConstraint m '[] = ()
  MkConstraint m (c ': cs) = (c m, MkConstraint m cs)

-- Safely read value.
mread :: Read a => String -> Maybe a
mread :: forall a. Read a => String -> Maybe a
mread String
s = do
  [(a
a, String
"")] <- forall a. a -> Maybe a
Just (forall a. Read a => ReadS a
reads String
s)
  forall a. a -> Maybe a
Just a
a

-- | Safely peek C string.
safePeekCString :: CString -> IO (Maybe String)
safePeekCString :: CString -> IO (Maybe String)
safePeekCString CString
cs
  | CString
cs forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  | Bool
otherwise     = forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO String
peekCString CString
cs

-- | Safely peek C string and return "" if NULL.
safePeekCString' :: CString -> IO String
safePeekCString' :: CString -> IO String
safePeekCString' CString
cs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO (Maybe String)
safePeekCString CString
cs

-- | Convert C string to 'PGbytea'.
cStringLenToBytea :: CStringLen -> PGbytea
cStringLenToBytea :: CStringLen -> PGbytea
cStringLenToBytea (CString
cs, Int
len) = PGbytea {
  pgByteaLen :: CInt
pgByteaLen = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
, pgByteaData :: CString
pgByteaData = CString
cs
}

-- | Convert 'PGbytea' to C string.
byteaToCStringLen :: PGbytea -> CStringLen
byteaToCStringLen :: PGbytea -> CStringLen
byteaToCStringLen PGbytea{CString
CInt
pgByteaData :: CString
pgByteaLen :: CInt
pgByteaData :: PGbytea -> CString
pgByteaLen :: PGbytea -> CInt
..} = (CString
pgByteaData, forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
pgByteaLen)

-- | Convert 'Text' to UTF-8 encoded C string wrapped by foreign pointer.
textToCString :: T.Text -> IO (ForeignPtr CChar)
textToCString :: Text -> IO (ForeignPtr CChar)
textToCString Text
bs = forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen (Text -> ByteString
T.encodeUtf8 Text
bs) forall a b. (a -> b) -> a -> b
$ \(CString
cs, Int
len) -> do
  ForeignPtr CChar
fptr <- forall a. Int -> IO (ForeignPtr a)
mallocForeignPtrBytes (Int
len forall a. Num a => a -> a -> a
+ Int
1)
  forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr CChar
fptr forall a b. (a -> b) -> a -> b
$ \CString
ptr -> do
    forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes CString
ptr CString
cs Int
len
    forall a b. Storable a => Ptr b -> Int -> a -> IO ()
pokeByteOff CString
ptr Int
len (CChar
0::CChar)
  forall (m :: * -> *) a. Monad m => a -> m a
return ForeignPtr CChar
fptr

-- | Check return value of a function from libpqtypes
-- and if it indicates an error, throw appropriate exception.
verifyPQTRes :: Ptr PGerror -> String -> CInt -> IO ()
verifyPQTRes :: Ptr PGerror -> String -> CInt -> IO ()
verifyPQTRes Ptr PGerror
err String
ctx CInt
0 = forall a. Ptr PGerror -> String -> IO a
throwLibPQTypesError Ptr PGerror
err String
ctx
verifyPQTRes   Ptr PGerror
_   String
_ CInt
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- 'alloca'-like function for managing usage of 'PGparam' object.
withPGparam :: Ptr PGconn -> (Ptr PGparam -> IO r) -> IO r
withPGparam :: forall r. Ptr PGconn -> (Ptr PGparam -> IO r) -> IO r
withPGparam Ptr PGconn
conn = forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket IO (Ptr PGparam)
create Ptr PGparam -> IO ()
c_PQparamClear
  where
    create :: IO (Ptr PGparam)
create = forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca forall a b. (a -> b) -> a -> b
$ \Ptr PGerror
err -> do
      Ptr PGparam
param <- Ptr PGconn -> Ptr PGerror -> IO (Ptr PGparam)
c_PQparamCreate Ptr PGconn
conn Ptr PGerror
err
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Ptr PGparam
param forall a. Eq a => a -> a -> Bool
== forall a. Ptr a
nullPtr) forall a b. (a -> b) -> a -> b
$
        forall a. Ptr PGerror -> String -> IO a
throwLibPQTypesError Ptr PGerror
err String
"withPGparam.create"
      forall (m :: * -> *) a. Monad m => a -> m a
return Ptr PGparam
param

----------------------------------------

-- | Throw libpq specific error.
throwLibPQError :: Ptr PGconn -> String -> IO a
throwLibPQError :: forall a. Ptr PGconn -> String -> IO a
throwLibPQError Ptr PGconn
conn String
ctx = do
  String
msg <- CString -> IO String
safePeekCString' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Ptr PGconn -> IO CString
c_PQerrorMessage Ptr PGconn
conn
  forall e a. Exception e => e -> IO a
E.throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LibPQError
LibPQError
    forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ctx then String
msg else String
ctx forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
msg

-- | Throw libpqtypes specific error.
throwLibPQTypesError :: Ptr PGerror -> String -> IO a
throwLibPQTypesError :: forall a. Ptr PGerror -> String -> IO a
throwLibPQTypesError Ptr PGerror
err String
ctx = do
  String
msg <- PGerror -> String
pgErrorMsg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Storable a => Ptr a -> IO a
peek Ptr PGerror
err
  forall e a. Exception e => e -> IO a
E.throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LibPQError
LibPQError
    forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ctx then String
msg else String
ctx forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
msg

-- | Rethrow supplied exception enriched with array index.
rethrowWithArrayError :: CInt -> E.SomeException -> IO a
rethrowWithArrayError :: forall a. CInt -> SomeException -> IO a
rethrowWithArrayError CInt
i (E.SomeException e
e) =
  forall e a. Exception e => e -> IO a
E.throwIO ArrayItemError {
    arrItemIndex :: Int
arrItemIndex = forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
i forall a. Num a => a -> a -> a
+ Int
1
  , arrItemError :: e
arrItemError = e
e
  }

-- | Throw 'HPQTypesError exception.
hpqTypesError :: String -> IO a
hpqTypesError :: forall a. String -> IO a
hpqTypesError = forall e a. Exception e => e -> IO a
E.throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HPQTypesError
HPQTypesError

-- | Throw 'unexpected NULL' exception.
unexpectedNULL :: IO a
unexpectedNULL :: forall a. IO a
unexpectedNULL = forall a. String -> IO a
hpqTypesError String
"unexpected NULL"