diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 870727a..176374d 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -106,7 +106,8 @@ onepost sid = do comments <- querySQL' ((table commentModel) `restrict` ("pid" :==: "?")) [SqlInt32 $ fromIntegral pid] commentModel renderToResponseM "onepost.html" [("post", C post), ("comments", C comments), - ("form", C form)] + ("form", C form), + ("invalid", C err)] POST -> do insertModel commentModel commentForm "1" [SqlInt32 $ fromIntegral pid] message "Комментарий добавлен." diff --git a/Framework/Forms/HTML.hs b/Framework/Forms/HTML.hs index 7181d07..af866d2 100644 --- a/Framework/Forms/HTML.hs +++ b/Framework/Forms/HTML.hs @@ -67,18 +67,20 @@ formToHtml form = tagToHtml $ formToHTML form formrow :: String -- ^ Form name -> String -- ^ Form ID -> String -- ^ Default value for widget - -> String -- ^ `class` attribute for <tr> + -> String -- ^ Error message -> FormField -- ^ Field -> HTMLTag -formrow fname fid def cls (Field name label widget _) = tag "tr" attrs [tag "td" [] [Text itemlabel], - tag "td" [] [html widget itemname def]] - where attrs = if null cls +formrow fname fid def err (Field name label widget _) = + tag "tr" attrs [tag "td" [] [Text itemlabel], wd] + where attrs = if null err then [] - else ["class" := cls] + else ["class" := "error"] itemlabel = if null label then (capitalize name)++":" else label itemname = mangleName fname fid name + wd | null err = tag "td" [] [html widget itemname def] + | otherwise = tag "td" [] [tag "p" [] [Text err], html widget itemname def] -- | Form's submit button submit :: HTMLTag diff --git a/Framework/Forms/Rendering.hs b/Framework/Forms/Rendering.hs index bddf00b..9b97a54 100644 --- a/Framework/Forms/Rendering.hs +++ b/Framework/Forms/Rendering.hs @@ -32,16 +32,22 @@ renderCreateForm :: Form -- ^ A form -> String -- ^ Target URL -> AController (String, String) -- ^ (Form HTML, error message) renderCreateForm form fid pairs action = do +-- liftIO $ print "renderCreateForm" form' <- processForm form +-- liftIO $ print $ fFields form' filled <- sessionLookup "filled" - rq <- asks request + sessionUnset "filled" let defvals = decodePairs filled - let err = httpGetVar' rq "invalid" "" + err <- sessionLookup "invalid" + sessionUnset "invalid" + msg <- sessionLookup "errors" + sessionUnset "errors" +-- liftIO $ print err 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) + then do html <- processHtmlForm $ createform form' fid pairs action + return (html, "") + else do html <- processHtmlForm $ refillForm (words err) (unpipelist msg) form' fid pairs defvals action + return (html, err) -- | Same, but filled with default values renderCreateForm' :: Form -- ^ A form @@ -53,13 +59,17 @@ renderCreateForm' :: Form -- ^ A form renderCreateForm' form fid defvals hidden action = do form' <- processForm form filled <- sessionLookup "filled" + sessionUnset "filled" rq <- asks request let filledVals = decodePairs filled - let err = httpGetVar' rq "invalid" "" + err <- sessionLookup "invalid" + sessionUnset "invalid" + msg <- sessionLookup "errors" + sessionUnset "errors" if null err - then do form' <- processHtmlForm $ refillFormU [] form' fid hidden defvals action + then do form' <- processHtmlForm $ refillFormU [] [] form' fid hidden defvals action return (form', "") - else do form' <- processHtmlForm $ refillForm (words err) form' fid hidden filledVals action + else do form' <- processHtmlForm $ refillForm (words err) (unpipelist msg) form' fid hidden filledVals action return (form', err) -- | Show edit form for model @@ -77,12 +87,16 @@ renderEditForm model form fid action = do returnInvalidForm :: Form -> String -- ^ Form ID - -> [String] -- ^ List of erroneus filled fields + -> [(String,String)] -- ^ Erroneus filled fields and error messages -> AController a -returnInvalidForm form fid errs = do +returnInvalidForm form fid errmsgs = do rq <- asks request let values = tail $ urlencode $ map packParam vars vars = formVars form fid rq + (errs,msgs) = unzip errmsgs +-- liftIO $ print errmsgs sessionSet "filled" values - returnNow $ redirectG (myUrl rq) ["invalid" := (unwords errs)] + sessionSet "invalid" $ unwords errs + sessionSet "errors" $ pipelist msgs + returnNow $ redirect $ myUrl rq diff --git a/Framework/Forms/Types.hs b/Framework/Forms/Types.hs index ddd52c3..905f468 100644 --- a/Framework/Forms/Types.hs +++ b/Framework/Forms/Types.hs @@ -23,7 +23,7 @@ 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 +type FormValidator = HttpRequest -> Either [(String,String)] Model data HTMLForm = HTMLForm { visibleFields :: HTML, diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index 2c82a6a..e911f03 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -9,9 +9,10 @@ module Framework.Forms.Validation -- import Debug.Trace import Control.Monad.Reader.Class +import Control.Arrow import qualified Data.Map as M import Data.Maybe - +import Data.List import Network.URI import Network.HTTP import qualified Database.HDBC as D @@ -31,24 +32,30 @@ import Framework.Forms.HTML -- fill with previous values refillFormG :: (String -> String -> String -> String) -- ^ Mangle function -> [String] -- ^ List of erroneus filled fields names + -> [String] -- ^ List of error messages -> Form -- ^ A form to generate -> String -- ^ Form ID -> [(String,String)] -- ^ Hidden values -> [(String,String)] -- ^ (name,value) pairs (already filled) -> String -- ^ Form's target url -> HTMLForm -refillFormG mfun errfields form fid hidden pairs action = HTMLForm vFields hFields name fid action - where vFields = zipWith3 (formrow name fid) vals clss (fFields form) +refillFormG mfun errfields msgs form fid hidden pairs action = HTMLForm vFields hFields name fid action + where -- vFields = zipWith3 (formrow name fid) vals msgs' (fFields form) + vFields = [formrow name fid v m fld | (v,m,fld) <- zip3 vals msgs' (fFields form)] hFields = map ((uncurry hiddenField).mangle) hidden - vals = map (\n -> maybe "" id $ lookup (mfun name fid n) pairs) names + mangled n = mfun name fid n + vals = map (\n -> fromMaybe "" $ lookup (mangled n) pairs) names names = map fName (fFields form) - clss = map (\n -> if n `elem` errfields then "error" else "") names + errmsgs = zip errfields msgs + msgs' = [if (mangled n) `elem` errfields then fromMaybe "" $ lookup (mangled n) errmsgs else "" | n <- names] +-- msgs' = zipWith (\n m -> if n `elem` errfields then m else "") names msgs name = formName form mangle (n,v) = (mfun name fid n, v) -- | Generate a \"to-edit\" form (as "createform", but mark erroneus fields and -- fill with previous values refillForm :: [String] -- ^ List of erroneus filled fields names + -> [String] -- ^ List of error messages -> Form -- ^ A form to generate -> String -- ^ Form ID -> [(String, String)] -- ^ Hidden values @@ -58,7 +65,7 @@ refillForm :: [String] -- ^ List of erroneus filled fields names refillForm = refillFormG mangleName -- | Same as refillForm, but do not mangle fields names -refillFormU :: [String]-> Form-> String-> [(String, String)]-> [(String, String)]-> String-> HTMLForm +refillFormU :: [String]-> [String] -> Form-> String-> [(String, String)]-> [(String, String)]-> String-> HTMLForm refillFormU = refillFormG (\_ _ z -> z) isRight :: Either t1 t -> Bool @@ -83,12 +90,13 @@ defValidate :: Form -> String -- ^ Form ID -> FormValidator defValidate form fid rq = - if all isRight maybes + if all (isRight.snd) maybes then Right $ record (formModel form) $ map D.toSql fields - else Left $ map fromLeft $ filter isLeft maybes - where fields = map fromRight maybes - maybes :: [Either String String] - maybes = zipWith3 apl (map (flip fValidate rq) (fFields form)) vars values + else Left $ map (second fromLeft) $ filter (isLeft.snd) maybes + where fields = map (fromRight.snd) maybes + maybes :: [(String,Either String String)] + maybes = [(v, fValidate fld rq v val) | (fld,v,val) <- zip3 (fFields form) vars values] +-- maybes = zip vars (zipWith3 apl (map (flip fValidate rq) (fFields form)) vars values) values = formVarsValues form fid rq vars = formVarsNames form fid @@ -115,7 +123,7 @@ formVars form fid rq = zip (formVarsNames form fid) (formVarsValues form fid rq) -- | Get any present form from HttpRequest getAnyForm :: M.Map String Form -- ^ Map of all forms with their names -> HttpRequest - -> (Either [String] Model, String, String) -- ^ (Errors|Model, form name, form ID) + -> (Either [(String,String)] Model, String, String) -- ^ (Errors|Model, form name, form ID) getAnyForm mm rq = case form of Nothing -> (Left [], "","") Just form' -> (defValidate form' fid rq, formname, fid) @@ -127,6 +135,6 @@ getAnyForm mm rq = case form of getForm :: Form -- ^ Map of all forms -> HttpRequest -> String -- ^ Form name - -> (Either [String] Model, String) -- ^ (Errors|Model, form ID) + -> (Either [(String,String)] Model, String) -- ^ (Errors|Model, form ID) getForm form rq name = (defValidate form fid rq, fid) where fid = httpPostVar' rq "formid" "" diff --git a/Framework/Forms/Validators.hs b/Framework/Forms/Validators.hs index b4693d6..1bbf892 100644 --- a/Framework/Forms/Validators.hs +++ b/Framework/Forms/Validators.hs @@ -6,7 +6,7 @@ import Framework.Forms.Types -- | Check that field is not empty notEmpty :: FieldValidator notEmpty _ name s = if null s - then Left name + then Left "This field should not be empty!" else Right s -- | Do not validate at all, consider all values are valid. @@ -16,7 +16,7 @@ noValidate _ _ s = Right s regexp :: String -> FieldValidator regexp re _ name s = if s =~ ("^"++re++"$") then Right s - else Left name + else Left $ "This field should be of form "++re isEmail :: FieldValidator isEmail = regexp "[a-zA-Z._-]+@[a-zA-Z._-]+" diff --git a/Framework/Modules/TextCaptcha/FormProcessors.hs b/Framework/Modules/TextCaptcha/FormProcessors.hs index 9d666bc..a6f4035 100644 --- a/Framework/Modules/TextCaptcha/FormProcessors.hs +++ b/Framework/Modules/TextCaptcha/FormProcessors.hs @@ -67,7 +67,7 @@ validateCaptcha :: FieldValidator validateCaptcha rq name str = if val == targetval then Right str - else Left name + else Left "Invalid captcha!" where val = if isNum str then read str else 9999 targetval = evalCaptcha captcha @@ -77,6 +77,7 @@ addCaptcha :: [String] -> Form -> FormController addCaptcha lst form = do if (formName form) `elem` lst then do +-- liftIO $ print $ "Processing "++(formName form) captcha <- liftIO $ randomCaptcha let field = Field "textcaptcha" "Captcha" captcha validateCaptcha return $ form `addFields` [field] diff --git a/Framework/Utils.hs b/Framework/Utils.hs index d1556d7..6c9057f 100644 --- a/Framework/Utils.hs +++ b/Framework/Utils.hs @@ -4,6 +4,7 @@ module Framework.Utils where import qualified Data.Map as M import Data.List import Data.Char +import Data.String.Utils import System.IO import System.IO.Unsafe import Foreign @@ -155,3 +156,5 @@ normal url = if last url == '/' then init url else url +pipelist = intercalate "|" +unpipelist = split "|" diff --git a/TODO b/TODO index 9194e30..7e633b7 100644 --- a/TODO +++ b/TODO @@ -6,7 +6,7 @@ TODO * (?) Автоматические CRUD-контроллеры; * Человеческая обработка завершения программы; * Все параметры, которые сейчас hard-coded, брать из конфига; - * (?) Полу-автоматическая интернационализация с помощью какого-л. Middleware; + * [PARTIALLY DONE] Полу-автоматическая интернационализация с помощью какого-л. Middleware; * [PARTIALLY DONE] Более высокоуровневый интерфейс для кэша - чтоб было легко закэшировать результат всей функции; * [PARTIALLY DONE] Соответственно, простые средства для инвалидации кэша; * [PARTIALLY DONE] Более продвинутые и высокоуровневые функции генерации SQL;