Add a module to read config from a file.

portnov [2009-07-07 19:08:07]
Add a module to read config from a file.
Filename
Blog/Blog.hs
Blog/blog.conf
Framework/Config.hs
Framework/Http/HTTPServer.hs
Framework/Types.hs
README.ru
diff --git a/Blog/Blog.hs b/Blog/Blog.hs
index 8d3b23c..218a939 100644
--- a/Blog/Blog.hs
+++ b/Blog/Blog.hs
@@ -17,7 +17,6 @@ import Framework.Models
 import Framework.Pager
 import Framework.Cache

-import Config
 import Models
 import Plugins

@@ -130,4 +129,4 @@ onepost conf sid = Just $ do
           pid = read sid


-main = serveHttp params urlconf
+main = serveHttp "blog.conf" urlconf
diff --git a/Blog/blog.conf b/Blog/blog.conf
new file mode 100644
index 0000000..edb5810
--- /dev/null
+++ b/Blog/blog.conf
@@ -0,0 +1,16 @@
+[network]
+port = 8080
+
+[static]
+staticPath = static/
+
+[database]
+path = host=rtfm-server password=31415
+
+[cache]
+backend = filesystem
+path = tmp
+
+[sessions]
+path = tmp/sessions
+
diff --git a/Framework/Config.hs b/Framework/Config.hs
new file mode 100644
index 0000000..446da47
--- /dev/null
+++ b/Framework/Config.hs
@@ -0,0 +1,45 @@
+module Framework.Config where
+
+import System.IO
+import System.Directory
+import qualified Data.ConfigFile as CF
+import Data.Either
+
+import Framework.Types
+
+getConfigPath :: String -> IO FilePath
+getConfigPath name = do
+    let etc = "/etc/"++name
+    ex <- doesFileExist etc
+    if ex
+      then return etc
+      else do
+          ex' <- doesFileExist name
+          if ex'
+            then return name
+            else error "Could not find config!"
+
+get' :: CF.Get_C a => CF.ConfigParser -> CF.SectionSpec -> CF.OptionSpec -> a -> a
+get' cp s o d = either (const d) id $ CF.get cp s o
+
+readConfig :: String -> StartupConfig -> IO StaticConfig
+readConfig name sc = do
+    path <- getConfigPath name
+    ecp <- CF.readfile CF.emptyCP path
+    case ecp of
+      Right cp -> do
+          return $ HP {
+                portNumber     = get' cp "network"  "port"      80,
+                docdir         = get' cp "static"   "staticdir" "static",
+                dbDriver       = get' cp "database" "backend"   "psql",
+                dbPath         = get' cp "database" "path"      "",
+                cacheDriver    = get' cp "cache"    "backend"   "fake",
+                cachePath      = get' cp "cache"    "path"      "/var/cache/web",
+                sessionsDriver = get' cp "sessions" "backend"   "files",
+                sessionsPath   = get' cp "sessions" "path"      "/var/sessions",
+                dbpool  = dbpoolSC sc,
+                cpool   = cpoolSC sc,
+                logChan = logChanSC sc,
+                errChan = errChanSC sc }
+      Left err -> error $ show err
+
diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs
index 4e6db48..b9b1837 100644
--- a/Framework/Http/HTTPServer.hs
+++ b/Framework/Http/HTTPServer.hs
@@ -17,6 +17,7 @@ import Network.URI
 import Network.HTTP
 import Data.Maybe

+import Framework.Config
 import Framework.Cache
 import Framework.Storage
 import Framework.Pool
@@ -88,23 +89,24 @@ cleanup dbPool cPool hacc herr = do
     exitWith ExitSuccess

 -- | Start HTTP server
-serveHttp :: StaticConfig     -- ^ Server config
+serveHttp :: String           -- ^ Name of the config file
           -> URLConf          -- ^ URL dispatcher config
           -> IO ()
-serveHttp hap conf = do
+serveHttp name urlconf = do
     dbPool <- emptyPool 10
     cPool <- emptyPool 10
-    garbageCollector dbPool disconnect'
-    garbageCollector cPool cDisconnect
     aLog <- newChan
     eLog <- newChan
+    conf <- readConfig name $ StartupConfig dbPool cPool aLog eLog
+    garbageCollector dbPool disconnect'
+    garbageCollector cPool cDisconnect
     hAccess <- openFile "access.log" WriteMode
     hErrors <- openFile "errors.log" WriteMode
     runLogWriter aLog eLog hAccess hErrors
-    let hap' = hap {dbpool = dbPool,
-                    cpool = cPool,
-                    logChan = aLog,
-                    errChan = eLog }
+    let conf' = conf {dbpool = dbPool,
+                      cpool = cPool,
+                      logChan = aLog,
+                      errChan = eLog }
     installHandler sigINT (CatchOnce (cleanup dbPool cPool hAccess hErrors)) Nothing
-    initServer hap' (httpWorker hap' conf)
+    initServer conf' (httpWorker conf' urlconf)

diff --git a/Framework/Types.hs b/Framework/Types.hs
index 15e05a0..ca6b0ef 100644
--- a/Framework/Types.hs
+++ b/Framework/Types.hs
@@ -46,6 +46,14 @@ data StaticConfig = HP {
     }
     deriving (Show)

+data StartupConfig = StartupConfig {
+    dbpoolSC :: MPool DBConnection,  -- ^ DB connections pool
+    cpoolSC :: MPool CacheConnection,-- ^ Cache connections pool
+    logChanSC :: Log,                -- ^ Handle to log
+    errChanSC :: Log                 -- ^ Handle to errors log
+    }
+    deriving (Show)
+
 -- | Runtime controller action configuration
 data ActionConfig = ActionConfig {
     request      :: HttpRequest,                  -- ^ HTTP request
diff --git a/README.ru b/README.ru
index b05874e..91a18a6 100644
--- a/README.ru
+++ b/README.ru
@@ -9,7 +9,7 @@
  * URL dispatcher
  * Модуль для работы с БД (использует HDBC, в настоящий момент полноценно работает только с PostgreSQL, sqlite3 поддерживает не все запросы)
  * EDSL для описания моделей данных (таблиц БД)
- * EDSL для формирования SQL-запросов
+ * EDSL для формирования SQL-запросов по моделям данных
  * Templating Engine - шаблоны пишутся в отдельных файлах с синтаксисом a la Django, но при сборке приложения компилируются в результирующий бинарник
  * Подсистема обработки форм (генерация HTML формы по объекту, валидация форм, показ недозаполненной формы)
ViewGit