Add ini-like config support

This commit is contained in:
rnhmjoj 2015-04-10 23:24:53 +02:00
parent bded0fb6bd
commit dd91af6b39

View File

@ -7,26 +7,57 @@ import Control.Applicative
import Control.Monad.IO.Class (liftIO)
import Text.Printf (printf)
import System.Environment (lookupEnv)
import System.Environment.XDG.BaseDir
import System.Directory (doesFileExist)
import Data.TConfig
import Web.Simple.Templates
import Network.Wai.Handler.Warp
data AppSettings = AppSettings { }
data ServerSettings = ServerSettings
{ bindPort :: Int
, bindHostname :: String
, bindUrl :: String
, urlTable :: FilePath
, warpSettings :: Settings
} deriving Show
serverSettings :: IO (String, Settings)
serverSettings = do
port <- maybe 3000 read <$> lookupEnv "PORT"
host <- maybe "localhost" id <$> lookupEnv "HOSTNAME"
let opts = setPort port defaultSettings
url = if port == 80
then printf "http://%s/" host
else printf "http://%s:%d/" host port
return (url, opts)
newAppSettings :: IO AppSettings
newAppSettings = return AppSettings
data AppSettings = AppSettings {}
instance HasTemplates IO AppSettings where
defaultLayout = do
main <- liftIO (getDataFileName "layouts/main.html")
Just <$> getTemplate main
newAppSettings :: IO AppSettings
newAppSettings = return AppSettings
createEmptyIfMissing :: FilePath -> IO FilePath
createEmptyIfMissing file = do
exists <- doesFileExist file
if not exists
then writeFile file "" >> return file
else return file
newServerSettings :: IO ServerSettings
newServerSettings = do
urlsPath <- getUserDataFile "breve" ""
configPath <- getUserConfigFile "breve" ""
config <- readConfig =<< createEmptyIfMissing configPath
let host = maybe "localhost" id (getValue "hostname" config)
port = maybe 3000 read (getValue "port" config)
urls = maybe urlsPath id (getValue "urltable" config)
createEmptyIfMissing urls
return ServerSettings
{ bindPort = port
, bindHostname = host
, bindUrl = if port == 80
then printf "http://%s/" host
else printf "http://%s:%d/" host port
, urlTable = urls
, warpSettings = setPort port defaultSettings
}