diff --git a/.gitignore b/.gitignore index 280b0bd..8a5e822 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,5 @@ html html/* tags *.hcr +*.mo + diff --git a/Blog/Blog.hs b/Blog/Blog.hs index a37ad6d..3be4c8b 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -13,6 +13,7 @@ urlconf = "blog" // "new" --> newpost <|> "blog" // "edit" // number ~> editpost <|> "blog" --> allposts <|> "form" --> testform + <|> "i18n" --> i18ntest <|> RawFunction serveStatic testform :: HttpAction @@ -24,6 +25,11 @@ testform = do liftIO $ print $ _POST rq return $ redirect "/blog/" +i18ntest :: HttpAction +i18ntest = do + text <- __ "Hello world!" + return $ renderToResponse "i18ntest.html" [("text", C text)] + allposts :: HttpAction allposts = do rq <- asks request diff --git a/Blog/Makefile b/Blog/Makefile index 3399fe3..5dc2ed5 100644 --- a/Blog/Makefile +++ b/Blog/Makefile @@ -10,6 +10,8 @@ TemplateGen: make -C ../Framework/TGenerator/ Blog: *.hs $(TEMPLATES) + hgettext -o po/messages.pot Blog.hs + msgfmt -o po/ru_RU.UTF-8/Blog.mo po/ru.po $(GHC) Blog.hs clean: diff --git a/Blog/blog.conf b/Blog/blog.conf index 5811316..860be9d 100644 --- a/Blog/blog.conf +++ b/Blog/blog.conf @@ -18,3 +18,6 @@ path = tmp/sessions access = access.log errors = errors.log +[gettext] +domain = Blog +path = ./po/ diff --git a/Blog/blog.db b/Blog/blog.db deleted file mode 100644 index 3a9aa16..0000000 Binary files a/Blog/blog.db and /dev/null differ diff --git a/Blog/po/messages.pot b/Blog/po/messages.pot new file mode 100644 index 0000000..1d64cb7 --- /dev/null +++ b/Blog/po/messages.pot @@ -0,0 +1,15 @@ +# 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: YEAR-MO-DA HO:MI+ZONE\n" +"Last-Translator: FULL NAME <EMAIL@ADDRESS>\n" +"Language-Team: LANGUAGE <LL@li.org>\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" + diff --git a/Blog/po/ru.po b/Blog/po/ru.po new file mode 100644 index 0000000..4d41775 --- /dev/null +++ b/Blog/po/ru.po @@ -0,0 +1,18 @@ +# 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 19:14+0600\n" +"Last-Translator: portnov <portnov@bk.ru>\n" +"Language-Team: Russian\n" +"MIME-Version: 1.0\n" +"Content-Type: text/plain; charset=UTF-8\n" +"Content-Transfer-Encoding: 8bit\n" +"Plural-Forms: nplurals=3; plural=(n%10==1 && n%100!=11 ? 0 : n%10>=2 && n%" +"10<=4 && (n%100<10 || n%100>=20) ? 1 : 2);\n" + +#: Blog.hs:0 +msgid "Hello world!" +msgstr "Привет, Мир!" diff --git a/Blog/templates/i18ntest.html b/Blog/templates/i18ntest.html new file mode 100644 index 0000000..54a6c0b --- /dev/null +++ b/Blog/templates/i18ntest.html @@ -0,0 +1,12 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" lang="ru"> + <head> + <title>I18N Test</title> + <meta name='author' content='Portnov'> + </head> + <body> + + <h1>{{text}}</h1> + + </body> +</html> diff --git a/Framework/API.hs b/Framework/API.hs index 2bdd8b5..f5fe7af 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -14,6 +14,7 @@ module Framework.API module Framework.Types, module Framework.Controller, module Framework.Exceptions, + module Framework.GetText, -- ** API modules module Framework.API.Cache, module Framework.API.Sessions, @@ -37,6 +38,8 @@ import Network.HTTP import Framework.Types import Framework.Controller import Framework.Exceptions +import Framework.GetText + import qualified Framework.Http.Cookies as Cookies import Framework.Http.HTTPServer (serveHttp,serveStatic) diff --git a/Framework/Config.hs b/Framework/Config.hs index 814acc7..f59d99c 100644 --- a/Framework/Config.hs +++ b/Framework/Config.hs @@ -1,5 +1,7 @@ module Framework.Config - (readConfig) + (openConfig, + readConfig, + getConfigValue) where import System.IO @@ -21,32 +23,36 @@ getConfigPath name = do 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 +getConfigValue :: CF.Get_C a => CF.ConfigParser -> CF.SectionSpec -> CF.OptionSpec -> a -> a +getConfigValue cp s o d = either (const d) id $ CF.get cp s o -- | Read config from file -readConfig :: String -- ^ Config name - -> StartupConfig -- ^ Parameters that are no in the config - -> IO StaticConfig -readConfig name sc = do +openConfig :: String -- ^ Config name + -> IO CF.ConfigParser +openConfig name = 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" "/var/www", - 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", - accessLogPath = get' cp "logs" "access" "/var/log/web/access.log", - errorsLogPath = get' cp "logs" "errors" "/var/log/web/errors.log", + return $ case ecp of + Right cp -> cp + Left err -> error $ show err + +readConfig :: CF.ConfigParser + -> StartupConfig -- ^ Parameters that are no in the config + -> StaticConfig +readConfig cp sc = HP { + portNumber = getConfigValue cp "network" "port" 80, + docdir = getConfigValue cp "static" "staticdir" "/var/www", + dbDriver = getConfigValue cp "database" "backend" "psql", + dbPath = getConfigValue cp "database" "path" "", + cacheDriver = getConfigValue cp "cache" "backend" "fake", + cachePath = getConfigValue cp "cache" "path" "/var/cache/web", + sessionsDriver = getConfigValue cp "sessions" "backend" "files", + sessionsPath = getConfigValue cp "sessions" "path" "/var/sessions", + accessLogPath = getConfigValue cp "logs" "access" "/var/log/web/access.log", + errorsLogPath = getConfigValue cp "logs" "errors" "/var/log/web/errors.log", dbpool = dbpoolSC sc, cpool = cpoolSC sc, logChan = logChanSC sc, - errChan = errChanSC sc } - Left err -> error $ show err + errChan = errChanSC sc, + config = configSC sc} diff --git a/Framework/GetText.hs b/Framework/GetText.hs new file mode 100644 index 0000000..d7b9562 --- /dev/null +++ b/Framework/GetText.hs @@ -0,0 +1,27 @@ +module Framework.GetText + (gettextInit, + __, + __io + ) where + +import System.Locale.SetLocale +import Text.I18N.GetText +import Codec.Binary.UTF8.String + +import Framework.Controller + +gettextInit :: String -> String -> String -> IO () +gettextInit lang domain dir = do + setLocale LC_ALL (Just lang) + bindTextDomain domain $ Just dir + textDomain $ Just domain + return () + +__io :: String -> IO String +__io text = do + res <- getText text + return $ decodeString res + +__ :: String -> AController String +__ text = liftIO $ __io text + diff --git a/Framework/Http/HTTPServer.hs b/Framework/Http/HTTPServer.hs index 16b709d..d7c3287 100644 --- a/Framework/Http/HTTPServer.hs +++ b/Framework/Http/HTTPServer.hs @@ -69,13 +69,13 @@ serveStatic' ps rq resource = -- | This function is called on each HTTP request httpWorker :: StaticConfig -> URLConf -> HttpRequest -> IO HttpResponse httpWorker hap conf req@(Request {rqURI = URI {uriPath}}) = do - req' <- requestMiddlewares req + req' <- requestMiddlewares hap req let s = unEscapeString $ rqBody req' -- putStrLn $ "Request body: "++show s -- putStrLn $ "deUTF:"++(decodeString s) -- putStrLn $ "Serving "++uriPath resp <- runURLConf hap req' (tail uriPath) conf - responseMiddlewares resp + responseMiddlewares hap resp defaultURLConf :: URLConf defaultURLConf = RawFunction serveStatic @@ -106,7 +106,8 @@ serveHttp name urlconf = do cPool <- emptyPool 10 aLog <- newChan eLog <- newChan - conf <- readConfig name $ StartupConfig dbPool cPool aLog eLog + cp <- openConfig name + let conf = readConfig cp $ StartupConfig dbPool cPool aLog eLog cp garbageCollector dbPool disconnect' garbageCollector cPool cDisconnect hAccess <- openLog (accessLogPath conf) diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs index cc00fc1..54beba6 100644 --- a/Framework/Http/Middlewares.hs +++ b/Framework/Http/Middlewares.hs @@ -5,23 +5,58 @@ module Framework.Http.Middlewares requestMiddlewares, responseMiddlewares) where +-- import Debug.Trace + +import Control.Monad (ap) +import Data.Char +import Data.String.Utils import Network.HTTP + -- import Framework.Utils import Framework.Types +import Framework.GetText +import Framework.Config + import qualified Settings (requestMiddlewares, responseMiddlewares) -type RequestMiddleware = HttpRequest -> IO HttpRequest -type ResponseMiddleware = HttpResponse -> IO HttpResponse +type RequestMiddleware = StaticConfig -> HttpRequest -> IO HttpRequest +type ResponseMiddleware = StaticConfig -> HttpResponse -> IO HttpResponse -addEncoding enc resp = return $ +addEncoding enc _ resp = return $ case lookupHeader HdrContentType (rspHeaders resp) of Nothing -> replaceHeader HdrContentType ("text/html; charset="++enc) resp Just ctype -> insertHeader HdrContentType (ctype++"; charset="++enc) resp -defaultRqMiddlewares = [addEncoding "UTF-8"] -defaultRspMiddlewares = [] +initI18N ps rq = do + gettextInit lang domain dir + return rq + where lang = parseLang $ rqHeaders rq + domain = getConfigValue cp "gettext" "domain" "" + dir = getConfigValue cp "gettext" "path" "." + cp = config ps + +parseLang :: [Header] -> String +parseLang hdrs = + case lookupHeader HdrAcceptLanguage hdrs of + Nothing -> "" + Just val -> (transformLang $ head $ split "," val)++enc + 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) + +defaultRqMiddlewares :: [RequestMiddleware] +defaultRqMiddlewares = [initI18N] + +defaultRspMiddlewares :: [ResponseMiddleware] +defaultRspMiddlewares = [addEncoding "UTF-8"] f `o` g = \x -> f x >>= g -responseMiddlewares = foldr o return $ defaultRqMiddlewares ++ Settings.requestMiddlewares -requestMiddlewares = foldr o return $ defaultRspMiddlewares ++ Settings.responseMiddlewares +requestMiddlewares ps = foldr o return $ ap (defaultRqMiddlewares ++ Settings.requestMiddlewares) [ps] +responseMiddlewares ps = foldr o return $ ap (defaultRspMiddlewares ++ Settings.responseMiddlewares) [ps] diff --git a/Framework/Types.hs b/Framework/Types.hs index 0a30661..ad57334 100644 --- a/Framework/Types.hs +++ b/Framework/Types.hs @@ -6,6 +6,7 @@ import Data.List import qualified Data.Map as M import qualified Database.HDBC as D import Network.HTTP +import qualified Data.ConfigFile as CF import Framework.Http.SessionTypes import Framework.Cache.Types @@ -23,6 +24,11 @@ instance Show DBConnection where show _ = "<DB connection>" ------------------------------------------------------------------------------------------- +-- +instance Show CF.ConfigParser where + show _ = "<Config>" + +------------------------------------------------------------------------------------------- type HttpRequest = Request String type HttpResponse = Response String @@ -54,7 +60,8 @@ data StaticConfig = HP { dbpool :: MPool DBConnection, -- ^ DB connections pool cpool :: MPool CacheConnection,-- ^ Cache connections pool logChan :: Log, -- ^ Handle to log - errChan :: Log -- ^ Handle to errors log + errChan :: Log, -- ^ Handle to errors log + config :: CF.ConfigParser } deriving (Show) @@ -63,7 +70,8 @@ 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 + errChanSC :: Log, -- ^ Handle to errors log + configSC :: CF.ConfigParser } deriving (Show) diff --git a/README.ru b/README.ru index 8484bb3..65f092f 100644 --- a/README.ru +++ b/README.ru @@ -17,38 +17,95 @@ ## Общие замечания об архитектуре -Архитектура фреймворка в общих чертах соответствует MVC. Модели описывают таблицы в БД (но могут иметь дополнительные поля, не хранящиеся в БД). В качестве слоя View выступает система шаблонов TEngine. Контроллеры занимаются выбором нужных данных и передачей этих данных в шаблоны. +Архитектура фреймворка в общих чертах соответствует MVC. Модели описывают +таблицы в БД (но могут иметь дополнительные поля, не хранящиеся в БД). В +качестве слоя View выступает система шаблонов TEngine. Контроллеры занимаются +выбором нужных данных и передачей этих данных в шаблоны. -Приложение обычно будет импортировать из фреймворка модули Framework.API и Framework.Utils. Модуль API ре-экспортирует интерфейсы некоторых внутренних модулей фреймворка и экспортирует "обёртки" для других модулей. +Приложение обычно будет импортировать из фреймворка модули Framework.API и +Framework.Utils. Модуль API ре-экспортирует интерфейсы некоторых внутренних +модулей фреймворка и экспортирует "обёртки" для других модулей. ## Диспетчер URL -Диспетчер URL конфигурируется с помощью типа URLConfig. Значение этого типа составляется с помощью операторов-комбинаторов, экспортируемых модулем Framework.Urls (и ре-экспортируемых модулем Framework.API). +Диспетчер URL конфигурируется с помощью типа URLConfig. Значение этого типа +составляется с помощью операторов-комбинаторов, экспортируемых модулем +Framework.Urls (и ре-экспортируемых модулем Framework.API). -Обработка URL в диспетчере происходит следующим образом. Сначала URL разбивается на части, разделённые косой чертой. Далее диспетчер проходит по конфигурации, пытаясь отождествить текущий фрагмент URL с "кусочком" конфигурации, и если это удаётся - вызывается указанный в конфигурации контроллер. +Обработка URL в диспетчере происходит следующим образом. Сначала URL +разбивается на части, разделённые косой чертой. Далее диспетчер проходит по +конфигурации, пытаясь отождествить текущий фрагмент URL с "кусочком" +конфигурации, и если это удаётся - вызывается указанный в конфигурации +контроллер. -Например, конфигурация "blog" --> allposts означает, что все URL, начинающиеся с /blog/, будет обрабатывать контроллер allposts. А конфигурация "blog" // "archive" --> archive означает, что URL, начинающиеся с /blog/archive/, обрабатывает контроллер archive. Оператор <|> комбинирует конфигурации по принципу "если не первое, то второе". Например, +Например, конфигурация -urlconf = "blog" // "archive" --> archive - <|> "blog" --> allposts +"blog" --> allposts -будет работать следующим образом: сначала будет проверено, не начинается ли URL с /blog/archive/; Если начинается, то будет вызван контроллер archive; Если же нет - контроллер allposts. При этом любой контроллер может "отвергнуть" переданный ему URL (см. ниже); Тогда диспетчер будет пробовать сопоставлять url со следующими правилами в конфигурации. Если ни одно правило не подошло (или все подходящие контроллеры отвергли этот url), будет порождена ошибка HTTP 404. +означает, что все URL, начинающиеся с /blog/, будет обрабатывать контроллер +allposts. А конфигурация -## Контроллеры + "blog" // "archive" --> archive + +означает, что URL, начинающиеся с /blog/archive/, +обрабатывает контроллер archive. Оператор <|> комбинирует конфигурации по +принципу "если не первое, то второе". Например, -Контроллеры приложения (и некоторые другие части) выполняются в монаде Controller. Controller является экземпляром классов Monad, MonadIO и MonadReader. Тип Controller имеет три типа-параметра: тип передаваемой конфигурации (обычно это ActionConfig или StaticConfig) и два возможных типа возвращаемого значения. + urlconf = "blog" // "archive" --> archive + <|> "blog" --> allposts -Контроллеры (Controller s r a) можно комбинировать (monadic bind) тремя способами. Во-первых, просто выполнение действий одно за другим, как в монаде IO. Такой контроллер возвращает тип a (третий тип-параметр). Во-вторых, контроллер (действие) может завершиться вызовом функции returnNow вместо return, тогда последующие контроллеры (действия) в цепочке не будут вычисляться, а вся цепочка вернёт значение типа r (второй тип-параметр). И в-третьих, в любой момент можно прервать вычисление вызовом действия reject. В контроллере приложения это будет означать "Я не буду обрабатывать этот URL". +будет работать следующим образом: сначала будет проверено, не начинается ли URL +с /blog/archive/; Если начинается, то будет вызван контроллер archive; Если же +нет - контроллер allposts. При этом любой контроллер может "отвергнуть" +переданный ему URL (см. ниже); Тогда диспетчер будет пробовать сопоставлять url +со следующими правилами в конфигурации. Если ни одно правило не подошло (или +все подходящие контроллеры отвергли этот url), будет порождена ошибка HTTP 404. -Контроллеры приложения возвращают тип Controller ActionConfig HttpResponse HttpResponse, для которого определено сокращение HttpController. Т.е. в качестве конфигурации они принимают ActionConfig (см. ниже) и в любом случае возвращают HttpResponse (сформированный объект-ответ). +## Контроллеры -Контроллеры-действия, определённые в фреймворке, часто имеют тип AController a, что раскрывается как Controller ActionConfig HttpResponse a. Т.е. они используют ActionConfig в качестве конфигурации, а возвращают либо HttpResponse, либо некий тип a. Например, действие tryReturnFromCache имеет тип AController (), т.е. оно может вернуть либо уже сформированный ответ (при этом последующие действия в цепочке не будут выполняться, контроллер вернёт этот ответ), либо "ничего", т.е. () (и будет продолжено выполнение остальных действий в цепочке). +Контроллеры приложения (и некоторые другие части) выполняются в монаде +Controller. Controller является экземпляром классов Monad, MonadIO и +MonadReader. Тип Controller имеет три типа-параметра: тип передаваемой +конфигурации (обычно это ActionConfig или StaticConfig) и два возможных типа +возвращаемого значения. + +Контроллеры (Controller s r a) можно комбинировать (monadic bind) тремя +способами. Во-первых, просто выполнение действий одно за другим, как в монаде +IO. Такой контроллер возвращает тип a (третий тип-параметр). Во-вторых, +контроллер (действие) может завершиться вызовом функции returnNow вместо +return, тогда последующие контроллеры (действия) в цепочке не будут +вычисляться, а вся цепочка вернёт значение типа r (второй тип-параметр). И +в-третьих, в любой момент можно прервать вычисление вызовом действия reject. В +контроллере приложения это будет означать "Я не буду обрабатывать этот URL". + +Контроллеры приложения возвращают тип Controller ActionConfig HttpResponse +HttpResponse, для которого определено сокращение HttpController. Т.е. в +качестве конфигурации они принимают ActionConfig (см. ниже) и в любом случае +возвращают HttpResponse (сформированный объект-ответ). + +Контроллеры-действия, определённые в фреймворке, часто имеют тип AController a, +что раскрывается как Controller ActionConfig HttpResponse a. Т.е. они +используют ActionConfig в качестве конфигурации, а возвращают либо +HttpResponse, либо некий тип a. Например, действие tryReturnFromCache имеет тип +AController (), т.е. оно может вернуть либо уже сформированный ответ (при этом +последующие действия в цепочке не будут выполняться, контроллер вернёт этот +ответ), либо "ничего", т.е. () (и будет продолжено выполнение остальных +действий в цепочке). ## Конфигурация -Параметры, которые могут понадобиться контроллеру или другой части приложения, можно разделить на две группы. Параметры первой группы не меняются во время работы приложения. Это, например, путь к статическим файлам, параметры соединения с БД и др. Параметры второй группы свои для каждой обработки HTTP-запроса. Это, например, собственно объект запроса HttpRequest, открытое соединение с БД, канал для лога и др. Параметры первой группы (статические) содержатся в структуре StaticConfig. Бòльшая их часть читается из файла конфигурации. Параметры второй группы содержатся в структуре ActionConfig, равно как и указатель на структуру StaticConfig. - -Т.к. Controller является экземпляром MonadReader, то доступ к конфигурации можно получить с помощью стандартных действий ask и asks, например: +Параметры, которые могут понадобиться контроллеру или другой части приложения, +можно разделить на две группы. Параметры первой группы не меняются во время +работы приложения. Это, например, путь к статическим файлам, параметры +соединения с БД и др. Параметры второй группы свои для каждой обработки +HTTP-запроса. Это, например, собственно объект запроса HttpRequest, открытое +соединение с БД, канал для лога и др. Параметры первой группы (статические) +содержатся в структуре StaticConfig. Бòльшая их часть читается из файла +конфигурации. Параметры второй группы содержатся в структуре ActionConfig, +равно как и указатель на структуру StaticConfig. + +Т.к. Controller является экземпляром MonadReader, то доступ к конфигурации +можно получить с помощью стандартных действий ask и asks, например: controller = do rq <- asks request -- Получить объект-запрос