{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- | MSSQL Connection
--
--   This module handles the connection against an MS SQL Server.
--   It defines the connection string, connection pool, default settings,
--   and conversion functions between MSSQL and graphql-engine.
module Hasura.Backends.MSSQL.Connection
  ( MSSQLConnConfiguration (MSSQLConnConfiguration),
    MSSQLSourceConfig (MSSQLSourceConfig, _mscExecCtx),
    MSSQLExecCtx (..),
    MonadMSSQLTx (..),
    createMSSQLPool,
    getEnv,
    odbcValueToJValue,
    mkMSSQLExecCtx,
    runMSSQLSourceReadTx,
    runMSSQLSourceWriteTx,
  )
where

import Autodocodec (HasCodec (codec), named)
import Control.Monad.Morph (hoist)
import Control.Monad.Trans.Control
import Data.Aeson
import Data.Aeson qualified as J
import Data.Aeson.TH
import Data.Environment qualified as Env
import Data.Text (pack, unpack)
import Database.MSSQL.Pool qualified as MSPool
import Database.MSSQL.Transaction qualified as MSTx
import Database.ODBC.SQLServer qualified as ODBC
import Hasura.Backends.MSSQL.SQL.Error
import Hasura.Base.Error
import Hasura.Incremental (Cacheable (..))
import Hasura.Metadata.DTO.Placeholder (placeholderCodecViaJSON)
import Hasura.Prelude

class MonadError QErr m => MonadMSSQLTx m where
  liftMSSQLTx :: MSTx.TxE QErr a -> m a

instance MonadMSSQLTx m => MonadMSSQLTx (ReaderT s m) where
  liftMSSQLTx :: TxE QErr a -> ReaderT s m a
liftMSSQLTx = m a -> ReaderT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> ReaderT s m a)
-> (TxE QErr a -> m a) -> TxE QErr a -> ReaderT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxE QErr a -> m a
forall (m :: * -> *) a. MonadMSSQLTx m => TxE QErr a -> m a
liftMSSQLTx

instance MonadMSSQLTx m => MonadMSSQLTx (StateT s m) where
  liftMSSQLTx :: TxE QErr a -> StateT s m a
liftMSSQLTx = m a -> StateT s m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> StateT s m a)
-> (TxE QErr a -> m a) -> TxE QErr a -> StateT s m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxE QErr a -> m a
forall (m :: * -> *) a. MonadMSSQLTx m => TxE QErr a -> m a
liftMSSQLTx

instance (Monoid w, MonadMSSQLTx m) => MonadMSSQLTx (WriterT w m) where
  liftMSSQLTx :: TxE QErr a -> WriterT w m a
liftMSSQLTx = m a -> WriterT w m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> WriterT w m a)
-> (TxE QErr a -> m a) -> TxE QErr a -> WriterT w m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxE QErr a -> m a
forall (m :: * -> *) a. MonadMSSQLTx m => TxE QErr a -> m a
liftMSSQLTx

instance MonadIO m => MonadMSSQLTx (MSTx.TxET QErr m) where
  liftMSSQLTx :: TxE QErr a -> TxET QErr m a
liftMSSQLTx = (forall a. IO a -> m a) -> TxE QErr a -> TxET QErr m a
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | ODBC connection string for MSSQL server
newtype MSSQLConnectionString = MSSQLConnectionString {MSSQLConnectionString -> Text
unMSSQLConnectionString :: Text}
  deriving (Int -> MSSQLConnectionString -> ShowS
[MSSQLConnectionString] -> ShowS
MSSQLConnectionString -> String
(Int -> MSSQLConnectionString -> ShowS)
-> (MSSQLConnectionString -> String)
-> ([MSSQLConnectionString] -> ShowS)
-> Show MSSQLConnectionString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MSSQLConnectionString] -> ShowS
$cshowList :: [MSSQLConnectionString] -> ShowS
show :: MSSQLConnectionString -> String
$cshow :: MSSQLConnectionString -> String
showsPrec :: Int -> MSSQLConnectionString -> ShowS
$cshowsPrec :: Int -> MSSQLConnectionString -> ShowS
Show, MSSQLConnectionString -> MSSQLConnectionString -> Bool
(MSSQLConnectionString -> MSSQLConnectionString -> Bool)
-> (MSSQLConnectionString -> MSSQLConnectionString -> Bool)
-> Eq MSSQLConnectionString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MSSQLConnectionString -> MSSQLConnectionString -> Bool
$c/= :: MSSQLConnectionString -> MSSQLConnectionString -> Bool
== :: MSSQLConnectionString -> MSSQLConnectionString -> Bool
$c== :: MSSQLConnectionString -> MSSQLConnectionString -> Bool
Eq, [MSSQLConnectionString] -> Value
[MSSQLConnectionString] -> Encoding
MSSQLConnectionString -> Value
MSSQLConnectionString -> Encoding
(MSSQLConnectionString -> Value)
-> (MSSQLConnectionString -> Encoding)
-> ([MSSQLConnectionString] -> Value)
-> ([MSSQLConnectionString] -> Encoding)
-> ToJSON MSSQLConnectionString
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [MSSQLConnectionString] -> Encoding
$ctoEncodingList :: [MSSQLConnectionString] -> Encoding
toJSONList :: [MSSQLConnectionString] -> Value
$ctoJSONList :: [MSSQLConnectionString] -> Value
toEncoding :: MSSQLConnectionString -> Encoding
$ctoEncoding :: MSSQLConnectionString -> Encoding
toJSON :: MSSQLConnectionString -> Value
$ctoJSON :: MSSQLConnectionString -> Value
ToJSON, Value -> Parser [MSSQLConnectionString]
Value -> Parser MSSQLConnectionString
(Value -> Parser MSSQLConnectionString)
-> (Value -> Parser [MSSQLConnectionString])
-> FromJSON MSSQLConnectionString
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [MSSQLConnectionString]
$cparseJSONList :: Value -> Parser [MSSQLConnectionString]
parseJSON :: Value -> Parser MSSQLConnectionString
$cparseJSON :: Value -> Parser MSSQLConnectionString
FromJSON, Eq MSSQLConnectionString
Eq MSSQLConnectionString
-> (Accesses
    -> MSSQLConnectionString -> MSSQLConnectionString -> Bool)
-> Cacheable MSSQLConnectionString
Accesses -> MSSQLConnectionString -> MSSQLConnectionString -> Bool
forall a. Eq a -> (Accesses -> a -> a -> Bool) -> Cacheable a
unchanged :: Accesses -> MSSQLConnectionString -> MSSQLConnectionString -> Bool
$cunchanged :: Accesses -> MSSQLConnectionString -> MSSQLConnectionString -> Bool
$cp1Cacheable :: Eq MSSQLConnectionString
Cacheable, Int -> MSSQLConnectionString -> Int
MSSQLConnectionString -> Int
(Int -> MSSQLConnectionString -> Int)
-> (MSSQLConnectionString -> Int) -> Hashable MSSQLConnectionString
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: MSSQLConnectionString -> Int
$chash :: MSSQLConnectionString -> Int
hashWithSalt :: Int -> MSSQLConnectionString -> Int
$chashWithSalt :: Int -> MSSQLConnectionString -> Int
Hashable, MSSQLConnectionString -> ()
(MSSQLConnectionString -> ()) -> NFData MSSQLConnectionString
forall a. (a -> ()) -> NFData a
rnf :: MSSQLConnectionString -> ()
$crnf :: MSSQLConnectionString -> ()
NFData)

-- * Orphan instances

instance Cacheable MSPool.ConnectionString

instance Hashable MSPool.ConnectionString

instance NFData MSPool.ConnectionString

data InputConnectionString
  = RawString MSPool.ConnectionString
  | FromEnvironment Text
  deriving stock (Int -> InputConnectionString -> ShowS
[InputConnectionString] -> ShowS
InputConnectionString -> String
(Int -> InputConnectionString -> ShowS)
-> (InputConnectionString -> String)
-> ([InputConnectionString] -> ShowS)
-> Show InputConnectionString
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [InputConnectionString] -> ShowS
$cshowList :: [InputConnectionString] -> ShowS
show :: InputConnectionString -> String
$cshow :: InputConnectionString -> String
showsPrec :: Int -> InputConnectionString -> ShowS
$cshowsPrec :: Int -> InputConnectionString -> ShowS
Show, InputConnectionString -> InputConnectionString -> Bool
(InputConnectionString -> InputConnectionString -> Bool)
-> (InputConnectionString -> InputConnectionString -> Bool)
-> Eq InputConnectionString
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InputConnectionString -> InputConnectionString -> Bool
$c/= :: InputConnectionString -> InputConnectionString -> Bool
== :: InputConnectionString -> InputConnectionString -> Bool
$c== :: InputConnectionString -> InputConnectionString -> Bool
Eq, (forall x. InputConnectionString -> Rep InputConnectionString x)
-> (forall x. Rep InputConnectionString x -> InputConnectionString)
-> Generic InputConnectionString
forall x. Rep InputConnectionString x -> InputConnectionString
forall x. InputConnectionString -> Rep InputConnectionString x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep InputConnectionString x -> InputConnectionString
$cfrom :: forall x. InputConnectionString -> Rep InputConnectionString x
Generic)

instance Cacheable InputConnectionString

instance Hashable InputConnectionString

instance NFData InputConnectionString

instance ToJSON InputConnectionString where
  toJSON :: InputConnectionString -> Value
toJSON =
    \case
      (RawString ConnectionString
m) -> ConnectionString -> Value
forall a. ToJSON a => a -> Value
toJSON ConnectionString
m
      (FromEnvironment Text
wEnv) -> [Pair] -> Value
object [Key
"from_env" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
wEnv]

instance FromJSON InputConnectionString where
  parseJSON :: Value -> Parser InputConnectionString
parseJSON =
    \case
      (Object Object
o) -> Text -> InputConnectionString
FromEnvironment (Text -> InputConnectionString)
-> Parser Text -> Parser InputConnectionString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"from_env"
      s :: Value
s@(String Text
_) -> ConnectionString -> InputConnectionString
RawString (ConnectionString -> InputConnectionString)
-> Parser ConnectionString -> Parser InputConnectionString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser ConnectionString
forall a. FromJSON a => Value -> Parser a
parseJSON Value
s
      Value
_ -> String -> Parser InputConnectionString
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"one of string or object must be provided"

data MSSQLPoolSettings = MSSQLPoolSettings
  { MSSQLPoolSettings -> Int
_mpsMaxConnections :: Int,
    MSSQLPoolSettings -> Int
_mpsIdleTimeout :: Int
  }
  deriving (Int -> MSSQLPoolSettings -> ShowS
[MSSQLPoolSettings] -> ShowS
MSSQLPoolSettings -> String
(Int -> MSSQLPoolSettings -> ShowS)
-> (MSSQLPoolSettings -> String)
-> ([MSSQLPoolSettings] -> ShowS)
-> Show MSSQLPoolSettings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MSSQLPoolSettings] -> ShowS
$cshowList :: [MSSQLPoolSettings] -> ShowS
show :: MSSQLPoolSettings -> String
$cshow :: MSSQLPoolSettings -> String
showsPrec :: Int -> MSSQLPoolSettings -> ShowS
$cshowsPrec :: Int -> MSSQLPoolSettings -> ShowS
Show, MSSQLPoolSettings -> MSSQLPoolSettings -> Bool
(MSSQLPoolSettings -> MSSQLPoolSettings -> Bool)
-> (MSSQLPoolSettings -> MSSQLPoolSettings -> Bool)
-> Eq MSSQLPoolSettings
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MSSQLPoolSettings -> MSSQLPoolSettings -> Bool
$c/= :: MSSQLPoolSettings -> MSSQLPoolSettings -> Bool
== :: MSSQLPoolSettings -> MSSQLPoolSettings -> Bool
$c== :: MSSQLPoolSettings -> MSSQLPoolSettings -> Bool
Eq, (forall x. MSSQLPoolSettings -> Rep MSSQLPoolSettings x)
-> (forall x. Rep MSSQLPoolSettings x -> MSSQLPoolSettings)
-> Generic MSSQLPoolSettings
forall x. Rep MSSQLPoolSettings x -> MSSQLPoolSettings
forall x. MSSQLPoolSettings -> Rep MSSQLPoolSettings x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MSSQLPoolSettings x -> MSSQLPoolSettings
$cfrom :: forall x. MSSQLPoolSettings -> Rep MSSQLPoolSettings x
Generic)

instance Cacheable MSSQLPoolSettings

instance Hashable MSSQLPoolSettings

instance NFData MSSQLPoolSettings

$(deriveToJSON hasuraJSON ''MSSQLPoolSettings)

instance FromJSON MSSQLPoolSettings where
  parseJSON :: Value -> Parser MSSQLPoolSettings
parseJSON = String
-> (Object -> Parser MSSQLPoolSettings)
-> Value
-> Parser MSSQLPoolSettings
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"MSSQL pool settings" ((Object -> Parser MSSQLPoolSettings)
 -> Value -> Parser MSSQLPoolSettings)
-> (Object -> Parser MSSQLPoolSettings)
-> Value
-> Parser MSSQLPoolSettings
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    Int -> Int -> MSSQLPoolSettings
MSSQLPoolSettings
      (Int -> Int -> MSSQLPoolSettings)
-> Parser Int -> Parser (Int -> MSSQLPoolSettings)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"max_connections" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= MSSQLPoolSettings -> Int
_mpsMaxConnections MSSQLPoolSettings
defaultMSSQLPoolSettings
      Parser (Int -> MSSQLPoolSettings)
-> Parser Int -> Parser MSSQLPoolSettings
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"idle_timeout" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= MSSQLPoolSettings -> Int
_mpsIdleTimeout MSSQLPoolSettings
defaultMSSQLPoolSettings

defaultMSSQLPoolSettings :: MSSQLPoolSettings
defaultMSSQLPoolSettings :: MSSQLPoolSettings
defaultMSSQLPoolSettings =
  MSSQLPoolSettings :: Int -> Int -> MSSQLPoolSettings
MSSQLPoolSettings
    { _mpsMaxConnections :: Int
_mpsMaxConnections = Int
50,
      _mpsIdleTimeout :: Int
_mpsIdleTimeout = Int
5
    }

data MSSQLConnectionInfo = MSSQLConnectionInfo
  { MSSQLConnectionInfo -> InputConnectionString
_mciConnectionString :: InputConnectionString,
    MSSQLConnectionInfo -> MSSQLPoolSettings
_mciPoolSettings :: MSSQLPoolSettings
  }
  deriving (Int -> MSSQLConnectionInfo -> ShowS
[MSSQLConnectionInfo] -> ShowS
MSSQLConnectionInfo -> String
(Int -> MSSQLConnectionInfo -> ShowS)
-> (MSSQLConnectionInfo -> String)
-> ([MSSQLConnectionInfo] -> ShowS)
-> Show MSSQLConnectionInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MSSQLConnectionInfo] -> ShowS
$cshowList :: [MSSQLConnectionInfo] -> ShowS
show :: MSSQLConnectionInfo -> String
$cshow :: MSSQLConnectionInfo -> String
showsPrec :: Int -> MSSQLConnectionInfo -> ShowS
$cshowsPrec :: Int -> MSSQLConnectionInfo -> ShowS
Show, MSSQLConnectionInfo -> MSSQLConnectionInfo -> Bool
(MSSQLConnectionInfo -> MSSQLConnectionInfo -> Bool)
-> (MSSQLConnectionInfo -> MSSQLConnectionInfo -> Bool)
-> Eq MSSQLConnectionInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MSSQLConnectionInfo -> MSSQLConnectionInfo -> Bool
$c/= :: MSSQLConnectionInfo -> MSSQLConnectionInfo -> Bool
== :: MSSQLConnectionInfo -> MSSQLConnectionInfo -> Bool
$c== :: MSSQLConnectionInfo -> MSSQLConnectionInfo -> Bool
Eq, (forall x. MSSQLConnectionInfo -> Rep MSSQLConnectionInfo x)
-> (forall x. Rep MSSQLConnectionInfo x -> MSSQLConnectionInfo)
-> Generic MSSQLConnectionInfo
forall x. Rep MSSQLConnectionInfo x -> MSSQLConnectionInfo
forall x. MSSQLConnectionInfo -> Rep MSSQLConnectionInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MSSQLConnectionInfo x -> MSSQLConnectionInfo
$cfrom :: forall x. MSSQLConnectionInfo -> Rep MSSQLConnectionInfo x
Generic)

instance Cacheable MSSQLConnectionInfo

instance Hashable MSSQLConnectionInfo

instance NFData MSSQLConnectionInfo

$(deriveToJSON hasuraJSON ''MSSQLConnectionInfo)

instance FromJSON MSSQLConnectionInfo where
  parseJSON :: Value -> Parser MSSQLConnectionInfo
parseJSON = String
-> (Object -> Parser MSSQLConnectionInfo)
-> Value
-> Parser MSSQLConnectionInfo
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Object" ((Object -> Parser MSSQLConnectionInfo)
 -> Value -> Parser MSSQLConnectionInfo)
-> (Object -> Parser MSSQLConnectionInfo)
-> Value
-> Parser MSSQLConnectionInfo
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    InputConnectionString -> MSSQLPoolSettings -> MSSQLConnectionInfo
MSSQLConnectionInfo
      (InputConnectionString -> MSSQLPoolSettings -> MSSQLConnectionInfo)
-> Parser InputConnectionString
-> Parser (MSSQLPoolSettings -> MSSQLConnectionInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Object
o Object -> Key -> Parser InputConnectionString
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"database_url") Parser InputConnectionString
-> Parser InputConnectionString -> Parser InputConnectionString
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Object
o Object -> Key -> Parser InputConnectionString
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"connection_string"))
      Parser (MSSQLPoolSettings -> MSSQLConnectionInfo)
-> Parser MSSQLPoolSettings -> Parser MSSQLConnectionInfo
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o Object -> Key -> Parser (Maybe MSSQLPoolSettings)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"pool_settings" Parser (Maybe MSSQLPoolSettings)
-> MSSQLPoolSettings -> Parser MSSQLPoolSettings
forall a. Parser (Maybe a) -> a -> Parser a
.!= MSSQLPoolSettings
defaultMSSQLPoolSettings

data MSSQLConnConfiguration = MSSQLConnConfiguration
  { MSSQLConnConfiguration -> MSSQLConnectionInfo
_mccConnectionInfo :: MSSQLConnectionInfo,
    MSSQLConnConfiguration -> Maybe (NonEmpty MSSQLConnectionInfo)
_mccReadReplicas :: Maybe (NonEmpty MSSQLConnectionInfo)
  }
  deriving (Int -> MSSQLConnConfiguration -> ShowS
[MSSQLConnConfiguration] -> ShowS
MSSQLConnConfiguration -> String
(Int -> MSSQLConnConfiguration -> ShowS)
-> (MSSQLConnConfiguration -> String)
-> ([MSSQLConnConfiguration] -> ShowS)
-> Show MSSQLConnConfiguration
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MSSQLConnConfiguration] -> ShowS
$cshowList :: [MSSQLConnConfiguration] -> ShowS
show :: MSSQLConnConfiguration -> String
$cshow :: MSSQLConnConfiguration -> String
showsPrec :: Int -> MSSQLConnConfiguration -> ShowS
$cshowsPrec :: Int -> MSSQLConnConfiguration -> ShowS
Show, MSSQLConnConfiguration -> MSSQLConnConfiguration -> Bool
(MSSQLConnConfiguration -> MSSQLConnConfiguration -> Bool)
-> (MSSQLConnConfiguration -> MSSQLConnConfiguration -> Bool)
-> Eq MSSQLConnConfiguration
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MSSQLConnConfiguration -> MSSQLConnConfiguration -> Bool
$c/= :: MSSQLConnConfiguration -> MSSQLConnConfiguration -> Bool
== :: MSSQLConnConfiguration -> MSSQLConnConfiguration -> Bool
$c== :: MSSQLConnConfiguration -> MSSQLConnConfiguration -> Bool
Eq, (forall x. MSSQLConnConfiguration -> Rep MSSQLConnConfiguration x)
-> (forall x.
    Rep MSSQLConnConfiguration x -> MSSQLConnConfiguration)
-> Generic MSSQLConnConfiguration
forall x. Rep MSSQLConnConfiguration x -> MSSQLConnConfiguration
forall x. MSSQLConnConfiguration -> Rep MSSQLConnConfiguration x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MSSQLConnConfiguration x -> MSSQLConnConfiguration
$cfrom :: forall x. MSSQLConnConfiguration -> Rep MSSQLConnConfiguration x
Generic)

instance Cacheable MSSQLConnConfiguration

instance Hashable MSSQLConnConfiguration

instance NFData MSSQLConnConfiguration

$(deriveJSON hasuraJSON {omitNothingFields = True} ''MSSQLConnConfiguration)

-- TODO: Write a proper codec, and use it to derive FromJSON and ToJSON
-- instances.
instance HasCodec MSSQLConnConfiguration where
  codec :: JSONCodec MSSQLConnConfiguration
codec = Text
-> JSONCodec MSSQLConnConfiguration
-> JSONCodec MSSQLConnConfiguration
forall input output.
Text -> ValueCodec input output -> ValueCodec input output
named Text
"MSSQLConnConfiguration" (JSONCodec MSSQLConnConfiguration
 -> JSONCodec MSSQLConnConfiguration)
-> JSONCodec MSSQLConnConfiguration
-> JSONCodec MSSQLConnConfiguration
forall a b. (a -> b) -> a -> b
$ JSONCodec MSSQLConnConfiguration
forall a. (FromJSON a, ToJSON a) => JSONCodec a
placeholderCodecViaJSON

createMSSQLPool ::
  MonadIO m =>
  QErrM m =>
  MSSQLConnectionInfo ->
  Env.Environment ->
  m (MSPool.ConnectionString, MSPool.MSSQLPool)
createMSSQLPool :: MSSQLConnectionInfo
-> Environment -> m (ConnectionString, MSSQLPool)
createMSSQLPool (MSSQLConnectionInfo InputConnectionString
iConnString MSSQLPoolSettings {Int
_mpsIdleTimeout :: Int
_mpsMaxConnections :: Int
_mpsIdleTimeout :: MSSQLPoolSettings -> Int
_mpsMaxConnections :: MSSQLPoolSettings -> Int
..}) Environment
env = do
  ConnectionString
connString <- Environment -> InputConnectionString -> m ConnectionString
forall (m :: * -> *).
QErrM m =>
Environment -> InputConnectionString -> m ConnectionString
resolveInputConnectionString Environment
env InputConnectionString
iConnString
  let connOptions :: ConnectionOptions
connOptions =
        ConnectionOptions :: Int -> Int -> Int -> ConnectionOptions
MSPool.ConnectionOptions
          { _coConnections :: Int
_coConnections = Int
_mpsMaxConnections,
            _coStripes :: Int
_coStripes = Int
1,
            _coIdleTime :: Int
_coIdleTime = Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
_mpsIdleTimeout
          }
  MSSQLPool
pool <- IO MSSQLPool -> m MSSQLPool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MSSQLPool -> m MSSQLPool) -> IO MSSQLPool -> m MSSQLPool
forall a b. (a -> b) -> a -> b
$ ConnectionString -> ConnectionOptions -> IO MSSQLPool
MSPool.initMSSQLPool ConnectionString
connString ConnectionOptions
connOptions
  (ConnectionString, MSSQLPool) -> m (ConnectionString, MSSQLPool)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConnectionString
connString, MSSQLPool
pool)

resolveInputConnectionString ::
  QErrM m =>
  Env.Environment ->
  InputConnectionString ->
  m MSPool.ConnectionString
resolveInputConnectionString :: Environment -> InputConnectionString -> m ConnectionString
resolveInputConnectionString Environment
env =
  \case
    (RawString ConnectionString
cs) -> ConnectionString -> m ConnectionString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnectionString
cs
    (FromEnvironment Text
envVar) -> Text -> ConnectionString
MSPool.ConnectionString (Text -> ConnectionString) -> m Text -> m ConnectionString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Environment -> Text -> m Text
forall (m :: * -> *). QErrM m => Environment -> Text -> m Text
getEnv Environment
env Text
envVar

getEnv :: QErrM m => Env.Environment -> Text -> m Text
getEnv :: Environment -> Text -> m Text
getEnv Environment
env Text
k = do
  let mEnv :: Maybe String
mEnv = Environment -> String -> Maybe String
Env.lookupEnv Environment
env (Text -> String
unpack Text
k)
  case Maybe String
mEnv of
    Maybe String
Nothing -> Code -> Text -> m Text
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
NotFound (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ Text
"environment variable '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' not set"
    Just String
envVal -> Text -> m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Text
pack String
envVal)

type MSSQLRunTx =
  forall m a. (MonadIO m, MonadBaseControl IO m) => MSTx.TxET QErr m a -> ExceptT QErr m a

-- | Execution Context required to execute MSSQL transactions
data MSSQLExecCtx = MSSQLExecCtx
  { -- | A function that runs read-only queries
    MSSQLExecCtx
-> forall (m :: * -> *) a.
   (MonadIO m, MonadBaseControl IO m) =>
   TxET QErr m a -> ExceptT QErr m a
mssqlRunReadOnly :: MSSQLRunTx,
    -- | A function that runs read-write queries; run in a transaction
    MSSQLExecCtx
-> forall (m :: * -> *) a.
   (MonadIO m, MonadBaseControl IO m) =>
   TxET QErr m a -> ExceptT QErr m a
mssqlRunReadWrite :: MSSQLRunTx,
    -- | Destroys connection pools
    MSSQLExecCtx -> IO ()
mssqlDestroyConn :: IO ()
  }

-- | Creates a MSSQL execution context for a single primary pool
mkMSSQLExecCtx :: MSPool.MSSQLPool -> MSSQLExecCtx
mkMSSQLExecCtx :: MSSQLPool -> MSSQLExecCtx
mkMSSQLExecCtx MSSQLPool
pool =
  MSSQLExecCtx :: (forall (m :: * -> *) a.
 (MonadIO m, MonadBaseControl IO m) =>
 TxET QErr m a -> ExceptT QErr m a)
-> (forall (m :: * -> *) a.
    (MonadIO m, MonadBaseControl IO m) =>
    TxET QErr m a -> ExceptT QErr m a)
-> IO ()
-> MSSQLExecCtx
MSSQLExecCtx
    { mssqlRunReadOnly :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
TxET QErr m a -> ExceptT QErr m a
mssqlRunReadOnly = \TxET QErr m a
tx -> (MSSQLTxError -> QErr)
-> TxET QErr m a -> MSSQLPool -> ExceptT QErr m a
forall (m :: * -> *) e a.
(MonadIO m, MonadBaseControl IO m) =>
(MSSQLTxError -> e) -> TxET e m a -> MSSQLPool -> ExceptT e m a
MSTx.runTxE MSSQLTxError -> QErr
defaultMSSQLTxErrorHandler TxET QErr m a
tx MSSQLPool
pool,
      mssqlRunReadWrite :: forall (m :: * -> *) a.
(MonadIO m, MonadBaseControl IO m) =>
TxET QErr m a -> ExceptT QErr m a
mssqlRunReadWrite = \TxET QErr m a
tx -> (MSSQLTxError -> QErr)
-> TxET QErr m a -> MSSQLPool -> ExceptT QErr m a
forall (m :: * -> *) e a.
(MonadIO m, MonadBaseControl IO m) =>
(MSSQLTxError -> e) -> TxET e m a -> MSSQLPool -> ExceptT e m a
MSTx.runTxE MSSQLTxError -> QErr
defaultMSSQLTxErrorHandler TxET QErr m a
tx MSSQLPool
pool,
      mssqlDestroyConn :: IO ()
mssqlDestroyConn = MSSQLPool -> IO ()
MSPool.drainMSSQLPool MSSQLPool
pool
    }

data MSSQLSourceConfig = MSSQLSourceConfig
  { MSSQLSourceConfig -> ConnectionString
_mscConnectionString :: MSPool.ConnectionString,
    MSSQLSourceConfig -> MSSQLExecCtx
_mscExecCtx :: MSSQLExecCtx
  }
  deriving ((forall x. MSSQLSourceConfig -> Rep MSSQLSourceConfig x)
-> (forall x. Rep MSSQLSourceConfig x -> MSSQLSourceConfig)
-> Generic MSSQLSourceConfig
forall x. Rep MSSQLSourceConfig x -> MSSQLSourceConfig
forall x. MSSQLSourceConfig -> Rep MSSQLSourceConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MSSQLSourceConfig x -> MSSQLSourceConfig
$cfrom :: forall x. MSSQLSourceConfig -> Rep MSSQLSourceConfig x
Generic)

instance Show MSSQLSourceConfig where
  show :: MSSQLSourceConfig -> String
show = ConnectionString -> String
forall a. Show a => a -> String
show (ConnectionString -> String)
-> (MSSQLSourceConfig -> ConnectionString)
-> MSSQLSourceConfig
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MSSQLSourceConfig -> ConnectionString
_mscConnectionString

instance Eq MSSQLSourceConfig where
  MSSQLSourceConfig ConnectionString
connStr1 MSSQLExecCtx
_ == :: MSSQLSourceConfig -> MSSQLSourceConfig -> Bool
== MSSQLSourceConfig ConnectionString
connStr2 MSSQLExecCtx
_ =
    ConnectionString
connStr1 ConnectionString -> ConnectionString -> Bool
forall a. Eq a => a -> a -> Bool
== ConnectionString
connStr2

instance Cacheable MSSQLSourceConfig where
  unchanged :: Accesses -> MSSQLSourceConfig -> MSSQLSourceConfig -> Bool
unchanged Accesses
_ = MSSQLSourceConfig -> MSSQLSourceConfig -> Bool
forall a. Eq a => a -> a -> Bool
(==)

instance ToJSON MSSQLSourceConfig where
  toJSON :: MSSQLSourceConfig -> Value
toJSON = ConnectionString -> Value
forall a. ToJSON a => a -> Value
toJSON (ConnectionString -> Value)
-> (MSSQLSourceConfig -> ConnectionString)
-> MSSQLSourceConfig
-> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MSSQLSourceConfig -> ConnectionString
_mscConnectionString

odbcValueToJValue :: ODBC.Value -> J.Value
odbcValueToJValue :: Value -> Value
odbcValueToJValue = \case
  ODBC.TextValue Text
t -> Text -> Value
J.String Text
t
  ODBC.ByteStringValue ByteString
b -> Text -> Value
J.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
bsToTxt ByteString
b
  ODBC.BinaryValue Binary
b -> Text -> Value
J.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
bsToTxt (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ Binary -> ByteString
ODBC.unBinary Binary
b
  ODBC.BoolValue Bool
b -> Bool -> Value
J.Bool Bool
b
  ODBC.DoubleValue Double
d -> Double -> Value
forall a. ToJSON a => a -> Value
J.toJSON Double
d
  ODBC.FloatValue Float
f -> Float -> Value
forall a. ToJSON a => a -> Value
J.toJSON Float
f
  ODBC.IntValue Int
i -> Int -> Value
forall a. ToJSON a => a -> Value
J.toJSON Int
i
  ODBC.ByteValue Word8
b -> Word8 -> Value
forall a. ToJSON a => a -> Value
J.toJSON Word8
b
  ODBC.DayValue Day
d -> Day -> Value
forall a. ToJSON a => a -> Value
J.toJSON Day
d
  ODBC.TimeOfDayValue TimeOfDay
td -> TimeOfDay -> Value
forall a. ToJSON a => a -> Value
J.toJSON TimeOfDay
td
  ODBC.LocalTimeValue LocalTime
l -> LocalTime -> Value
forall a. ToJSON a => a -> Value
J.toJSON LocalTime
l
  Value
ODBC.NullValue -> Value
J.Null

runMSSQLSourceReadTx ::
  (MonadIO m, MonadBaseControl IO m) =>
  MSSQLSourceConfig ->
  MSTx.TxET QErr m a ->
  m (Either QErr a)
runMSSQLSourceReadTx :: MSSQLSourceConfig -> TxET QErr m a -> m (Either QErr a)
runMSSQLSourceReadTx MSSQLSourceConfig
msc =
  ExceptT QErr m a -> m (Either QErr a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr m a -> m (Either QErr a))
-> (TxET QErr m a -> ExceptT QErr m a)
-> TxET QErr m a
-> m (Either QErr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MSSQLExecCtx
-> forall (m :: * -> *) a.
   (MonadIO m, MonadBaseControl IO m) =>
   TxET QErr m a -> ExceptT QErr m a
mssqlRunReadOnly (MSSQLSourceConfig -> MSSQLExecCtx
_mscExecCtx MSSQLSourceConfig
msc)

runMSSQLSourceWriteTx ::
  (MonadIO m, MonadBaseControl IO m) =>
  MSSQLSourceConfig ->
  MSTx.TxET QErr m a ->
  m (Either QErr a)
runMSSQLSourceWriteTx :: MSSQLSourceConfig -> TxET QErr m a -> m (Either QErr a)
runMSSQLSourceWriteTx MSSQLSourceConfig
msc =
  ExceptT QErr m a -> m (Either QErr a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr m a -> m (Either QErr a))
-> (TxET QErr m a -> ExceptT QErr m a)
-> TxET QErr m a
-> m (Either QErr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MSSQLExecCtx
-> forall (m :: * -> *) a.
   (MonadIO m, MonadBaseControl IO m) =>
   TxET QErr m a -> ExceptT QErr m a
mssqlRunReadWrite (MSSQLSourceConfig -> MSSQLExecCtx
_mscExecCtx MSSQLSourceConfig
msc)