{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
module Yesod.Default.Config2
(
configSettingsYml
, getDevSettings
, develMainHelper
, makeYesodLogger
, applyCurrentEnv
, getCurrentEnv
, applyEnvValue
, loadYamlSettings
, loadYamlSettingsArgs
, EnvUsage
, ignoreEnv
, useEnv
, requireEnv
, useCustomEnv
, requireCustomEnv
, 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 forall a b. (a -> b) -> a -> b
$ Value -> Value -> Value
mergeValues Value
x Value
y
mergeValues :: Value -> Value -> Value
mergeValues :: Value -> Value -> Value
mergeValues (Object Object
x) (Object Object
y) = Object -> Value
Object forall a b. (a -> b) -> a -> b
$ 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
loadAppSettings
:: FromJSON settings
=> [FilePath]
-> [Value]
-> EnvUsage
-> IO settings
loadAppSettings :: forall settings.
FromJSON settings =>
[[Char]] -> [Value] -> EnvUsage -> IO settings
loadAppSettings = forall settings.
FromJSON settings =>
[[Char]] -> [Value] -> EnvUsage -> IO settings
loadYamlSettings
{-# DEPRECATED loadAppSettings "Use loadYamlSettings" #-}
loadAppSettingsArgs
:: FromJSON settings
=> [Value]
-> EnvUsage
-> IO settings
loadAppSettingsArgs :: forall settings.
FromJSON settings =>
[Value] -> EnvUsage -> IO settings
loadAppSettingsArgs = forall settings.
FromJSON settings =>
[Value] -> EnvUsage -> IO settings
loadYamlSettingsArgs
{-# DEPRECATED loadAppSettingsArgs "Use loadYamlSettingsArgs" #-}
configSettingsYml :: FilePath
configSettingsYml :: [Char]
configSettingsYml = [Char]
"config/settings.yml"
getDevSettings :: Settings -> IO Settings
getDevSettings :: Settings -> IO Settings
getDevSettings Settings
settings = do
[([Char], [Char])]
env <- IO [([Char], [Char])]
getEnvironment
let p :: Port
p = forall a. a -> Maybe a -> a
fromMaybe (Settings -> Port
getPort Settings
settings) forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"PORT" [([Char], [Char])]
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Read a => [Char] -> Maybe a
readMaybe
pdisplay :: Port
pdisplay = forall a. a -> Maybe a -> a
fromMaybe Port
p forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"DISPLAY_PORT" [([Char], [Char])]
env forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Read a => [Char] -> Maybe a
readMaybe
[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Devel application launched: http://localhost:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Port
pdisplay
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Port -> Settings -> Settings
setPort Port
p Settings
settings
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 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a. Maybe a
Nothing
#endif
[Char] -> IO ()
putStrLn [Char]
"Starting devel application"
(Settings
settings, Application
app) <- IO (Settings, Application)
getSettingsApp
ThreadId
_ <- IO () -> IO ThreadId
forkIO 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 <- [Char] -> IO Bool
doesFileExist [Char]
"yesod-devel/devel-terminate"
if Bool
e then IO ()
terminateDevel else IO ()
loop
terminateDevel :: IO ()
terminateDevel :: IO ()
terminateDevel = forall a. IO a
exitSuccess
makeYesodLogger :: LoggerSet -> IO Logger
makeYesodLogger :: LoggerSet -> IO Logger
makeYesodLogger LoggerSet
loggerSet' = do
(DateCacheGetter
getter, IO ()
_) <- IO (DateCacheGetter, IO ())
clockDateCacher
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! LoggerSet -> DateCacheGetter -> Logger
Yesod.Core.Types.Logger LoggerSet
loggerSet' DateCacheGetter
getter