Added functions for object type for advance queuing

Author: tusharad

src/Database/Oracle/Simple/FromField.hs

@@ -2,12 +2,19 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
 
 module Database.Oracle.Simple.FromField
   ( FieldParser (..),
     FromField (..),
     ReadDPIBuffer,
     dpiTimeStampToUTCTime,
+    getInt64,
+    getFloat, 
+    getDouble,
+    getString,
+    getBool,
+    getTimestamp,
   )
 where
 

src/Database/Oracle/Simple/Internal.hs

@@ -45,8 +45,13 @@ module Database.Oracle.Simple.Internal
     ErrorInfo (..),
     VersionInfo (..),
     DPIJson (..),
+    DPIObjectType (..),
+    DPIObject (..),
     genJSON,
+    genObject,
+    getObjectType,
     renderErrorInfo,
+    releaseObject,
     ping,
     fetch,
     close,
@@ -78,6 +83,7 @@ module Database.Oracle.Simple.Internal
     dpiData_getTimestamp,
     dpiConn_close_finalizer,
     dpiConn_release_finalizer,
+    dpiNativeTypeToUInt,
   )
 where
 
@@ -125,6 +131,14 @@ newtype DPIJson = DPIJson (Ptr DPIJson)
   deriving (Show, Eq)
   deriving newtype (Storable)
 
+newtype DPIObjectType = DPIObjectType (Ptr DPIObjectType)
+  deriving (Show, Eq)
+  deriving newtype (Storable)
+
+newtype DPIObject = DPIObject (Ptr DPIObject)
+  deriving (Show, Eq)
+  deriving newtype (Storable)
+
 data AdditionalConnectionParams = AdditionalConnectionParams
   { minSessions :: Natural
   , maxSessions :: Natural
@@ -1773,3 +1787,48 @@ foreign import ccall unsafe "dpiConn_newJson"
     -- | dpiJSON **
     Ptr DPIJson ->
     IO CInt
+
+getObjectType :: Connection -> String -> IO DPIObjectType
+getObjectType (Connection fptr) objectName = do
+  withForeignPtr fptr $ \conn -> do
+    withCStringLen objectName $ \(objectNameC, fromIntegral -> objectNameLen) -> do
+      alloca $ \objectTypePtr -> do
+        throwOracleError =<< dpiConn_getObjectType conn objectNameC objectNameLen objectTypePtr
+        peek objectTypePtr
+
+foreign import ccall unsafe "dpiConn_getObjectType"
+    dpiConn_getObjectType ::
+    -- | dpiConn *
+    Ptr DPIConn ->
+    -- | char * name
+    CString ->
+    -- | cuint32_t nameLength
+    CUInt -> 
+    -- | dpiObjectType ** objType
+    Ptr DPIObjectType ->
+    IO CInt
+
+genObject :: DPIObjectType -> IO DPIObject
+genObject objType = do
+  alloca $ \objectPtr -> do
+    throwOracleError =<< dpiObjectType_createObject objType objectPtr
+    peek objectPtr
+
+foreign import ccall unsafe "dpiObjectType_createObject"
+    dpiObjectType_createObject ::
+    -- | dpiObjectType *
+    DPIObjectType ->
+    -- | dpiObject ** obj
+    Ptr DPIObject ->
+    IO CInt
+
+releaseObject :: DPIObject -> IO ()
+releaseObject obj = do
+  throwOracleError =<< dpiObject_release obj
+
+foreign import ccall unsafe "dpiObject_release"
+    dpiObject_release ::
+    -- | dpiObject *
+    DPIObject ->
+    IO CInt
+

src/Database/Oracle/Simple/JSON.hs

@@ -9,7 +9,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wno-missed-specialisations #-} -- suppressing fromFloatDigits warning
 
-module Database.Oracle.Simple.JSON (AesonField (..), JsonDecodeError (..), DPIJsonNode(..)) where
+module Database.Oracle.Simple.JSON (AesonField (..), JsonDecodeError (..), DPIJsonNode(..), getJson) where
 
 import Control.Exception (Exception (displayException), SomeException, catch, evaluate, throwIO)
 import Control.Monad (void, (<=<))

src/Database/Oracle/Simple/Queue.hs

@@ -1,30 +1,38 @@
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Database.Oracle.Simple.Queue (
     DPIQueue (..)
   , DPIMsgProps (..)
   , DPIDeqOptions (..)
   , DPIEnqOptions (..)
   , DPIObjectType (..)
-  , ObjectType (..)
   , deqMany
   , deqOne
   , enqMany
   , enqOne 
   , getDeqOptions
   , getEnqOptions
   , queueRelease 
-  , genJSONQueue
+  , genQueueJSON
+  , genQueueObject
   , genMsgProps
   , genQueue 
   , getMsgPropsNumOfAttempts 
   , getMsgPropsDelay
   , getMsgPropsPayLoadBytes
   , getMsgPropsPayLoadJson 
+  , getMsgPropsPayLoadObject 
   , setMsgPropsPayLoadBytes 
   , setMsgPropsPayLoadJSON 
+  , setMsgPropsPayLoadObject
+  , objectAppendElement 
+  , getObjectElementByIdx
 ) where
 
 import Foreign (alloca, withArray, withForeignPtr, nullPtr)
@@ -33,7 +41,10 @@ import Foreign.C.Types (CInt (..), CUInt (..))
 import Foreign.Ptr (Ptr)
 import Foreign.C.String
 import Database.Oracle.Simple.Internal
+import Database.Oracle.Simple.ToField
+import Database.Oracle.Simple.FromField
 import qualified Data.ByteString.Char8 as BSC
+import Data.Proxy (Proxy (..))
 
 newtype DPIQueue = DPIQueue (Ptr DPIQueue)
   deriving (Show, Eq)
@@ -51,13 +62,6 @@ newtype DPIEnqOptions = DPIEnqOptions (Ptr DPIEnqOptions)
   deriving (Show, Eq)
   deriving newtype (Storable)
 
-newtype DPIObjectType = DPIObjectType (Ptr DPIObjectType)
-  deriving (Show, Eq)
-  deriving newtype (Storable)
-
-data ObjectType = JSON | Raw
-    deriving (Show, Eq)
-
 deqMany :: DPIQueue -> Int -> IO DPIMsgProps
 deqMany dpiQueue numProps = do
   alloca $ \dpiMsgPropsPtr -> do
@@ -167,8 +171,8 @@ foreign import ccall unsafe "dpiQueue_release"
     DPIQueue ->
     IO CInt
 
-genJSONQueue :: Connection -> String -> IO DPIQueue
-genJSONQueue (Connection fptr) queueName = do
+genQueueJSON :: Connection -> String -> IO DPIQueue
+genQueueJSON (Connection fptr) queueName = do
   withForeignPtr fptr $ \conn -> do
     alloca $ \dpiQueuePtr -> do
       withCStringLen queueName $ \(queueNameC , fromIntegral -> queueNameLen) -> do
@@ -202,14 +206,20 @@ foreign import ccall unsafe "dpiConn_newMsgProps"
     Ptr DPIMsgProps ->
     IO CInt
 
--- For now, Passing objectType will not work :( use setPayLoadType.
 genQueue :: Connection -> String -> IO DPIQueue
 genQueue (Connection fptr) queueName = do
   withForeignPtr fptr $ \conn -> do
     alloca $ \dpiQueuePtr -> do
       withCStringLen queueName $ \(queueNameC , fromIntegral -> queueNameLen) -> do
         throwOracleError =<< dpiConn_newQueue conn queueNameC queueNameLen nullPtr dpiQueuePtr
-        -- TODO: Accomodate ObjectType
+        peek dpiQueuePtr
+
+genQueueObject :: Connection -> String -> DPIObjectType -> IO DPIQueue
+genQueueObject (Connection fptr) queueName (DPIObjectType objectType) = do
+  withForeignPtr fptr $ \conn -> do
+    alloca $ \dpiQueuePtr -> do
+      withCStringLen queueName $ \(queueNameC , fromIntegral -> queueNameLen) -> do
+        throwOracleError =<< dpiConn_newQueue conn queueNameC queueNameLen objectType dpiQueuePtr
         peek dpiQueuePtr
 
 foreign import ccall unsafe "dpiConn_newQueue"
@@ -221,7 +231,7 @@ foreign import ccall unsafe "dpiConn_newQueue"
     -- | name Length
     CUInt ->
     -- | dpiObjectType *
-    Ptr () ->
+    Ptr DPIObjectType ->
     -- | dpiQueue **
     Ptr DPIQueue ->
     IO CInt
@@ -256,7 +266,6 @@ foreign import ccall unsafe "dpiMsgProps_getDelay"
     Ptr CUInt ->
     IO CInt
 
-
 {-
 This function internally calls getPayLoad which either returns payLoad in either Object or in bytes.
 Hence, the result might be null.
@@ -271,13 +280,21 @@ getMsgPropsPayLoadBytes dpiMsgProps = do
             if cStr == nullPtr 
               then return Nothing
             else Just . BSC.pack <$> peekCString cStr
-      
+
+getMsgPropsPayLoadObject :: DPIMsgProps -> IO (Maybe DPIObject)
+getMsgPropsPayLoadObject dpiMsgProps = 
+  alloca $ \dpiObjectPtr -> do
+        throwOracleError =<< dpiMsgProps_getPayload dpiMsgProps dpiObjectPtr nullPtr nullPtr
+        if dpiObjectPtr  == nullPtr
+            then return Nothing
+        else Just <$> peek dpiObjectPtr 
+
 foreign import ccall unsafe "dpiMsgProps_getPayload"
   dpiMsgProps_getPayload ::
     -- | dpiMsgProps *
     DPIMsgProps ->
     -- | dpiObject **
-    Ptr  DPIObjectType ->
+    Ptr DPIObject ->
     -- | const char ** value
     Ptr CString ->
     -- | valueLength
@@ -313,6 +330,18 @@ foreign import ccall unsafe "dpiMsgProps_setPayloadBytes"
     CUInt ->
     IO CInt
 
+setMsgPropsPayLoadObject :: DPIMsgProps -> DPIObject-> IO ()
+setMsgPropsPayLoadObject dpiMsgProps obj = do
+  throwOracleError =<< dpiMsgProps_setPayloadObject dpiMsgProps obj
+
+foreign import ccall unsafe "dpiMsgProps_setPayloadObject"
+    dpiMsgProps_setPayloadObject ::
+    -- | dpiMsgProps *
+    DPIMsgProps ->
+    -- | dpiObject* obj
+    DPIObject ->
+    IO CInt
+
 setMsgPropsPayLoadJSON :: DPIMsgProps -> DPIJson -> IO ()
 setMsgPropsPayLoadJSON dpiMsgProps payLoadJson = do
   throwOracleError =<< dpiMsgProps_setPayloadJson dpiMsgProps payLoadJson
@@ -324,3 +353,55 @@ foreign import ccall unsafe "dpiMsgProps_setPayloadJson"
     -- | dpiJson * 
     DPIJson ->
     IO CInt
+
+objectAppendElement :: forall a. (ToField a) => DPIObject -> a -> IO ()
+objectAppendElement obj val = do
+    dataValue <- toField val
+    let dataIsNull = case dataValue of
+                            AsNull -> 1
+                            _ -> 0
+    alloca $ \dpiDataPtr -> do
+      let dpiData = DPIData{..}
+      poke dpiDataPtr (dpiData :: DPIData WriteBuffer)
+      throwOracleError =<< 
+        dpiObject_appendElement 
+            obj 
+            (dpiNativeTypeToUInt (toDPINativeType (Proxy @a))) 
+            (dpiDataPtr :: Ptr (DPIData WriteBuffer))
+
+foreign import ccall unsafe "dpiObject_appendElement"
+    dpiObject_appendElement ::
+    -- | dpiObject *
+    DPIObject ->
+    -- | dpiNativeTypeNum
+    CUInt ->
+    -- | dpiData* val
+    Ptr (DPIData WriteBuffer) ->
+    IO CInt
+
+getObjectElementByIdx 
+    :: forall a. (FromField a) => 
+    DPIObject -> 
+    Int -> 
+    IO a
+getObjectElementByIdx obj idx = do
+    alloca $ \dpiDataPtr -> do
+      throwOracleError =<< 
+        dpiObject_getElementExistsByIndex 
+            obj 
+            (CInt $ fromIntegral idx)
+            (dpiNativeTypeToUInt (fromDPINativeType (Proxy @a)))
+            dpiDataPtr
+      readDPIDataBuffer (fromField @a) dpiDataPtr
+
+foreign import ccall unsafe "dpiObject_getElementExistsByIndex"
+    dpiObject_getElementExistsByIndex ::
+    -- | dpiObject *
+    DPIObject ->
+    -- | int32_t index
+    CInt ->
+    -- | dpiNativeTypeNum
+    CUInt ->
+    -- | dpiData *
+    Ptr (DPIData ReadBuffer) ->
+    IO CInt

test/Main.hs

@@ -395,12 +395,13 @@ spec pool = do
         queue <- genQueue conn "test_queue"
         queueRelease queue
         -- No exception implies success
+        
       it "should set and get a msgProp payload" $ \conn -> do
         msgProps <- genMsgProps conn
         setMsgPropsPayLoadBytes msgProps (BSC.pack "Hello from Haskell!")
         payload <- getMsgPropsPayLoadBytes msgProps
         payload `shouldBe` Just "Hello from Haskell!"
-      it "should enque and deque msg prop from queue" $ \conn -> do
+      it "should enque and deque msg prop from queue for bytes" $ \conn -> do
         void $ execute_ conn "\
         \BEGIN\
          \ DBMS_AQADM.CREATE_QUEUE_TABLE(\
@@ -423,6 +424,18 @@ spec pool = do
         payload <- getMsgPropsPayLoadBytes newMsgProps
         payload `shouldBe` Just "Hello from Haskell!"
         queueRelease queue
+        void $ execute_ conn "\
+        \BEGIN\
+         \ DBMS_AQADM.STOP_QUEUE(\
+           \  queue_name => 'TEST_QUEUE'\
+          \);\
+         \ DBMS_AQADM.DROP_QUEUE(\
+          \   queue_name => 'TEST_QUEUE'\
+         \ );\
+         \ DBMS_AQADM.DROP_QUEUE_TABLE(\
+           \  queue_table        => 'TEST_QUEUE_TABLE'\
+         \ );\
+        \END;"
   where
     handleOracleError action = Exc.try @OracleError action >>= either (\_ -> pure ()) (\_ -> pure ())