diff --git a/Blog/Blog.hs b/Blog/Blog.hs index e2bdf72..fd4fd77 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -15,6 +15,7 @@ urlconf :: URLConf urlconf = "blog" // "new" --> newpost <|> "blog" // "post" // number ~> onepost <|> "blog" // "edit" // number ~> editpost + <|> "blog" // "del" // number ~> delpost <|> "blog2" --> allposts2 <|> "blog" --> allposts <|> "login" --> login @@ -76,6 +77,10 @@ newpost = loginRequired $ do renderToResponseM "newpost.html" [("form", C form), ("invalid", C err)] +delpost sid = loginRequired $ do + delete postModel (read sid) "/blog/" + renderToResponseM "delconfirm.html" [] + editpost :: StrAction editpost sid = loginRequired $ do (form,err) <- update postModel (read sid) "/blog/" diff --git a/Blog/Extensions/Signals.hs b/Blog/Extensions/Signals.hs index 2e8838c..c83db4a 100644 --- a/Blog/Extensions/Signals.hs +++ b/Blog/Extensions/Signals.hs @@ -5,9 +5,11 @@ import qualified Data.Map as M import Framework.SignalTypes import Invalidation + connectSignals :: M.Map Signal [SignalHandler] connectSignals = M.fromList [ ("pre_insert", [invalidatePostsCache]), ("auth_ok", [invalidatePostsCache]), ("logout", [invalidatePostsCache]), + ("pre_delete", [invalidatePostsCache]), ("pre_update", [invalidatePostsCache]) ] diff --git a/Blog/templates/delconfirm.html b/Blog/templates/delconfirm.html new file mode 100644 index 0000000..1fb8734 --- /dev/null +++ b/Blog/templates/delconfirm.html @@ -0,0 +1,14 @@ +<!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>Confirm delete</title> + <meta name='author' content='Portnov'> + </head> + <body> + + <h1>Do you really want to delete {{object}}?</h1> + <p><a href="/blog/">No</a><p> + <p><a href="{{myurl}}?confirm=yes">Yes</a></p> + + </body> +</html> diff --git a/Framework/API/CRUD.hs b/Framework/API/CRUD.hs index cf9b85a..57316d0 100644 --- a/Framework/API/CRUD.hs +++ b/Framework/API/CRUD.hs @@ -7,6 +7,7 @@ import Text.Printf import Framework.Types import Framework.Utils import Framework.Controller +import Framework.Http.Vars import Framework.Http.Response import Framework.ORM.Types import Framework.API.SQL @@ -16,6 +17,7 @@ import Framework.Forms.Types import Framework.Forms.Rendering import Framework.Forms.ModelForm import Framework.GetText.Controller +import Framework.TEngine.TemplateUtil create' :: Model -> Form -> String -> AController (String,String) create' model form target = do @@ -48,3 +50,26 @@ update' model form oid target = do update :: Model -> Int -> String -> AController (String,String) update model oid target = update' model (modelForm model) oid target + +delete :: Model -> Int -> String -> AController () +delete model oid target = do + rq <- asks request + let url = myUrl rq + let confg = httpGetVar' rq "confirm" "" + let conf = if null confg + then httpPostVar' rq "confirm" "" + else confg + case rqMethod rq of + GET -> do + if conf=="yes" + then doDelete + else return () + POST -> + if conf=="yes" + then doDelete + else returnNow $ redirect url + where + doDelete = do + deleteModel model oid + returnNow $ redirect target + diff --git a/Framework/API/SQLUtils.hs b/Framework/API/SQLUtils.hs index a8a7de8..8803c52 100644 --- a/Framework/API/SQLUtils.hs +++ b/Framework/API/SQLUtils.hs @@ -2,6 +2,7 @@ module Framework.API.SQLUtils where import Control.Monad.Reader.Class import qualified Database.HDBC as HDBC +import Data.Maybe import Framework.Types import Framework.Controller @@ -62,4 +63,9 @@ updateModel model form fid oid = do values = map (obj -:>) fields Left e -> returnInvalidForm form' fid e - +deleteModel model oid = do + send "pre_delete" model + queryListSQL' (deleteM model (pk:==:"?")) [HDBC.toSql oid] + commit + where + pk = fromMaybe "id" $ getPK model diff --git a/Framework/ContextProcessors.hs b/Framework/ContextProcessors.hs index fb4e905..9a3feb7 100644 --- a/Framework/ContextProcessors.hs +++ b/Framework/ContextProcessors.hs @@ -2,7 +2,10 @@ module Framework.ContextProcessors (contextProcessors) where -import Framework.Types(TContainer(C)) +import Control.Monad.Reader.Class + +import Framework.Types +import Framework.Utils import Framework.Controller import Framework.API.Sessions @@ -10,7 +13,7 @@ import qualified Extensions.Context as Context (contextProcessors) -- | Default set of context processors defaultProcessors :: [ContextProcessor] -defaultProcessors = [addMessage] +defaultProcessors = [addMessage, addMyUrl] contextProcessors :: [ContextProcessor] contextProcessors = defaultProcessors ++ Context.contextProcessors @@ -21,3 +24,8 @@ addMessage = do msg <- sessionLookup "message" sessionUnset "message" return [("message", C msg)] + +addMyUrl :: ContextProcessor +addMyUrl = do + rq <- asks request + return [("myurl", C $ myUrl rq)] diff --git a/Framework/ORM/SQL.hs b/Framework/ORM/SQL.hs index 6639d3c..0f22215 100644 --- a/Framework/ORM/SQL.hs +++ b/Framework/ORM/SQL.hs @@ -7,7 +7,7 @@ module Framework.ORM.SQL restrict, limit, countChildren, - insertM,updateM, + insertM,updateM,deleteM, aggregate, count ) where @@ -47,6 +47,8 @@ sql' (InsertQuery table fields values) = "INSERT INTO "++table++" ("++(commas fi sql' (UpdateQuery table fields values whre) = "UPDATE "++table++" SET "++eqs++wpart where wpart = if whre==NoCondition then "" else " WHERE "++(sqlFragment whre) eqs = commas $ zipWith (\n v -> n++"="++v) fields values +sql' (DelQuery table whre) = "DELETE FROM "++table++wpart + where wpart = if whre==NoCondition then "" else " WHERE "++(sqlFragment whre) commas :: [String] -> String commas = concat . intersperse ", " @@ -108,6 +110,9 @@ updateM m cond = UpdateQuery (mTable m) (map fieldName updfields) temps cond normal s = (not ("id" `isSuffixOf` (fieldName s))) && ((fieldType s)/=CurrentDateColumn) temps = replicate (length updfields) "?" +deleteM :: Model -> SQLCondition -> Query +deleteM m cond = DelQuery (mTable m) cond + -- | Get foreign key of the model getForeignKey :: Model -> ModelField getForeignKey m = fkey (mFields m) diff --git a/Framework/ORM/Types.hs b/Framework/ORM/Types.hs index 7b8966b..f500651 100644 --- a/Framework/ORM/Types.hs +++ b/Framework/ORM/Types.hs @@ -37,6 +37,11 @@ data Query = Query -- SELECT query uValues :: [String], -- ^ Values uWhere :: SQLCondition -- ^ Condition (WHERE part) } + | DelQuery -- DELETE query + { + dTable :: String, + dWhere :: SQLCondition + } deriving (Eq,Show) data SQLField = QField String -- ^ Just a named field