Improve multiple languages handling

diff --git a/Blog/po/en.po b/Blog/po/en.po
new file mode 100644
index 0000000..5d9357a
--- /dev/null
+++ b/Blog/po/en.po
@@ -0,0 +1,17 @@
+# Translation file
+msgid ""
+msgstr ""
+"Project-Id-Version: PACKAGE VERSION\n"
+"Report-Msgid-Bugs-To: \n"
+"POT-Creation-Date: 2009-01-13 06:05-0800\n"
+"PO-Revision-Date: 2009-07-11 20:28+0600\n"
+"Last-Translator: portnov <portnov@bk.ru>\n"
+"Language-Team: English\n"
+"MIME-Version: 1.0\n"
+"Content-Type: text/plain; charset=UTF-8\n"
+"Content-Transfer-Encoding: 8bit\n"
+"Plural-Forms: nplurals=2; plural=(n != 1);\n"
+
+#: Blog.hs:0
+msgid "Hello world!"
+msgstr "Hello world!"
diff --git a/Framework/GetText.hs b/Framework/GetText.hs
index d7b9562..b432605 100644
--- a/Framework/GetText.hs
+++ b/Framework/GetText.hs
@@ -4,15 +4,31 @@ module Framework.GetText
      __io
     ) where

+import Data.Char
 import System.Locale.SetLocale
 import Text.I18N.GetText
 import Codec.Binary.UTF8.String

 import Framework.Controller

+countries = [
+    ("en", "GB"),
+    ("ru", "RU")]
+
+fillLocale :: String -> String
+fillLocale loc =
+    if '_' `elem` loc
+      then loc
+      else case lookup loc countries of
+             Just c -> loc++"_"++c++".UTF-8"
+             Nothing -> loc++"_"++(map toUpper loc)++".UTF-8"
+
 gettextInit :: String -> String -> String -> IO ()
 gettextInit lang domain dir = do
-    setLocale LC_ALL (Just lang)
+    val <- setLocale LC_ALL $ Just $ fillLocale lang
+    case val of
+      Nothing -> setLocale LC_ALL $ Just "en_GB.UTF-8"
+      Just _  -> return Nothing
     bindTextDomain domain $ Just dir
     textDomain $ Just domain
     return ()
diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs
index 54beba6..15ae309 100644
--- a/Framework/Http/Middlewares.hs
+++ b/Framework/Http/Middlewares.hs
@@ -9,6 +9,7 @@ module Framework.Http.Middlewares

 import Control.Monad (ap)
 import Data.Char
+import Data.Maybe
 import Data.String.Utils
 import Network.HTTP

@@ -27,10 +28,21 @@ addEncoding enc _ resp = return $
         Nothing               -> replaceHeader HdrContentType ("text/html; charset="++enc) resp
         Just ctype            -> insertHeader  HdrContentType (ctype++"; charset="++enc) resp

+readLanguage ps rq = do
+    let h = insertHeader (HdrCustom "X-UserLanguage") lang rq
+    let h' = insertHeader (HdrCustom "X-UserCharset") enc h
+    return h'
+  where
+    hdrs = rqHeaders rq
+    lang = parseLang hdrs
+    enc = parseEnc hdrs
+
 initI18N ps rq = do
-        gettextInit lang domain dir
+        gettextInit (lang++enc) domain dir
         return rq
-    where lang = parseLang $ rqHeaders rq
+    where lang = fromMaybe "" $ lookupHeader (HdrCustom "X-UserLanguage") hdrs
+          enc = fromMaybe "" $ lookupHeader (HdrCustom "X-UserCharset") hdrs
+          hdrs = rqHeaders rq
           domain = getConfigValue cp "gettext" "domain" ""
           dir = getConfigValue cp "gettext" "path" "."
           cp = config ps
@@ -39,24 +51,30 @@ parseLang :: [Header] -> String
 parseLang hdrs =
     case lookupHeader HdrAcceptLanguage hdrs of
       Nothing -> ""
-      Just val -> (transformLang $ head $ split "," val)++enc
+      Just val -> transformLang $ head $ split "," $ head $ split ";" val
     where
-        enc = case lookupHeader HdrAcceptCharset hdrs of
-                Nothing -> ""
-                Just x -> "."++(head $ split "," x)
         transformLang s =
             let els = split "-" s
             in case length els of
                 1 -> head els
                 _ -> (head els)++"_"++(map toUpper $ els!!1)

+parseEnc :: [Header] -> String
+parseEnc hdrs =
+    case lookupHeader HdrAcceptCharset hdrs of
+      Nothing -> ""
+      Just x -> "."++(head $ split "," x)
+
 defaultRqMiddlewares :: [RequestMiddleware]
-defaultRqMiddlewares = [initI18N]
+defaultRqMiddlewares = [readLanguage, initI18N]

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

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

+requestMiddlewares :: RequestMiddleware
 requestMiddlewares ps  = foldr o return $ ap (defaultRqMiddlewares ++ Settings.requestMiddlewares) [ps]
+
+responseMiddlewares :: ResponseMiddleware
 responseMiddlewares ps = foldr o return $ ap (defaultRspMiddlewares ++ Settings.responseMiddlewares) [ps]