MySQL backend

portnov [2009-07-12 07:59:17]
MySQL backend
Filename
Framework/Http/Middlewares.hs
Framework/Storage.hs
TODO
graph.dot
diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs
index 15ae309..b30e31f 100644
--- a/Framework/Http/Middlewares.hs
+++ b/Framework/Http/Middlewares.hs
@@ -23,10 +23,13 @@ import qualified Settings (requestMiddlewares, responseMiddlewares)
 type RequestMiddleware  = StaticConfig -> HttpRequest -> IO HttpRequest
 type ResponseMiddleware = StaticConfig -> HttpResponse -> IO HttpResponse

-addEncoding enc _ resp = return $
+addEncoding _ resp = return $
     case lookupHeader HdrContentType (rspHeaders resp) of
-        Nothing               -> replaceHeader HdrContentType ("text/html; charset="++enc) resp
-        Just ctype            -> insertHeader  HdrContentType (ctype++"; charset="++enc) resp
+        Nothing    -> replaceHeader HdrContentType ("text/html; charset="++enc) resp
+        Just ctype -> insertHeader HdrContentType (ctype++"; charset="++enc) resp
+    where enc = case lookupHeader (HdrCustom "X-UserCharset") (rspHeaders resp) of
+                  Just x -> tail x
+                  Nothing -> "UTF-8"

 readLanguage ps rq = do
     let h = insertHeader (HdrCustom "X-UserLanguage") lang rq
@@ -40,8 +43,8 @@ readLanguage ps rq = do
 initI18N ps rq = do
         gettextInit (lang++enc) domain dir
         return rq
-    where lang = fromMaybe "" $ lookupHeader (HdrCustom "X-UserLanguage") hdrs
-          enc = fromMaybe "" $ lookupHeader (HdrCustom "X-UserCharset") hdrs
+    where lang = fromMaybe "en_GB" $ lookupHeader (HdrCustom "X-UserLanguage") hdrs
+          enc = fromMaybe ".UTF-8" $ lookupHeader (HdrCustom "X-UserCharset") hdrs
           hdrs = rqHeaders rq
           domain = getConfigValue cp "gettext" "domain" ""
           dir = getConfigValue cp "gettext" "path" "."
@@ -69,7 +72,7 @@ defaultRqMiddlewares :: [RequestMiddleware]
 defaultRqMiddlewares = [readLanguage, initI18N]

 defaultRspMiddlewares :: [ResponseMiddleware]
-defaultRspMiddlewares = [addEncoding "UTF-8"]
+defaultRspMiddlewares = [addEncoding]

 f `o` g = \x -> f x >>= g

diff --git a/Framework/Storage.hs b/Framework/Storage.hs
index 2efe6ae..597fbcc 100644
--- a/Framework/Storage.hs
+++ b/Framework/Storage.hs
@@ -10,8 +10,9 @@ module Framework.Storage
     where


+import Data.String.Utils
 import qualified Database.HDBC.Sqlite3 as Sqlite3
--- import qualified Database.HDBC.MySQL as MySQL
+import qualified Database.HDBC.MySQL as MySQL
 import qualified Database.HDBC.PostgreSQL as PostgreSQL
 import qualified Database.HDBC as D

@@ -25,6 +26,16 @@ connect' :: String              -- ^ DB backend
          -> IO DBConnection
 connect' "sqlite3" file = DBC `fmap` (Sqlite3.connectSqlite3 file)
 connect' "psql"  str    = DBC `fmap` (PostgreSQL.connectPostgreSQL str)
+connect' "mysql" str    = DBC `fmap` (MySQL.connectMySQL $ parsedMySQL)
+    where
+        parsedMySQL = MySQL.defaultMySQLConnectInfo {
+            MySQL.mysqlUser = user,
+            MySQL.mysqlPassword = pass,
+            MySQL.mysqlHost = server,
+            MySQL.mysqlDatabase = db}
+        [user,x] = split ":" str
+        [pass,x'] = split "@" x
+        [server,db] = split "/" x'

 -- | Connect to DB, get parameters from "StaticConfig"
 connect :: MPool DBConnection                 -- ^ Pool of connections
diff --git a/TODO b/TODO
index 609f739..4182cc7 100644
--- a/TODO
+++ b/TODO
@@ -2,7 +2,6 @@ TODO

  * Человеческая обработка завершения программы;
  * Соответственно, все параметры, которые сейчас hard-coded, брать из конфига;
- * Бэкенд для MySQL;
  * Более высокоуровневый интерфейс для кэша - чтоб было легко закэшировать результат всей функции;
  * Соответственно, простые средства для инвалидации кэша;
  * Более продвинутые и высокоуровневые функции генерации SQL;
@@ -13,6 +12,7 @@ TODO
  * (!) Документация ко всей этой красоте.
  * Протестировать поддержку PUT web-сервером;

+ * [DONE] Бэкенд для MySQL;
  * [DONE] Чтение конфига из файла либо удобный EDSL для конфига;
  * [DONE] Перенести текущий правленный Network.Shed.Httpd в дерево проекта (написать свой?);
  * [DONE] Лучше интегрировать Httpd в движок, в частности - чтоб средствами движка писал логи итп;
diff --git a/graph.dot b/graph.dot
index 74dec88..1576083 100644
--- a/graph.dot
+++ b/graph.dot
@@ -1,86 +1,81 @@
 digraph G {
-u43[label="TemplateParser"];
-u42[label="Plugins"];
-u40[label="Models"];
-u0[label="Main"];
+u49[label="TemplateParser"];
+u48[label="Settings"];
+u45[label="Models"];
+u0[label="Main",color=green];
+
 subgraph cluster_0 {
 label="Framework";
-color="#ccffcc";
-style="filled";
-u41[label="Markdown"];
-u39[label="Pager"];
-u38[label="ContextProcessors"];
-u27[label="SQL"];
-u20[label="Wrapper"];
-u19[label="Urls"];
-u18[label="Models"];
-u17[label="Storage"];
-u14[label="Cache",shape=box];
-u13[label="Config"];
-u10[label="Logger"];
-u6[label="Controller"];
-u5[label="Pool"];
-u1[label="API", shape=box];
-forms[label="Forms", shape=box];
-http[label="HTTP", shape=box];
-tengine[label="TEngine",shape=box];
+
+api[label="API",shape=box];
+forms[label=Forms,shape=box];
+tengine[label=TEngine,shape=box];
+u47[label="Markdown"];
+u44[label="Pager"];
+u43[label="ContextProcessors"];
+
+subgraph cluster_1 {
+color=gray;
+label=DB;
+orm[label="ORM",shape=box];
+u19[label="Storage"];
+}
+
+cache[label="Cache",shape=box];
+u15[label="Config"];
+u12[label="GetText"];
+
+subgraph cluster_3 {
+color=gray;
+label=Network;
+http[label=HTTP,shape=box,color=red];
+u25[label="Wrapper"];
+u24[label="Urls"];
 }

+}
+api -> cache;
+api -> forms;
+api -> http;
+api -> orm;
+api -> tengine;
+api -> u12;
+api -> u19;
+api -> u24;
+api -> u44;
+forms -> api;
 forms -> http;
-forms -> u1;
-forms -> u18;
-forms -> u42;
-forms -> u6;
-http -> u10;
-http -> u13;
-http -> u14;
-http -> u17;
+forms -> orm;
+forms -> u48;
+http -> cache;
+http -> u12;
+http -> u15;
 http -> u19;
-http -> u5;
-http -> u6;
+http -> u24;
+http -> u48;
+tengine -> api;
+tengine -> cache;
 tengine -> http;
-tengine -> u1;
-tengine -> u14;
-tengine -> u38;
-tengine -> u40;
-tengine -> u6;
-u0 -> u1;
-u0 -> u40;
-u14 -> u5;
-u17 -> u18;
-u17 -> u5;
-u19 -> http;
-u19 -> u10;
-u19 -> u20;
-u19 -> u6;
-u1 -> forms;
-u1 -> http;
-u1 -> tengine;
-u1 -> u10;
-u1 -> u14;
-u1 -> u17;
-u1 -> u18;
-u1 -> u19;
-u1 -> u27;
-u1 -> u39;
-u1 -> u6;
-u20 -> http;
-u20 -> u14;
-u20 -> u17;
-u27 -> u18;
-u38 -> u1;
-u38 -> u6;
-u39 -> forms;
-u39 -> http;
-u39 -> u1;
-u39 -> u18;
-u39 -> u27;
-u39 -> u6;
-u40 -> forms;
-u40 -> u17;
-u40 -> u18;
-u40 -> u41;
-u42 -> forms;
-u6 -> http;
+tengine -> u43;
+tengine -> u45;
+u0 -> api;
+u0 -> u45;
+u19 -> orm;
+u24 -> http;
+u24 -> u25;
+u25 -> cache;
+u25 -> http;
+u25 -> u19;
+u43 -> api;
+u44 -> api;
+u44 -> forms;
+u44 -> http;
+u44 -> orm;
+u45 -> forms;
+u45 -> orm;
+u45 -> u47;
+u48 -> forms;
+u48 -> tengine;
+
 }
ViewGit