Add Test Cases for Advanced Queuing with Object type and JSON (#49)

* Added test cases for AQ object and AQ JSON * Added numOfAttributes argument in getObjAttributes
haskell-oracle · Dec 10, 2024 · fe96cd2 · fe96cd2
1 parent 2ead777
commit fe96cd2
Show file tree

Hide file tree

Showing 7 changed files with 536 additions and 172 deletions.
diff --git a/oracle-simple.cabal b/oracle-simple.cabal
@@ -40,6 +40,7 @@ library
       Database.Oracle.Simple.ToRow
       Database.Oracle.Simple.Transaction
       Database.Oracle.Simple.Queue
+      Database.Oracle.Simple.Object
   hs-source-dirs:
       src
   c-sources:

diff --git a/src/Database/Oracle/Simple.hs b/src/Database/Oracle/Simple.hs
@@ -11,3 +11,4 @@ import Database.Oracle.Simple.ToField as Export
 import Database.Oracle.Simple.ToRow as Export
 import Database.Oracle.Simple.Transaction as Export
 import Database.Oracle.Simple.Queue as Export
+import Database.Oracle.Simple.Object as Export
diff --git a/src/Database/Oracle/Simple/Internal.hs b/src/Database/Oracle/Simple/Internal.hs
@@ -44,14 +44,7 @@ module Database.Oracle.Simple.Internal
     OracleError (..),
     ErrorInfo (..),
     VersionInfo (..),
-    DPIJson (..),
-    DPIObjectType (..),
-    DPIObject (..),
-    genJSON,
-    genObject,
-    getObjectType,
     renderErrorInfo,
-    releaseObject,
     ping,
     fetch,
     close,
@@ -70,6 +63,7 @@ module Database.Oracle.Simple.Internal
     bindValueByPos,
     freeWriteBuffer,
     mkDPIBytesUTF8,
+    mkStringFromDPIBytesUTF8,
     isHealthy,
     dpiTimeStampToUTCDPITimeStamp,
     throwOracleError,
@@ -127,18 +121,6 @@ newtype DPIShardingKeyColumn = DPIShardingKeyColumn (Ptr DPIShardingKeyColumn)
   deriving (Show, Eq)
   deriving newtype (Storable)
 
-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
@@ -1134,6 +1116,9 @@ mkDPIBytesUTF8 str = do
   dpiBytesEncoding <- newCString "UTF-8"
   pure $ DPIBytes {..}
 
+mkStringFromDPIBytesUTF8 :: DPIBytes -> IO String
+mkStringFromDPIBytesUTF8 DPIBytes{..} = peekCString dpiBytesPtr
+
 data DPIIntervalDS = DPIIntervalDS
   { days :: CInt
   , hours :: CInt
@@ -1773,62 +1758,4 @@ newtype Only a = Only {fromOnly :: a}
   deriving stock (Eq, Ord, Read, Show, Generic)
   deriving newtype (Enum)
 
-genJSON :: Connection -> IO DPIJson
-genJSON (Connection fptr) = do
-  withForeignPtr fptr $ \conn -> do
-    alloca $ \jsonPtr -> do
-      throwOracleError =<< dpiConn_newJson conn jsonPtr
-      peek jsonPtr
-
-foreign import ccall unsafe "dpiConn_newJson"
-  dpiConn_newJson ::
-    -- | dpiConn *
-    Ptr DPIConn ->
-    -- | 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
 
diff --git a/src/Database/Oracle/Simple/JSON.hs b/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(..), getJson) where
+module Database.Oracle.Simple.JSON (AesonField (..), JsonDecodeError (..), DPIJsonNode(..), getJson, DPIJson(..), dpiJson_getValue, parseJson) where
 
 import Control.Exception (Exception (displayException), SomeException, catch, evaluate, throwIO)
 import Control.Monad (void, (<=<))
@@ -78,58 +78,53 @@ instance (Aeson.FromJSON a) => FromField (AesonField a) where
 
 getJson :: (Aeson.FromJSON a) => ReadDPIBuffer a
 getJson = parseJson <=< peek <=< dpiJson_getValue <=< dpiData_getJson
-  where
-    parseJson topNode = do
-      aesonValue <- buildValue topNode
-      case Aeson.fromJSON aesonValue of
-        Aeson.Error msg -> throwIO $ ParseError msg
-        Aeson.Success a -> pure a
-
-    -- Build Aeson values for various cases:
-
-    -- Object
-    buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_JSON_OBJECT nodeValue) = do
-      DPIJsonObject {..} <- peek =<< dpiDataBuffer_getAsJsonObject nodeValue
-      fieldNamePtrs <- peekArray (fromIntegral djoNumFields) djoFieldNames
-      fieldNameLengths <- fmap fromIntegral <$> peekArray (fromIntegral djoNumFields) djoFieldNameLengths
-      ks <- mapM (fmap fromString . peekCStringLen) (zip fieldNamePtrs fieldNameLengths)
-      values <- mapM buildValue =<< peekArray (fromIntegral djoNumFields) djoFields
-      pure $ Aeson.Object $ KeyMap.fromList (zip ks values)
-
-    -- Array
-    buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_JSON_ARRAY nodeValue) = do
-      DPIJsonArray {..} <- peek =<< dpiDataBuffer_getAsJsonArray nodeValue
-      values <- mapM buildValue =<< peekArray (fromIntegral djaNumElements) djaElements
-      pure $ Aeson.Array $ Vector.fromList values
-
-    -- Number returned as DPIBytes
-    buildValue (DPIJsonNode DPI_ORACLE_TYPE_NUMBER DPI_NATIVE_TYPE_BYTES nodeValue) = do
-      DPIBytes {..} <- peek =<< dpiDataBuffer_getAsBytes nodeValue
-      bytes <- BS.packCStringLen (dpiBytesPtr, fromIntegral dpiBytesLength)
-      let numStr = C8.unpack bytes
-      number <- evaluate (read numStr) `catch` (\(_ :: SomeException) -> throwIO $ InvalidNumber numStr)
-      pure $ Aeson.Number number
-
-    -- String
-    buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_BYTES nodeValue) = do
-      DPIBytes {..} <- peek =<< dpiDataBuffer_getAsBytes nodeValue
-      bytes <- BS.packCStringLen (dpiBytesPtr, fromIntegral dpiBytesLength)
-      pure $ Aeson.String (decodeUtf8 bytes)
-
-    -- Number encoded as Double (will not fire as dpiJsonOptions_numberAsString is set)
-    buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_DOUBLE nodeValue) = do
-      doubleVal <- dpiDataBuffer_getAsDouble nodeValue
-      pure $ Aeson.Number $ fromFloatDigits doubleVal
-
-    -- Boolean literals (true, false)
-    buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_BOOLEAN nodeValue) = do
-      intVal <- dpiDataBuffer_getAsBoolean nodeValue
-      pure $ Aeson.Bool (intVal == 1)
-
-    -- Null literal (null)
-    buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_NULL _) = pure Aeson.Null
-    -- All other DPI native types
-    buildValue (DPIJsonNode _ nativeType _) = throwIO $ UnsupportedDPINativeType nativeType
+
+parseJson :: Aeson.FromJSON b => DPIJsonNode -> IO b
+parseJson topNode = do
+  aesonValue <- buildValue topNode
+  case Aeson.fromJSON aesonValue of
+    Aeson.Error msg -> throwIO $ ParseError msg
+    Aeson.Success a -> pure a
+
+-- Build Aeson values for various cases:
+-- Object
+buildValue :: DPIJsonNode -> IO Aeson.Value
+buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_JSON_OBJECT nodeValue) = do
+  DPIJsonObject {..} <- peek =<< dpiDataBuffer_getAsJsonObject nodeValue
+  fieldNamePtrs <- peekArray (fromIntegral djoNumFields) djoFieldNames
+  fieldNameLengths <- fmap fromIntegral <$> peekArray (fromIntegral djoNumFields) djoFieldNameLengths
+  ks <- mapM (fmap fromString . peekCStringLen) (zip fieldNamePtrs fieldNameLengths)
+  values <- mapM buildValue =<< peekArray (fromIntegral djoNumFields) djoFields
+  pure $ Aeson.Object $ KeyMap.fromList (zip ks values)
+-- Array
+buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_JSON_ARRAY nodeValue) = do
+  DPIJsonArray {..} <- peek =<< dpiDataBuffer_getAsJsonArray nodeValue
+  values <- mapM buildValue =<< peekArray (fromIntegral djaNumElements) djaElements
+  pure $ Aeson.Array $ Vector.fromList values
+-- Number returned as DPIBytes
+buildValue (DPIJsonNode DPI_ORACLE_TYPE_NUMBER DPI_NATIVE_TYPE_BYTES nodeValue) = do
+  DPIBytes {..} <- peek =<< dpiDataBuffer_getAsBytes nodeValue
+  bytes <- BS.packCStringLen (dpiBytesPtr, fromIntegral dpiBytesLength)
+  let numStr = C8.unpack bytes
+  number <- evaluate (read numStr) `catch` (\(_ :: SomeException) -> throwIO $ InvalidNumber numStr)
+  pure $ Aeson.Number number
+-- String
+buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_BYTES nodeValue) = do
+  DPIBytes {..} <- peek =<< dpiDataBuffer_getAsBytes nodeValue
+  bytes <- BS.packCStringLen (dpiBytesPtr, fromIntegral dpiBytesLength)
+  pure $ Aeson.String (decodeUtf8 bytes)
+-- Number encoded as Double (will not fire as dpiJsonOptions_numberAsString is set)
+buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_DOUBLE nodeValue) = do
+  doubleVal <- dpiDataBuffer_getAsDouble nodeValue
+  pure $ Aeson.Number $ fromFloatDigits doubleVal
+-- Boolean literals (true, false)
+buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_BOOLEAN nodeValue) = do
+  intVal <- dpiDataBuffer_getAsBoolean nodeValue
+  pure $ Aeson.Bool (intVal == 1)
+-- Null literal (null)
+buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_NULL _) = pure Aeson.Null
+-- All other DPI native types
+buildValue (DPIJsonNode _ nativeType _) = throwIO $ UnsupportedDPINativeType nativeType
 
 newtype DPIJson = DPIJson (Ptr DPIJson)
   deriving (Show, Eq)