{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Some next-gen helper functions for the scaffolding's configuration system.
module Yesod.Default.Config2
    ( -- * Locally defined
      configSettingsYml
    , getDevSettings
    , develMainHelper
    , makeYesodLogger
      -- * Re-exports from Data.Yaml.Config
    , applyCurrentEnv
    , getCurrentEnv
    , applyEnvValue
    , loadYamlSettings
    , loadYamlSettingsArgs
    , EnvUsage
    , ignoreEnv
    , useEnv
    , requireEnv
    , useCustomEnv
    , requireCustomEnv
      -- * For backwards compatibility
    , MergedValue (..)
    , loadAppSettings
    , loadAppSettingsArgs
    ) where


import Data.Yaml.Config

import Data.Semigroup
import Data.Aeson
import System.Environment (getEnvironment)
import Network.Wai (Application)
import Network.Wai.Handler.Warp
import Text.Read (readMaybe)
import Data.Maybe (fromMaybe)
import Control.Concurrent (forkIO, threadDelay)
import System.Exit (exitSuccess)
import System.Directory (doesFileExist)
import Network.Wai.Logger (clockDateCacher)
import Yesod.Core.Types (Logger (Logger))
import System.Log.FastLogger (LoggerSet)

#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.KeyMap as H
#else
import qualified Data.HashMap.Strict as H
#endif

#ifndef mingw32_HOST_OS
import System.Posix.Signals (installHandler, sigINT, Handler(Catch))
#endif

newtype MergedValue = MergedValue { MergedValue -> Value
getMergedValue :: Value }

instance Semigroup MergedValue where
    MergedValue Value
x <> :: MergedValue -> MergedValue -> MergedValue
<> MergedValue Value
y = Value -> MergedValue
MergedValue (Value -> MergedValue) -> Value -> MergedValue
forall a b. (a -> b) -> a -> b
$ Value -> Value -> Value
mergeValues Value
x Value
y

-- | Left biased
mergeValues :: Value -> Value -> Value
mergeValues :: Value -> Value -> Value
mergeValues (Object Object
x) (Object Object
y) = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value) -> Object -> Object -> Object
forall v. (v -> v -> v) -> KeyMap v -> KeyMap v -> KeyMap v
H.unionWith Value -> Value -> Value
mergeValues Object
x Object
y
mergeValues Value
x Value
_ = Value
x

-- | Load the settings from the following three sources:
--
-- * Run time config files
--
-- * Run time environment variables
--
-- * The default compile time config file
loadAppSettings
    :: FromJSON settings
    => [FilePath] -- ^ run time config files to use, earlier files have precedence
    -> [Value] -- ^ any other values to use, usually from compile time config. overridden by files
    -> EnvUsage
    -> IO settings
loadAppSettings :: [FilePath] -> [Value] -> EnvUsage -> IO settings
loadAppSettings = [FilePath] -> [Value] -> EnvUsage -> IO settings
forall settings.
FromJSON settings =>
[FilePath] -> [Value] -> EnvUsage -> IO settings
loadYamlSettings
{-# DEPRECATED loadAppSettings "Use loadYamlSettings" #-}

-- | Same as @loadAppSettings@, but get the list of runtime config files from
-- the command line arguments.
loadAppSettingsArgs
    :: FromJSON settings
    => [Value] -- ^ any other values to use, usually from compile time config. overridden by files
    -> EnvUsage -- ^ use environment variables
    -> IO settings
loadAppSettingsArgs :: [Value] -> EnvUsage -> IO settings
loadAppSettingsArgs = [Value] -> EnvUsage -> IO settings
forall settings.
FromJSON settings =>
[Value] -> EnvUsage -> IO settings
loadYamlSettingsArgs
{-# DEPRECATED loadAppSettingsArgs "Use loadYamlSettingsArgs" #-}

-- | Location of the default config file.
configSettingsYml :: FilePath
configSettingsYml :: FilePath
configSettingsYml = FilePath
"config/settings.yml"

-- | Helper for getApplicationDev in the scaffolding. Looks up PORT and
-- DISPLAY_PORT and prints appropriate messages.
getDevSettings :: Settings -> IO Settings
getDevSettings :: Settings -> IO Settings
getDevSettings Settings
settings = do
    [(FilePath, FilePath)]
env <- IO [(FilePath, FilePath)]
getEnvironment
    let p :: Port
p = Port -> Maybe Port -> Port
forall a. a -> Maybe a -> a
fromMaybe (Settings -> Port
getPort Settings
settings) (Maybe Port -> Port) -> Maybe Port -> Port
forall a b. (a -> b) -> a -> b
$ FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"PORT" [(FilePath, FilePath)]
env Maybe FilePath -> (FilePath -> Maybe Port) -> Maybe Port
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Maybe Port
forall a. Read a => FilePath -> Maybe a
readMaybe
        pdisplay :: Port
pdisplay = Port -> Maybe Port -> Port
forall a. a -> Maybe a -> a
fromMaybe Port
p (Maybe Port -> Port) -> Maybe Port -> Port
forall a b. (a -> b) -> a -> b
$ FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"DISPLAY_PORT" [(FilePath, FilePath)]
env Maybe FilePath -> (FilePath -> Maybe Port) -> Maybe Port
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Maybe Port
forall a. Read a => FilePath -> Maybe a
readMaybe
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Devel application launched: http://localhost:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Port -> FilePath
forall a. Show a => a -> FilePath
show Port
pdisplay
    Settings -> IO Settings
forall (m :: * -> *) a. Monad m => a -> m a
return (Settings -> IO Settings) -> Settings -> IO Settings
forall a b. (a -> b) -> a -> b
$ Port -> Settings -> Settings
setPort Port
p Settings
settings

-- | Helper for develMain in the scaffolding.
develMainHelper :: IO (Settings, Application) -> IO ()
develMainHelper :: IO (Settings, Application) -> IO ()
develMainHelper IO (Settings, Application)
getSettingsApp = do
#ifndef mingw32_HOST_OS
    Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigINT (IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Maybe SignalSet
forall a. Maybe a
Nothing
#endif

    FilePath -> IO ()
putStrLn FilePath
"Starting devel application"
    (Settings
settings, Application
app) <- IO (Settings, Application)
getSettingsApp
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Settings -> Application -> IO ()
runSettings Settings
settings Application
app
    IO ()
loop
  where
    loop :: IO ()
    loop :: IO ()
loop = do
        Port -> IO ()
threadDelay Port
100000
        Bool
e <- FilePath -> IO Bool
doesFileExist FilePath
"yesod-devel/devel-terminate"
        if Bool
e then IO ()
terminateDevel else IO ()
loop

    terminateDevel :: IO ()
    terminateDevel :: IO ()
terminateDevel = IO ()
forall a. IO a
exitSuccess

-- | Create a 'Logger' value (from yesod-core) out of a 'LoggerSet' (from
-- fast-logger).
makeYesodLogger :: LoggerSet -> IO Logger
makeYesodLogger :: LoggerSet -> IO Logger
makeYesodLogger LoggerSet
loggerSet' = do
    (DateCacheGetter
getter, IO ()
_) <- IO (DateCacheGetter, IO ())
clockDateCacher
    Logger -> IO Logger
forall (m :: * -> *) a. Monad m => a -> m a
return (Logger -> IO Logger) -> Logger -> IO Logger
forall a b. (a -> b) -> a -> b
$! LoggerSet -> DateCacheGetter -> Logger
Yesod.Core.Types.Logger LoggerSet
loggerSet' DateCacheGetter
getter