{-# 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 qualified Data.HashMap.Strict as H
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)
#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 x :: Value
x <> :: MergedValue -> MergedValue -> MergedValue
<> MergedValue y :: 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 x :: Object
x) (Object y :: Object
y) = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$ (Value -> Value -> Value) -> Object -> Object -> Object
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> HashMap k v -> HashMap k v -> HashMap k v
H.unionWith Value -> Value -> Value
mergeValues Object
x Object
y
mergeValues x :: Value
x _ = Value
x
loadAppSettings
:: FromJSON settings
=> [FilePath]
-> [Value]
-> 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" #-}
loadAppSettingsArgs
:: FromJSON settings
=> [Value]
-> EnvUsage
-> 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" #-}
configSettingsYml :: FilePath
configSettingsYml :: FilePath
configSettingsYml = "config/settings.yml"
getDevSettings :: Settings -> IO Settings
getDevSettings :: Settings -> IO Settings
getDevSettings settings :: 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 "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 "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
$ "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
develMainHelper :: IO (Settings, Application) -> IO ()
develMainHelper :: IO (Settings, Application) -> IO ()
develMainHelper getSettingsApp :: 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 "Starting devel application"
(settings :: Settings
settings, app :: 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 100000
Bool
e <- FilePath -> IO Bool
doesFileExist "yesod-devel/devel-terminate"
if Bool
e then IO ()
terminateDevel else IO ()
loop
terminateDevel :: IO ()
terminateDevel :: IO ()
terminateDevel = IO ()
forall a. IO a
exitSuccess
makeYesodLogger :: LoggerSet -> IO Logger
makeYesodLogger :: LoggerSet -> IO Logger
makeYesodLogger loggerSet' :: LoggerSet
loggerSet' = do
(getter :: DateCacheGetter
getter, _) <- 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