-- |
-- Copyright: (c) 2019 Lucas David Traverso
-- License: MPL-2.0
-- Maintainer: Lucas David Traverso <lucas6246@gmail.com>
-- Stability: stable
-- Portability: portable
--
-- FromConfig instance for hedis
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE CPP #-}
module Conferer.FromConfig.Hedis where

import Conferer.FromConfig
import Conferer.Config

import qualified Database.Redis as Redis
import Data.Text (Text, unpack)
import Text.Read (readMaybe)
import Data.Dynamic

instance FromConfig Redis.PortID where
  fromConfig :: Key -> Config -> IO PortID
fromConfig = (Text -> Maybe PortID) -> Key -> Config -> IO PortID
forall a. Typeable a => (Text -> Maybe a) -> Key -> Config -> IO a
fetchFromConfigWith (\Text
t -> do
      case String -> Maybe PortNumber
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe PortNumber) -> String -> Maybe PortNumber
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
t of
        Just PortNumber
n -> PortID -> Maybe PortID
forall (m :: * -> *) a. Monad m => a -> m a
return (PortID -> Maybe PortID) -> PortID -> Maybe PortID
forall a b. (a -> b) -> a -> b
$ PortNumber -> PortID
Redis.PortNumber PortNumber
n
        Maybe PortNumber
Nothing -> do
#ifdef mingw32_HOST_OS
          Nothing
#else
          PortID -> Maybe PortID
forall (m :: * -> *) a. Monad m => a -> m a
return (PortID -> Maybe PortID) -> PortID -> Maybe PortID
forall a b. (a -> b) -> a -> b
$ String -> PortID
Redis.UnixSocket (String -> PortID) -> String -> PortID
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
t
#endif
    )

-- | Deconstruct a 'Redis.ConnectInfo' into a many key/dynamic pairs to
-- provide valid defaults for downstream 'fetchFromConfig'
deconstructConnInfoToDefaults :: Redis.ConnectInfo -> [(Key, Dynamic)]
deconstructConnInfoToDefaults :: ConnectInfo -> [(Key, Dynamic)]
deconstructConnInfoToDefaults Redis.ConnInfo{Int
Integer
String
Maybe ByteString
Maybe NominalDiffTime
Maybe ClientParams
PortID
NominalDiffTime
connectHost :: ConnectInfo -> String
connectPort :: ConnectInfo -> PortID
connectAuth :: ConnectInfo -> Maybe ByteString
connectDatabase :: ConnectInfo -> Integer
connectMaxConnections :: ConnectInfo -> Int
connectMaxIdleTime :: ConnectInfo -> NominalDiffTime
connectTimeout :: ConnectInfo -> Maybe NominalDiffTime
connectTLSParams :: ConnectInfo -> Maybe ClientParams
connectTLSParams :: Maybe ClientParams
connectTimeout :: Maybe NominalDiffTime
connectMaxIdleTime :: NominalDiffTime
connectMaxConnections :: Int
connectDatabase :: Integer
connectAuth :: Maybe ByteString
connectPort :: PortID
connectHost :: String
..} =
  [ (Key
"host", String -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn String
connectHost)
  , (Key
"port", PortID -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn PortID
connectPort)
  , (Key
"auth", Maybe ByteString -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe ByteString
connectAuth)
  , (Key
"database", Integer -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Integer
connectDatabase)

  , (Key
"maxConnections", Int -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Int
connectMaxConnections)
  , (Key
"maxIdleTime", NominalDiffTime -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn NominalDiffTime
connectMaxIdleTime)
  , (Key
"timeout", Maybe NominalDiffTime -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe NominalDiffTime
connectTimeout)
#if MIN_VERSION_hedis(0,10,2)
  , (Key
"tlsParams", Maybe ClientParams -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe ClientParams
connectTLSParams)
#endif
  ]

instance DefaultConfig Redis.ConnectInfo where
  configDef :: ConnectInfo
configDef = ConnectInfo
Redis.defaultConnectInfo

instance FromConfig Redis.ConnectInfo where
  fromConfig :: Key -> Config -> IO ConnectInfo
fromConfig Key
key Config
originalConfig = do
    Config
firstConfig <- (ConnectInfo -> [(Key, Dynamic)]) -> Key -> Config -> IO Config
forall a.
Typeable a =>
(a -> [(Key, Dynamic)]) -> Key -> Config -> IO Config
addDefaultsAfterDeconstructingToDefaults ConnectInfo -> [(Key, Dynamic)]
deconstructConnInfoToDefaults Key
key Config
originalConfig

-- For hedis < 0.10.0 `Redis.parseConnectInfo` doesn't exist so in that case
-- we simply avoid reading the url directly from key, and instead we directly
-- act as if it wasn't present
#if MIN_VERSION_hedis(0,10,0)
    Config
config <-
      Key -> Config -> IO (Maybe Text)
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig @(Maybe Text) (Key
key Key -> Key -> Key
/. Key
"url") Config
firstConfig
        IO (Maybe Text) -> (Maybe Text -> IO Config) -> IO Config
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Text
connectionString -> do
          case String -> Either String ConnectInfo
Redis.parseConnectInfo (String -> Either String ConnectInfo)
-> String -> Either String ConnectInfo
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
connectionString of
            Right Redis.ConnInfo{Int
Integer
String
Maybe ByteString
Maybe NominalDiffTime
Maybe ClientParams
PortID
NominalDiffTime
connectTLSParams :: Maybe ClientParams
connectTimeout :: Maybe NominalDiffTime
connectMaxIdleTime :: NominalDiffTime
connectMaxConnections :: Int
connectDatabase :: Integer
connectAuth :: Maybe ByteString
connectPort :: PortID
connectHost :: String
connectHost :: ConnectInfo -> String
connectPort :: ConnectInfo -> PortID
connectAuth :: ConnectInfo -> Maybe ByteString
connectDatabase :: ConnectInfo -> Integer
connectMaxConnections :: ConnectInfo -> Int
connectMaxIdleTime :: ConnectInfo -> NominalDiffTime
connectTimeout :: ConnectInfo -> Maybe NominalDiffTime
connectTLSParams :: ConnectInfo -> Maybe ClientParams
..} -> do
              Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> IO Config) -> Config -> IO Config
forall a b. (a -> b) -> a -> b
$
                Config
firstConfig
                Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& [(Key, Dynamic)] -> Config -> Config
addDefaults
                    [ (Key
key Key -> Key -> Key
/. Key
"host", String -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn String
connectHost)
                    , (Key
key Key -> Key -> Key
/. Key
"port", PortID -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn PortID
connectPort)
                    , (Key
key Key -> Key -> Key
/. Key
"auth", Maybe ByteString -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Maybe ByteString
connectAuth)
                    , (Key
key Key -> Key -> Key
/. Key
"database", Integer -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn Integer
connectDatabase)
                    ]
            Left String
_e ->
              Key -> Text -> IO Config
forall a b. Typeable a => Key -> Text -> IO b
throwConfigParsingError @Redis.ConnectInfo Key
key Text
connectionString
        Maybe Text
Nothing -> do
          Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return Config
firstConfig
#else
    config <- return firstConfig
#endif
    String
connectHost <- Key -> Config -> IO String
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"host") Config
config
    PortID
connectPort <- Key -> Config -> IO PortID
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"port") Config
config
    Maybe ByteString
connectAuth <- Key -> Config -> IO (Maybe ByteString)
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"auth") Config
config
    Integer
connectDatabase <- Key -> Config -> IO Integer
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"database") Config
config

    Int
connectMaxConnections <- Key -> Config -> IO Int
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"maxConnections") Config
config
    NominalDiffTime
connectMaxIdleTime <- Key -> Config -> IO NominalDiffTime
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"maxIdleTime") Config
config
    Maybe NominalDiffTime
connectTimeout <- Key -> Config -> IO (Maybe NominalDiffTime)
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"timeout") Config
config
#if MIN_VERSION_hedis(0,10,2)
    Maybe ClientParams
connectTLSParams <- Key -> Config -> IO (Maybe ClientParams)
forall a. (FromConfig a, Typeable a) => Key -> Config -> IO a
fetchFromConfig (Key
key Key -> Key -> Key
/. Key
"tlsParams") Config
config
#endif
    ConnectInfo -> IO ConnectInfo
forall (f :: * -> *) a. Applicative f => a -> f a
pure ConnInfo :: String
-> PortID
-> Maybe ByteString
-> Integer
-> Int
-> NominalDiffTime
-> Maybe NominalDiffTime
-> Maybe ClientParams
-> ConnectInfo
Redis.ConnInfo{Int
Integer
String
Maybe ByteString
Maybe NominalDiffTime
Maybe ClientParams
PortID
NominalDiffTime
connectTLSParams :: Maybe ClientParams
connectTimeout :: Maybe NominalDiffTime
connectMaxIdleTime :: NominalDiffTime
connectMaxConnections :: Int
connectDatabase :: Integer
connectAuth :: Maybe ByteString
connectPort :: PortID
connectHost :: String
connectHost :: String
connectPort :: PortID
connectAuth :: Maybe ByteString
connectDatabase :: Integer
connectMaxConnections :: Int
connectMaxIdleTime :: NominalDiffTime
connectTimeout :: Maybe NominalDiffTime
connectTLSParams :: Maybe ClientParams
..}