diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 9de0432..48a6da2 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -8,6 +8,7 @@ import Framework.Utils import Framework.Modules.Auth.Controllers import Framework.Modules.Auth.Utils +import Framework.Modules.TextCaptcha.FormProcessors import Models @@ -65,7 +66,7 @@ newpost = loginRequired $ do renderToResponseM "newpost.html" [("form", C form), ("invalid", C err)] POST -> do - insertModel allForms postModel postForm "1" [] + insertModel postModel postForm "1" [] message "Пост успешно добавлен." return $ redirect "/blog/" @@ -81,7 +82,7 @@ editpost sid = loginRequired $ do renderToResponseM "editpost.html" [("form", C form), ("invalid", C err)] POST -> - do updateModel allForms postModel postForm "1" sid + do updateModel postModel postForm "1" sid message "Пост отредактирован." return $ redirect "/blog/" @@ -90,7 +91,9 @@ onepost sid = do rq <- asks request let url = myUrl rq pid = read sid - (form,err) <- retryForm commentForm "1" [] url +-- form' <- addCaptcha ["comment"] commentForm + form' <- processForm commentForm + (form,err) <- retryForm form' "1" [] url case rqMethod rq of GET -> do post <- getOneObject postModel pid @@ -99,7 +102,7 @@ onepost sid = do ("comments", C comments), ("form", C form)] POST -> do - insertModel allForms commentModel commentForm "1" [SqlInt32 $ fromIntegral pid] + insertModel commentModel form' "1" [SqlInt32 $ fromIntegral pid] message "Комментарий добавлен." return $ redirect url diff --git a/Blog/Extensions/FormProcessors.hs b/Blog/Extensions/FormProcessors.hs index e03d528..0ecee79 100644 --- a/Blog/Extensions/FormProcessors.hs +++ b/Blog/Extensions/FormProcessors.hs @@ -1,11 +1,11 @@ module Extensions.FormProcessors where +import Framework.Controller import Framework.Forms.Types --- | These functions may modify each Form. -formProcessors :: [Form -> Form] -formProcessors = [simple] +import Framework.Modules.TextCaptcha.FormProcessors -simple :: Form -> Form -simple = id +-- | These functions may modify each Form. +formProcessors :: FormsPlugins +formProcessors = [addCaptcha ["comment"]] diff --git a/Framework/API/SQLUtils.hs b/Framework/API/SQLUtils.hs index af61f44..4d773b3 100644 --- a/Framework/API/SQLUtils.hs +++ b/Framework/API/SQLUtils.hs @@ -23,15 +23,14 @@ getOneObject model oid = do assertC $ (length objs)==1 return $ head objs -insertModel :: M.Map String Form -- ^ Map of all forms - -> Model +insertModel :: Model -> Form -> String -- ^ Form ID -> [HDBC.SqlValue] -- ^ Additional fields (which are not in form) -> AController () -insertModel mm model form fid params = do +insertModel model form fid params = do rq <- asks request - let (d,_) = getForm mm rq (formName form) + let (d,_) = getForm form rq (formName form) case d of Right obj -> do send "pre_insert" obj @@ -42,16 +41,15 @@ insertModel mm model form fid params = do values = map (obj -:>) fields Left e -> returnInvalidForm form fid e -updateModel :: M.Map String Form -- ^ Map of all forms - -> Model -- ^ Model +updateModel :: Model -- ^ Model -> Form -> String -- ^ Form ID -> String -- ^ Object ID -> AController () -updateModel mm model form fid oid = do +updateModel model form fid oid = do rq <- asks request idf <- forceMaybe "Could not find PK!" $ getPK model - let (d,_) = getForm mm rq (formName form) + let (d,_) = getForm form rq (formName form) case d of Right obj -> do send "pre_update" obj diff --git a/Framework/Forms/Types.hs b/Framework/Forms/Types.hs index a9f937b..32edb40 100644 --- a/Framework/Forms/Types.hs +++ b/Framework/Forms/Types.hs @@ -1,18 +1,20 @@ -{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts #-} +{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts, ImpredicativeTypes, RankNTypes #-} module Framework.Forms.Types (Form (..), FormField (..), HTMLForm (..), HTMLTag (..), HTML, Widget (..), - FormsPlugins, + FormsPlugins, FormController, FormValidator, FieldValidator ) where import Framework.Types import Framework.ORM +import Framework.Controller +type FormController = AController Form -- | Form plugin transforms a Form -type FormsPlugins = [Form -> Form] +type FormsPlugins = [Form -> FormController] -- $doc -- HTML forms generation and validation. @@ -49,7 +51,7 @@ data HTMLForm = HTMLForm { -- | Form validator takes request and returns either list of erroneus filled field or filled Model type FormValidator = HttpRequest -> Either [String] Model -- | Field validator takes field value and returns either error message or validated value -type FieldValidator = String -> Either String String +type FieldValidator = HttpRequest -> String -> Either String String data FormField = forall w. (Widget w) => Field { fName :: String, diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index fd1c83c..5ab7493 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts #-} +{-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts, ImpredicativeTypes #-} module Framework.Forms.Validation (refillForm, retryForm, retryEditForm, @@ -6,7 +6,8 @@ module Framework.Forms.Validation returnInvalidForm, formVars, formVarsNames, formVarsValues, defValidate, - getAnyForm, getForm + getAnyForm, getForm, + processForm ) where -- import Debug.Trace @@ -32,6 +33,12 @@ 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 @@ -145,7 +152,7 @@ defValidate form fid rq = else Left $ map fromLeft $ filter isLeft maybes where fields = map fromRight maybes maybes :: [Either String String] - maybes = zipWith ($) (map fValidate (fFields form)) vars + maybes = zipWith ($) (map (flip fValidate rq) (fFields form)) vars vars :: [String] vars = formVarsValues form fid rq @@ -168,6 +175,7 @@ formVars form fid rq = zip (formVarsNames form fid) (formVarsValues form fid rq) ---------------------------------------------------------------------------------------------------- +-- FIXME: this should use processed forms -- | Get any present form from HttpRequest getAnyForm :: M.Map String Form -- ^ Map of all forms with their names -> HttpRequest @@ -180,11 +188,9 @@ getAnyForm mm rq = case form of fid = httpPostVar' rq "formid" "" -- | Get specified form from HttpRequest -getForm :: M.Map String Form -- ^ Map of all forms +getForm :: Form -- ^ Map of all forms -> HttpRequest -> String -- ^ Form name -> (Either [String] Model, String) -- ^ (Errors|Model, form ID) -getForm mm rq name = if name==formname - then (e,fid) - else (Left [], "") - where (e,formname,fid) = getAnyForm mm rq +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 30d3fd2..07b691b 100644 --- a/Framework/Forms/Validators.hs +++ b/Framework/Forms/Validators.hs @@ -4,10 +4,10 @@ import Framework.Forms.Types -- | Check that field is not empty notEmpty :: String -> FieldValidator -notEmpty msg s = if null s +notEmpty msg _ s = if null s then Left msg else Right s -- | Do not validate at all, consider all values are valid. noValidate :: FieldValidator -noValidate s = Right s +noValidate _ s = Right s diff --git a/Framework/Http/Middlewares.hs b/Framework/Http/Middlewares.hs index 5ef21a3..fcadc31 100644 --- a/Framework/Http/Middlewares.hs +++ b/Framework/Http/Middlewares.hs @@ -15,6 +15,7 @@ import Network.HTTP -- import Framework.Utils import Framework.Types +import Framework.Utils import Framework.GetText import Framework.Config @@ -74,10 +75,8 @@ defaultRqMiddlewares = [readLanguage, initI18N] defaultRspMiddlewares :: [ResponseMiddleware] defaultRspMiddlewares = [addEncoding] -f `o` g = \x -> f x >>= g - requestMiddlewares :: RequestMiddleware -requestMiddlewares ps = foldr o return $ ap (defaultRqMiddlewares ++ Settings.requestMiddlewares) [ps] +requestMiddlewares ps = ioPipe (defaultRqMiddlewares ++ Settings.requestMiddlewares) ps responseMiddlewares :: ResponseMiddleware -responseMiddlewares ps = foldr o return $ ap (defaultRspMiddlewares ++ Settings.responseMiddlewares) [ps] +responseMiddlewares ps = ioPipe (defaultRspMiddlewares ++ Settings.responseMiddlewares) ps diff --git a/Framework/Modules/Auth/Controllers.hs b/Framework/Modules/Auth/Controllers.hs index 660d0f4..ba04d49 100644 --- a/Framework/Modules/Auth/Controllers.hs +++ b/Framework/Modules/Auth/Controllers.hs @@ -24,8 +24,7 @@ checkAuth' target retry form = do rq <- asks request errorIf 400 "Invalid request method" $ rqMethod rq /= POST let model = formModel form - onlyNeeded = M.fromList [(formName form, form)] - (d,_) = getForm onlyNeeded rq $ formName form + (d,_) = getForm form rq $ formName form case d of Right user -> do send "pre_auth" user diff --git a/Framework/Modules/TextCaptcha/FormProcessors.hs b/Framework/Modules/TextCaptcha/FormProcessors.hs new file mode 100644 index 0000000..04fc00d --- /dev/null +++ b/Framework/Modules/TextCaptcha/FormProcessors.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE PatternGuards, TypeFamilies #-} +module Framework.Modules.TextCaptcha.FormProcessors where + +import Debug.Trace + +import System.Random +import Data.Char + +import Framework.Types +import Framework.Controller +import Framework.Http.Vars +import Framework.Forms.Types +import Framework.Forms.HTML + +data TextCaptcha = TCAdd Int Int + | TCSub Int Int + | TCMul Int Int + +instance Show TextCaptcha where + show (TCAdd x y) = "+ "++(show x)++" "++(show y) + show (TCSub x y) = "- "++(show x)++" "++(show y) + show (TCMul x y) = "* "++(show x)++" "++(show y) + +readCaptcha str | [s,xs,ys] <- words str = + let x = read xs + y = read ys + in case s of + "+" -> TCAdd x y + "-" -> TCSub x y + "*" -> TCMul x y + +evalCaptcha (TCAdd x y) = x+y +evalCaptcha (TCSub x y) = x-y +evalCaptcha (TCMul x y) = x*y + +renderCaptcha (TCAdd x y) = (show x)++" plus "++(show y)++" equals..." +renderCaptcha (TCSub x y) = (show x)++" minus "++(show y)++" equals..." +renderCaptcha (TCMul x y) = (show x)++" multiply "++(show y)++" equals..." + +instance Widget TextCaptcha where + type WContent TextCaptcha = Int + + html captcha name value = tag "div" [] [tag "p" [] [Text $ renderCaptcha captcha], + html inputbox name value, + hiddenField "captcha" (show captcha)] + + wRead = read + +randomCaptcha :: IO TextCaptcha +randomCaptcha = do + x <- getStdRandom (randomR (-50,50)) + y <- getStdRandom (randomR (-50,50)) + n <- getStdRandom (randomR (0,2)) + return $ case n::Int of + 0 -> TCAdd x y + 1 -> TCSub x y + 2 -> TCMul x y + +isNum s = ((head s) `elem` "-0123456789") && (all isDigit (tail s)) + +validateCaptcha :: FieldValidator +validateCaptcha rq str = + if (trace ("S:"++str) val) == (trace (show targetval) targetval) + then Right str + else Left "TextCaptcha" + where + val = if isNum str then read str else 9999 + targetval = evalCaptcha captcha + captcha = readCaptcha $ httpPostVar' rq "captcha" "+ 0 0" + +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]} + else return form diff --git a/Framework/Utils.hs b/Framework/Utils.hs index 274322e..cefe570 100644 --- a/Framework/Utils.hs +++ b/Framework/Utils.hs @@ -12,6 +12,7 @@ import System.Locale import Codec.Binary.UTF8.String import Network.URI import Network.HTTP +import Control.Monad (ap) import Framework.Http.Httpd (queryToArguments) import Framework.Types @@ -144,3 +145,8 @@ expirationDate = do -- | Get URL from Request myUrl :: HttpRequest -> String myUrl rq = uriPath $ rqURI rq + +f `o` g = \x -> f x >>= g +ioPipe fs x = foldr o return $ ap fs [x] +ioPipe' fs = foldr o return fs + diff --git a/Makefile b/Makefile index 95d8090..4b5ae34 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,11 @@ +SHELL=/bin/zsh + all: make -C Blog/ clean: - make -C Framework/ clean - make -C Blog/ clean + find . -name *.hi -delete + find . -name *.o -delete + +haddock: + haddock -h -o html/ --optghc=-iBlog/ Framework/**/*.hs