{-# 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 (Value -> MergedValue) -> Value -> 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 (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
loadAppSettings
:: FromJSON settings
=> [FilePath]
-> [Value]
-> EnvUsage
-> IO settings
loadAppSettings :: forall settings.
FromJSON settings =>
[[Char]] -> [Value] -> EnvUsage -> IO settings
loadAppSettings = [[Char]] -> [Value] -> EnvUsage -> IO settings
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 = [Value] -> EnvUsage -> IO settings
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
env <- IO [([Char], [Char])]
getEnvironment
let 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
$ [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"PORT" [([Char], [Char])]
env Maybe [Char] -> ([Char] -> Maybe Port) -> Maybe Port
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Maybe Port
forall a. Read a => [Char] -> Maybe a
readMaybe
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
$ [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"DISPLAY_PORT" [([Char], [Char])]
env Maybe [Char] -> ([Char] -> Maybe Port) -> Maybe Port
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Maybe Port
forall a. Read a => [Char] -> Maybe a
readMaybe
putStrLn $ "Devel application launched: http://localhost:" ++ show pdisplay
return $ setPort p settings
develMainHelper :: IO (Settings, Application) -> IO ()
develMainHelper :: IO (Settings, Application) -> IO ()
develMainHelper IO (Settings, Application)
getSettingsApp = do
#ifndef mingw32_HOST_OS
_ <- 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Maybe SignalSet
forall a. Maybe a
Nothing
#endif
putStrLn "Starting devel application"
(settings, app) <- getSettingsApp
_ <- forkIO $ runSettings settings app
loop
where
loop :: IO ()
loop :: IO ()
loop = do
Port -> IO ()
threadDelay Port
100000
e <- [Char] -> IO Bool
doesFileExist [Char]
"yesod-devel/devel-terminate"
if e then terminateDevel else loop
terminateDevel :: IO ()
terminateDevel :: IO ()
terminateDevel = IO ()
forall a. IO a
exitSuccess
makeYesodLogger :: LoggerSet -> IO Logger
makeYesodLogger :: LoggerSet -> IO Logger
makeYesodLogger LoggerSet
loggerSet' = do
(getter, _) <- IO (DateCacheGetter, IO ())
clockDateCacher
return $! Yesod.Core.Types.Logger loggerSet' getter