├── .ghci ├── Setup.hs ├── .gitignore ├── nix ├── nixpkgs.json └── default.nix ├── CHANGELOG.md ├── stack.yaml ├── init-scripts └── init.sql ├── db └── startup.sh ├── fourmolu.yaml ├── docker-compose.yml ├── .github └── workflows │ └── main.yml ├── cbits ├── dpiDataBuffer.c └── oracleHelpers.c ├── shell.nix ├── default.nix ├── LICENSE ├── src └── Database │ └── Oracle │ ├── Simple │ ├── Execute.hs │ ├── Query.hs │ ├── ToField.hs │ ├── ToRow.hs │ ├── FromRow.hs │ ├── Pool.hs │ ├── FromField.hs │ ├── Object.hs │ ├── JSON.hs │ ├── Transaction.hs │ ├── LOB.hs │ └── Queue.hs │ └── Simple.hs ├── README.md ├── oracle-simple.cabal └── test └── Main.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | 3 | main = defaultMain 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /TAGS 2 | /dist-newstyle/ 3 | /dist/ 4 | /result 5 | *.o 6 | *.hi 7 | /cabal.project.local 8 | /.stack-work/ 9 | -------------------------------------------------------------------------------- /nix/nixpkgs.json: -------------------------------------------------------------------------------- 1 | { 2 | "rev" : "aeb75dba965", 3 | "sha256": "119lcwpkr9yy49z9fgpq32hp33igc4apbip2y2ppc7hwxs0hwyjk" 4 | } 5 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for oracle-simple 2 | 3 | ## 0.1.0.0 -- YYYY-mm-dd 4 | 5 | * First version. Released on an unsuspecting world. 6 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: 2 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/12.yaml 3 | 4 | packages: 5 | - . 6 | -------------------------------------------------------------------------------- /init-scripts/init.sql: -------------------------------------------------------------------------------- 1 | alter session set "_oracle_script"=true; 2 | CREATE USER username IDENTIFIED BY password; 3 | GRANT ALL PRIVILEGES TO username; 4 | GRANT EXECUTE ON DBMS_AQADM TO username; -------------------------------------------------------------------------------- /db/startup.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | sqlplus -s username/password@localhost/devdb <asJsonObject; 10 | } 11 | 12 | dpiJsonArray *dpiDataBuffer_getAsJsonArray(dpiDataBuffer *buffer) 13 | { 14 | return &buffer->asJsonArray; 15 | } 16 | 17 | dpiBytes *dpiDataBuffer_getAsBytes(dpiDataBuffer *buffer) 18 | { 19 | return &buffer->asBytes; 20 | } 21 | 22 | int dpiDataBuffer_getAsBoolean(dpiDataBuffer *buffer) 23 | { 24 | return buffer->asBoolean; 25 | } 26 | 27 | double dpiDataBuffer_getAsDouble(dpiDataBuffer *buffer) 28 | { 29 | return buffer->asDouble; 30 | } 31 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let 2 | oraclePkgs = (import ./default.nix {}); 3 | inherit (oraclePkgs) oracle-simple; 4 | in 5 | with oraclePkgs.pkgs; 6 | oracle-simple.env.overrideAttrs (drv: { 7 | shellHook = '' 8 | export PATH=$PATH:${pkgs.cabal-install}/bin 9 | function build () { 10 | cabal configure \ 11 | --extra-lib-dirs=${pkgs.odpic}/lib \ 12 | --extra-include-dirs=${pkgs.odpic}/include 13 | cabal build 14 | } 15 | function clean () { 16 | cabal clean 17 | } 18 | function ghcid () { 19 | ${pkgs.ghcid}/bin/ghcid --poll -c 'cabal configure \ 20 | --extra-lib-dirs=${pkgs.odpic}/lib \ 21 | --extra-include-dirs=${pkgs.odpic}/include && cabal repl' 22 | } 23 | ''; 24 | }) 25 | -------------------------------------------------------------------------------- /cbits/oracleHelpers.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include "dpi.h" 5 | 6 | int context_create (int majorVersion, int minorVersion, dpiContext **context, dpiErrorInfo *errorInfo) { 7 | return dpiContext_createWithParams (majorVersion, minorVersion, NULL, context, errorInfo); 8 | } 9 | 10 | void finalize_connection_default (dpiConn *conn) { 11 | dpiConn_close (conn, DPI_MODE_CONN_CLOSE_DEFAULT, NULL, 0); 12 | } 13 | 14 | void close_pool_default (dpiPool *pool) { 15 | dpiPool_close (pool, DPI_MODE_POOL_CLOSE_DEFAULT); 16 | } 17 | 18 | int getMajorVersion () { 19 | return DPI_MAJOR_VERSION; 20 | } 21 | 22 | int getMinorVersion () { 23 | return DPI_MINOR_VERSION; 24 | } 25 | 26 | int acquire_connection (dpiPool *pool, dpiConn **conn) { 27 | return dpiPool_acquireConnection (pool, NULL, 0, NULL, 0, NULL, conn); 28 | } 29 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | { pkgs ? import ./nix 2 | }: 3 | with pkgs.haskell.lib; 4 | let 5 | # derive-storable-plugin-src = pkgs.fetchFromGitHub { 6 | # repo = "derive-storable-plugin"; 7 | # owner = "mkloczko"; 8 | # rev = "0a01dfb483db5bd15ef6b2400b4192b23ab82b2e"; 9 | # sha256 = "ppLkCL9O6jbjawj4JVwy0z3CIEFzis6jrTMb713pvPE="; 10 | # }; 11 | overrides = self: super: { 12 | # derive-storable-plugin = self.callCabal2nix "derive-storable-plugin" derive-storable-plugin-src {}; 13 | derive-storable = enableCabalFlag super.derive-storable "sumtypes"; 14 | }; 15 | hPkgs = pkgs.haskell.packages.ghc961.override { inherit overrides; }; 16 | src = ./.; 17 | oracle-simple = hPkgs.callCabal2nix "oracle-simple" src { inherit (pkgs) odpic; }; 18 | in 19 | { 20 | oracle-simple = appendConfigureFlags (disableCabalFlag oracle-simple "default_paths") 21 | [ "--extra-include-dirs=${pkgs.odpic}/include" 22 | "--extra-lib-dirs=${pkgs.odpic}/lib" 23 | ]; 24 | inherit pkgs; 25 | } 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2021 H-E-B 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. -------------------------------------------------------------------------------- /src/Database/Oracle/Simple/Execute.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | 3 | module Database.Oracle.Simple.Execute 4 | ( execute, 5 | execute_, 6 | executeMany, 7 | ) 8 | where 9 | 10 | import Control.Monad (foldM) 11 | import Control.Monad.State.Strict (evalStateT) 12 | import Data.Word (Word64) 13 | 14 | import Database.Oracle.Simple.Internal 15 | ( Column (Column), 16 | Connection, 17 | DPIModeExec (DPI_MODE_EXEC_DEFAULT), 18 | dpiExecute, 19 | getRowCount, 20 | prepareStmt, 21 | ) 22 | import Database.Oracle.Simple.ToRow (RowWriter (runRowWriter), ToRow, toRow) 23 | 24 | {- | Execute an INSERT, UPDATE, or other SQL query that is not expected to return results. 25 | Returns the number of rows affected. 26 | -} 27 | execute :: (ToRow a) => Connection -> String -> a -> IO Word64 28 | execute conn sql param = do 29 | stmt <- prepareStmt conn sql 30 | _ <- evalStateT (runRowWriter (toRow param) stmt) (Column 0) 31 | _ <- dpiExecute stmt DPI_MODE_EXEC_DEFAULT 32 | getRowCount stmt 33 | 34 | -- | A version of 'execute' that does not perform query substitution. 35 | execute_ :: Connection -> String -> IO Word64 36 | execute_ conn sql = do 37 | stmt <- prepareStmt conn sql 38 | _ <- dpiExecute stmt DPI_MODE_EXEC_DEFAULT 39 | getRowCount stmt 40 | 41 | {- | Execute a multi-row INSERT, UPDATE or other SQL query that is not expected to return results. 42 | Returns the number of rows affected. If the list of parameters is empty, the function will simply 43 | return 0 without issuing the query to the backend. 44 | -} 45 | executeMany :: (ToRow a) => Connection -> String -> [a] -> IO Word64 46 | executeMany _ _ [] = pure 0 47 | executeMany conn sql params = do 48 | stmt <- prepareStmt conn sql 49 | foldM (go stmt) 0 params 50 | where 51 | go stmt !totalRowsAffected param = do 52 | _ <- evalStateT (runRowWriter (toRow param) stmt) (Column 0) 53 | _ <- dpiExecute stmt DPI_MODE_EXEC_DEFAULT 54 | rowsAffected <- getRowCount stmt 55 | pure (totalRowsAffected + rowsAffected) 56 | -------------------------------------------------------------------------------- /src/Database/Oracle/Simple/Query.hs: -------------------------------------------------------------------------------- 1 | module Database.Oracle.Simple.Query 2 | ( query, 3 | query_, 4 | forEach_, 5 | ) 6 | where 7 | 8 | import Control.Monad.State.Strict (evalStateT) 9 | 10 | import Database.Oracle.Simple.FromRow (FromRow, getRow) 11 | import Database.Oracle.Simple.Internal 12 | ( Column (Column), 13 | Connection, 14 | DPIModeExec (DPI_MODE_EXEC_DEFAULT), 15 | dpiExecute, 16 | fetch, 17 | prepareStmt, 18 | ) 19 | import Database.Oracle.Simple.ToRow (RowWriter (runRowWriter), ToRow, toRow) 20 | 21 | {- | Perform a SELECT or other SQL query that is expected to return results. 22 | All results are retrieved and converted before this function ends. 23 | -} 24 | query :: (FromRow a, ToRow b) => Connection -> String -> b -> IO [a] 25 | query conn sql param = do 26 | stmt <- prepareStmt conn sql 27 | _ <- evalStateT (runRowWriter (toRow param) stmt) (Column 0) 28 | _ <- dpiExecute stmt DPI_MODE_EXEC_DEFAULT 29 | found <- fetch stmt 30 | loop stmt found 31 | where 32 | loop _ n | n < 1 = pure [] 33 | loop stmt _ = do 34 | tsVal <- getRow stmt 35 | found <- fetch stmt 36 | (tsVal :) <$> loop stmt found 37 | 38 | -- | A version of 'query' that does not perform query substitution. 39 | query_ :: FromRow a => Connection -> String -> IO [a] 40 | query_ conn sql = do 41 | stmt <- prepareStmt conn sql 42 | _ <- dpiExecute stmt DPI_MODE_EXEC_DEFAULT 43 | found <- fetch stmt 44 | loop stmt found 45 | where 46 | loop _ n | n < 1 = pure [] 47 | loop stmt _ = do 48 | tsVal <- getRow stmt 49 | found <- fetch stmt 50 | (tsVal :) <$> loop stmt found 51 | 52 | -- | Incrementally process a query 53 | forEach_ :: FromRow row => Connection -> String -> (row -> IO ()) -> IO () 54 | forEach_ conn sql cont = do 55 | stmt <- prepareStmt conn sql 56 | _ <- dpiExecute stmt DPI_MODE_EXEC_DEFAULT 57 | found <- fetch stmt 58 | loop stmt found 59 | where 60 | loop _ n | n < 1 = pure () 61 | loop stmt _ = do 62 | tsVal <- getRow stmt 63 | cont tsVal 64 | found <- fetch stmt 65 | loop stmt found 66 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | oracle-simple 2 | ===================================== 3 | ![](https://github.com/haskell-oracle/oracle-simple/actions/workflows/main.yml/badge.svg) 4 | 5 | Modern bindings to Oracle [odpic](https://oracle.github.io/odpi/) C library. 6 | - See [here](https://github.com/oracle/odpi/blob/main/include/dpi.h) for a list of all structs and functions used in this library. 7 | 8 | ## Example 9 | 10 | ```haskell 11 | {-# LANGUAGE DerivingStrategies #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE DeriveAnyClass #-} 14 | {-# LANGUAGE DeriveGeneric #-} 15 | module Main where 16 | 17 | import Data.Text (Text) 18 | import Database.Oracle.Simple 19 | import GHC.Generics (Generic) 20 | 21 | main :: IO () 22 | main = do 23 | let stmt = "select count(*), sysdate, 'ignore next column', 125.24, 3.14 from dual" 24 | conn <- connect (ConnectionParams "username" "password" "localhost/XEPDB1" Nothing) 25 | rows <- query_ conn stmt :: IO [ReturnedRow] 26 | print rows 27 | 28 | -- [ ReturnedRow { count = RowCount {getRowCount = 1.0} 29 | -- , sysdate = DPITimeStamp {year = 2023, month = 9, day = 15, hour = 2, minute = 10, second = 50, fsecond = 0, tzHourOffset = 0, tzMinuteOffset = 0} 30 | -- , hint = "ignore next column" 31 | -- , amount = 125.24000000000001 32 | -- , piValue = 3.14 33 | -- } 34 | -- ] 35 | 36 | newtype RowCount = RowCount { getRowCount :: Double } 37 | deriving (Show) 38 | 39 | instance FromField RowCount where 40 | fromField = RowCount <$> fromField 41 | 42 | data ReturnedRow = ReturnedRow 43 | { count :: RowCount 44 | , sysdate :: DPITimeStamp 45 | , hint :: Text 46 | , amount :: Double 47 | , piValue :: Double 48 | } 49 | deriving stock (Show, Generic) 50 | deriving anyclass FromRow 51 | 52 | -- instance FromRow ReturnedRow where 53 | -- fromRow = do 54 | -- count <- field 55 | -- sysdate <- field 56 | -- amount <- field 57 | -- pure ReturnedRow{..} 58 | 59 | ``` 60 | 61 | ## Developing locally 62 | 63 | ### Using nix 64 | 65 | #### Building 66 | 67 | ```bash 68 | $ nix-build 69 | ``` 70 | 71 | ```bash 72 | $ nix-shell --run 'cabal build' 73 | ``` 74 | 75 | #### Running tests 76 | 77 | ```bash 78 | $ docker-compose up -d 79 | $ nix-build && ./result/bin/example 80 | ``` 81 | 82 | ### Using stack 83 | 84 | #### Building 85 | 86 | First install `odpi` (e.g. on MacOS): 87 | ``` bash 88 | brew install odpi 89 | ``` 90 | 91 | This should suffice to permit you to build: 92 | ```bash 93 | $ stack build 94 | ``` 95 | 96 | #### Running tests 97 | 98 | You'll need a runtime dependency: goto https://www.oracle.com/database/technologies/instant-client/macos-intel-x86-downloads.html#ic_osx_inst and follow the instant client installation instructions. 99 | 100 | Then link a dynamic lib from the instant client to a location on your host where it can be found: 101 | ``` 102 | ln -s ~/Downloads/instantclient_19_8/libclntsh.dylib /usr/local/lib/ 103 | ``` 104 | 105 | Run docker-compose up and tests as so: 106 | ``` bash 107 | docker-compose up -d 108 | stack run tests 109 | ``` 110 | -------------------------------------------------------------------------------- /oracle-simple.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >=1.10 2 | name: oracle-simple 3 | version: 0.1.0.0 4 | synopsis: Easy access to Oracle 5 | description: Query Oracle databases using odpic 6 | bug-reports: https://github.com/haskell-oracle/oracle-simple 7 | license: MIT 8 | license-file: LICENSE 9 | author: David Johnson 10 | maintainer: code@dmj.io, khandkararjun@gmail.com 11 | copyright: H-E-B (c) 2025 12 | category: Database 13 | build-type: Simple 14 | extra-source-files: CHANGELOG.md 15 | 16 | flag default_paths 17 | default: 18 | True 19 | description: 20 | use default paths for odpic as set via `make install` from source 21 | 22 | flag apt_paths 23 | default: 24 | False 25 | description: 26 | use paths for odpic as set by libodpic4 and odpic-dev from apt 27 | 28 | library 29 | exposed-modules: 30 | Database.Oracle.Simple 31 | other-modules: 32 | Database.Oracle.Simple.Execute 33 | Database.Oracle.Simple.FromField 34 | Database.Oracle.Simple.FromRow 35 | Database.Oracle.Simple.Internal 36 | Database.Oracle.Simple.JSON 37 | Database.Oracle.Simple.Pool 38 | Database.Oracle.Simple.Query 39 | Database.Oracle.Simple.ToField 40 | Database.Oracle.Simple.ToRow 41 | Database.Oracle.Simple.Transaction 42 | Database.Oracle.Simple.Queue 43 | Database.Oracle.Simple.Object 44 | Database.Oracle.Simple.LOB 45 | hs-source-dirs: 46 | src 47 | c-sources: 48 | cbits/dpiDataBuffer.c 49 | cbits/oracleHelpers.c 50 | extra-libraries: 51 | odpic 52 | build-depends: 53 | aeson 54 | , base 55 | , bytestring 56 | , derive-storable 57 | , mtl 58 | , random 59 | , scientific 60 | , text 61 | , time 62 | , uuid 63 | , vector 64 | default-language: Haskell2010 65 | ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-export-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wnoncanonical-monad-instances -Wredundant-constraints -Wpartial-fields -Wmissed-specialisations -Wunused-packages -O2 -haddock 66 | if os(linux) && flag(default_paths) 67 | include-dirs: 68 | /usr/local/include 69 | extra-lib-dirs: 70 | /usr/local/lib 71 | if os(linux) && flag(apt_paths) 72 | include-dirs: 73 | /usr/include 74 | extra-lib-dirs: 75 | /usr/lib/x86_64-linux-gnu 76 | if os(osx) && flag(default_paths) 77 | include-dirs: 78 | /usr/local/include 79 | extra-lib-dirs: 80 | /usr/local/lib 81 | 82 | executable tests 83 | main-is: 84 | Main.hs 85 | hs-source-dirs: 86 | test 87 | default-language: 88 | Haskell2010 89 | ghc-options: -Wall -Werror -Wcompat -Widentities -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-export-lists -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wnoncanonical-monad-instances -Wredundant-constraints -Wpartial-fields -Wmissed-specialisations -Wunused-packages -O2 -threaded -rtsopts -with-rtsopts=-N 90 | build-depends: 91 | aeson 92 | , base 93 | , hedgehog 94 | , hspec 95 | , hspec-hedgehog 96 | , oracle-simple 97 | , time 98 | , bytestring 99 | 100 | source-repository head 101 | type: git 102 | location: git://github.com/haskell-oracle/oracle-simple.git 103 | -------------------------------------------------------------------------------- /src/Database/Oracle/Simple/ToField.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | 6 | module Database.Oracle.Simple.ToField 7 | ( ToField (..), 8 | utcTimeToDPITimestamp, 9 | ) 10 | where 11 | 12 | import Data.Int (Int32, Int64) 13 | import Data.Proxy (Proxy (..)) 14 | import qualified Data.Text as T 15 | import Data.Time (LocalTime (..), TimeOfDay (..), TimeZone (..), UTCTime (..), ZonedTime (..), toGregorian, utc, utcToZonedTime) 16 | import Foreign.Marshal.Utils (fromBool) 17 | import Numeric.Natural (Natural) 18 | import Database.Oracle.Simple.Internal 19 | 20 | -- | This class provides a way to write values of any type to a database buffer, 21 | -- | allowing you to convert complex data types into something that can be written 22 | -- | directly to the database. 23 | class ToField a where 24 | toDPINativeType :: Proxy a -> DPINativeType 25 | -- ^ The DPI native type of the value written to the buffer. 26 | 27 | toField :: a -> IO WriteBuffer 28 | -- ^ Write a value of type @a@ to the data buffer. 29 | 30 | instance ToField Bool where 31 | toDPINativeType _ = DPI_NATIVE_TYPE_BOOLEAN 32 | toField = pure . AsBoolean . fromBool 33 | 34 | instance ToField Double where 35 | toDPINativeType _ = DPI_NATIVE_TYPE_DOUBLE 36 | toField = pure . AsDouble 37 | 38 | instance ToField T.Text where 39 | toDPINativeType _ = DPI_NATIVE_TYPE_BYTES 40 | toField = fmap AsBytes . mkDPIBytesUTF8 . T.unpack 41 | 42 | instance ToField String where 43 | toDPINativeType _ = DPI_NATIVE_TYPE_BYTES 44 | toField = fmap AsBytes . mkDPIBytesUTF8 45 | 46 | instance ToField Int64 where 47 | toDPINativeType _ = DPI_NATIVE_TYPE_INT64 48 | toField = pure . AsInt64 49 | 50 | instance ToField Int32 where 51 | toDPINativeType _ = toDPINativeType (Proxy @Int64) 52 | toField = pure . AsInt64 . fromIntegral 53 | 54 | instance ToField Int where 55 | toDPINativeType _ = toDPINativeType (Proxy @Int64) 56 | toField = pure . AsInt64 . fromIntegral 57 | 58 | instance ToField Natural where 59 | toDPINativeType _ = toDPINativeType (Proxy @Int64) 60 | toField = pure . AsInt64 . fromIntegral 61 | 62 | instance (ToField a) => ToField (Maybe a) where 63 | toDPINativeType _ = toDPINativeType (Proxy @a) 64 | toField (Just val) = toField val 65 | toField Nothing = pure AsNull 66 | 67 | instance ToField DPITimestamp where 68 | toDPINativeType _ = DPI_NATIVE_TYPE_TIMESTAMP 69 | toField = pure . AsTimestamp 70 | 71 | instance ToField UTCTime where 72 | toDPINativeType _ = DPI_NATIVE_TYPE_TIMESTAMP 73 | toField utcTime = pure $ AsTimestamp (utcTimeToDPITimestamp utcTime) 74 | 75 | -- | Convert a UTCTime value to a DPITimestamp. 76 | utcTimeToDPITimestamp :: UTCTime -> DPITimestamp 77 | utcTimeToDPITimestamp utcTime = dpiTimeStampToUTCDPITimeStamp dpiTs 78 | where 79 | ZonedTime {..} = utcToZonedTime utc utcTime 80 | LocalTime {..} = zonedTimeToLocalTime 81 | (year, month, day) = toGregorian localDay 82 | TimeOfDay {..} = localTimeOfDay 83 | TimeZone {..} = zonedTimeZone 84 | (seconds, fractionalSeconds) = properFraction todSec 85 | (hourOffset, minuteOffset) = timeZoneMinutes `quotRem` 60 86 | dpiTs = 87 | DPITimestamp 88 | { year = fromIntegral year 89 | , month = fromIntegral month 90 | , day = fromIntegral day 91 | , hour = fromIntegral todHour 92 | , minute = fromIntegral todMin 93 | , second = seconds 94 | , fsecond = truncate (fractionalSeconds * 1e9) 95 | , tzHourOffset = fromIntegral hourOffset 96 | , tzMinuteOffset = fromIntegral minuteOffset 97 | } 98 | -------------------------------------------------------------------------------- /src/Database/Oracle/Simple/ToRow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | {-# LANGUAGE UndecidableInstances #-} 11 | 12 | module Database.Oracle.Simple.ToRow 13 | ( RowWriter (..), 14 | ToRow (..), 15 | ) 16 | where 17 | 18 | import Control.Monad (void) 19 | import Control.Monad.IO.Class (liftIO) 20 | import Control.Monad.State.Strict (StateT, get, modify) 21 | import Data.Functor.Identity (Identity) 22 | import Data.Proxy (Proxy (..)) 23 | import GHC.Generics 24 | import GHC.TypeLits 25 | 26 | import Database.Oracle.Simple.Internal 27 | import Database.Oracle.Simple.ToField 28 | 29 | -- | This type represents a column-oriented abstraction over SQL row writers 30 | newtype RowWriter a = RowWriter {runRowWriter :: DPIStmt -> StateT Column IO a} 31 | 32 | instance Functor RowWriter where 33 | fmap f g = RowWriter $ fmap f . runRowWriter g 34 | 35 | instance Applicative RowWriter where 36 | pure a = RowWriter $ \_ -> pure a 37 | fn <*> g = RowWriter $ \dpiStmt -> do 38 | f <- runRowWriter fn dpiStmt 39 | f <$> runRowWriter g dpiStmt 40 | 41 | instance Monad RowWriter where 42 | return = pure 43 | f >>= g = RowWriter $ \dpiStmt -> do 44 | f' <- runRowWriter f dpiStmt 45 | runRowWriter (g f') dpiStmt 46 | 47 | -- | The ToRow class provides a way to convert values of type 'a' into RowWriter instances that write nothing to the database. 48 | class ToRow a where 49 | toRow :: a -> RowWriter () 50 | default toRow :: (GToRow (Rep a), Generic a) => a -> RowWriter () 51 | toRow = gToRow . from 52 | 53 | instance ToField a => ToRow (Only a) 54 | 55 | instance ToField a => ToRow (Identity a) 56 | 57 | instance (ToField a, ToField b) => ToRow (a, b) 58 | 59 | instance (ToField a, ToField b, ToField c) => ToRow (a, b, c) 60 | 61 | instance (ToField a, ToField b, ToField c, ToField d) => ToRow (a, b, c, d) 62 | 63 | instance (ToField a, ToField b, ToField c, ToField d, ToField e) => ToRow (a, b, c, d, e) 64 | 65 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f) => ToRow (a, b, c, d, e, f) 66 | 67 | instance (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g) => ToRow (a, b, c, d, e, f, g) 68 | 69 | instance 70 | (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h) => 71 | ToRow (a, b, c, d, e, f, g, h) 72 | 73 | instance 74 | (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i) => 75 | ToRow (a, b, c, d, e, f, g, h, i) 76 | 77 | instance 78 | (ToField a, ToField b, ToField c, ToField d, ToField e, ToField f, ToField g, ToField h, ToField i, ToField j) => 79 | ToRow (a, b, c, d, e, f, g, h, i, j) 80 | 81 | class GToRow f where 82 | gToRow :: f a -> RowWriter () 83 | 84 | instance (GToRow m) => GToRow (D1 i m) where 85 | gToRow (M1 x) = gToRow x 86 | 87 | instance (GToRow m) => GToRow (C1 i m) where 88 | gToRow (M1 x) = gToRow x 89 | 90 | instance (GToRow m) => GToRow (S1 i m) where 91 | gToRow (M1 x) = gToRow x 92 | 93 | instance (GToRow l, GToRow r) => GToRow (l :*: r) where 94 | gToRow (l :*: r) = gToRow l >> gToRow r 95 | 96 | instance (() ~ TypeError ('Text "Sum types not supported")) => GToRow (l :+: r) where 97 | gToRow = error "Sum types not supported" 98 | 99 | instance (ToField a) => GToRow (K1 i a) where 100 | gToRow (K1 x) = void (writeField x) 101 | 102 | writeField :: forall a. (ToField a) => a -> RowWriter () 103 | writeField field = RowWriter $ \stmt -> do 104 | col <- modify (+ 1) >> get 105 | liftIO $ do 106 | dataValue <- toField field 107 | let dataIsNull = case dataValue of 108 | AsNull -> 1 109 | _ -> 0 110 | bindValueByPos stmt col (toDPINativeType (Proxy @a)) (DPIData {..}) 111 | freeWriteBuffer dataValue -- no longer needed as dpiStmt_bindValueByPos creates a memory-managed dpiVar 112 | -------------------------------------------------------------------------------- /src/Database/Oracle/Simple/FromRow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | module Database.Oracle.Simple.FromRow 11 | ( FromRow (..), 12 | getRow, 13 | ) 14 | where 15 | 16 | import Control.Exception hiding (TypeError) 17 | import Control.Monad (unless) 18 | import Control.Monad.IO.Class (liftIO) 19 | import Control.Monad.State.Strict (StateT, evalStateT, get, modify) 20 | import Data.Functor.Identity (Identity) 21 | import Data.Proxy (Proxy (..)) 22 | import Data.Word (Word32) 23 | import GHC.Generics 24 | import GHC.TypeLits 25 | 26 | import Database.Oracle.Simple.FromField 27 | import Database.Oracle.Simple.Internal 28 | 29 | -- | A type class for types that can be converted from a database row. 30 | -- This class allows for flexible, type-safe extraction of data from rows, 31 | -- using a 'RowParser' to define how each field should be parsed. 32 | class FromRow a where 33 | fromRow :: RowParser a 34 | default fromRow :: (GFromRow (Rep a), Generic a) => RowParser a 35 | fromRow = to <$> gFromRow 36 | 37 | instance FromField a => FromRow (Only a) 38 | 39 | instance FromField a => FromRow (Identity a) 40 | 41 | instance (FromField a, FromField b) => FromRow (a, b) 42 | 43 | instance (FromField a, FromField b, FromField c) => FromRow (a, b, c) 44 | 45 | instance (FromField a, FromField b, FromField c, FromField d) => FromRow (a, b, c, d) 46 | 47 | instance (FromField a, FromField b, FromField c, FromField d, FromField e) => FromRow (a, b, c, d, e) 48 | 49 | instance (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f) => FromRow (a, b, c, d, e, f) 50 | 51 | instance 52 | (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g) => 53 | FromRow (a, b, c, d, e, f, g) 54 | 55 | instance 56 | (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h) => 57 | FromRow (a, b, c, d, e, f, g, h) 58 | 59 | instance 60 | (FromField a, FromField b, FromField c, FromField d, FromField e, FromField f, FromField g, FromField h, FromField i) => 61 | FromRow (a, b, c, d, e, f, g, h, i) 62 | 63 | instance 64 | ( FromField a 65 | , FromField b 66 | , FromField c 67 | , FromField d 68 | , FromField e 69 | , FromField f 70 | , FromField g 71 | , FromField h 72 | , FromField i 73 | , FromField j 74 | ) => 75 | FromRow (a, b, c, d, e, f, g, h, i, j) 76 | 77 | class GFromRow f where 78 | gFromRow :: RowParser (f a) 79 | 80 | instance (GFromRow m) => GFromRow (D1 i m) where 81 | gFromRow = M1 <$> gFromRow 82 | 83 | instance (GFromRow m) => GFromRow (C1 i m) where 84 | gFromRow = M1 <$> gFromRow 85 | 86 | instance (GFromRow m) => GFromRow (S1 i m) where 87 | gFromRow = M1 <$> gFromRow 88 | 89 | instance (GFromRow l, GFromRow r) => GFromRow (l :*: r) where 90 | gFromRow = (:*:) <$> gFromRow <*> gFromRow 91 | 92 | instance (() ~ TypeError ('Text "Sum types not supported")) => GFromRow (l :+: r) where 93 | gFromRow = error "Sum types not supported" 94 | 95 | instance (FromField a) => GFromRow (K1 i a) where 96 | gFromRow = K1 <$> readField 97 | 98 | newtype RowParser a = RowParser {runRowParser :: DPIStmt -> StateT Word32 IO a} 99 | 100 | instance Functor RowParser where 101 | fmap f g = RowParser $ fmap f . runRowParser g 102 | 103 | instance Applicative RowParser where 104 | pure a = RowParser $ \_ -> pure a 105 | fn <*> g = RowParser $ \dpiStmt -> do 106 | f <- runRowParser fn dpiStmt 107 | f <$> runRowParser g dpiStmt 108 | 109 | instance Monad RowParser where 110 | return = pure 111 | f >>= g = RowParser $ \dpiStmt -> do 112 | f' <- runRowParser f dpiStmt 113 | runRowParser (g f') dpiStmt 114 | 115 | -- | Retrieve the currently fetched row. 116 | getRow :: forall a. (FromRow a) => DPIStmt -> IO a 117 | getRow stmt = evalStateT (runRowParser fromRow stmt) 0 118 | 119 | -- | Derive a @RowParser@ for a field at the specified column position. 120 | readField :: (FromField a) => RowParser a 121 | readField = fieldWith fromField 122 | 123 | {- | Derive a 'RowParser' for a field at the specified column position 124 | using the supplied 'FieldParser'. 125 | -} 126 | fieldWith :: forall a. (FromField a) => FieldParser a -> RowParser a 127 | fieldWith FieldParser {..} = RowParser $ \dpiStmt -> do 128 | pos <- modify (+ 1) >> get 129 | liftIO $ do 130 | (gotType, dataBuf) <- getQueryValue dpiStmt (fromIntegral pos) 131 | let typ = fromDPINativeType (Proxy @a) 132 | unless (gotType == typ) $ 133 | throwIO $ 134 | TypeMismatch typ gotType (Column pos) 135 | readDPIDataBuffer dataBuf 136 | 137 | data RowParseError 138 | = -- | We encountered a type that we were not expecting. 139 | TypeMismatch 140 | { expectedType :: DPINativeType 141 | -- ^ The DPI native type we were expecting 142 | , gotType :: DPINativeType 143 | -- ^ The DPI native type we got 144 | , column :: Column 145 | -- ^ Column position where type mismatch was encountered (1-indexed) 146 | } 147 | deriving (Show) 148 | 149 | instance Exception RowParseError where 150 | displayException (TypeMismatch {..}) = 151 | "Row parse error due to type mismatch: At column " 152 | <> show column 153 | <> ", expected " 154 | <> show expectedType 155 | <> " but got " 156 | <> show gotType 157 | <> "." 158 | -------------------------------------------------------------------------------- /src/Database/Oracle/Simple/Pool.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | 3 | module Database.Oracle.Simple.Pool 4 | ( Pool, 5 | createPool, 6 | acquireConnection, 7 | withPool, 8 | withPoolConnection, 9 | closePool, 10 | ) 11 | where 12 | 13 | import Control.Exception (bracket) 14 | import Data.IORef (readIORef) 15 | import Foreign 16 | ( ForeignPtr, 17 | FunPtr, 18 | Ptr, 19 | addForeignPtrFinalizer, 20 | alloca, 21 | finalizeForeignPtr, 22 | newForeignPtr_, 23 | nullPtr, 24 | peek, 25 | withForeignPtr, 26 | ) 27 | import Foreign.C (CInt (CInt), CString, CUInt (CUInt), withCStringLen) 28 | import Foreign.Storable (poke) 29 | 30 | import Database.Oracle.Simple.Internal 31 | ( AdditionalConnectionParams (..), 32 | Connection (Connection), 33 | ConnectionParams (additionalParams, connString, pass, user), 34 | DPICommonCreateParams, 35 | DPIConn (DPIConn), 36 | DPIContext (DPIContext), 37 | DPIPool (DPIPool), 38 | DPIPoolCreateParams (..), 39 | close, 40 | dpiConn_close_finalizer, 41 | dpiConn_release_finalizer, 42 | globalContext, 43 | throwOracleError, 44 | withDefaultPoolCreateParams, 45 | ) 46 | 47 | -- | A session pool; a group of stateless connections ("sessions") to the database. 48 | newtype Pool = Pool (ForeignPtr DPIPool) 49 | deriving (Show, Eq) 50 | 51 | -- | Creates and maintains a group of stateless connections to the database. 52 | createPool :: 53 | ConnectionParams -> 54 | IO Pool 55 | createPool params = do 56 | ctx <- readIORef globalContext 57 | DPIPool poolPtr <- alloca $ \connPtr -> do 58 | withCStringLen (user params) $ \(userCString, fromIntegral -> userLen) -> 59 | withCStringLen (pass params) $ \(passCString, fromIntegral -> passLen) -> 60 | withCStringLen (connString params) $ \(connCString, fromIntegral -> connLen) -> do 61 | let poolCreate paramsPtr = 62 | dpiPool_create ctx userCString userLen passCString passLen connCString connLen nullPtr paramsPtr connPtr 63 | status <- 64 | case additionalParams params of 65 | Nothing -> poolCreate nullPtr 66 | Just addParams -> 67 | withDefaultPoolCreateParams $ \defaultPoolParmsPtr -> do 68 | defaultPoolParams <- peek defaultPoolParmsPtr 69 | 70 | poke 71 | defaultPoolParmsPtr 72 | defaultPoolParams 73 | { dpi_minSessions = fromIntegral $ minSessions addParams 74 | , dpi_maxSessions = fromIntegral $ maxSessions addParams 75 | , dpi_sessionIncrement = fromIntegral $ sessionIncrement addParams 76 | , dpi_pingInterval = fromIntegral $ pingInterval addParams 77 | , dpi_pingTimeout = fromIntegral $ pingTimeout addParams 78 | , dpi_homogeneous = fromIntegral $ homogeneous addParams 79 | , dpi_getMode = getMode addParams 80 | , dpi_timeout = fromIntegral $ timeout addParams 81 | , dpi_waitTimeout = fromIntegral $ waitTimeout addParams 82 | , dpi_maxLifetimeSession = fromIntegral $ maxLifetimeSession addParams 83 | , dpi_maxSessionsPerShard = fromIntegral $ maxSessionsPerShard addParams 84 | } 85 | 86 | poolCreate defaultPoolParmsPtr 87 | 88 | throwOracleError status 89 | peek connPtr 90 | fptr <- newForeignPtr_ poolPtr 91 | addForeignPtrFinalizer dpiPool_release_finalizer fptr 92 | addForeignPtrFinalizer dpiPool_close_finalizer fptr 93 | pure (Pool fptr) 94 | 95 | foreign import ccall unsafe "dpiPool_create" 96 | dpiPool_create :: 97 | -- | const dpiContext *context 98 | DPIContext -> 99 | -- | const char *userName 100 | CString -> 101 | -- | uint32_t userNameLength 102 | CUInt -> 103 | -- | const char *password 104 | CString -> 105 | -- | uint32_t passwordLength 106 | CUInt -> 107 | -- | const char *connectString 108 | CString -> 109 | -- | uint32_t connLength 110 | CUInt -> 111 | -- | const dpiCommonCreateParams *commonParams 112 | Ptr DPICommonCreateParams -> 113 | -- | const dpiPoolCreateParams *createParams 114 | Ptr DPIPoolCreateParams -> 115 | -- | dpiPool **pool 116 | Ptr DPIPool -> 117 | IO CInt 118 | 119 | foreign import ccall "&close_pool_default" 120 | dpiPool_close_finalizer :: FunPtr (Ptr DPIPool -> IO ()) 121 | 122 | foreign import ccall "&dpiPool_release" 123 | dpiPool_release_finalizer :: FunPtr (Ptr DPIPool -> IO ()) 124 | 125 | -- | Close a session pool. 126 | closePool :: Pool -> IO () 127 | closePool (Pool pool) = finalizeForeignPtr pool 128 | 129 | -- | Bracket a computation between creating and closing a session pool. 130 | withPool :: ConnectionParams -> (Pool -> IO c) -> IO c 131 | withPool params = bracket (createPool params) closePool 132 | 133 | -- | Acquire a connection from a session pool. 134 | acquireConnection :: Pool -> IO Connection 135 | acquireConnection (Pool poolFptr) = do 136 | (DPIConn connPtr) <- withForeignPtr poolFptr $ \pool -> do 137 | alloca $ \conn -> do 138 | throwOracleError =<< acquire_connection pool conn 139 | peek conn 140 | fptr <- newForeignPtr_ connPtr 141 | addForeignPtrFinalizer dpiConn_release_finalizer fptr 142 | addForeignPtrFinalizer dpiConn_close_finalizer fptr 143 | pure (Connection fptr) 144 | 145 | foreign import ccall unsafe "acquire_connection" 146 | acquire_connection :: 147 | -- | dpiPool *pool 148 | Ptr DPIPool -> 149 | -- | dpiConn **conn 150 | Ptr DPIConn -> 151 | IO CInt 152 | 153 | -- | Bracket a computation between acquiring a connection from a session pool and releasing the connection. 154 | withPoolConnection :: Pool -> (Connection -> IO c) -> IO c 155 | withPoolConnection pool = bracket (acquireConnection pool) close 156 | -------------------------------------------------------------------------------- /src/Database/Oracle/Simple.hs: -------------------------------------------------------------------------------- 1 | ------------------------------------------------------------------------------ 2 | 3 | ------------------------------------------------------------------------------ 4 | 5 | -- | 6 | -- Module: Database.Oracle.Simple 7 | -- Copyright: H-E-B (c) 2025. 8 | -- License: BSD3 9 | -- Maintainer: David Johnson , khandkararjun@gmail.com 10 | -- Stability: experimental 11 | -- 12 | -- A mid-level client library for the Oracle database, aimed at ease of 13 | -- use and high performance. 14 | -- 15 | -- Modern bindings to Oracle odpic C library. 16 | module Database.Oracle.Simple 17 | ( -- * Writing queries 18 | -- $use 19 | -- $querytype 20 | -- $subst 21 | module Query 22 | 23 | -- * Statements that do not return results 24 | , module Execute 25 | 26 | -- * Connection management 27 | , module Connection 28 | 29 | -- ** Pool connection 30 | , module Pool 31 | 32 | -- * Transaction handling 33 | , module Transaction 34 | 35 | -- * Advanced Queuing 36 | -- $queue 37 | , module Queue 38 | , module Object 39 | 40 | -- * Error Handling 41 | , module Error 42 | 43 | -- * ToField TypeClass 44 | , module ToField 45 | 46 | -- * FromField TypeClass 47 | , module FromField 48 | 49 | -- * JSON Support 50 | , module JSON 51 | 52 | -- * FromRow Instance 53 | , module FromRow 54 | 55 | -- * ToRow Instance 56 | , module ToRow 57 | 58 | -- * Miscellaneous 59 | , module Export 60 | , module LOB 61 | ) where 62 | 63 | import Database.Oracle.Simple.Execute as Execute 64 | import Database.Oracle.Simple.FromField as FromField 65 | import Database.Oracle.Simple.FromRow as FromRow 66 | import Database.Oracle.Simple.Internal as Connection 67 | ( AdditionalConnectionParams (..) 68 | , Connection (..) 69 | , ConnectionCreateParams (..) 70 | , ConnectionParams (..) 71 | , DPIConn (..) 72 | , DPIPool (..) 73 | , DPIPoolCreateParams (..) 74 | , close 75 | , connect 76 | , defaultAdditionalConnectionParams 77 | , withConnection 78 | , withDefaultPoolCreateParams 79 | ) 80 | import Database.Oracle.Simple.Internal as Error 81 | ( ErrorInfo (..) 82 | , OracleError (..) 83 | , renderErrorInfo 84 | , throwOracleError 85 | ) 86 | import Database.Oracle.Simple.Internal as Export hiding 87 | ( AdditionalConnectionParams (..) 88 | , Connection (..) 89 | , ConnectionCreateParams (..) 90 | , ConnectionParams (..) 91 | , DPIConn (..) 92 | , DPIPool (..) 93 | , DPIPoolCreateParams (..) 94 | , ErrorInfo (..) 95 | , OracleError (..) 96 | , connect 97 | , close 98 | , defaultAdditionalConnectionParams 99 | , renderErrorInfo 100 | , throwOracleError 101 | , withConnection 102 | , withDefaultPoolCreateParams 103 | ) 104 | import Database.Oracle.Simple.JSON as JSON 105 | import Database.Oracle.Simple.Object as Object 106 | import Database.Oracle.Simple.Pool as Pool 107 | import Database.Oracle.Simple.Query as Query 108 | import Database.Oracle.Simple.Queue as Queue 109 | import Database.Oracle.Simple.ToField as ToField 110 | import Database.Oracle.Simple.ToRow as ToRow 111 | import Database.Oracle.Simple.Transaction as Transaction 112 | import Database.Oracle.Simple.LOB as LOB 113 | 114 | -- $use 115 | -- This library provides a 'Query' type and a parameter substitution 116 | -- facility to address both ease of use and security. 117 | 118 | -- $querytype 119 | -- 120 | -- To most easily construct a query and write your query as a normal literal string. 121 | -- 122 | -- > import Database.Oracle.Simple 123 | -- > 124 | -- > main :: IO () 125 | -- > main = do 126 | -- > let stmt = "select 2 + 2" 127 | -- > conn <- connect (ConnectionParams "username" "password" "localhost/Free" Nothing) 128 | -- > rows <- query_ conn stmt :: IO [Only Double] 129 | -- > print rows 130 | -- 131 | -- A 'Query' value does not represent the actual query that will be 132 | -- executed, but is a template for constructing the final query. 133 | 134 | -- $subst 135 | -- 136 | -- Since applications need to be able to construct queries with 137 | -- parameters that change, this library provides a query substitution 138 | -- capability. 139 | -- For example, 140 | -- 141 | -- > {# LANGUAGE TypeApplications #} 142 | -- > 143 | -- > main :: IO () 144 | -- > main = do 145 | -- > conn <- connect (ConnectionParams "username" "password" "localhost/Free" Nothing) 146 | -- > void $ execute_ conn "create table test(text_column number(10,0) primary key)" 147 | -- > void $ execute conn "insert into test values(:1)" (Only @Int 1) 148 | -- > results <- query_ conn "select * from test" :: IO [Only Int] 149 | -- > print result 150 | -- 151 | -- Output: 152 | -- 153 | -- > [Only {fromOnly = 1}] 154 | 155 | -- $queue 156 | -- 157 | -- Oracle Database Advanced Queuing provides database-integrated message queuing functionality. 158 | -- It is built on top of Oracle Streams and leverages the functions of Oracle Database so that messages can be stored persistently, 159 | -- propagated between queues on different computers and databases, and transmitted using Oracle Net Services and HTTP(S). 160 | -- Because Oracle Database Advanced Queuing is implemented in database tables, all operational benefits of high availability, 161 | -- scalability, and reliability are also applicable to queue data. Standard database features such as recovery, restart, 162 | -- and security are supported by Oracle Database Advanced Queuing. You can use database development and management tools 163 | -- such as Oracle Enterprise Manager to monitor queues. Like other database tables, queue tables can be imported and exported. 164 | -- Messages can be queried using standard SQL. This means that you can use SQL to access the message properties, 165 | -- the message history, and the payload. With SQL access you can also audit and track messages. 166 | -- All available SQL technology, such as indexes, can be used to optimize access to messages 167 | -- 168 | -- > import Database.Oracle.Simple 169 | -- > 170 | -- > params :: ConnectionParams 171 | -- > params = ConnectionParams "username" "password" "localhost:1521/free" Nothing 172 | -- > 173 | -- > main :: IO () 174 | -- > main = do 175 | -- > conn <- connect params 176 | -- > msgProps <- genMsgProps conn 177 | -- > queue <- genQueue conn "TEST_QUEUE" 178 | -- > 179 | -- > setMsgPropsPayLoadBytes msgProps (BSC.pack "Hello from Haskell!") 180 | -- > 181 | -- > void $ enqOne queue msgProps 182 | -- > newMsgProps <- deqOne queue 183 | -- > mPayload <- getMsgPropsPayLoadBytes newMsgProps 184 | -- > 185 | -- > print mPayload 186 | -- > queueRelease queue 187 | -- 188 | -------------------------------------------------------------------------------- /src/Database/Oracle/Simple/FromField.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE RankNTypes #-} 6 | 7 | module Database.Oracle.Simple.FromField 8 | ( FieldParser (..), 9 | FromField (..), 10 | ReadDPIBuffer, 11 | dpiTimeStampToUTCTime, 12 | getInt64, 13 | getFloat, 14 | getDouble, 15 | getString, 16 | getBool, 17 | getTimestamp, 18 | getLOB_, 19 | ) 20 | where 21 | 22 | import Control.Exception (Exception, SomeException, catch, displayException, evaluate, throwIO) 23 | import Control.Monad ((<=<)) 24 | import qualified Data.ByteString as BS 25 | import Data.Coerce (coerce) 26 | import Data.Fixed (Fixed (..), Pico) 27 | import Data.Int (Int64) 28 | import Data.Proxy (Proxy (..)) 29 | import qualified Data.Text as T 30 | import qualified Data.Text.Encoding as TE 31 | import qualified Data.Time as Time 32 | import Data.Word (Word64) 33 | import Foreign.C.String (peekCString) 34 | import Foreign.Ptr (Ptr) 35 | import Foreign.Storable.Generic (peek) 36 | 37 | import Database.Oracle.Simple.Internal 38 | 39 | -- | A type that may be parsed from a database field. 40 | class FromField a where 41 | fromDPINativeType :: Proxy a -> DPINativeType 42 | -- ^ The DPI native type for the value in the data buffer. 43 | 44 | fromField :: FieldParser a 45 | -- ^ Retrieve a value of type @a@ from the data buffer. 46 | 47 | instance Functor FieldParser where 48 | fmap f FieldParser {..} = FieldParser (fmap f <$> readDPIDataBuffer) 49 | 50 | instance FromField Double where 51 | fromDPINativeType _ = DPI_NATIVE_TYPE_DOUBLE 52 | fromField = FieldParser getDouble 53 | 54 | instance FromField Float where 55 | fromDPINativeType _ = DPI_NATIVE_TYPE_FLOAT 56 | fromField = FieldParser getFloat 57 | 58 | instance FromField DPITimestamp where 59 | fromDPINativeType _ = DPI_NATIVE_TYPE_TIMESTAMP 60 | fromField = FieldParser getTimestamp 61 | 62 | instance FromField T.Text where 63 | fromDPINativeType _ = DPI_NATIVE_TYPE_BYTES 64 | fromField = FieldParser getText 65 | 66 | instance FromField String where 67 | fromDPINativeType _ = DPI_NATIVE_TYPE_BYTES 68 | fromField = FieldParser getString 69 | 70 | instance FromField Int64 where 71 | fromDPINativeType _ = DPI_NATIVE_TYPE_INT64 72 | fromField = FieldParser getInt64 73 | 74 | instance FromField Word64 where 75 | fromDPINativeType _ = DPI_NATIVE_TYPE_UINT64 76 | fromField = FieldParser getWord64 77 | 78 | instance FromField Bool where 79 | fromDPINativeType _ = DPI_NATIVE_TYPE_BOOLEAN 80 | fromField = FieldParser getBool 81 | 82 | instance FromField Int where 83 | fromDPINativeType _ = fromDPINativeType (Proxy @Int64) 84 | fromField = fromIntegral <$> fromField @Int64 85 | 86 | instance (FromField a) => FromField (Maybe a) where 87 | fromDPINativeType _ = fromDPINativeType (Proxy @a) 88 | fromField = FieldParser $ \ptr -> do 89 | result <- dpiData_getIsNull ptr 90 | if result == 1 91 | then pure Nothing 92 | else Just <$> readDPIDataBuffer (fromField @a) ptr 93 | 94 | instance FromField Time.UTCTime where 95 | fromDPINativeType _ = DPI_NATIVE_TYPE_TIMESTAMP 96 | fromField = dpiTimeStampToUTCTime <$> fromField 97 | 98 | instance FromField DPILob where 99 | fromDPINativeType _ = DPI_NATIVE_TYPE_LOB 100 | fromField = FieldParser getLOB_ 101 | 102 | -- Question: For large object should the type be lazy bytestring 103 | foreign import ccall "dpiData_getLOB" 104 | dpiData_getLOB :: Ptr (DPIData ReadBuffer) -> IO DPILob 105 | 106 | getLOB_ :: ReadDPIBuffer DPILob 107 | getLOB_ = dpiData_getLOB 108 | 109 | -- | Converts a 'DPITimestamp' to a 'Time.UTCTime'. 110 | -- This function is useful for working with timestamps in Haskell's time library. 111 | dpiTimeStampToUTCTime :: DPITimestamp -> Time.UTCTime 112 | dpiTimeStampToUTCTime dpi = 113 | let DPITimestamp {..} = dpiTimeStampToUTCDPITimeStamp dpi 114 | local = Time.LocalTime d tod 115 | d = Time.fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day) 116 | tod = Time.TimeOfDay (fromIntegral hour) (fromIntegral minute) (fromIntegral second + picos) 117 | picos = MkFixed (fromIntegral fsecond * 1000) :: Pico 118 | in Time.localTimeToUTC Time.utc local 119 | 120 | -- | Encapsulates all information needed to parse a field as a Haskell value. 121 | newtype FieldParser a = FieldParser 122 | { readDPIDataBuffer :: ReadDPIBuffer a 123 | -- ^ A function that retrieves a value of type @a@ from the DPI data buffer. 124 | } 125 | 126 | instance Applicative FieldParser where 127 | pure x = FieldParser $ \_ -> pure x 128 | FieldParser f <*> FieldParser g = FieldParser $ \ptr -> do 129 | f' <- f ptr 130 | x <- g ptr 131 | pure (f' x) 132 | 133 | instance Monad FieldParser where 134 | FieldParser g >>= f = FieldParser $ \ptr -> do 135 | x <- g ptr 136 | readDPIDataBuffer (f x) ptr 137 | 138 | -- | Alias for a function that retrieves a value of type @a@ from the DPI data buffer 139 | type ReadDPIBuffer a = Ptr (DPIData ReadBuffer) -> IO a 140 | 141 | -- ** @ReadDPIBuffer@s for common types 142 | 143 | -- | Get a Double value from the data buffer 144 | getDouble :: ReadDPIBuffer Double 145 | getDouble = coerce <$> dpiData_getDouble 146 | 147 | -- | Get a Float value from the data buffer 148 | getFloat :: ReadDPIBuffer Float 149 | getFloat = coerce <$> dpiData_getFloat 150 | 151 | -- | Get an Int64 value from the data buffer. 152 | getInt64 :: ReadDPIBuffer Int64 153 | getInt64 = dpiData_getInt64 154 | 155 | -- | Get a Word64 value from the data buffer. 156 | getWord64 :: ReadDPIBuffer Word64 157 | getWord64 = dpiData_getUint64 158 | 159 | -- | Get a boolean value from the data buffer. 160 | getBool :: ReadDPIBuffer Bool 161 | getBool ptr = (== 1) <$> dpiData_getBool ptr 162 | 163 | {- | Get Text from the data buffer. 164 | Supports ASCII, UTF-8 and UTF-16 big- and little-endian encodings. 165 | Throws 'FieldParseError' if any other encoding is encountered. 166 | -} 167 | getText :: ReadDPIBuffer T.Text 168 | getText = buildText <=< peek <=< dpiData_getBytes 169 | where 170 | buildText DPIBytes {..} = do 171 | gotBytes <- BS.packCStringLen (dpiBytesPtr, fromIntegral dpiBytesLength) 172 | encoding <- peekCString dpiBytesEncoding 173 | decodeFn <- case encoding of 174 | "ASCII" -> pure TE.decodeASCII 175 | "UTF-8" -> pure TE.decodeUtf8 176 | "UTF-16BE" -> pure TE.decodeUtf16BE 177 | "UTF-16LE" -> pure TE.decodeUtf16LE 178 | otherEnc -> throwIO $ UnsupportedEncoding otherEnc 179 | evaluate (decodeFn gotBytes) 180 | `catch` ( \(e :: SomeException) -> throwIO (ByteDecodeError encoding (displayException e)) 181 | ) 182 | 183 | -- | Get Text from the data buffer 184 | getString :: ReadDPIBuffer String 185 | getString = fmap T.unpack <$> getText 186 | 187 | -- | Get a `DPITimestamp` from the buffer 188 | getTimestamp :: ReadDPIBuffer DPITimestamp 189 | getTimestamp = peek <=< dpiData_getTimestamp 190 | 191 | -- | Errors encountered when parsing a database field. 192 | data FieldParseError 193 | = -- | We encountered an encoding other than ASCII, UTF-8 or UTF-16 194 | UnsupportedEncoding String 195 | | -- | Failed to decode bytes using stated encoding 196 | ByteDecodeError String String 197 | deriving (Show) 198 | 199 | instance Exception FieldParseError where 200 | displayException (UnsupportedEncoding fpeOtherEncoding) = 201 | "Field Parse Error: Encountered unsupported text encoding '" 202 | <> fpeOtherEncoding 203 | <> "'. Supported encodings: ASCII, UTF-8, UTF-16BE, UTF-16LE." 204 | displayException (ByteDecodeError fpeEncoding fpeErrorMsg) = 205 | "Field Parse Error: Failed to decode bytes as " <> fpeEncoding <> ": " <> fpeErrorMsg 206 | -------------------------------------------------------------------------------- /src/Database/Oracle/Simple/Object.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE RankNTypes #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE ViewPatterns #-} 11 | 12 | module Database.Oracle.Simple.Object 13 | ( genObject 14 | , getObjectType 15 | , getObjAttributes 16 | , setObjAttribute 17 | , getObjAttribute 18 | , releaseObject 19 | , getObjectInfo 20 | , getAttributeInfo 21 | , DPIObjectType (..) 22 | , DPIObject (..) 23 | , ObjectTypeInfo (numAttributes, isCollection) 24 | ) where 25 | 26 | import Data.Char (toUpper) 27 | import Data.Proxy (Proxy (..)) 28 | import Database.Oracle.Simple.FromField 29 | import Database.Oracle.Simple.Internal 30 | import Database.Oracle.Simple.ToField 31 | import Foreign (alloca, peekArray, withForeignPtr) 32 | import Foreign.C.String 33 | import Foreign.C.Types (CInt (..), CSChar, CShort, CUChar, CUInt (..), CUShort (..)) 34 | import Foreign.Ptr (Ptr) 35 | import Foreign.Storable.Generic (GStorable, Storable (..)) 36 | import GHC.Generics 37 | 38 | -- | `DPIObjectType` is a newtype wrapper around a pointer to a DPI objectType. 39 | -- | It is primarily used for representing and interacting with Objects 40 | newtype DPIObjectType = DPIObjectType (Ptr DPIObjectType) 41 | deriving (Show, Eq) 42 | deriving newtype (Storable) 43 | 44 | -- | `DPIObject` is a newtype wrapper around a pointer to a DPI object. 45 | -- | It is primarily used for representing and interacting with objects 46 | newtype DPIObject = DPIObject (Ptr DPIObject) 47 | deriving (Show, Eq) 48 | deriving newtype (Storable) 49 | 50 | -- | `DPIObjectAttr` is a newtype wrapper around a pointer to a DPI Object Attribute. 51 | -- | It is primarily used for representing and interacting with objects 52 | newtype DPIObjectAttr = DPIObjectAttr (Ptr DPIObjectAttr) 53 | deriving (Show, Eq) 54 | deriving newtype (Storable) 55 | 56 | -- | `DPIObjectAttrInfo` is a newtype wrapper around a pointer to a DPI Object Attribute info. 57 | -- | It is primarily used for representing and interacting with objects 58 | data ObjectAttrInfo = ObjectAttrInfo 59 | { name :: CString 60 | , nameLength :: CUInt 61 | , typeInfo :: DPIDataTypeInfo 62 | } 63 | deriving (Show, Eq, Generic, GStorable) 64 | 65 | data DPIDataTypeInfo = DPIDataTypeInfo 66 | { oracleTypeNum :: CUInt 67 | , defaultNativeTypeNum :: CUInt 68 | , ociTypeCode :: CUShort 69 | , dbSizeInBytes :: CUInt 70 | , clientSizeInBytes :: CUInt 71 | , sizeInChars :: CUInt 72 | , precision :: CShort 73 | , scale :: CSChar 74 | , fsPrecision :: CUChar 75 | , objectType :: DPIObjectType 76 | , isJson :: CInt 77 | , domainSchema :: CString 78 | , domainSchemaLength :: CUInt 79 | , domainName :: CString 80 | , domainNameLength :: CUInt 81 | , numAnnotations :: CUInt 82 | , annotations :: Ptr () 83 | , isOson :: CInt 84 | , vectorDimensions :: CUInt 85 | , vectorFormat :: CUChar 86 | , vectorFlags :: CUChar 87 | } 88 | deriving (Eq, Show, Generic, GStorable) 89 | 90 | -- | This data structure contains metadata about the object type 91 | data ObjectTypeInfo = ObjectTypeInfo 92 | { schema :: CString 93 | , schemaLength :: CInt 94 | , name :: CString 95 | , nameLength :: CInt 96 | , isCollection :: Bool 97 | , elementTypeInfo :: DPIDataTypeInfo 98 | , numAttributes :: CUShort 99 | , packageName :: CString 100 | , packageNameLength :: CUInt 101 | } 102 | deriving (Eq, Show, GStorable, Generic) 103 | 104 | -- | Returns the value of one of the object’s attributes. 105 | getObjAttribute :: forall a. (FromField a) => DPIObject -> DPIObjectAttr -> IO a 106 | getObjAttribute obj objTypeAttr = do 107 | alloca $ \dpiDataPtr -> do 108 | throwOracleError 109 | =<< dpiObject_getAttributeValue 110 | obj 111 | objTypeAttr 112 | (dpiNativeTypeToUInt (fromDPINativeType (Proxy @a))) 113 | dpiDataPtr 114 | readDPIDataBuffer (fromField @a) dpiDataPtr 115 | 116 | foreign import ccall unsafe "dpiObject_getAttributeValue" 117 | dpiObject_getAttributeValue 118 | :: DPIObject 119 | -- ^ dpiObject * 120 | -> DPIObjectAttr 121 | -- ^ dpiObjectAttr* 122 | -> CUInt 123 | -- ^ dpiNativeTypeNum 124 | -> Ptr (DPIData ReadBuffer) 125 | -- ^ dpiData * 126 | -> IO CInt 127 | 128 | -- | Sets the value of one of the object’s attributes. 129 | setObjAttribute :: forall a. (ToField a) => DPIObject -> DPIObjectAttr -> a -> IO () 130 | setObjAttribute obj objTypeAttr val = do 131 | dataValue <- toField val 132 | let dataIsNull = case dataValue of 133 | AsNull -> 1 134 | _ -> 0 135 | alloca $ \dpiDataPtr -> do 136 | let dpiData = DPIData{..} 137 | poke dpiDataPtr (dpiData :: DPIData WriteBuffer) 138 | throwOracleError 139 | =<< dpiObject_setAttributeValue 140 | obj 141 | objTypeAttr 142 | (dpiNativeTypeToUInt (toDPINativeType (Proxy @a))) 143 | dpiDataPtr 144 | 145 | foreign import ccall unsafe "dpiObject_setAttributeValue" 146 | dpiObject_setAttributeValue 147 | :: DPIObject 148 | -- ^ dpiObject * 149 | -> DPIObjectAttr 150 | -- ^ dpiObjectAttr* 151 | -> CUInt 152 | -- ^ dpiNativeTypeNum 153 | -> Ptr (DPIData WriteBuffer) 154 | -- ^ dpiData * 155 | -> IO CInt 156 | 157 | -- | Returns the list of attributes that belong to the object type. 158 | getObjAttributes :: DPIObjectType -> Int -> IO [DPIObjectAttr] 159 | getObjAttributes objType n = do 160 | -- objInfo <- getObjectInfo objType 161 | alloca $ \objAttrsPtr -> do 162 | throwOracleError =<< dpiObjectType_getAttributes objType (fromIntegral n) objAttrsPtr 163 | peekArray n objAttrsPtr 164 | 165 | foreign import ccall unsafe "dpiObjectType_getAttributes" 166 | dpiObjectType_getAttributes 167 | :: DPIObjectType 168 | -- ^ dpiObjectType * 169 | -> CUShort 170 | -- ^ int16_t numAttributes 171 | -> Ptr DPIObjectAttr 172 | -- ^ dpiObjectAttr * 173 | -> IO CInt 174 | 175 | -- | Returns information about the object type. 176 | getObjectInfo :: DPIObjectType -> IO ObjectTypeInfo 177 | getObjectInfo objType = do 178 | alloca $ \objectTypeInfoPtr -> do 179 | throwOracleError =<< dpiObjectType_getInfo objType objectTypeInfoPtr 180 | peek objectTypeInfoPtr 181 | 182 | foreign import ccall unsafe "dpiObjectType_getInfo" 183 | dpiObjectType_getInfo 184 | :: DPIObjectType 185 | -- ^ dpiObjectType * 186 | -> Ptr ObjectTypeInfo 187 | -- ^ dpiObjectTypeInfo ** 188 | -> IO CInt 189 | 190 | {- 191 | The name is uppercased! Because here Oracle seems to be case-sensitive. 192 | -} 193 | 194 | -- | Looks up an object type by name in the database and returns a reference to it. 195 | -- | The name is uppercased! Because here Oracle seems to be case-sensitive. 196 | getObjectType :: Connection -> String -> IO DPIObjectType 197 | getObjectType (Connection fptr) objectName_ = do 198 | let objectName = map toUpper objectName_ 199 | withForeignPtr fptr $ \conn -> do 200 | withCStringLen objectName $ \(objectNameC, fromIntegral -> objectNameLen) -> do 201 | alloca $ \objectTypePtr -> do 202 | throwOracleError =<< dpiConn_getObjectType conn objectNameC objectNameLen objectTypePtr 203 | peek objectTypePtr 204 | 205 | foreign import ccall unsafe "dpiConn_getObjectType" 206 | dpiConn_getObjectType 207 | :: Ptr DPIConn 208 | -- ^ dpiConn * 209 | -> CString 210 | -- ^ char * name 211 | -> CUInt 212 | -- ^ cuint32_t nameLength 213 | -> Ptr DPIObjectType 214 | -- ^ dpiObjectType ** objType 215 | -> IO CInt 216 | 217 | -- | Creates an object of the specified type and returns a reference to it. 218 | genObject :: DPIObjectType -> IO DPIObject 219 | genObject objType = do 220 | alloca $ \objectPtr -> do 221 | throwOracleError =<< dpiObjectType_createObject objType objectPtr 222 | peek objectPtr 223 | 224 | foreign import ccall unsafe "dpiObjectType_createObject" 225 | dpiObjectType_createObject 226 | :: DPIObjectType 227 | -- ^ dpiObjectType * 228 | -> Ptr DPIObject 229 | -- ^ dpiObject ** obj 230 | -> IO CInt 231 | 232 | -- | Returns information about the attribute. 233 | getAttributeInfo :: DPIObjectAttr -> IO ObjectAttrInfo 234 | getAttributeInfo objAttr = do 235 | alloca $ \objectAttrInfoPtr -> do 236 | throwOracleError =<< dpiObjectAttr_getInfo objAttr objectAttrInfoPtr 237 | peek objectAttrInfoPtr 238 | 239 | foreign import ccall unsafe "dpiObjectAttr_getInfo" 240 | dpiObjectAttr_getInfo 241 | :: DPIObjectAttr 242 | -- ^ dpiObjectAttr * 243 | -> Ptr ObjectAttrInfo 244 | -- ^ dpiObjectAttrInfo * 245 | -> IO CInt 246 | 247 | -- | Releases a reference to the object. 248 | releaseObject :: DPIObject -> IO () 249 | releaseObject obj = do 250 | throwOracleError =<< dpiObject_release obj 251 | 252 | foreign import ccall unsafe "dpiObject_release" 253 | dpiObject_release 254 | :: DPIObject 255 | -- ^ dpiObject * 256 | -> IO CInt 257 | -------------------------------------------------------------------------------- /src/Database/Oracle/Simple/JSON.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingStrategies #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | {-# OPTIONS_GHC -Wno-missed-specialisations #-} -- suppressing fromFloatDigits warning 11 | 12 | module Database.Oracle.Simple.JSON (AesonField (..), JsonDecodeError (..), DPIJsonNode(..), getJson, DPIJson(..), dpiJson_getValue, parseJson) where 13 | 14 | import Control.Exception (Exception (displayException), SomeException, catch, evaluate, throwIO) 15 | import Control.Monad (void, (<=<)) 16 | import qualified Data.Aeson as Aeson 17 | import Data.Aeson.KeyMap as KeyMap 18 | import qualified Data.ByteString as BS 19 | import qualified Data.ByteString.Char8 as C8 20 | import qualified Data.ByteString.Lazy as LBS 21 | import Data.Coerce (coerce) 22 | import Data.Scientific (fromFloatDigits) 23 | import Data.String (fromString) 24 | import Data.Text.Encoding (decodeUtf8) 25 | import qualified Data.Vector as Vector 26 | import Foreign (Ptr, Storable, alloca, peekArray) 27 | import Foreign.C (CDouble (CDouble), CInt (CInt), CString, CUInt (CUInt), peekCStringLen) 28 | import Foreign.Storable.Generic (GStorable, Storable(..)) 29 | import Foreign.Ptr (castPtr, plusPtr) 30 | import GHC.Generics (Generic) 31 | 32 | import Database.Oracle.Simple.FromField (FieldParser (FieldParser), FromField (fromDPINativeType, fromField), ReadDPIBuffer) 33 | import Database.Oracle.Simple.Internal 34 | ( DPIBytes (DPIBytes, dpiBytesLength, dpiBytesPtr), 35 | DPIData, 36 | DPINativeType 37 | ( DPI_NATIVE_TYPE_BOOLEAN, 38 | DPI_NATIVE_TYPE_BYTES, 39 | DPI_NATIVE_TYPE_DOUBLE, 40 | DPI_NATIVE_TYPE_JSON, 41 | DPI_NATIVE_TYPE_JSON_ARRAY, 42 | DPI_NATIVE_TYPE_JSON_OBJECT, 43 | DPI_NATIVE_TYPE_NULL 44 | ), 45 | DPIOracleType (DPI_ORACLE_TYPE_NUMBER), 46 | ReadBuffer, 47 | WriteBuffer (AsBytes), 48 | mkDPIBytesUTF8, 49 | ) 50 | import Database.Oracle.Simple.ToField (ToField (toDPINativeType, toField)) 51 | 52 | {- | Use this newtype with the DerivingVia extension to 53 | derive ToField/FromField instances for types that you want 54 | to serialize via their Aeson instance. 55 | -} 56 | newtype AesonField a = AesonField {unAesonField :: a} 57 | deriving newtype (Aeson.ToJSON, Aeson.FromJSON) 58 | 59 | instance (Aeson.ToJSON a) => ToField (AesonField a) where 60 | toDPINativeType _ = DPI_NATIVE_TYPE_BYTES 61 | 62 | -- Oracle allows JSON data to be inserted using the character API. 63 | toField = 64 | fmap AsBytes 65 | . mkDPIBytesUTF8 66 | . C8.unpack 67 | . LBS.toStrict 68 | . Aeson.encode 69 | . unAesonField 70 | 71 | -- | For use with columns that have @JSON@ data type (since Oracle 21c) 72 | instance (Aeson.FromJSON a) => FromField (AesonField a) where 73 | fromDPINativeType _ = DPI_NATIVE_TYPE_JSON 74 | 75 | -- ODPI does not support casting from DPI_ORACLE_TYPE_JSON to DPI_NATIVE_TYPE_BYTES. 76 | -- This means we need to build an aeson Value from the top-level DPIJsonNode. 77 | fromField = coerce (FieldParser (getJson @a)) 78 | 79 | -- | Reads a JSON object from a DPI buffer. 80 | -- This function is parameterized over any type that has an 'Aeson.FromJSON' instance. 81 | getJson :: (Aeson.FromJSON a) => ReadDPIBuffer a 82 | getJson = parseJson <=< peek <=< dpiJson_getValue <=< dpiData_getJson 83 | 84 | -- | Parses a 'DPIJsonNode' into a Haskell value. 85 | -- This function requires a type with an 'Aeson.FromJSON' instance to convert the JSON node. 86 | parseJson :: Aeson.FromJSON b => DPIJsonNode -> IO b 87 | parseJson topNode = do 88 | aesonValue <- buildValue topNode 89 | case Aeson.fromJSON aesonValue of 90 | Aeson.Error msg -> throwIO $ ParseError msg 91 | Aeson.Success a -> pure a 92 | 93 | -- Build Aeson values for various cases: 94 | -- Object 95 | buildValue :: DPIJsonNode -> IO Aeson.Value 96 | buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_JSON_OBJECT nodeValue) = do 97 | DPIJsonObject {..} <- peek =<< dpiDataBuffer_getAsJsonObject nodeValue 98 | fieldNamePtrs <- peekArray (fromIntegral djoNumFields) djoFieldNames 99 | fieldNameLengths <- fmap fromIntegral <$> peekArray (fromIntegral djoNumFields) djoFieldNameLengths 100 | ks <- mapM (fmap fromString . peekCStringLen) (zip fieldNamePtrs fieldNameLengths) 101 | values <- mapM buildValue =<< peekArray (fromIntegral djoNumFields) djoFields 102 | pure $ Aeson.Object $ KeyMap.fromList (zip ks values) 103 | -- Array 104 | buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_JSON_ARRAY nodeValue) = do 105 | DPIJsonArray {..} <- peek =<< dpiDataBuffer_getAsJsonArray nodeValue 106 | values <- mapM buildValue =<< peekArray (fromIntegral djaNumElements) djaElements 107 | pure $ Aeson.Array $ Vector.fromList values 108 | -- Number returned as DPIBytes 109 | buildValue (DPIJsonNode DPI_ORACLE_TYPE_NUMBER DPI_NATIVE_TYPE_BYTES nodeValue) = do 110 | DPIBytes {..} <- peek =<< dpiDataBuffer_getAsBytes nodeValue 111 | bytes <- BS.packCStringLen (dpiBytesPtr, fromIntegral dpiBytesLength) 112 | let numStr = C8.unpack bytes 113 | number <- evaluate (read numStr) `catch` (\(_ :: SomeException) -> throwIO $ InvalidNumber numStr) 114 | pure $ Aeson.Number number 115 | -- String 116 | buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_BYTES nodeValue) = do 117 | DPIBytes {..} <- peek =<< dpiDataBuffer_getAsBytes nodeValue 118 | bytes <- BS.packCStringLen (dpiBytesPtr, fromIntegral dpiBytesLength) 119 | pure $ Aeson.String (decodeUtf8 bytes) 120 | -- Number encoded as Double (will not fire as dpiJsonOptions_numberAsString is set) 121 | buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_DOUBLE nodeValue) = do 122 | doubleVal <- dpiDataBuffer_getAsDouble nodeValue 123 | pure $ Aeson.Number $ fromFloatDigits doubleVal 124 | -- Boolean literals (true, false) 125 | buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_BOOLEAN nodeValue) = do 126 | intVal <- dpiDataBuffer_getAsBoolean nodeValue 127 | pure $ Aeson.Bool (intVal == 1) 128 | -- Null literal (null) 129 | buildValue (DPIJsonNode _ DPI_NATIVE_TYPE_NULL _) = pure Aeson.Null 130 | -- All other DPI native types 131 | buildValue (DPIJsonNode _ nativeType _) = throwIO $ UnsupportedDPINativeType nativeType 132 | 133 | -- | Represents a JSON object in the Oracle database. 134 | -- The 'DPIJson' type wraps a pointer to a DPI JSON structure. 135 | newtype DPIJson = DPIJson (Ptr DPIJson) 136 | deriving (Show, Eq) 137 | deriving newtype (Storable) 138 | 139 | -- | Represents a JSON node in Oracle, including type numbers and value buffer. 140 | -- The 'DPIJsonNode' type is used for handling JSON data within Oracle operations. 141 | data DPIJsonNode = DPIJsonNode 142 | { djnOracleTypeNumber :: DPIOracleType -- ^ Oracle's type number for the JSON node. 143 | , djnNativeTypeNumber :: DPINativeType -- ^ Native type number for the JSON node. 144 | , djnValue :: Ptr ReadBuffer -- ^ Pointer to the buffer storing the node's value. 145 | } 146 | deriving (Eq, Show) 147 | 148 | instance Storable DPIJsonNode where 149 | sizeOf _ = sizeOf (undefined :: DPIOracleType) 150 | + sizeOf (undefined :: DPINativeType) 151 | + sizeOf (undefined :: Ptr ReadBuffer) 152 | alignment _ = alignment (undefined :: DPIOracleType) 153 | 154 | peek ptr = do 155 | let base = castPtr ptr 156 | DPIJsonNode 157 | <$> peek (base `plusPtr` 0) -- DPIOracleType 158 | <*> peek (base `plusPtr` sizeOf (undefined :: DPIOracleType)) -- DPINativeType 159 | <*> peek (base `plusPtr` sizeOf (undefined :: DPIOracleType) 160 | `plusPtr` sizeOf (undefined :: DPINativeType)) -- Ptr ReadBuffer 161 | poke ptr DPIJsonNode{..} = do 162 | let base = castPtr ptr 163 | poke (base `plusPtr` 0) djnOracleTypeNumber 164 | poke (base `plusPtr` sizeOf (undefined :: DPIOracleType)) djnNativeTypeNumber 165 | poke (base `plusPtr` sizeOf (undefined :: DPIOracleType) 166 | `plusPtr` sizeOf (undefined :: Ptr ReadBuffer)) djnValue 167 | 168 | data DPIJsonArray = DPIJsonArray 169 | { djaNumElements :: CUInt 170 | , djaElements :: Ptr DPIJsonNode 171 | , djaElementValues :: Ptr ReadBuffer 172 | } 173 | deriving (Generic) 174 | deriving anyclass (GStorable) 175 | 176 | data DPIJsonObject = DPIJsonObject 177 | { djoNumFields :: CUInt 178 | , djoFieldNames :: Ptr CString 179 | , djoFieldNameLengths :: Ptr CUInt 180 | , djoFields :: Ptr DPIJsonNode 181 | , fieldValues :: Ptr ReadBuffer 182 | } 183 | deriving (Generic) 184 | deriving anyclass (GStorable) 185 | 186 | foreign import ccall "dpiData_getJson" 187 | dpiData_getJson :: Ptr (DPIData ReadBuffer) -> IO DPIJson 188 | 189 | foreign import ccall "dpiJson_getValue" 190 | dpiJson_getValue' :: DPIJson -> CUInt -> Ptr (Ptr DPIJsonNode) -> IO CInt 191 | 192 | -- | Retrieves the value of a JSON object as a pointer to a 'DPIJsonNode'. 193 | -- This function performs an IO action to extract the JSON node from a 'DPIJson'. 194 | dpiJson_getValue :: DPIJson -> IO (Ptr DPIJsonNode) 195 | dpiJson_getValue dpiJson = alloca $ \ptr -> do 196 | let dpiJsonOptions_numberAsString = 0x01 -- return data from numeric fields as DPIBytes 197 | void $ dpiJson_getValue' dpiJson dpiJsonOptions_numberAsString ptr 198 | peek ptr 199 | 200 | foreign import ccall "dpiDataBuffer_getAsJsonObject" 201 | dpiDataBuffer_getAsJsonObject :: Ptr ReadBuffer -> IO (Ptr DPIJsonObject) 202 | 203 | foreign import ccall "dpiDataBuffer_getAsJsonArray" 204 | dpiDataBuffer_getAsJsonArray :: Ptr ReadBuffer -> IO (Ptr DPIJsonArray) 205 | 206 | foreign import ccall "dpiDataBuffer_getAsBytes" 207 | dpiDataBuffer_getAsBytes :: Ptr ReadBuffer -> IO (Ptr DPIBytes) 208 | 209 | foreign import ccall "dpiDataBuffer_getAsBoolean" 210 | dpiDataBuffer_getAsBoolean :: Ptr ReadBuffer -> IO CInt 211 | 212 | foreign import ccall "dpiDataBuffer_getAsDouble" 213 | dpiDataBuffer_getAsDouble :: Ptr ReadBuffer -> IO CDouble 214 | 215 | -- | Represents errors that may occur during JSON decoding. 216 | -- 'JsonDecodeError' includes specific errors for invalid numbers, 217 | -- parsing errors, and unsupported native types. 218 | data JsonDecodeError = InvalidNumber String | ParseError String | UnsupportedDPINativeType DPINativeType 219 | deriving (Show) 220 | 221 | instance Exception JsonDecodeError where 222 | displayException (ParseError msg) = "Failed to parse JSON: " <> msg 223 | displayException (InvalidNumber numStr) = 224 | "While parsing JSON node, encountered invalid numeric value '" <> numStr <> "'" 225 | displayException (UnsupportedDPINativeType nativeType) = 226 | "While parsing JSON node, encountered unsupported DPI native type " <> show nativeType 227 | -------------------------------------------------------------------------------- /src/Database/Oracle/Simple/Transaction.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE RecordWildCards #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE ViewPatterns #-} 6 | 7 | module Database.Oracle.Simple.Transaction 8 | ( 9 | DPIXid (..), 10 | beginTransaction, 11 | commitTransaction, 12 | prepareCommit, 13 | withTransaction, 14 | commitIfNeeded, 15 | withSavepoint, 16 | ) where 17 | 18 | import Control.Exception (catch, throw) 19 | import Control.Monad (replicateM, void, when, (<=<)) 20 | import Data.UUID (UUID, toString) 21 | import Data.UUID.V4 (nextRandom) 22 | import Foreign (alloca, withForeignPtr) 23 | import Foreign.C.String (CString, withCStringLen) 24 | import Foreign.C.Types (CInt (CInt), CLong, CUInt (CUInt)) 25 | import Foreign.Ptr (Ptr ,castPtr) 26 | import Foreign.Storable (Storable(..)) 27 | import System.Random (getStdRandom, uniformR) 28 | 29 | import Database.Oracle.Simple.Execute (execute_) 30 | import Database.Oracle.Simple.Internal 31 | ( Connection (Connection), 32 | DPIConn, 33 | OracleError, 34 | throwOracleError, 35 | ) 36 | 37 | -- * Transactions 38 | 39 | {- | Execute an action in an SQL transaction. 40 | 41 | If the action succeeds, the transaction will be completed with commit before this function returns. 42 | If the action throws any kind of exception, the transaction is rolled back and the exception will be rethrown. 43 | 44 | Nesting transactions may result in undefined behavior. For /nesting-like/ functionality, use 'withSavepoint'. 45 | -} 46 | withTransaction :: Connection -> IO a -> IO a 47 | withTransaction conn action = do 48 | txHandle <- beginTransaction conn 49 | result <- 50 | action 51 | `catch` (\(e :: OracleError) -> rollbackTransaction conn txHandle >> throw e) 52 | commitIfNeeded conn txHandle 53 | pure result 54 | 55 | -- ** Low-level transaction interface 56 | 57 | data Transaction = Transaction 58 | { transactionId :: UUID 59 | , branchQualifier :: UUID 60 | } 61 | 62 | -- | Begin a new transaction. 63 | beginTransaction :: Connection -> IO Transaction 64 | beginTransaction (Connection fptr) = 65 | withForeignPtr fptr $ \conn -> do 66 | transactionId <- nextRandom 67 | branchQualifier <- nextRandom 68 | let dpiTransaction = Transaction {..} 69 | withDPIXid dpiTransaction $ \dpiXid -> 70 | throwOracleError =<< dpiConn_tpcBegin conn dpiXid 0 0x00000001 71 | pure dpiTransaction 72 | 73 | foreign import ccall unsafe "dpiConn_tpcBegin" 74 | dpiConn_tpcBegin :: 75 | Ptr DPIConn -> 76 | Ptr DPIXid -> 77 | CUInt -> 78 | CUInt -> 79 | IO CInt 80 | 81 | {- | Prepare transaction for commit. Returns whether the transaction needs to be committed. 82 | Attempting a commit if this function returns False may cause an exception. 83 | 84 | Use 'commitIfNeeded' to safely commit a transaction. 85 | -} 86 | prepareCommit :: Connection -> Transaction -> IO Bool 87 | prepareCommit (Connection fptr) dpiTransaction = 88 | withForeignPtr fptr $ \conn -> 89 | withDPIXid dpiTransaction $ \dpiXid -> 90 | alloca $ \commitNeededPtr -> do 91 | throwOracleError =<< dpiConn_tpcPrepare conn dpiXid commitNeededPtr 92 | (== 1) <$> peek commitNeededPtr 93 | 94 | foreign import ccall unsafe "dpiConn_tpcPrepare" 95 | dpiConn_tpcPrepare :: 96 | Ptr DPIConn -> 97 | Ptr DPIXid -> 98 | Ptr CInt -> 99 | IO CInt 100 | 101 | {- | Commit a transaction. 102 | Throws an exception if a commit was not necessary. 103 | Whether a commit is necessary can be checked by 'prepareCommit'. 104 | -} 105 | commitTransaction :: Connection -> Transaction -> IO () 106 | commitTransaction (Connection fptr) dpiTransaction = 107 | withForeignPtr fptr $ \conn -> 108 | withDPIXid dpiTransaction $ \dpiXid -> 109 | throwOracleError =<< dpiConn_tpcCommit conn dpiXid 0 110 | 111 | foreign import ccall unsafe "dpiConn_tpcCommit" 112 | dpiConn_tpcCommit :: 113 | Ptr DPIConn -> 114 | Ptr DPIXid -> 115 | CInt -> 116 | IO CInt 117 | 118 | -- | Roll back a transaction. 119 | rollbackTransaction :: Connection -> Transaction -> IO () 120 | rollbackTransaction (Connection fptr) dpiTransaction = 121 | withForeignPtr fptr $ \conn -> 122 | withDPIXid dpiTransaction $ throwOracleError <=< dpiConn_tpcRollback conn 123 | 124 | foreign import ccall unsafe "dpiConn_tpcRollback" 125 | dpiConn_tpcRollback :: 126 | Ptr DPIConn -> 127 | Ptr DPIXid -> 128 | IO CInt 129 | 130 | -- | Commit a transaction, if needed. 131 | commitIfNeeded :: Connection -> Transaction -> IO () 132 | commitIfNeeded conn dpiTransaction = do 133 | commitNeeded <- prepareCommit conn dpiTransaction 134 | when commitNeeded $ commitTransaction conn dpiTransaction 135 | 136 | -- | This data structure represents an Oracle database identifier, 137 | -- | which includes a format ID and other details such as the global transaction ID and branch qualifier. 138 | data DPIXid = DPIXid 139 | { dpixFormatId :: CLong 140 | , dpixGlobalTransactionId :: CString 141 | , dpixGlobalTransactionIdLength :: CUInt 142 | , dpixBranchQualifier :: CString 143 | , dpixBranchQualifierLength :: CUInt 144 | } 145 | deriving (Show, Eq) 146 | 147 | instance Storable DPIXid where 148 | sizeOf _ = 149 | let 150 | -- Sizes of fields 151 | sizeFormatId = sizeOf (undefined :: CLong) 152 | sizeTransactionId = sizeOf (undefined :: CString) 153 | sizeTransactionIdLength = sizeOf (undefined :: CUInt) 154 | sizeQualifier = sizeOf (undefined :: CString) 155 | sizeQualifierLength = sizeOf (undefined :: CUInt) 156 | 157 | -- Alignments of fields 158 | alignFormatId = alignment (undefined :: CLong) 159 | alignTransactionId = alignment (undefined :: CString) 160 | alignTransactionIdLength = alignment (undefined :: CUInt) 161 | alignQualifier = alignment (undefined :: CString) 162 | alignQualifierLength = alignment (undefined :: CUInt) 163 | 164 | -- Padding for each field 165 | paddingTransactionId = padding sizeFormatId alignTransactionId 166 | paddingTransactionIdLength = padding (sizeTransactionId + paddingTransactionId) alignTransactionIdLength 167 | paddingQualifier = padding (sizeTransactionIdLength + paddingTransactionIdLength) alignQualifier 168 | paddingQualifierLength = padding (sizeQualifier + paddingQualifier) alignQualifierLength 169 | in 170 | sizeFormatId + 171 | paddingTransactionId + sizeTransactionId + 172 | paddingTransactionIdLength + sizeTransactionIdLength + 173 | paddingQualifier + sizeQualifier + 174 | paddingQualifierLength + sizeQualifierLength + 175 | -- Final padding to align the structure itself 176 | padding (sizeFormatId + 177 | paddingTransactionId + sizeTransactionId + 178 | paddingTransactionIdLength + sizeTransactionIdLength + 179 | paddingQualifier + sizeQualifier + 180 | paddingQualifierLength + sizeQualifierLength) alignFormatId 181 | 182 | alignment _ = alignment (undefined :: CLong) 183 | 184 | peek p = do 185 | let basePtr = castPtr p 186 | formatId <- peekByteOff basePtr 0 187 | 188 | let offsetTransactionId = alignedOffset 0 (sizeOf (undefined :: CLong)) (alignment (undefined :: CString)) 189 | transactionId <- peekByteOff basePtr offsetTransactionId 190 | 191 | let offsetTransactionIdLength = offsetTransactionId + sizeOf (undefined :: CString) 192 | transactionIdLength <- peekByteOff basePtr offsetTransactionIdLength 193 | 194 | let offsetQualifier = alignedOffset offsetTransactionIdLength (sizeOf (undefined :: CUInt)) (alignment (undefined :: CString)) 195 | qualifier <- peekByteOff basePtr offsetQualifier 196 | 197 | let offsetQualifierLength = offsetQualifier + sizeOf (undefined :: CString) 198 | qualifierLength <- peekByteOff basePtr offsetQualifierLength 199 | 200 | return $ DPIXid formatId transactionId transactionIdLength qualifier qualifierLength 201 | 202 | poke p (DPIXid formatId transactionId transactionIdLength qualifier qualifierLength) = do 203 | let basePtr = castPtr p 204 | pokeByteOff basePtr 0 formatId 205 | 206 | let offsetTransactionId = alignedOffset 0 (sizeOf (undefined :: CLong)) (alignment (undefined :: CString)) 207 | pokeByteOff basePtr offsetTransactionId transactionId 208 | 209 | let offsetTransactionIdLength = offsetTransactionId + sizeOf (undefined :: CString) 210 | pokeByteOff basePtr offsetTransactionIdLength transactionIdLength 211 | 212 | let offsetQualifier = alignedOffset offsetTransactionIdLength (sizeOf (undefined :: CUInt)) (alignment (undefined :: CString)) 213 | pokeByteOff basePtr offsetQualifier qualifier 214 | 215 | let offsetQualifierLength = offsetQualifier + sizeOf (undefined :: CString) 216 | pokeByteOff basePtr offsetQualifierLength qualifierLength 217 | 218 | -- Helper to calculate padding between fields 219 | padding :: Int -> Int -> Int 220 | padding size align = (align - size `mod` align) `mod` align 221 | 222 | -- Helper to calculate aligned offsets 223 | alignedOffset :: Int -> Int -> Int -> Int 224 | alignedOffset base size align = base + size + padding (base + size) align 225 | 226 | withDPIXid :: Transaction -> (Ptr DPIXid -> IO a) -> IO a 227 | withDPIXid Transaction {..} action = 228 | withCStringLen (toString transactionId) $ \(dpixGlobalTransactionId, fromIntegral -> dpixGlobalTransactionIdLength) -> 229 | withCStringLen (toString branchQualifier) $ \(dpixBranchQualifier, fromIntegral -> dpixBranchQualifierLength) -> 230 | let dpixFormatId = 115 -- chosen at our discretion, can be anything but 0 231 | in alloca $ \dpiPtr -> poke dpiPtr DPIXid {..} >> action dpiPtr 232 | 233 | -- * Savepoints 234 | 235 | {- | Create a savepoint, and roll back to it if an error occurs. This should only be used within a transaction. 236 | 237 | Savepoints may be nested. 238 | -} 239 | withSavepoint :: Connection -> IO a -> IO a 240 | withSavepoint conn action = do 241 | savepoint <- newSavepoint conn 242 | action 243 | `catch` (\(e :: OracleError) -> rollbackToSavepoint conn savepoint >> throw e) 244 | 245 | -- ** Low-level savepoint interface 246 | 247 | newtype Savepoint = Savepoint String 248 | deriving newtype (Show) 249 | 250 | -- | Create a new savepoint. This should only be used within a transaction. 251 | newSavepoint :: Connection -> IO Savepoint 252 | newSavepoint conn = do 253 | name <- genSavepointName 254 | _ <- execute_ conn ("savepoint " <> name) 255 | pure $ Savepoint name 256 | where 257 | genSavepointName = replicateM 8 (getStdRandom $ uniformR ('a', 'z')) 258 | 259 | -- | Roll back to a savepoint. 260 | rollbackToSavepoint :: Connection -> Savepoint -> IO () 261 | rollbackToSavepoint conn (Savepoint name) = void $ execute_ conn ("rollback to savepoint " <> name) 262 | -------------------------------------------------------------------------------- /src/Database/Oracle/Simple/LOB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingVia #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | 4 | -- | 5 | -- Module: Database.Oracle.Simple.LOB 6 | -- 7 | -- Implementation of handler functions for oracle's large objects (CLOB, BLOB, NCLOB, BFILE) 8 | module Database.Oracle.Simple.LOB 9 | ( LOBType (..) 10 | , LOBField (..) 11 | , withLOB 12 | , genLOB 13 | , readLOB 14 | , writeLOB 15 | , closeLOB 16 | , openLOBResource 17 | , closeLOBResource 18 | , readLOBBytes 19 | , getLOBType 20 | , setLOBVal 21 | , copyLOB 22 | , getLOBBufferSize 23 | , getLOBChunkSize 24 | , getLOBDirectoryAndFile 25 | , setLOBDirectoryAndFile 26 | , isLOBResoureOpen 27 | , doesLOBFileExists 28 | , getLOBSize 29 | , releaseLOB 30 | , trimLOBVal 31 | , dpiLobToByteString 32 | ) where 33 | 34 | import Control.Monad (when, (<=<)) 35 | import qualified Data.ByteString.Lazy.Char8 as BSLC 36 | import Data.Coerce (coerce) 37 | import Database.Oracle.Simple.FromField 38 | import Database.Oracle.Simple.Internal 39 | import Foreign 40 | import Foreign.C.String 41 | import Foreign.C.Types (CInt (..), CUInt (..), CULong (..)) 42 | 43 | -- | Represents the types of Oracle Large Objects (LOBs) such as CLOB, NCLOB, and BLOB. 44 | data LOBType = CLOB | NCLOB | BLOB 45 | deriving (Show, Eq) 46 | 47 | -- | Wraps a lazy ByteString to represent LOB fields. For writing FromField instance 48 | newtype LOBField = LOBField {unLOBField :: BSLC.ByteString} 49 | deriving (Show, Eq) 50 | 51 | instance FromField LOBField where 52 | fromDPINativeType _ = DPI_NATIVE_TYPE_LOB 53 | fromField = coerce $ FieldParser (dpiLobToByteString <=< getLOB_) 54 | 55 | -- | Converts a LOB to a lazy ByteString for easier manipulation and viewing. 56 | dpiLobToByteString :: DPILob -> IO BSLC.ByteString 57 | dpiLobToByteString lob = do 58 | lobSize <- getLOBSize lob 59 | chunkSize <- getLOBChunkSize lob 60 | readInChunks lob (fromIntegral chunkSize) 1 lobSize 61 | 62 | readInChunks :: DPILob -> Int64 -> Int64 -> Int64 -> IO BSLC.ByteString 63 | readInChunks lob chunkSize offset remaining 64 | | remaining <= 0 = return BSLC.empty 65 | | otherwise = do 66 | res <- readLOBBytes lob offset chunkSize 67 | let sizeRead = BSLC.length res 68 | when (sizeRead == 0) $ closeLOB lob 69 | rest <- readInChunks lob chunkSize (offset + sizeRead) (remaining - sizeRead) 70 | return $ res `BSLC.append` rest 71 | 72 | lobTypeToCUInt :: LOBType -> CUInt 73 | lobTypeToCUInt CLOB = dpiOracleTypeToUInt DPI_ORACLE_TYPE_CLOB 74 | lobTypeToCUInt NCLOB = dpiOracleTypeToUInt DPI_ORACLE_TYPE_NCLOB 75 | lobTypeToCUInt BLOB = dpiOracleTypeToUInt DPI_ORACLE_TYPE_BLOB 76 | 77 | cuintToLobType :: CUInt -> Maybe LOBType 78 | cuintToLobType 2018 = Just NCLOB -- DPI_ORACLE_TYPE_NCLOB 79 | cuintToLobType 2017 = Just CLOB -- DPI_ORACLE_TYPE_CLOB 80 | cuintToLobType 2019 = Just BLOB -- DPI_ORACLE_TYPE_BLOB 81 | cuintToLobType _ = Nothing 82 | 83 | -- x Higher level convenience functions x-- 84 | -- | Executes a function with a temporary LOB, ensuring the LOB is properly closed afterwards. 85 | withLOB :: Connection -> LOBType -> (DPILob -> IO ()) -> IO () 86 | withLOB conn lobType func = do 87 | lob <- genLOB conn lobType 88 | func lob 89 | closeLOB lob 90 | 91 | -- | Executes a function with a temporary LOB, ensuring the LOB is properly closed afterwards. 92 | genLOB :: Connection -> LOBType -> IO DPILob 93 | genLOB (Connection fptr) lobType = do 94 | withForeignPtr fptr $ \conn -> do 95 | alloca $ \dpiLobPtr -> do 96 | throwOracleError =<< dpiConn_newTempLob conn (lobTypeToCUInt lobType) dpiLobPtr 97 | peek dpiLobPtr 98 | 99 | foreign import ccall unsafe "dpiConn_newTempLob" 100 | dpiConn_newTempLob 101 | :: Ptr DPIConn 102 | -- ^ dpiConn * 103 | -> CUInt 104 | -- ^ dpiOracleTypeNum 105 | -> Ptr DPILob 106 | -- ^ dpiLob ** 107 | -> IO CInt 108 | 109 | -- | Closes a LOB to release associated resources. 110 | closeLOB :: DPILob -> IO () 111 | closeLOB lob = throwOracleError =<< dpiLob_close lob 112 | 113 | -- | Closes an open LOB resource without releasing the LOB. 114 | closeLOBResource :: DPILob -> IO () 115 | closeLOBResource lob = throwOracleError =<< dpiLob_closeResource lob 116 | 117 | foreign import ccall unsafe "dpiLob_close" 118 | dpiLob_close 119 | :: DPILob 120 | -- ^ dpiLob * 121 | -> IO CInt 122 | 123 | foreign import ccall unsafe "dpiLob_closeResource" 124 | dpiLob_closeResource 125 | :: DPILob 126 | -- ^ dpiLob * 127 | -> IO CInt 128 | 129 | -- | Copies a LOB, creating a new LOB with the same content. 130 | copyLOB :: DPILob -> IO DPILob 131 | copyLOB lob = do 132 | alloca $ \dpiLobPtr -> do 133 | throwOracleError =<< dpiLob_copy lob dpiLobPtr 134 | peek dpiLobPtr 135 | 136 | foreign import ccall unsafe "dpiLob_copy" 137 | dpiLob_copy 138 | :: DPILob 139 | -- ^ dpiLob * 140 | -> Ptr DPILob 141 | -- ^ dpiLob ** 142 | -> IO CInt 143 | 144 | -- | Gets the buffer size needed to read a specified number of characters from a LOB. 145 | getLOBBufferSize :: DPILob -> Int64 -> IO Int64 146 | getLOBBufferSize lob sizeInChars = do 147 | alloca $ \sizeInBytesPtr -> do 148 | throwOracleError 149 | =<< dpiLob_getBufferSize lob (CULong $ fromIntegral sizeInChars) sizeInBytesPtr 150 | fromIntegral <$> peek sizeInBytesPtr 151 | 152 | foreign import ccall unsafe "dpiLob_getBufferSize" 153 | dpiLob_getBufferSize 154 | :: DPILob 155 | -- ^ dpiLob * 156 | -> CULong 157 | -- ^ sizeInChars 158 | -> Ptr CULong 159 | -- ^ sizeInBytes 160 | -> IO CInt 161 | 162 | -- | Retrieves the chunk size for LOB read/write operations. 163 | getLOBChunkSize :: DPILob -> IO Int 164 | getLOBChunkSize lob = do 165 | alloca $ \sizePtr -> do 166 | throwOracleError 167 | =<< dpiLob_getChunkSize lob sizePtr 168 | fromIntegral <$> peek sizePtr 169 | 170 | foreign import ccall unsafe "dpiLob_getChunkSize" 171 | dpiLob_getChunkSize 172 | :: DPILob 173 | -- ^ dpiLob * 174 | -> Ptr CUInt 175 | -- ^ uint32_t size 176 | -> IO CInt 177 | 178 | -- | Gets the directory and file name associated with a BFILE LOB. 179 | getLOBDirectoryAndFile :: DPILob -> IO (String, String) 180 | getLOBDirectoryAndFile lob = do 181 | alloca $ \directoryAliasPtr -> do 182 | alloca $ \directoryAliasLenPtr -> do 183 | alloca $ \fileNamePtr -> do 184 | alloca $ \fileNameLenPtr -> do 185 | throwOracleError 186 | =<< dpiLob_getDirectoryAndFileName 187 | lob 188 | directoryAliasPtr 189 | directoryAliasLenPtr 190 | fileNamePtr 191 | fileNameLenPtr 192 | r1 <- peekCString =<< peek fileNamePtr 193 | r2 <- peekCString =<< peek directoryAliasPtr 194 | return (r1, r2) 195 | 196 | foreign import ccall unsafe "dpiLob_getDirectoryAndFileName" 197 | dpiLob_getDirectoryAndFileName 198 | :: DPILob 199 | -- ^ dpiLob * 200 | -> Ptr CString 201 | -- ^ const char **directoryAlias 202 | -> Ptr CUInt 203 | -- ^ uint32_t *directoryAliasLength 204 | -> Ptr CString 205 | -- ^ const char **fileName 206 | -> Ptr CUInt 207 | -- ^ uint32_t *fileNameLength 208 | -> IO CInt 209 | 210 | -- | Sets the directory and file name for a BFILE LOB. 211 | setLOBDirectoryAndFile :: DPILob -> String -> String -> IO () 212 | setLOBDirectoryAndFile lob directoryName fileName = do 213 | withCStringLen directoryName $ \(dirNamePtr, dirNameLen) -> do 214 | withCStringLen fileName $ \(fNamePtr, fNameLen) -> do 215 | throwOracleError 216 | =<< dpiLob_setDirectoryAndFileName 217 | lob 218 | dirNamePtr 219 | (fromIntegral dirNameLen) 220 | fNamePtr 221 | (fromIntegral fNameLen) 222 | 223 | foreign import ccall unsafe "dpiLob_setDirectoryAndFileName" 224 | dpiLob_setDirectoryAndFileName 225 | :: DPILob 226 | -- ^ dpiLob * 227 | -> CString 228 | -- ^ const char *directoryAlias 229 | -> CUInt 230 | -- ^ uint32_t directoryAliasLength 231 | -> CString 232 | -- ^ const char *fileName 233 | -> CUInt 234 | -- ^ uint32_t fileNameLength 235 | -> IO CInt 236 | 237 | -- | Checks if the file associated with a BFILE LOB exists. 238 | doesLOBFileExists :: DPILob -> IO Bool 239 | doesLOBFileExists lob = do 240 | alloca $ \isOpenPtr -> do 241 | throwOracleError 242 | =<< dpiLob_getFileExists lob isOpenPtr 243 | r <- peek isOpenPtr 244 | if r == 0 then return False else return True 245 | 246 | foreign import ccall unsafe "dpiLob_getFileExists" 247 | dpiLob_getFileExists 248 | :: DPILob 249 | -- ^ dpiLob * 250 | -> Ptr CInt 251 | -- ^ int *isOpen 252 | -> IO CInt 253 | 254 | -- | Checks if the LOB resource is currently open. 255 | isLOBResoureOpen :: DPILob -> IO Bool 256 | isLOBResoureOpen lob = do 257 | alloca $ \isOpenPtr -> do 258 | throwOracleError 259 | =<< dpiLob_getIsResourceOpen lob isOpenPtr 260 | r <- peek isOpenPtr 261 | if r == 0 then return False else return True 262 | 263 | foreign import ccall unsafe "dpiLob_getIsResourceOpen" 264 | dpiLob_getIsResourceOpen 265 | :: DPILob 266 | -- ^ dpiLob * 267 | -> Ptr CInt 268 | -- ^ int *isOpen 269 | -> IO CInt 270 | 271 | {- 272 | WARNING: for historical reasons, Oracle stores CLOBs and NCLOBs using the UTF-16 encoding, regardless of what encoding is otherwise in use by the database. The number of characters, however, is defined by the number of UCS-2 codepoints. For this reason, if a character requires more than one UCS-2 codepoint, the size returned will be inaccurate and care must be taken to account for the difference. 273 | -} 274 | -- | Retrieves the size of a LOB in characters or bytes, depending on the LOB type. 275 | getLOBSize :: DPILob -> IO Int64 276 | getLOBSize lob = do 277 | alloca $ \sizePtr -> do 278 | throwOracleError 279 | =<< dpiLob_getSize lob sizePtr 280 | fromIntegral <$> peek sizePtr 281 | 282 | foreign import ccall unsafe "dpiLob_getSize" 283 | dpiLob_getSize 284 | :: DPILob 285 | -- ^ dpiLob * 286 | -> Ptr CULong 287 | -- ^ uint64_t *size 288 | -> IO CInt 289 | 290 | -- | Retrieves the type of a given LOB. 291 | getLOBType :: DPILob -> IO LOBType 292 | getLOBType lob = do 293 | alloca $ \numTypePtr -> do 294 | throwOracleError 295 | =<< dpiLob_getType lob numTypePtr 296 | mType <- cuintToLobType <$> peek numTypePtr 297 | case mType of 298 | Nothing -> return BLOB -- kind of impossible case 299 | Just r -> return r 300 | 301 | foreign import ccall unsafe "dpiLob_getType" 302 | dpiLob_getType 303 | :: DPILob 304 | -- ^ dpiLob * 305 | -> Ptr CUInt 306 | -- ^ dpiOracleTypeNum numType 307 | -> IO CInt 308 | 309 | -- | Opens a LOB resource, preparing it for subsequent operations. 310 | openLOBResource :: DPILob -> IO () 311 | openLOBResource lob = do 312 | throwOracleError 313 | =<< dpiLob_openResource lob 314 | 315 | foreign import ccall unsafe "dpiLob_openResource" 316 | dpiLob_openResource 317 | :: DPILob 318 | -- ^ dpiLob * 319 | -> IO CInt 320 | 321 | -- | Releases a LOB, freeing associated resources. 322 | releaseLOB :: DPILob -> IO () 323 | releaseLOB lob = do 324 | throwOracleError 325 | =<< dpiLob_release lob 326 | 327 | foreign import ccall unsafe "dpiLob_release" 328 | dpiLob_release 329 | :: DPILob 330 | -- ^ dpiLob * 331 | -> IO CInt 332 | 333 | -- offset starts at 1 334 | -- | Reads a specified number of bytes from a LOB starting at a given offset. 335 | readLOBBytes :: DPILob -> Int64 -> Int64 -> IO BSLC.ByteString 336 | readLOBBytes lob offset maxAmount = do 337 | valPtr <- callocBytes (fromIntegral maxAmount) 338 | alloca $ \valLenPtr -> do 339 | poke valLenPtr (fromIntegral maxAmount) 340 | throwOracleError 341 | =<< dpiLob_readBytes 342 | lob 343 | (fromIntegral offset) 344 | (fromIntegral maxAmount) 345 | valPtr 346 | valLenPtr 347 | res <- BSLC.pack <$> peekCString valPtr 348 | free valPtr 349 | return res 350 | 351 | -- offset starts at 1 352 | -- | Reads a specified number of characters from a LOB starting at a given offset. 353 | readLOB :: DPILob -> Int64 -> Int64 -> IO String 354 | readLOB lob offset maxAmount = do 355 | valPtr <- callocBytes (fromIntegral maxAmount) 356 | alloca $ \valLenPtr -> do 357 | poke valLenPtr (fromIntegral maxAmount) 358 | throwOracleError 359 | =<< dpiLob_readBytes 360 | lob 361 | (fromIntegral offset) 362 | (fromIntegral maxAmount) 363 | valPtr 364 | valLenPtr 365 | res <- peekCString valPtr 366 | free valPtr 367 | return res 368 | 369 | foreign import ccall unsafe "dpiLob_readBytes" 370 | dpiLob_readBytes 371 | :: DPILob 372 | -- ^ dpiLob * 373 | -> CULong 374 | -- ^ uint64_t offset 375 | -> CULong 376 | -- ^ uint64_t amount 377 | -> CString 378 | -- ^ char *value 379 | -> Ptr CULong 380 | -- ^ uint64_t *valueLength 381 | -> IO CInt 382 | 383 | -- offset starts at 1 384 | {- 385 | WARNING: for historical reasons, Oracle stores CLOBs and NCLOBs using the UTF-16 encoding, regardless of what encoding is otherwise in use by the database. The number of characters, however, is defined by the number of UCS-2 codepoints. For this reason, if a character requires more than one UCS-2 codepoint, care must be taken to account for them in the offset parameter. 386 | -} 387 | 388 | -- | 389 | -- e.g 390 | -- ghci> :set -XOverloadedStrings 391 | -- ghci> writeLOB lob 1 "Hello" 392 | -- ghci> dpiLobToByteString lob 393 | -- "Hello" 394 | -- ghci> writeLOB lob 6 " World!" 395 | -- ghci> dpiLobToByteString lob 396 | -- "Hello World!" 397 | -- | Writes a ByteString to a LOB starting at a given offset. 398 | writeLOB :: DPILob -> Int64 -> BSLC.ByteString -> IO () 399 | writeLOB lob offset val = do 400 | valPtr <- newCString (BSLC.unpack val) 401 | let valPtrLen = BSLC.length val 402 | throwOracleError 403 | =<< dpiLob_writeBytes 404 | lob 405 | (fromIntegral offset) 406 | valPtr 407 | (fromIntegral valPtrLen) 408 | 409 | foreign import ccall unsafe "dpiLob_writeBytes" 410 | dpiLob_writeBytes 411 | :: DPILob 412 | -- ^ dpiLob * 413 | -> CULong 414 | -- ^ uint64_t offset 415 | -> CString 416 | -- ^ char *value 417 | -> CULong 418 | -- ^ uint64_t valueLength 419 | -> IO CInt 420 | 421 | -- | Sets the value of a LOB from a given string. 422 | setLOBVal :: DPILob -> String -> IO () 423 | setLOBVal lob val = do 424 | withCStringLen val $ \(valPtr, valPtrLen) -> do 425 | throwOracleError 426 | =<< dpiLob_setFromBytes lob valPtr (fromIntegral valPtrLen) 427 | 428 | foreign import ccall unsafe "dpiLob_setFromBytes" 429 | dpiLob_setFromBytes 430 | :: DPILob 431 | -- ^ dpiLob * 432 | -> CString 433 | -- ^ const char *value 434 | -> CULong 435 | -- ^ uint64_t value 436 | -> IO CInt 437 | 438 | -- | Trims the LOB to a specified size, effectively removing excess data. 439 | trimLOBVal :: DPILob -> Int64 -> IO () 440 | trimLOBVal lob newSize = do 441 | throwOracleError 442 | =<< dpiLob_trim lob (fromIntegral newSize) 443 | 444 | foreign import ccall unsafe "dpiLob_trim" 445 | dpiLob_trim 446 | :: DPILob 447 | -> CULong 448 | -- ^ uint64_t newSize 449 | -> IO CInt 450 | -------------------------------------------------------------------------------- /src/Database/Oracle/Simple/Queue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DerivingStrategies #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE RankNTypes #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE ViewPatterns #-} 8 | 9 | module Database.Oracle.Simple.Queue 10 | ( genQueue 11 | , genQueueObject 12 | , genQueueJSON 13 | , genMsgProps 14 | , enqOne 15 | , enqMany 16 | , deqOne 17 | , deqMany 18 | , setMsgPropsPayLoadBytes 19 | , getMsgPropsPayLoadBytes 20 | , setMsgPropsPayLoadObject 21 | , getMsgPropsPayLoadObject 22 | , setMsgPropsPayLoadJSON 23 | , getMsgPropsPayLoadJson 24 | , queueRelease 25 | , getEnqOptions 26 | , getDeqOptions 27 | , getMsgPropsDelay 28 | , genJSON 29 | , getMsgPropsNumOfAttempts 30 | , objectAppendElement 31 | , getObjectElementByIdx 32 | , setObjectElementByIdx 33 | , setTextInJson 34 | , dpiJsonToVal 35 | , releaseDpiJson 36 | , setValInJSON 37 | , DPIQueue (..) 38 | , DPIMsgProps (..) 39 | , DPIDeqOptions (..) 40 | , DPIEnqOptions (..) 41 | , DPIObjectType (..) 42 | ) where 43 | 44 | import Data.Aeson (FromJSON, ToJSON, encode) 45 | import qualified Data.ByteString.Char8 as BSC 46 | import qualified Data.ByteString.Lazy.Char8 as BSLC 47 | import Data.Proxy (Proxy (..)) 48 | import Database.Oracle.Simple.FromField 49 | import Database.Oracle.Simple.Internal 50 | import Database.Oracle.Simple.JSON 51 | import Database.Oracle.Simple.Object 52 | import Database.Oracle.Simple.ToField 53 | import Foreign (alloca, nullPtr, withArray, withForeignPtr) 54 | import Foreign.C.String 55 | import Foreign.C.Types (CInt (..), CUInt (..), CULong (..)) 56 | import Foreign.Ptr (Ptr) 57 | import Foreign.Storable.Generic (Storable (..)) 58 | 59 | -- | Represents a queue in the Oracle database. 60 | -- The 'DPIQueue' type is a wrapper for a pointer to a DPI queue. 61 | newtype DPIQueue = DPIQueue (Ptr DPIQueue) 62 | deriving (Show, Eq) 63 | deriving newtype (Storable) 64 | 65 | -- | This type represents a pointer to a `DPIMsgProps` struct, 66 | -- | which contains metadata about an Oracle message, including its 67 | -- | properties and attributes. 68 | newtype DPIMsgProps = DPIMsgProps (Ptr DPIMsgProps) 69 | deriving (Show, Eq) 70 | deriving newtype (Storable) 71 | 72 | -- | This type represents a pointer to a `DPIDeqOptions` struct. 73 | newtype DPIDeqOptions = DPIDeqOptions (Ptr DPIDeqOptions) 74 | deriving (Show, Eq) 75 | deriving newtype (Storable) 76 | 77 | -- | This type represents a pointer to a `DPIEnqOptions` struct. 78 | newtype DPIEnqOptions = DPIEnqOptions (Ptr DPIEnqOptions) 79 | deriving (Show, Eq) 80 | deriving newtype (Storable) 81 | 82 | -- | Dequeues multiple messages from the queue. 83 | deqMany :: DPIQueue -> Int -> IO DPIMsgProps 84 | deqMany dpiQueue numProps = do 85 | alloca $ \dpiMsgPropsPtr -> do 86 | alloca $ \numPropsPtr -> do 87 | poke numPropsPtr (fromIntegral numProps) 88 | throwOracleError 89 | =<< dpiQueue_deqMany dpiQueue numPropsPtr dpiMsgPropsPtr 90 | peek dpiMsgPropsPtr 91 | 92 | foreign import ccall unsafe "dpiQueue_deqMany" 93 | dpiQueue_deqMany 94 | :: DPIQueue 95 | -- ^ dpiQueue * 96 | -> Ptr CUInt 97 | -- ^ numProps * 98 | -> Ptr DPIMsgProps 99 | -- ^ props ** 100 | -> IO CInt 101 | 102 | -- | Dequeues a single message from the queue. 103 | deqOne :: DPIQueue -> IO DPIMsgProps 104 | deqOne dpiQueue = do 105 | alloca $ \dpiMsgPropsPtr -> do 106 | throwOracleError 107 | =<< dpiQueue_deqOne dpiQueue dpiMsgPropsPtr 108 | peek dpiMsgPropsPtr 109 | 110 | foreign import ccall unsafe "dpiQueue_deqOne" 111 | dpiQueue_deqOne 112 | :: DPIQueue 113 | -- ^ dpiQueue * 114 | -> Ptr DPIMsgProps 115 | -- ^ props ** 116 | -> IO CInt 117 | 118 | -- | 119 | -- Enqueues multiple messages into the queue. 120 | -- 121 | -- Warning: calling this function in parallel on different connections acquired from 122 | -- the same pool may fail due to Oracle bug 29928074. Ensure that this function is not 123 | -- run in parallel, use standalone connections or connections from different pools, or 124 | -- make multiple calls to dpiQueue_enqOne() instead. The function dpiQueue_deqMany() call is not affected. 125 | enqMany :: DPIQueue -> [DPIMsgProps] -> IO () 126 | enqMany dpiQueue dpiMsgPropss = do 127 | let numOfProps = length dpiMsgPropss 128 | withArray dpiMsgPropss $ \dpiMsgPropsPtr -> do 129 | alloca $ \numPropsPtr -> do 130 | poke numPropsPtr (fromIntegral numOfProps) 131 | throwOracleError 132 | =<< dpiQueue_enqMany dpiQueue numPropsPtr dpiMsgPropsPtr 133 | 134 | foreign import ccall unsafe "dpiQueue_enqMany" 135 | dpiQueue_enqMany 136 | :: DPIQueue 137 | -- ^ dpiQueue * 138 | -> Ptr CUInt 139 | -- ^ numProps * 140 | -> Ptr DPIMsgProps 141 | -- ^ props ** 142 | -> IO CInt 143 | 144 | -- | Enqueues a single mesasge into the queue. 145 | enqOne :: DPIQueue -> DPIMsgProps -> IO () 146 | enqOne dpiQueue dpiMsgProps = 147 | throwOracleError 148 | =<< dpiQueue_enqOne dpiQueue dpiMsgProps 149 | 150 | foreign import ccall unsafe "dpiQueue_enqOne" 151 | dpiQueue_enqOne 152 | :: DPIQueue 153 | -- ^ dpiQueue * 154 | -> DPIMsgProps 155 | -- ^ props * 156 | -> IO CInt 157 | 158 | -- | Returns a reference to the dequeue options associated with the queue. These options affect how messages are dequeued. 159 | getDeqOptions :: DPIQueue -> IO DPIDeqOptions 160 | getDeqOptions dpiQueue = do 161 | alloca $ \dpiDeqOptionsPtr -> do 162 | throwOracleError =<< dpiQueue_getDeqOptions dpiQueue dpiDeqOptionsPtr 163 | peek dpiDeqOptionsPtr 164 | 165 | foreign import ccall unsafe "dpiQueue_getDeqOptions" 166 | dpiQueue_getDeqOptions 167 | :: DPIQueue 168 | -- ^ dpiQueue * 169 | -> Ptr DPIDeqOptions 170 | -- ^ options ** 171 | -> IO CInt 172 | 173 | -- | Returns a reference to the enqueue options associated with the queue. These options affect how messages are enqueued. 174 | getEnqOptions :: DPIQueue -> IO DPIEnqOptions 175 | getEnqOptions dpiQueue = do 176 | alloca $ \dpiEnqOptionsPtr -> do 177 | throwOracleError =<< dpiQueue_getEnqOptions dpiQueue dpiEnqOptionsPtr 178 | peek dpiEnqOptionsPtr 179 | 180 | foreign import ccall unsafe "dpiQueue_getEnqOptions" 181 | dpiQueue_getEnqOptions 182 | :: DPIQueue 183 | -- ^ dpiQueue * 184 | -> Ptr DPIEnqOptions 185 | -- ^ options ** 186 | -> IO CInt 187 | 188 | -- | Releases a reference to the queue. 189 | queueRelease :: DPIQueue -> IO () 190 | queueRelease dpiQueue = throwOracleError =<< dpiQueue_release dpiQueue 191 | 192 | foreign import ccall unsafe "dpiQueue_release" 193 | dpiQueue_release 194 | :: DPIQueue 195 | -- ^ dpiQueue * 196 | -> IO CInt 197 | 198 | -- | Returns a reference to a new queue which enqueues and dequeues messages from Advanced Queueing (AQ) with a JSON payload. 199 | genQueueJSON :: Connection -> String -> IO DPIQueue 200 | genQueueJSON (Connection fptr) queueName = do 201 | withForeignPtr fptr $ \conn -> do 202 | alloca $ \dpiQueuePtr -> do 203 | withCStringLen queueName $ \(queueNameC, fromIntegral -> queueNameLen) -> do 204 | throwOracleError =<< dpiConn_newJsonQueue conn queueNameC queueNameLen dpiQueuePtr 205 | peek dpiQueuePtr 206 | 207 | foreign import ccall unsafe "dpiConn_newJsonQueue" 208 | dpiConn_newJsonQueue 209 | :: Ptr DPIConn 210 | -- ^ dpiConn * 211 | -> CString 212 | -- ^ char* name 213 | -> CUInt 214 | -- ^ name Length 215 | -> Ptr DPIQueue 216 | -- ^ dpiQueue ** 217 | -> IO CInt 218 | 219 | -- | Returns a reference to a new set of message properties, used in enqueuing and dequeuing objects in a queue. 220 | genMsgProps :: Connection -> IO DPIMsgProps 221 | genMsgProps (Connection fptr) = do 222 | withForeignPtr fptr $ \conn -> do 223 | alloca $ \dpiMsgPropsPtr -> do 224 | throwOracleError =<< dpiConn_newMsgProps conn dpiMsgPropsPtr 225 | peek dpiMsgPropsPtr 226 | 227 | foreign import ccall unsafe "dpiConn_newMsgProps" 228 | dpiConn_newMsgProps 229 | :: Ptr DPIConn 230 | -- ^ dpiConn * 231 | -> Ptr DPIMsgProps 232 | -- ^ dpiMsgProps ** 233 | -> IO CInt 234 | 235 | -- | Returns a reference to a new queue which may be used to enqueue and dequeue messages from Advanced Queuing (AQ) queues. 236 | genQueue :: Connection -> String -> IO DPIQueue 237 | genQueue (Connection fptr) queueName = do 238 | withForeignPtr fptr $ \conn -> do 239 | alloca $ \dpiQueuePtr -> do 240 | withCStringLen queueName $ \(queueNameC, fromIntegral -> queueNameLen) -> do 241 | throwOracleError =<< dpiConn_newQueue conn queueNameC queueNameLen nullPtr dpiQueuePtr 242 | peek dpiQueuePtr 243 | 244 | -- | Returns a reference to a new queue which may be used to 245 | -- | enqueue and dequeue messages from Advanced Queuing (AQ) queues with Object as Payload type. 246 | genQueueObject :: Connection -> String -> DPIObjectType -> IO DPIQueue 247 | genQueueObject (Connection fptr) queueName (DPIObjectType objectType) = do 248 | withForeignPtr fptr $ \conn -> do 249 | alloca $ \dpiQueuePtr -> do 250 | withCStringLen queueName $ \(queueNameC, fromIntegral -> queueNameLen) -> do 251 | throwOracleError =<< dpiConn_newQueue conn queueNameC queueNameLen objectType dpiQueuePtr 252 | peek dpiQueuePtr 253 | 254 | foreign import ccall unsafe "dpiConn_newQueue" 255 | dpiConn_newQueue 256 | :: Ptr DPIConn 257 | -- ^ dpiConn * 258 | -> CString 259 | -- ^ char* name 260 | -> CUInt 261 | -- ^ name Length 262 | -> Ptr DPIObjectType 263 | -- ^ dpiObjectType * 264 | -> Ptr DPIQueue 265 | -- ^ dpiQueue ** 266 | -> IO CInt 267 | 268 | -----x DPI MsgProps related functions x----- 269 | 270 | -- | Returns the number of attempts that have been made to dequeue a message. 271 | getMsgPropsNumOfAttempts :: DPIMsgProps -> IO Int 272 | getMsgPropsNumOfAttempts dpiMsgProps = do 273 | alloca $ \numPtr -> do 274 | throwOracleError =<< dpiMsgProps_getNumAttempts dpiMsgProps numPtr 275 | fromIntegral <$> peek numPtr 276 | 277 | foreign import ccall unsafe "dpiMsgProps_getNumAttempts" 278 | dpiMsgProps_getNumAttempts 279 | :: DPIMsgProps 280 | -- ^ dpiMsgProps * 281 | -> Ptr CUInt 282 | -- ^ Number of Attempts that will be read. 283 | -> IO CInt 284 | 285 | -- | Returns the number of seconds the enqueued message will be delayed. 286 | getMsgPropsDelay :: DPIMsgProps -> IO Int 287 | getMsgPropsDelay dpiMsgProps = do 288 | alloca $ \numPtr -> do 289 | throwOracleError =<< dpiMsgProps_getDelay dpiMsgProps numPtr 290 | fromIntegral <$> peek numPtr 291 | 292 | foreign import ccall unsafe "dpiMsgProps_getDelay" 293 | dpiMsgProps_getDelay 294 | :: DPIMsgProps 295 | -- ^ dpiMsgProps * 296 | -> Ptr CUInt 297 | -- ^ Number of delayed seconds from given Message prop. 298 | -> IO CInt 299 | 300 | -- | Returns the payload associated with the message properties in bytes. 301 | getMsgPropsPayLoadBytes :: DPIMsgProps -> IO (Maybe BSC.ByteString) 302 | getMsgPropsPayLoadBytes dpiMsgProps = do 303 | alloca $ \dpiObjectPtr -> do 304 | alloca $ \cStringPtr -> do 305 | alloca $ \cStringLengthptr -> do 306 | throwOracleError =<< dpiMsgProps_getPayload dpiMsgProps dpiObjectPtr cStringPtr cStringLengthptr 307 | cStr <- peek cStringPtr 308 | if cStr == nullPtr 309 | then return Nothing 310 | else Just . BSC.pack <$> peekCString cStr 311 | 312 | -- | Returns the payload associated with the message properties in Object type. 313 | getMsgPropsPayLoadObject :: DPIMsgProps -> IO (Maybe DPIObject) 314 | getMsgPropsPayLoadObject dpiMsgProps = 315 | alloca $ \dpiObjectPtr -> do 316 | throwOracleError =<< dpiMsgProps_getPayload dpiMsgProps dpiObjectPtr nullPtr nullPtr 317 | if dpiObjectPtr == nullPtr 318 | then return Nothing 319 | else Just <$> peek dpiObjectPtr 320 | 321 | foreign import ccall unsafe "dpiMsgProps_getPayload" 322 | dpiMsgProps_getPayload 323 | :: DPIMsgProps 324 | -- ^ dpiMsgProps * 325 | -> Ptr DPIObject 326 | -- ^ dpiObject ** 327 | -> Ptr CString 328 | -- ^ const char ** value 329 | -> Ptr CUInt 330 | -- ^ valueLength 331 | -> IO CInt 332 | 333 | -- | Returns the payload associated with the message properties, The payload must be a JSON object 334 | getMsgPropsPayLoadJson :: FromJSON a => DPIMsgProps -> IO (Maybe a) 335 | getMsgPropsPayLoadJson dpiMsgProps = do 336 | alloca $ \dpiJsonPtr -> do 337 | throwOracleError =<< dpiMsgProps_getPayloadJson dpiMsgProps dpiJsonPtr 338 | if (dpiJsonPtr == nullPtr) 339 | then return Nothing 340 | else do 341 | dpiJson <- peek dpiJsonPtr 342 | res <- dpiJsonToVal dpiJson 343 | return $ Just res 344 | 345 | foreign import ccall unsafe "dpiMsgProps_getPayloadJson" 346 | dpiMsgProps_getPayloadJson 347 | :: DPIMsgProps 348 | -- ^ dpiMsgProps * 349 | -> Ptr DPIJson 350 | -- ^ dpiJson ** 351 | -> IO CInt 352 | 353 | -- | Sets the payload for the message as a series of bytes. 354 | setMsgPropsPayLoadBytes :: DPIMsgProps -> BSC.ByteString -> IO () 355 | setMsgPropsPayLoadBytes dpiMsgProps payLoad = do 356 | withCStringLen (BSC.unpack payLoad) $ \(payLoadC, fromIntegral -> payLoadLen) -> do 357 | throwOracleError =<< dpiMsgProps_setPayloadBytes dpiMsgProps payLoadC payLoadLen 358 | 359 | foreign import ccall unsafe "dpiMsgProps_setPayloadBytes" 360 | dpiMsgProps_setPayloadBytes 361 | :: DPIMsgProps 362 | -- ^ dpiMsgProps * 363 | -> CString 364 | -- ^ const char * value 365 | -> CUInt 366 | -- ^ uint32 valueLength 367 | -> IO CInt 368 | 369 | -- | Sets the payload for the message as a object. 370 | setMsgPropsPayLoadObject :: DPIMsgProps -> DPIObject -> IO () 371 | setMsgPropsPayLoadObject dpiMsgProps obj = do 372 | throwOracleError =<< dpiMsgProps_setPayloadObject dpiMsgProps obj 373 | 374 | foreign import ccall unsafe "dpiMsgProps_setPayloadObject" 375 | dpiMsgProps_setPayloadObject 376 | :: DPIMsgProps 377 | -- ^ dpiMsgProps * 378 | -> DPIObject 379 | -- ^ dpiObject* obj 380 | -> IO CInt 381 | 382 | -- | Sets the payload for the message as a JSON object. 383 | setMsgPropsPayLoadJSON :: DPIMsgProps -> DPIJson -> IO () 384 | setMsgPropsPayLoadJSON dpiMsgProps dpiJson = 385 | throwOracleError =<< dpiMsgProps_setPayloadJson dpiMsgProps dpiJson 386 | 387 | foreign import ccall unsafe "dpiMsgProps_setPayloadJson" 388 | dpiMsgProps_setPayloadJson 389 | :: DPIMsgProps 390 | -- ^ dpiMsgProps * 391 | -> DPIJson 392 | -- ^ dpiJson * 393 | -> IO CInt 394 | 395 | -- | Appends an element with the specified value to the collection. 396 | objectAppendElement :: forall a. (ToField a) => DPIObject -> a -> IO () 397 | objectAppendElement obj val = do 398 | dataValue <- toField val 399 | let dataIsNull = case dataValue of 400 | AsNull -> 1 401 | _ -> 0 402 | alloca $ \dpiDataPtr -> do 403 | let dpiData = DPIData{..} 404 | poke dpiDataPtr (dpiData :: DPIData WriteBuffer) 405 | throwOracleError 406 | =<< dpiObject_appendElement 407 | obj 408 | (dpiNativeTypeToUInt (toDPINativeType (Proxy @a))) 409 | (dpiDataPtr :: Ptr (DPIData WriteBuffer)) 410 | 411 | foreign import ccall unsafe "dpiObject_appendElement" 412 | dpiObject_appendElement 413 | :: DPIObject 414 | -- ^ dpiObject * 415 | -> CUInt 416 | -- ^ dpiNativeTypeNum 417 | -> Ptr (DPIData WriteBuffer) 418 | -- ^ dpiData* val 419 | -> IO CInt 420 | 421 | -- | Returns the value of the element found at the specified index. 422 | getObjectElementByIdx 423 | :: forall a 424 | . (FromField a) 425 | => DPIObject 426 | -> Int 427 | -> IO a 428 | getObjectElementByIdx obj idx = do 429 | alloca $ \dpiDataPtr -> do 430 | throwOracleError 431 | =<< dpiObject_getElementValueByIndex 432 | obj 433 | (CInt $ fromIntegral idx) 434 | (dpiNativeTypeToUInt (fromDPINativeType (Proxy @a))) 435 | dpiDataPtr 436 | readDPIDataBuffer (fromField @a) dpiDataPtr 437 | 438 | foreign import ccall unsafe "dpiObject_getElementValueByIndex" 439 | dpiObject_getElementValueByIndex 440 | :: DPIObject 441 | -- ^ dpiObject * 442 | -> CInt 443 | -- ^ int32_t index 444 | -> CUInt 445 | -- ^ dpiNativeTypeNum 446 | -> Ptr (DPIData ReadBuffer) 447 | -- ^ dpiData * 448 | -> IO CInt 449 | 450 | -- | Sets the value of the element found at the specified index. 451 | setObjectElementByIdx 452 | :: forall a 453 | . (ToField a) 454 | => DPIObject 455 | -> Int 456 | -> a 457 | -> IO () 458 | setObjectElementByIdx obj idx val = do 459 | dataValue <- toField val 460 | let dataIsNull = case dataValue of 461 | AsNull -> 1 462 | _ -> 0 463 | alloca $ \dpiDataPtr -> do 464 | let dpiData = DPIData{..} 465 | poke dpiDataPtr (dpiData :: DPIData WriteBuffer) 466 | throwOracleError 467 | =<< dpiObject_setElementValueByIndex 468 | obj 469 | (CInt $ fromIntegral idx) 470 | (dpiNativeTypeToUInt (toDPINativeType (Proxy @a))) 471 | dpiDataPtr 472 | 473 | foreign import ccall unsafe "dpiObject_setElementValueByIndex" 474 | dpiObject_setElementValueByIndex 475 | :: DPIObject 476 | -- ^ dpiObject * 477 | -> CInt 478 | -- ^ int32_t index 479 | -> CUInt 480 | -- ^ dpiNativeTypeNum 481 | -> Ptr (DPIData WriteBuffer) 482 | -- ^ dpiData * 483 | -> IO CInt 484 | 485 | -- | Returns a reference to a new JSON object. 486 | genJSON :: Connection -> IO DPIJson 487 | genJSON (Connection fptr) = do 488 | withForeignPtr fptr $ \conn -> do 489 | alloca $ \jsonPtr -> do 490 | throwOracleError =<< dpiConn_newJson conn jsonPtr 491 | peek jsonPtr 492 | 493 | foreign import ccall unsafe "dpiConn_newJson" 494 | dpiConn_newJson 495 | :: Ptr DPIConn 496 | -- ^ dpiConn * 497 | -> Ptr DPIJson 498 | -- ^ dpiJSON ** 499 | -> IO CInt 500 | 501 | -- | Helper function that inserts any type with ToJSON instance into DPIJson. 502 | setValInJSON :: forall a. (ToJSON a) => DPIJson -> a -> IO DPIJson 503 | setValInJSON dpiJson jsonData = do 504 | let res_ = BSLC.unpack $ encode jsonData 505 | setTextInJson dpiJson res_ 506 | 507 | -- | Helper function that takes value from DPIJson into any type with FromJSON Instance. 508 | dpiJsonToVal :: FromJSON a => DPIJson -> IO a 509 | dpiJsonToVal dpiJson = do 510 | jsonNodePtr <- dpiJson_getValue dpiJson 511 | jsonNode <- (peek jsonNodePtr) 512 | parseJson jsonNode 513 | 514 | -- | Helper function that inserts JSON string into DPIJson. 515 | setTextInJson :: DPIJson -> String -> IO DPIJson 516 | setTextInJson dpiJson jsonVal = do 517 | withCStringLen jsonVal $ \(jsonString, jsonStringLen) -> do 518 | throwOracleError 519 | =<< dpiJson_setFromText dpiJson jsonString (fromIntegral jsonStringLen) 0 520 | return dpiJson 521 | 522 | foreign import ccall unsafe "dpiJson_setFromText" 523 | dpiJson_setFromText 524 | :: DPIJson 525 | -- ^ dpiJson * 526 | -> CString 527 | -- ^ const char *value 528 | -> CULong 529 | -- ^ uint64_t 530 | -> CUInt 531 | -- ^ flags 532 | -> IO CInt 533 | 534 | -- | Releases a reference to the JSON value. 535 | releaseDpiJson :: DPIJson -> IO () 536 | releaseDpiJson dpiJson = do 537 | throwOracleError =<< dpiJson_release dpiJson 538 | 539 | foreign import ccall unsafe "dpiJson_release" 540 | dpiJson_release 541 | :: DPIJson 542 | -- ^ dpiJson * 543 | -> IO CInt 544 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DerivingVia #-} 4 | {-# LANGUAGE RecordWildCards #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | module Main 10 | ( main, 11 | ) 12 | where 13 | 14 | import qualified Control.Exception as Exc 15 | import Control.Monad (void, (<=<)) 16 | import qualified Data.Aeson as Aeson 17 | import qualified Data.Time as Time 18 | import qualified Data.Time.Calendar.OrdinalDate as OrdinalDate 19 | import qualified GHC.Generics as Generics 20 | import Hedgehog ((===)) 21 | import qualified Hedgehog as HH 22 | import qualified Hedgehog.Gen as Gen 23 | import qualified Hedgehog.Range as Range 24 | import Test.Hspec (Spec, around, describe, hspec, it, shouldBe, expectationFailure) 25 | import Test.Hspec.Hedgehog (hedgehog) 26 | import Foreign (peek, Storable, with, nullFunPtr, nullPtr) 27 | import Foreign.C.Types (CLong(..), CUInt(..), CInt(..)) 28 | import Foreign.C.String (newCString) 29 | import qualified Data.ByteString.Char8 as BSC 30 | import qualified Data.ByteString.Lazy.Char8 as BSLC 31 | 32 | import Database.Oracle.Simple 33 | 34 | data SumType = This | That 35 | deriving (Generics.Generic, Eq, Show) 36 | deriving anyclass (Aeson.FromJSON, Aeson.ToJSON) 37 | 38 | data JsonData = JsonData 39 | { string :: String 40 | , number :: Int 41 | , bool :: Bool 42 | , maybeBool :: Maybe Bool 43 | , stringList :: [String] 44 | , sumType :: SumType 45 | , double :: Double 46 | } 47 | deriving (Generics.Generic, Eq, Show) 48 | deriving anyclass (Aeson.FromJSON, Aeson.ToJSON) 49 | deriving (FromField, ToField) via AesonField JsonData 50 | 51 | data MixTable = MixTable 52 | { intColumn :: Int 53 | , jsonColumn :: JsonData 54 | } 55 | deriving (Generics.Generic, Eq, Show) 56 | deriving anyclass (FromRow, ToRow) 57 | 58 | main :: IO () 59 | main = withPool params $ hspec . spec 60 | 61 | params :: ConnectionParams 62 | params = ConnectionParams "username" "password" "localhost:1521/free" Nothing 63 | 64 | genDPITimestamp :: HH.Gen DPITimestamp 65 | genDPITimestamp = do 66 | let choose (l, h) = Gen.integral (Range.linear l h) 67 | tzHourOffset <- choose (-14, 14) 68 | DPITimestamp 69 | <$> choose (1000, 2023) 70 | <*> choose (1, 12) 71 | <*> choose (1, 28) 72 | <*> choose (1, 23) 73 | <*> choose (1, 59) 74 | <*> choose (1, 59) 75 | <*> choose (0, 100000) 76 | <*> pure tzHourOffset 77 | <*> if signum tzHourOffset < 0 78 | then choose (-59, 0) 79 | else choose (0, 59) 80 | 81 | spec :: Pool -> Spec 82 | spec pool = do 83 | around (withPoolConnection pool) $ do 84 | describe "SELECT tests" $ do 85 | it "Should select timestamp from Oracle" $ \conn -> do 86 | currentDay <- Time.utctDay <$> Time.getCurrentTime 87 | [Only DPITimestamp {..}] <- query_ conn "select sysdate from dual" 88 | currentDay 89 | `shouldBe` Time.fromGregorian 90 | (fromIntegral year) 91 | (fromIntegral month) 92 | (fromIntegral day) 93 | 94 | describe "Connection tests" $ do 95 | it "Should check connection health" $ (`shouldBe` True) <=< isHealthy 96 | 97 | it "Should ping connection" $ (`shouldBe` True) <=< ping 98 | 99 | describe "DPITimeStamp tests" $ do 100 | it "Should roundtrip DPITimestamp through UTCTime" $ \_ -> do 101 | hedgehog $ do 102 | dpiTimestamp <- HH.forAll $ genDPITimestamp 103 | utcTimeToDPITimestamp (dpiTimeStampToUTCTime dpiTimestamp) 104 | === dpiTimeStampToUTCDPITimeStamp dpiTimestamp 105 | 106 | it "Idempotency of dpiTimeStampToUTCDPITimeStamp " $ \_ -> do 107 | hedgehog $ do 108 | dpi <- HH.forAll $ genDPITimestamp 109 | dpiTimeStampToUTCDPITimeStamp (dpiTimeStampToUTCDPITimeStamp dpi) 110 | === dpiTimeStampToUTCDPITimeStamp dpi 111 | 112 | it "YYYY/MM/DD should be affected by UTC offset changes" $ \_ -> do 113 | let dpi = 114 | DPITimestamp 115 | { year = 1000 116 | , month = 1 117 | , day = 1 118 | , hour = 0 119 | , minute = 0 120 | , second = 0 121 | , fsecond = 0 122 | , tzHourOffset = 0 123 | , tzMinuteOffset = 1 124 | } 125 | let expected = 126 | DPITimestamp 127 | { year = 999 128 | , month = 12 129 | , day = 31 130 | , hour = 23 131 | , minute = 59 132 | , second = 0 133 | , fsecond = 0 134 | , tzHourOffset = 0 135 | , tzMinuteOffset = 0 136 | } 137 | dpiTimeStampToUTCDPITimeStamp dpi `shouldBe` expected 138 | 139 | it "Should roundtrip UTCTime through DPITimestamp (w/ nanos -- not picos) " $ \_ -> do 140 | hedgehog $ do 141 | utc <- HH.forAll $ do 142 | d <- 143 | OrdinalDate.fromOrdinalDate 144 | <$> Gen.integral (Range.linear 2000 2400) 145 | <*> Gen.int (Range.linear 1 365) 146 | seconds <- Gen.integral (Range.linear 0 86400) 147 | pure $ Time.UTCTime d (Time.secondsToDiffTime seconds) 148 | 149 | utc === dpiTimeStampToUTCTime (utcTimeToDPITimestamp utc) 150 | 151 | describe "JSON tests" $ do 152 | it "should roundtrip JSON data" $ \conn -> do 153 | _ <- execute_ conn "create table json_test(test_column json)" 154 | let jsonData = JsonData "str" 123 True Nothing ["hello", "world"] That 3.14 155 | _ <- execute conn "insert into json_test values (:1)" (Only jsonData) 156 | [Only gotData] <- query_ conn "select * from json_test" 157 | _ <- execute_ conn "drop table json_test" 158 | gotData `shouldBe` jsonData 159 | 160 | it "handles a mix of json and non-json fields in tables" $ \conn -> do 161 | _ <- execute_ conn "create table json_mix_test(int_column number(10,0), json_column json)" 162 | let insertRows = 163 | [ MixTable 1 (JsonData "str" 123 True Nothing ["hello", "world"] That 3.14) 164 | , MixTable 2 (JsonData "foo" 456 False (Just False) ["goodbye!"] This 9.99) 165 | ] 166 | _ <- executeMany conn "insert into json_mix_test values (:1, :2)" insertRows 167 | gotRows <- query_ conn "select * from json_mix_test" 168 | _ <- execute_ conn "drop table json_mix_test" 169 | gotRows `shouldBe` insertRows 170 | 171 | describe "transaction tests" $ do 172 | it "should commit transaction successfully" $ \conn -> do 173 | void $ execute_ conn "create table transaction_test(text_column number(10,0) primary key)" 174 | void $ withTransaction conn $ do 175 | void $ execute conn "insert into transaction_test values(:1)" (Only @Int 1) 176 | void $ execute conn "insert into transaction_test values(:1)" (Only @Int 2) 177 | void $ execute conn "insert into transaction_test values(:1)" (Only @Int 3) 178 | void $ execute conn "insert into transaction_test values(:1)" (Only @Int 4) 179 | results <- query_ @(Only Int) conn "select * from transaction_test" 180 | void $ execute_ conn "drop table transaction_test" 181 | results `shouldBe` [Only 1, Only 2, Only 3, Only 4] 182 | 183 | it "should roll back transaction in case of failure" $ \conn -> do 184 | void $ execute_ conn "create table rollback_test(text_column number(10,0) primary key)" 185 | handleOracleError $ withTransaction conn $ do 186 | void $ execute conn "insert into rollback_test values(:1)" (Only @Int 1) 187 | void $ execute conn "insert into rollback_test values(:1)" (Only @Int 2) 188 | void $ execute conn "insert into rollback_test values(:1)" (Only @Int 3) 189 | void $ execute conn "insert into rollback_test values(:1)" (Only @Int 3) -- should fail 190 | results <- query_ @(Only Int) conn "select * from rollback_test" 191 | void $ execute_ conn "drop table rollback_test" 192 | results `shouldBe` [] -- should roll back transaction 193 | it "should roll back to savepoint" $ \conn -> do 194 | void $ execute_ conn "create table savepoint_test(text_column number(10,0) primary key)" 195 | void $ withTransaction conn $ do 196 | void $ execute conn "insert into savepoint_test values(:1)" (Only @Int 1) 197 | void $ execute conn "insert into savepoint_test values(:1)" (Only @Int 2) 198 | handleOracleError $ withSavepoint conn $ do 199 | void $ execute conn "insert into savepoint_test values(:1)" (Only @Int 3) 200 | void $ execute conn "insert into savepoint_test values(:1)" (Only @Int 4) 201 | void $ execute conn "insert into savepoint_test values(:1)" (Only @Int 4) -- should fail 202 | results <- query_ @(Only Int) conn "select * from savepoint_test" 203 | void $ execute_ conn "drop table savepoint_test" 204 | results `shouldBe` [Only 1, Only 2] -- should roll back to before savepoint 205 | it "allows for nesting savepoints" $ \conn -> do 206 | void $ execute_ conn "create table savepoint_nesting_test(text_column number(10,0) primary key)" 207 | withTransaction conn $ do 208 | void $ execute conn "insert into savepoint_nesting_test values(:1)" (Only @Int 1) 209 | void $ execute conn "insert into savepoint_nesting_test values(:1)" (Only @Int 2) 210 | handleOracleError $ withSavepoint conn $ do 211 | void $ execute conn "insert into savepoint_nesting_test values(:1)" (Only @Int 3) 212 | void $ execute conn "insert into savepoint_nesting_test values(:1)" (Only @Int 4) 213 | handleOracleError $ withSavepoint conn $ do 214 | void $ execute conn "insert into savepoint_nesting_test values(:1)" (Only @Int 5) 215 | void $ execute conn "insert into savepoint_nesting_test values(:1)" (Only @Int 5) -- should fail 216 | void $ execute conn "insert into savepoint_nesting_test values(:1)" (Only @Int 6) 217 | results <- query_ @(Only Int) conn "select * from savepoint_nesting_test" 218 | void $ execute_ conn "drop table savepoint_nesting_test" 219 | results `shouldBe` [Only 1, Only 2, Only 3, Only 4, Only 6] -- should roll back to inner savepoint 220 | it "handles consecutive transactions" $ \conn -> do 221 | void $ execute_ conn "create table transactions_test(text_column number(10,0) primary key)" 222 | -- transaction that inserts rows 223 | void $ withTransaction conn $ do 224 | void $ execute conn "insert into transactions_test values(:1)" (Only @Int 1) 225 | void $ execute conn "insert into transactions_test values(:1)" (Only @Int 2) 226 | void $ execute conn "insert into transactions_test values(:1)" (Only @Int 3) 227 | void $ execute conn "insert into transactions_test values(:1)" (Only @Int 4) 228 | -- transaction that makes no changes that require commit 229 | void $ withTransaction conn $ do 230 | _ <- query_ @(Only Int) conn "select * from transactions_test" 231 | pure () 232 | -- transaction that inserts rows with savepoint 233 | void $ withTransaction conn $ do 234 | void $ execute conn "insert into transactions_test values(:1)" (Only @Int 5) 235 | void $ withSavepoint conn $ do 236 | void $ execute conn "insert into transactions_test values(:1)" (Only @Int 6) 237 | void $ execute conn "insert into transactions_test values(:1)" (Only @Int 7) 238 | -- transaction that is rolled back 239 | handleOracleError $ withTransaction conn $ do 240 | void $ execute conn "insert into transactions_test values(:1)" (Only @Int 6) -- should fail 241 | -- transaction that inserts rows with savepoint that is rolled back to 242 | void $ withTransaction conn $ do 243 | void $ execute conn "insert into transactions_test values(:1)" (Only @Int 8) 244 | handleOracleError $ withSavepoint conn $ do 245 | void $ execute conn "insert into transactions_test values(:1)" (Only @Int 9) 246 | void $ execute conn "insert into transactions_test values(:1)" (Only @Int 9) -- should fail 247 | void $ execute conn "insert into transactions_test values(:1)" (Only @Int 10) 248 | results <- query_ @(Only Int) conn "select * from transactions_test" 249 | void $ execute_ conn "drop table transactions_test" 250 | results `shouldBe` [Only 1 .. Only 8] <> [Only 10] 251 | describe "Storable round trip tests" $ do 252 | it "VersionInfo" $ \_ -> do 253 | let versionInfo = VersionInfo { 254 | versionNum = 1 255 | , releaseNum = 2 256 | , updateNum = 3 257 | , portReleaseNum = 4 258 | , portUpdateNum = 5 259 | , fullVersionNum = 6 260 | } 261 | result <- roundTripStorable versionInfo 262 | result `shouldBe` versionInfo 263 | it "DPIXid" $ \_ -> do 264 | someCString <- newCString "hello" 265 | let dpixid = DPIXid { 266 | dpixFormatId = CLong 1 267 | , dpixGlobalTransactionId = someCString 268 | , dpixGlobalTransactionIdLength = CUInt 2 269 | , dpixBranchQualifier = someCString 270 | , dpixBranchQualifierLength = CUInt 3 271 | } 272 | result <- roundTripStorable dpixid 273 | result `shouldBe` dpixid 274 | it "DPIPoolCreateParams" $ \_ -> do 275 | someCString <- newCString "hello" 276 | let dPIPoolCreateParams = DPIPoolCreateParams { 277 | dpi_minSessions = CUInt 1 278 | , dpi_maxSessions = CUInt 1 279 | , dpi_sessionIncrement = CUInt 1 280 | , dpi_pingInterval = CInt 1 281 | , dpi_pingTimeout = CInt 1 282 | , dpi_homogeneous = CInt 1 283 | , dpi_externalAuth = CInt 1 284 | , dpi_getMode = DPI_MODE_POOL_GET_WAIT 285 | , dpi_outPoolName = someCString 286 | , dpi_outPoolNameLength = CUInt 1 287 | , dpi_timeout = CUInt 1 288 | , dpi_waitTimeout = CUInt 1 289 | , dpi_maxLifetimeSession = CUInt 1 290 | , dpi_plsqlFixupCallback = someCString 291 | , dpi_plsqlFixupCallbackLength = CUInt 1 292 | , dpi_maxSessionsPerShard = CUInt 1 293 | , dpi_accessTokenCallback = nullFunPtr 294 | , dpi_accessTokenCallbackContext = nullPtr 295 | } 296 | result <- roundTripStorable dPIPoolCreateParams 297 | result `shouldBe` dPIPoolCreateParams 298 | it "ConnectionCreateParams" $ \_ -> do 299 | someCString <- newCString "hello" 300 | let connectionCreateParams = ConnectionCreateParams { 301 | dpi_authMode = DPI_MODE_AUTH_DEFAULT 302 | , connectionClass = someCString 303 | , connectionClassLength = CUInt 1 304 | , purity = DPI_PURITY_DEFAULT 305 | , newPassword = someCString 306 | , newPasswordLength = CUInt 1 307 | , appContenxt = nullPtr 308 | , numAppContext = CUInt 1 309 | , externalAuth = CInt 1 310 | , externalHandle = nullPtr 311 | , pool = DPIPool nullPtr 312 | , tag = someCString 313 | , tagLength = CUInt 1 314 | , matchAnyTag = CInt 1 315 | , outTag = someCString 316 | , outTagLength = CUInt 1 317 | , outTagFound = CInt 1 318 | , shardingKeyColumn = DPIShardingKeyColumn nullPtr 319 | , numShardingKeyColumns = 1 320 | , superShardingKeyColumns = nullPtr 321 | , numSuperShardingKeyColumns = 1 322 | , outNewSession = CInt 1 323 | } 324 | result <- roundTripStorable connectionCreateParams 325 | result `shouldBe` connectionCreateParams 326 | it "DPICommonCreateParams" $ \_ -> do 327 | someCString <- newCString "hello" 328 | let dPICommonCreateParams = DPICommonCreateParams { 329 | createMode = DPI_MODE_CREATE_DEFAULT 330 | , encoding = someCString 331 | , nencoding = someCString 332 | , edition = someCString 333 | , editionLength = CInt 1 334 | , driverName = someCString 335 | , driverNameLength = CInt 1 336 | , sodaMetadataCache = 1 337 | , stmtCacheSize = CInt 1 338 | } 339 | result <- roundTripStorable dPICommonCreateParams 340 | result `shouldBe` dPICommonCreateParams 341 | it "DPITimestamp" $ \_ -> do 342 | let dPITimestamp = DPITimestamp { 343 | year = 1 344 | , month = 1 345 | , day = 1 346 | , hour = 1 347 | , minute = 1 348 | , second = 1 349 | , fsecond = CUInt 1 350 | , tzHourOffset = 1 351 | , tzMinuteOffset = 1 352 | } 353 | result <- roundTripStorable dPITimestamp 354 | result `shouldBe` dPITimestamp 355 | it "DPIAppContext" $ \_ -> do 356 | someCString <- newCString "hello" 357 | let dPIAppContext = DPIAppContext { 358 | namespaceName = someCString 359 | , namespaceNameLength = CUInt 1 360 | , name = someCString 361 | , nameLength = CUInt 1 362 | , value = someCString 363 | , valueLength = CUInt 1 364 | } 365 | result <- roundTripStorable dPIAppContext 366 | result `shouldBe` dPIAppContext 367 | it "DPIContextCreateParams" $ \_ -> do 368 | someCString <- newCString "hello" 369 | let dPIContextCreateParams = DPIContextCreateParams { 370 | defaultDriverName = someCString 371 | , defaultEncoding = someCString 372 | , loadErrorUrl = someCString 373 | , oracleClientLibDir = someCString 374 | , oracleClientConfigDir = someCString 375 | } 376 | result <- roundTripStorable dPIContextCreateParams 377 | result `shouldBe` dPIContextCreateParams 378 | it "DPIJsonNode" $ \_ -> do 379 | let dPIJsonNode = DPIJsonNode { 380 | djnOracleTypeNumber = DPI_ORACLE_TYPE_NONE 381 | , djnNativeTypeNumber = DPI_NATIVE_TYPE_INT64 382 | , djnValue = nullPtr 383 | } 384 | result <- roundTripStorable dPIJsonNode 385 | result `shouldBe` dPIJsonNode 386 | describe "Advanced Queuing" $ do 387 | it "should create and release a raw queue successfully" $ \conn -> do 388 | queue <- genQueue conn "test_queue" 389 | queueRelease queue 390 | -- No exception implies success 391 | 392 | it "should set and get a msgProp payload" $ \conn -> do 393 | msgProps <- genMsgProps conn 394 | setMsgPropsPayLoadBytes msgProps (BSC.pack "Hello from Haskell!") 395 | payload <- getMsgPropsPayLoadBytes msgProps 396 | payload `shouldBe` Just "Hello from Haskell!" 397 | 398 | it "should enque and deque msg prop from queue for bytes" $ \conn -> do 399 | void $ execute_ conn $ unlines [ 400 | "BEGIN" 401 | , "DBMS_AQADM.CREATE_QUEUE_TABLE(" 402 | , "queue_table => 'TEST_QUEUE_TABLE'," 403 | , "queue_payload_type => 'RAW'" 404 | ,");" 405 | ,"DBMS_AQADM.CREATE_QUEUE(" 406 | , "queue_name => 'TEST_QUEUE'," 407 | , "queue_table => 'TEST_QUEUE_TABLE'" 408 | , ");" 409 | , "DBMS_AQADM.START_QUEUE(" 410 | , "queue_name => 'TEST_QUEUE'" 411 | , ");" 412 | , "END;" ] 413 | msgProps <- genMsgProps conn 414 | setMsgPropsPayLoadBytes msgProps (BSC.pack "Hello from Haskell!") 415 | queue <- genQueue conn "TEST_QUEUE" 416 | void $ enqOne queue msgProps 417 | newMsgProps <- deqOne queue 418 | payload <- getMsgPropsPayLoadBytes newMsgProps 419 | payload `shouldBe` Just "Hello from Haskell!" 420 | queueRelease queue 421 | void $ execute_ conn $ unlines [ 422 | "BEGIN" 423 | , "DBMS_AQADM.STOP_QUEUE(" 424 | , "queue_name => 'TEST_QUEUE'" 425 | , ");" 426 | , "DBMS_AQADM.DROP_QUEUE(" 427 | , "queue_name => 'TEST_QUEUE'" 428 | , ");" 429 | , "DBMS_AQADM.DROP_QUEUE_TABLE(" 430 | , "queue_table => 'TEST_QUEUE_TABLE'" 431 | , ");" 432 | , "END;"] 433 | 434 | it "should enque and deque msg prop from queue for object" $ \conn -> do 435 | void $ execute_ conn $ "CREATE OR REPLACE TYPE MessageType AS OBJECT" 436 | <> "(id NUMBER,text VARCHAR2(100));" 437 | void $ execute_ conn $ unlines [ 438 | "BEGIN" 439 | , "DBMS_AQADM.CREATE_QUEUE_TABLE(" 440 | , "queue_table => 'TEST_QUEUE_TABLE'," 441 | , "queue_payload_type => 'MessageType'" 442 | ,");" 443 | ,"DBMS_AQADM.CREATE_QUEUE(" 444 | , "queue_name => 'TEST_QUEUE'," 445 | , "queue_table => 'TEST_QUEUE_TABLE'" 446 | , ");" 447 | , "DBMS_AQADM.START_QUEUE(" 448 | , "queue_name => 'TEST_QUEUE'" 449 | , ");" 450 | , "END;" ] 451 | 452 | msgProps <- genMsgProps conn 453 | objType <- getObjectType conn "messageType" 454 | obj <- genObject objType 455 | -- objInfo <- getObjectInfo objType 456 | queue <- genQueueObject conn "test_queue" objType 457 | [attr1, attr2] <- getObjAttributes objType 2 458 | 459 | setObjAttribute obj attr1 (1 :: Int) 460 | setObjAttribute obj attr2 ("Hello from Haskell" :: String) 461 | 462 | -- numAttributes objInfo `shouldBe` 2 463 | setMsgPropsPayLoadObject msgProps obj 464 | 465 | enqOne queue msgProps 466 | newMsgProps <- deqOne queue 467 | 468 | mObj <- getMsgPropsPayLoadObject newMsgProps 469 | case mObj of 470 | Nothing -> expectationFailure "MsgProp not found" 471 | Just newObj -> do 472 | val1 <- getObjAttribute newObj attr1 473 | val2 <- getObjAttribute newObj attr2 474 | val1 `shouldBe` (1 :: Int) 475 | val2 `shouldBe` ("Hello from Haskell" :: String) 476 | 477 | void $ execute_ conn $ unlines [ 478 | "BEGIN" 479 | , "DBMS_AQADM.STOP_QUEUE(" 480 | , "queue_name => 'TEST_QUEUE'" 481 | , ");" 482 | , "DBMS_AQADM.DROP_QUEUE(" 483 | , "queue_name => 'TEST_QUEUE'" 484 | , ");" 485 | , "DBMS_AQADM.DROP_QUEUE_TABLE(" 486 | , "queue_table => 'TEST_QUEUE_TABLE'" 487 | , ");" 488 | , "END;"] 489 | 490 | it "should enque and deque msg prop from queue for json" $ \conn -> do 491 | void $ execute_ conn $ unlines [ 492 | "BEGIN" 493 | , "DBMS_AQADM.CREATE_QUEUE_TABLE(" 494 | , "queue_table => 'TEST_QUEUE_TABLE'," 495 | , "queue_payload_type => 'JSON'" 496 | ,");" 497 | ,"DBMS_AQADM.CREATE_QUEUE(" 498 | , "queue_name => 'TEST_QUEUE'," 499 | , "queue_table => 'TEST_QUEUE_TABLE'" 500 | , ");" 501 | , "DBMS_AQADM.START_QUEUE(" 502 | , "queue_name => 'TEST_QUEUE'" 503 | , ");" 504 | , "END;" ] 505 | let jsonData = JsonData "str" 123 True Nothing ["hello", "world"] That 3.14 506 | 507 | msgProps <- genMsgProps conn 508 | queue <- genQueueJSON conn "TEST_QUEUE" 509 | 510 | dpiJson_ <- genJSON conn 511 | dpiJson <- setValInJSON dpiJson_ jsonData 512 | setMsgPropsPayLoadJSON msgProps dpiJson 513 | enqOne queue msgProps 514 | newMsgProps <- deqOne queue 515 | 516 | mJson <- getMsgPropsPayLoadJson newMsgProps 517 | 518 | case mJson of 519 | Nothing -> expectationFailure "Got Nothing" 520 | Just newJson -> do 521 | newJson `shouldBe` jsonData 522 | 523 | releaseDpiJson dpiJson 524 | void $ execute_ conn $ unlines [ 525 | "BEGIN" 526 | , "DBMS_AQADM.STOP_QUEUE(" 527 | , "queue_name => 'TEST_QUEUE'" 528 | , ");" 529 | , "DBMS_AQADM.DROP_QUEUE(" 530 | , "queue_name => 'TEST_QUEUE'" 531 | , ");" 532 | , "DBMS_AQADM.DROP_QUEUE_TABLE(" 533 | , "queue_table => 'TEST_QUEUE_TABLE'" 534 | , ");" 535 | , "END;"] 536 | 537 | describe "Large objects" $ do 538 | it "creates and closes a temporary LOB" $ \conn -> do 539 | withLOB conn CLOB $ \lob -> do 540 | isOpen <- isLOBResoureOpen lob 541 | isOpen `shouldBe` False 542 | openLOBResource lob 543 | isOpen2 <- isLOBResoureOpen lob 544 | isOpen2 `shouldBe` True 545 | closeLOBResource lob 546 | isOpen3 <- isLOBResoureOpen lob 547 | isOpen3 `shouldBe` False 548 | 549 | it "writes and reads from a LOB" $ \conn -> do 550 | withLOB conn CLOB $ \lob -> do 551 | let testData = "Hello, Oracle LOB!" 552 | writeLOB lob 1 testData 553 | result <- readLOBBytes lob 1 1024 554 | result `shouldBe` testData 555 | 556 | it "trims a LOB to a new size" $ \conn -> do 557 | withLOB conn CLOB $ \lob -> do 558 | let testData = "Hello, Oracle LOB!" 559 | writeLOB lob 1 testData 560 | prefferedChunkSize <- getLOBChunkSize lob 561 | trimLOBVal lob 5 562 | result <- readLOBBytes lob 1 (fromIntegral prefferedChunkSize) 563 | result `shouldBe` "Hello" 564 | 565 | it "copies a LOB" $ \conn -> do 566 | withLOB conn BLOB $ \lob -> do 567 | let testData = "Copy me :)" 568 | writeLOB lob 1 testData 569 | prefferedChunkSize <- getLOBChunkSize lob 570 | 571 | newLob <- copyLOB lob 572 | 573 | result <- readLOBBytes newLob 1 (fromIntegral prefferedChunkSize) 574 | result `shouldBe` testData 575 | 576 | it "checks LOB size" $ \conn -> do 577 | withLOB conn BLOB $ \lob -> do 578 | let testData = "some string" 579 | writeLOB lob 1 testData 580 | size <- getLOBSize lob 581 | size `shouldBe` BSLC.length testData 582 | where 583 | handleOracleError action = Exc.try @OracleError action >>= either (\_ -> pure ()) (\_ -> pure ()) 584 | 585 | -- | Round-trip a value through its `Storable` instance. 586 | roundTripStorable :: Storable a => a -> IO a 587 | roundTripStorable x = with x peek 588 | --------------------------------------------------------------------------------