diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 0d2878a..4921f20 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -70,7 +70,7 @@ newpost = loginRequired $ do let url = myUrl rq case rqMethod rq of GET -> do - (form,err) <- retryForm postForm "1" [] url + (form,err) <- renderCreateForm postForm "1" [] url renderToResponseM "newpost.html" [("form", C form), ("invalid", C err)] POST -> do @@ -86,7 +86,7 @@ editpost sid = loginRequired $ do case rqMethod rq of GET -> do post <- getOneObject postModel pid - (form,err) <- editModelForm post postForm "1" url + (form,err) <- renderEditForm post postForm "1" url renderToResponseM "editpost.html" [("form", C form), ("invalid", C err)] POST -> @@ -99,9 +99,7 @@ onepost sid = do rq <- asks request let url = myUrl rq pid = read sid --- form' <- addCaptcha ["comment"] commentForm - form' <- processForm commentForm - (form,err) <- retryForm form' "1" [] url + (form,err) <- renderCreateForm commentForm "1" [] url case rqMethod rq of GET -> do post <- getOneObject postModel pid @@ -110,7 +108,7 @@ onepost sid = do ("comments", C comments), ("form", C form)] POST -> do - insertModel commentModel form' "1" [SqlInt32 $ fromIntegral pid] + insertModel commentModel commentForm "1" [SqlInt32 $ fromIntegral pid] message "Комментарий добавлен." return $ redirect url diff --git a/Framework/API.hs b/Framework/API.hs index 4f0d9de..eac0559 100644 --- a/Framework/API.hs +++ b/Framework/API.hs @@ -15,7 +15,7 @@ module Framework.API module Framework.Controller, module Framework.Exceptions, module Framework.Signals, - module Framework.GetText, + module Framework.GetText.Controller, -- ** API modules module Framework.API.Cache, module Framework.API.Sessions, @@ -26,7 +26,7 @@ module Framework.API module Framework.API.UserMessage, -- ** Specific modules module Framework.TEngine.TemplateUtil, - module Framework.Forms.Validation, + module Framework.Forms.Rendering, module Framework.Pager, module Framework.Http.Vars, module Framework.Urls, @@ -40,7 +40,7 @@ import Network.HTTP import Framework.Types import Framework.Controller import Framework.Exceptions -import Framework.GetText +import Framework.GetText.Controller import Framework.Signals import qualified Framework.Http.Cookies as Cookies @@ -55,7 +55,7 @@ import Framework.API.Logger import Framework.API.UserMessage import Framework.TEngine.TemplateUtil -import Framework.Forms.Validation +import Framework.Forms.Rendering import Framework.Pager import Framework.Http.Vars import Framework.Urls hiding (runURLConf) diff --git a/Framework/API/SQLUtils.hs b/Framework/API/SQLUtils.hs index 4d773b3..ad83c93 100644 --- a/Framework/API/SQLUtils.hs +++ b/Framework/API/SQLUtils.hs @@ -9,6 +9,7 @@ import Framework.Controller import Framework.Exceptions import Framework.Signals import Framework.Forms.Types +import Framework.Forms.Rendering import Framework.Forms.Validation import Framework.ORM import Framework.API.SQL @@ -29,8 +30,9 @@ insertModel :: Model -> [HDBC.SqlValue] -- ^ Additional fields (which are not in form) -> AController () insertModel model form fid params = do + form' <- processForm form rq <- asks request - let (d,_) = getForm form rq (formName form) + let (d,_) = getForm form' rq (formName form') case d of Right obj -> do send "pre_insert" obj @@ -39,7 +41,7 @@ insertModel model form fid params = do where fields = map fieldName $ filter (not . isExternalField) $ mFields model values = map (obj -:>) fields - Left e -> returnInvalidForm form fid e + Left e -> returnInvalidForm form' fid e updateModel :: Model -- ^ Model -> Form @@ -47,9 +49,10 @@ updateModel :: Model -- ^ Model -> String -- ^ Object ID -> AController () updateModel model form fid oid = do + form' <- processForm form rq <- asks request idf <- forceMaybe "Could not find PK!" $ getPK model - let (d,_) = getForm form rq (formName form) + let (d,_) = getForm form' rq (formName form') case d of Right obj -> do send "pre_update" obj @@ -58,6 +61,6 @@ updateModel model form fid oid = do where fields = map fieldName $ filter (not . isExternalField) $ mFields model values = map (obj -:>) fields - Left e -> returnInvalidForm form fid e + Left e -> returnInvalidForm form' fid e diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index 9ede547..2c82a6a 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -1,13 +1,9 @@ {-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts, ImpredicativeTypes #-} module Framework.Forms.Validation - (refillForm, - retryForm, retryEditForm, - editModelForm, - returnInvalidForm, + (refillForm, refillFormU, formVars, formVarsNames, formVarsValues, defValidate, - getAnyForm, getForm, - processForm + getAnyForm, getForm ) where -- import Debug.Trace @@ -31,14 +27,6 @@ import Framework.Http.Vars import Framework.Forms.Types import Framework.Forms.HTML -import Extensions.FormProcessors (formProcessors) - -processForm' :: [Form -> FormController] -> Form -> FormController -processForm' fs = ioPipe' fs - -processForm :: Form -> FormController -processForm = processForm' formProcessors - -- | Generate a \"to-edit\" form (as "createform", but mark erroneus fields and -- fill with previous values refillFormG :: (String -> String -> String -> String) -- ^ Mangle function @@ -71,61 +59,7 @@ refillForm = refillFormG mangleName -- | Same as refillForm, but do not mangle fields names refillFormU :: [String]-> Form-> String-> [(String, String)]-> [(String, String)]-> String-> HTMLForm -refillFormU = refillFormG (\x y z -> z) - --- | Generate a form, maybe filled with already-entered data -retryForm :: Form -- ^ A form - -> String -- ^ Form ID - -> [(String,String)] -- ^ Hidden values - -> String -- ^ Target URL - -> Controller ActionConfig r (String, String) -- ^ (Form HTML, error message) -retryForm form fid pairs action = do - filled <- sessionLookup "filled" - rq <- asks request --- putStrLn $ "retryForm: Session read: "++(show filled) - let defvals = decodePairs filled --- liftIO $ putStrLn $ "retryForm: defvals: "++(show defvals) - let err = httpGetVar' rq "invalid" "" - if null err - then return (formToHtml $ createform form fid pairs action, "") - else return (formToHtml $ refillForm (words err) form fid pairs defvals action, err) - -retryEditForm :: Form -- ^ A form - -> String -- ^ Form ID - -> [(String,String)] -- ^ Default values - -> [(String,String)] -- ^ Hidden values - -> String -- ^ Target URL - -> AController (String, String) -- ^ (Form HTML, error message) -retryEditForm form fid defvals hidden action = do - filled <- sessionLookup "filled" - rq <- asks request - let filledVals = decodePairs filled - let err = httpGetVar' rq "invalid" "" - if null err - then return (formToHtml $ refillFormU [] form fid hidden defvals action, "") - else return (formToHtml $ refillForm (words err) form fid hidden filledVals action, err) - --- FIXME: should this be moved to API.hs ? --- | Show edit form for model -editModelForm :: Model - -> Form - -> String -- ^ Form ID - -> String -- ^ Target URL - -> AController (String, String) -editModelForm model form fid action = retryEditForm 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 (uriPath $ rqURI rq) ["invalid" := (unwords errs)] +refillFormU = refillFormG (\_ _ z -> z) isRight :: Either t1 t -> Bool isRight (Right _) = True diff --git a/Framework/Forms/Validators.hs b/Framework/Forms/Validators.hs index 228b321..b4693d6 100644 --- a/Framework/Forms/Validators.hs +++ b/Framework/Forms/Validators.hs @@ -17,3 +17,12 @@ regexp :: String -> FieldValidator regexp re _ name s = if s =~ ("^"++re++"$") then Right s else Left name + +isEmail :: FieldValidator +isEmail = regexp "[a-zA-Z._-]+@[a-zA-Z._-]+" + +isUrl :: FieldValidator +isUrl = regexp "http://[a-zA-Z._/-]+" + +isInteger :: FieldValidator +isInteger = regexp "[0-9]+" diff --git a/Framework/GetText.hs b/Framework/GetText.hs deleted file mode 100644 index d2741ad..0000000 --- a/Framework/GetText.hs +++ /dev/null @@ -1,49 +0,0 @@ -module Framework.GetText - (gettextInit, - __, - __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" - --- | 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 () - --- | Translate the string (in IO monad) -__io :: String -> IO String -__io text = do - res <- getText text - return $ decodeString res - --- | Translate the string -__ :: String -> AController String -__ text = liftIO $ __io text - diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs index fcadc31..d531535 100644 --- a/Framework/Http/Middlewares.hs +++ b/Framework/Http/Middlewares.hs @@ -16,7 +16,7 @@ import Network.HTTP -- import Framework.Utils import Framework.Types import Framework.Utils -import Framework.GetText +import Framework.GetText.Init import Framework.Config import qualified Extensions.Middlewares as Settings (requestMiddlewares, responseMiddlewares) diff --git a/Framework/Modules/Auth/Context.hs b/Framework/Modules/Auth/Context.hs index 78dd8ff..604f4bc 100644 --- a/Framework/Modules/Auth/Context.hs +++ b/Framework/Modules/Auth/Context.hs @@ -16,6 +16,6 @@ addLoginForm :: String -- ^ URL of auth-checking controller addLoginForm target = do url <- asks (myUrl.request) if normal url == (normal target) - then do (loginhtml,err) <- showLoginForm target + then do (loginhtml,err) <- changeR $ showLoginForm target return [("form", C loginhtml), ("invalid", C err)] else return [] diff --git a/Framework/Modules/Auth/Controllers.hs b/Framework/Modules/Auth/Controllers.hs index 4a1a23e..80f6143 100644 --- a/Framework/Modules/Auth/Controllers.hs +++ b/Framework/Modules/Auth/Controllers.hs @@ -5,6 +5,7 @@ import Database.HDBC import qualified Data.Map as M import Framework.Forms.Types +import Framework.Forms.Validation import Framework.API import Framework.Utils @@ -57,10 +58,12 @@ checkAuth :: String checkAuth target retry = checkAuth' target retry defaultLoginForm -- | Simple controller for login page. -loginPage :: String -- ^ Where to redirect after succesful login +loginPage' :: Form -- ^ Login form + -> String -- ^ Where to redirect after succesful login -> String -- ^ Where to redirect if login fails -> AController () -loginPage target retry = do +loginPage' form target retry = do + form' <- processForm form rq <- asks request case rqMethod rq of GET -> do @@ -74,9 +77,11 @@ loginPage target retry = do let target' = if null t then target else t - resp <- checkAuth target' retry + resp <- checkAuth' target' retry form' returnNow resp +loginPage = loginPage' defaultLoginForm + -- | Log out current user doLogout :: String -- ^ Where to redirect after logout -> HttpAction diff --git a/Framework/Modules/Auth/ShowForm.hs b/Framework/Modules/Auth/ShowForm.hs index 9a46183..2014a55 100644 --- a/Framework/Modules/Auth/ShowForm.hs +++ b/Framework/Modules/Auth/ShowForm.hs @@ -3,18 +3,19 @@ module Framework.Modules.Auth.ShowForm where import Framework.Types import Framework.Controller import Framework.Forms.Types -import Framework.Forms.Validation +import Framework.Forms.Rendering import Framework.Modules.Auth.Models - -- | Wraps @retryForm@ for login form showLoginForm' :: String -- ^ Form target (URL of auth-checking controller) -> Form -- ^ Login form - -> Controller ActionConfig r (String,String) -- ^ (Form HTML, errors) -showLoginForm' target form = retryForm form "1" [] target + -> AController (String,String) -- ^ (Form HTML, errors) +showLoginForm' target form = do + form' <- processForm form + renderCreateForm form' "1" [] target -- | Same as @showLoginForm'@, but with default login form showLoginForm :: String -- ^ Form target - -> Controller ActionConfig r (String,String) + -> AController (String,String) showLoginForm target = showLoginForm' target defaultLoginForm diff --git a/Framework/Modules/Registration/Context.hs b/Framework/Modules/Registration/Context.hs index 7a251f4..8ad80d8 100644 --- a/Framework/Modules/Registration/Context.hs +++ b/Framework/Modules/Registration/Context.hs @@ -14,6 +14,6 @@ addRegistrationForm :: String -- ^ target URL addRegistrationForm target = do url <- asks (myUrl.request) if normal url == (normal target) - then do (html,err) <- showRegistrationForm target + then do (html,err) <- changeR $ showRegistrationForm target return [("form", C html), ("invalid", C err)] else return [] diff --git a/Framework/Modules/Registration/Forms.hs b/Framework/Modules/Registration/Forms.hs index ba71775..d3312ec 100644 --- a/Framework/Modules/Registration/Forms.hs +++ b/Framework/Modules/Registration/Forms.hs @@ -12,6 +12,7 @@ import Framework.Signals import Framework.Forms.Types import Framework.Forms.Validators import Framework.Forms.Validation +import Framework.Forms.Rendering import Framework.Forms.HTML import Framework.Http.Vars import Framework.Http.Response @@ -49,10 +50,12 @@ registrationForm = Form { Field "password" "Password" twoPasswordBoxes validatePasswords ] } -showRegistrationForm' :: Form-> String-> Controller ActionConfig r (String, String) -showRegistrationForm' form target = retryForm form "1" [] target +showRegistrationForm' :: Form-> String-> AController (String, String) +showRegistrationForm' form target = do + form' <- processForm form + renderCreateForm form' "1" [] target -showRegistrationForm :: String-> Controller ActionConfig r (String, String) +showRegistrationForm :: String-> AController (String, String) showRegistrationForm target = showRegistrationForm' registrationForm target doRegister' :: Form -> String -> HttpController diff --git a/Framework/Modules/TextCaptcha/FormProcessors.hs b/Framework/Modules/TextCaptcha/FormProcessors.hs index c932645..9d666bc 100644 --- a/Framework/Modules/TextCaptcha/FormProcessors.hs +++ b/Framework/Modules/TextCaptcha/FormProcessors.hs @@ -14,6 +14,7 @@ import Framework.Controller import Framework.Http.Vars import Framework.Forms.Types import Framework.Forms.HTML +import Framework.Forms.ModelForm data TextCaptcha = TCAdd Int Int | TCSub Int Int @@ -74,11 +75,9 @@ validateCaptcha rq name str = addCaptcha :: [String] -> Form -> FormController addCaptcha lst form = do - liftIO $ print $ formName form if (formName form) `elem` lst then do captcha <- liftIO $ randomCaptcha - liftIO $ print captcha let field = Field "textcaptcha" "Captcha" captcha validateCaptcha - return form {fFields = (fFields form)++[field]} + return $ form `addFields` [field] else return form