diff --git a/Blog/Extensions/FormProcessors.hs b/Blog/Extensions/FormProcessors.hs index 698d1dc..1692506 100644 --- a/Blog/Extensions/FormProcessors.hs +++ b/Blog/Extensions/FormProcessors.hs @@ -9,3 +9,5 @@ import Framework.Modules.TextCaptcha.FormProcessors formProcessors :: FormProcessors formProcessors = [addCaptcha ["commentform"]] +htmlProcessors = [] + diff --git a/Framework/Forms/HTML.hs b/Framework/Forms/HTML.hs index d2b7df1..7181d07 100644 --- a/Framework/Forms/HTML.hs +++ b/Framework/Forms/HTML.hs @@ -5,7 +5,8 @@ module Framework.Forms.HTML tag, tagToHtml, toHtml, formrow, hiddenField, mangleName, - formToHtml, createform + formToHtml, formToHTML, + createform ) where import Framework.Forms.Types @@ -52,13 +53,16 @@ mangleName :: String -- ^ Form name mangleName formname fid name = formname++fid++"-"++name -- | Render HTML Form -formToHtml :: HTMLForm -> String -formToHtml form = tagToHtml $ tag "form" ["method" := "POST","action" := (formAction form), "id" := tagid] $ +formToHTML :: HTMLForm -> HTMLTag +formToHTML form = tag "form" ["method" := "POST","action" := (formAction form), "id" := tagid] $ [tag "table" [] $ (visibleFields form) ++ (hiddenFields form) ++ [fidfield, namefield, submit]] where fidfield = hiddenField "formid" (formId form) namefield = hiddenField "formname" (htmlFormName form) tagid = (htmlFormName form)++(formId form) +formToHtml :: HTMLForm -> String +formToHtml form = tagToHtml $ formToHTML form + -- | Generate form row (widget with label) formrow :: String -- ^ Form name -> String -- ^ Form ID diff --git a/Framework/Forms/Rendering.hs b/Framework/Forms/Rendering.hs new file mode 100644 index 0000000..e25300e --- /dev/null +++ b/Framework/Forms/Rendering.hs @@ -0,0 +1,88 @@ +module Framework.Forms.Rendering where + +import Control.Monad.Reader.Class +import qualified Database.HDBC as D + +import Framework.Types +import Framework.Utils +import Framework.Controller +import Framework.Forms.Types +import Framework.Forms.HTML +import Framework.Forms.Validation +import Framework.ORM +import Framework.API.Sessions +import Framework.Http.Vars +import Framework.Http.Response + +import Extensions.FormProcessors (formProcessors, htmlProcessors) + +processForm' :: [Form -> FormController] -> Form -> FormController +processForm' fs = ioPipe' fs + +processForm :: Form -> FormController +processForm = processForm' formProcessors + +processHtmlForm :: HTMLForm -> AController String +processHtmlForm form = (return.tagToHtml) =<< (ioPipe' htmlProcessors $ formToHTML form) + +-- | Generate a form, maybe filled with already-entered data. This never does returnNow. +renderCreateForm :: Form -- ^ A form + -> String -- ^ Form ID + -> [(String,String)] -- ^ Hidden values + -> String -- ^ Target URL + -> AController (String, String) -- ^ (Form HTML, error message) +renderCreateForm form fid pairs action = do + form' <- processForm form + filled <- sessionLookup "filled" + rq <- asks request + let defvals = decodePairs filled + let err = httpGetVar' rq "invalid" "" + if null err + then do form' <- processHtmlForm $ createform form' fid pairs action + return (form', "") + else do form' <- processHtmlForm $ refillForm (words err) form' fid pairs defvals action + return (form', err) + +-- | Same, but filled with default values +renderCreateForm' :: Form -- ^ A form + -> String -- ^ Form ID + -> [(String,String)] -- ^ Default values + -> [(String,String)] -- ^ Hidden values + -> String -- ^ Target URL + -> AController (String, String) -- ^ (Form HTML, error message) +renderCreateForm' form fid defvals hidden action = do + form' <- processForm form + filled <- sessionLookup "filled" + rq <- asks request + let filledVals = decodePairs filled + let err = httpGetVar' rq "invalid" "" + if null err + then do form' <- processHtmlForm $ refillFormU [] form' fid hidden defvals action + return (form', "") + else do form' <- processHtmlForm $ refillForm (words err) form' fid hidden filledVals action + return (form', err) + +-- | Show edit form for model +renderEditForm :: Model + -> Form + -> String -- ^ Form ID + -> String -- ^ Target URL + -> AController (String, String) +renderEditForm model form fid action = do + form' <- processForm form + renderCreateForm' form fid (zip fields values) [] action + where + fields = map fieldName $ filter (not . isExternalField) $ mFields model + values = map (D.fromSql.(model -:>)) fields + +returnInvalidForm :: Form + -> String -- ^ Form ID + -> [String] -- ^ List of erroneus filled fields + -> AController a +returnInvalidForm form fid errs = do + rq <- asks request + let values = tail $ urlencode $ map packParam vars + vars = formVars form fid rq + sessionSet "filled" values + returnNow $ redirectG (myUrl rq) ["invalid" := (unwords errs)] + diff --git a/Framework/Forms/Types.hs b/Framework/Forms/Types.hs index 0ab8f7e..ddd52c3 100644 --- a/Framework/Forms/Types.hs +++ b/Framework/Forms/Types.hs @@ -6,6 +6,7 @@ module Framework.Forms.Types HTMLTag (..), HTML, Widget (..), FormProcessors, FormController, + HTMLProcessors, HTMLController, FormValidator, FieldValidator ) where @@ -16,8 +17,10 @@ import Framework.Controller import Framework.Forms.HTMLTypes type FormController = AController Form +type HTMLController = AController HTML -- | Form plugin transforms a Form type FormProcessors = [Form -> FormController] +type HTMLProcessors = [HTML -> HTMLController] -- | Form validator takes request and returns either list of erroneus filled field or filled Model type FormValidator = HttpRequest -> Either [String] Model diff --git a/Framework/GetText/Controller.hs b/Framework/GetText/Controller.hs new file mode 100644 index 0000000..e136e25 --- /dev/null +++ b/Framework/GetText/Controller.hs @@ -0,0 +1,14 @@ +module Framework.GetText.Controller + (__ + ) where + +import Text.I18N.GetText +import Codec.Binary.UTF8.String + +import Framework.Controller +import qualified Framework.GetText.IO as IO + +-- | Translate the string +__ :: String -> AController String +__ text = liftIO $ IO.__ text + diff --git a/Framework/GetText/IO.hs b/Framework/GetText/IO.hs new file mode 100644 index 0000000..4d3fa1d --- /dev/null +++ b/Framework/GetText/IO.hs @@ -0,0 +1,12 @@ +module Framework.GetText.IO + (__) + where + +import Text.I18N.GetText +import Codec.Binary.UTF8.String + +-- | Translate the string (in IO monad) +__ :: String -> IO String +__ text = do + res <- getText text + return $ decodeString res diff --git a/Framework/GetText/Init.hs b/Framework/GetText/Init.hs new file mode 100644 index 0000000..f53daba --- /dev/null +++ b/Framework/GetText/Init.hs @@ -0,0 +1,33 @@ +module Framework.GetText.Init + (gettextInit + ) where + +import Data.Char +import System.Locale.SetLocale +import Text.I18N.GetText + +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" + +-- | Initialize GetText. NB: initialization affects all the OS thread, not only haskell's `green` thread. +gettextInit :: String -- ^ Locale specification, such as `en_GB.UTF-8' + -> String -- ^ GetText domain + -> String -- ^ Directory with .mo files + -> IO () +gettextInit lang domain dir = do + 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 ()