diff --git a/Blog/Blog.hs b/Blog/Blog.hs index 53334fa..d043df4 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -6,16 +6,33 @@ import Control.Monad(forM) import Framework.API import Framework.Utils +import Framework.Modules.Auth.Controllers + import Models urlconf = "blog" // "new" --> newpost <|> "blog" // "post" // number ~> onepost <|> "blog" // "edit" // number ~> editpost <|> "blog" --> allposts + <|> "login" --> login + <|> "logout" --> (doLogout "/blog/") + <|> "auth" --> (checkAuth "/blog/" "/login/") <|> "form" --> testform <|> "i18n" --> i18ntest <|> RawFunction serveStatic +login :: HttpAction +login = do + rq <- asks request + errorIf 400 "Invalid request" $ rqMethod rq /= GET + already <- sessionLookup "username" + if not $ null already + then returnNow $ redirect "/blog/" + else return () + (loginhtml,err) <- showLoginForm "/auth/" + renderToResponseM "login.html" [("form", C loginhtml), + ("invalid", C err)] + testform :: HttpAction testform = do rq <- asks request @@ -39,8 +56,10 @@ allposts = do tryReturnFromCache key (posts,pagerHtml) <- pager (countChildren postModel commentModel) [] postModel lastComments <- querySQL' ((table commentModel) `order` [Desceding "dt"] `limit` (0,10)) [] commentModel + username <- sessionLookup "username" renderToResponseP key "blogposts.html" [("posts", C posts), ("comments", C lastComments), + ("username", C username), ("pager", C pagerHtml)] newpost :: HttpAction diff --git a/Blog/Settings.hs b/Blog/Settings.hs index 94a3149..b9cc05b 100644 --- a/Blog/Settings.hs +++ b/Blog/Settings.hs @@ -36,4 +36,6 @@ responseMiddlewares = [] connectSignals :: M.Map Signal [SignalHandler] connectSignals = M.fromList [ ("pre_insert", [invalidatePostsCache]), + ("auth_ok", [invalidatePostsCache]), + ("logout", [invalidatePostsCache]), ("pre_update", [invalidatePostsCache]) ] diff --git a/Blog/blog.sql b/Blog/blog.sql new file mode 100644 index 0000000..ec0679f --- /dev/null +++ b/Blog/blog.sql @@ -0,0 +1,259 @@ +-- +-- PostgreSQL database dump +-- + +SET client_encoding = 'UTF8'; +SET standard_conforming_strings = off; +SET check_function_bodies = false; +SET client_min_messages = warning; +SET escape_string_warning = off; + +SET search_path = public, pg_catalog; + +SET default_tablespace = ''; + +SET default_with_oids = false; + +-- +-- Name: comments; Type: TABLE; Schema: public; Owner: portnov; Tablespace: +-- + +CREATE TABLE comments ( + id integer NOT NULL, + pid integer, + dt date, + author character varying(50), + body text +); + + +ALTER TABLE public.comments OWNER TO portnov; + +-- +-- Name: comments_id_seq; Type: SEQUENCE; Schema: public; Owner: portnov +-- + +CREATE SEQUENCE comments_id_seq + INCREMENT BY 1 + NO MAXVALUE + NO MINVALUE + CACHE 1; + + +ALTER TABLE public.comments_id_seq OWNER TO portnov; + +-- +-- Name: comments_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: portnov +-- + +ALTER SEQUENCE comments_id_seq OWNED BY comments.id; + + +-- +-- Name: comments_id_seq; Type: SEQUENCE SET; Schema: public; Owner: portnov +-- + +SELECT pg_catalog.setval('comments_id_seq', 26, true); + + +-- +-- Name: posts; Type: TABLE; Schema: public; Owner: portnov; Tablespace: +-- + +CREATE TABLE posts ( + id integer NOT NULL, + dt date, + title character varying(100), + body text +); + + +ALTER TABLE public.posts OWNER TO portnov; + +-- +-- Name: posts_id_seq; Type: SEQUENCE; Schema: public; Owner: portnov +-- + +CREATE SEQUENCE posts_id_seq + INCREMENT BY 1 + NO MAXVALUE + NO MINVALUE + CACHE 1; + + +ALTER TABLE public.posts_id_seq OWNER TO portnov; + +-- +-- Name: posts_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: portnov +-- + +ALTER SEQUENCE posts_id_seq OWNED BY posts.id; + + +-- +-- Name: posts_id_seq; Type: SEQUENCE SET; Schema: public; Owner: portnov +-- + +SELECT pg_catalog.setval('posts_id_seq', 10, true); + + +-- +-- Name: test; Type: TABLE; Schema: public; Owner: portnov; Tablespace: +-- + +CREATE TABLE test ( + id integer NOT NULL, + name character varying, + value character varying +); + + +ALTER TABLE public.test OWNER TO portnov; + +-- +-- Name: test_id_seq; Type: SEQUENCE; Schema: public; Owner: portnov +-- + +CREATE SEQUENCE test_id_seq + INCREMENT BY 1 + NO MAXVALUE + NO MINVALUE + CACHE 1; + + +ALTER TABLE public.test_id_seq OWNER TO portnov; + +-- +-- Name: test_id_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: portnov +-- + +ALTER SEQUENCE test_id_seq OWNED BY test.id; + + +-- +-- Name: test_id_seq; Type: SEQUENCE SET; Schema: public; Owner: portnov +-- + +SELECT pg_catalog.setval('test_id_seq', 1, true); + + +-- +-- Name: id; Type: DEFAULT; Schema: public; Owner: portnov +-- + +ALTER TABLE comments ALTER COLUMN id SET DEFAULT nextval('comments_id_seq'::regclass); + + +-- +-- Name: id; Type: DEFAULT; Schema: public; Owner: portnov +-- + +ALTER TABLE posts ALTER COLUMN id SET DEFAULT nextval('posts_id_seq'::regclass); + + +-- +-- Name: id; Type: DEFAULT; Schema: public; Owner: portnov +-- + +ALTER TABLE test ALTER COLUMN id SET DEFAULT nextval('test_id_seq'::regclass); + + +-- +-- Data for Name: comments; Type: TABLE DATA; Schema: public; Owner: portnov +-- + +COPY comments (id, pid, dt, author, body) FROM stdin; +1 1 2009-06-17 Я проверка +2 1 2009-06-17 Тоже я Ещё каммент +3 2 2009-06-17 Я Первый! +4 1 2009-06-19 me Третй +5 8 2009-06-19 me Будут комментарии! +6 2 2009-06-19 me Второй +7 6 2009-06-19 me Comment +8 6 2009-06-19 me Забыл добавить. +9 3 2009-06-20 me Коммент к абракадабре +10 6 2009-06-20 Я И ещё. +11 9 2009-06-20 Portnov А чо вы хотели :) +12 6 2009-06-21 me # priority-queue library: Simple implementation of a priority queue.\r\n# procrastinating-structure library: Pure structures that can be incrementally created in impure code\r\n# procrastinating-variable library: Haskell values that cannot be evaluated immediately.\r\n# property-list library: XML property list parser +13 6 2009-07-02 *** Типа коммент +14 1 2009-07-07 me Проверка +15 1 2009-07-07 Я Yet another test +16 1 2009-07-07 me Test +17 5 2009-07-07 me Test +18 5 2009-07-07 Я Ещё тест +19 10 2009-07-07 me # Не работай с правами root-а.\r\nИспользуй “sudo” или “su -” для задач администрирования.\r\n\r\n# Используй менеджер пакетов, если возможно.\r\nИногда установки из исходников не избежать, но если использовать пакетный менеджер дистрибутива для установки программы, с его же помощью можно эту программу обновить или удалить. Это одна из сильных сторон Linux.\r\n\r\n# Будь частью сообщества.\r\nДелись тем, что получил бесплатно. Предлагай помощь и совет всегда, когда возможно.\r\n\r\n# Читай документацию и страницы man.\r\nВсегда читай документацию. Авторы программ пытались предвидеть твои вопросы и ответить на них еще до того, как ты их задал.\r\n\r\n# Используй помощь других.\r\nПереход на Linux может быть трудным делом. Это может раздражать, но множество людей хотят помочь тебе в этом деле. Позволь им.\r\n +20 4 2009-07-08 me Тут тоже русские. +21 5 2009-07-09 me TTT +22 6 2009-07-09 me Тута текст +23 3 2009-07-09 me !!!! +24 5 2009-07-09 zzz aaaaa +25 4 2009-07-09 Portnov TEST +26 4 2009-07-10 me zzzz +\. + + +-- +-- Data for Name: posts; Type: TABLE DATA; Schema: public; Owner: portnov +-- + +COPY posts (id, dt, title, body) FROM stdin; +3 2009-06-19 Абракадабра Тут была абракадабра +8 2009-06-19 фыва Такой вот пост... WWW +2 2009-06-19 aaaaa Всё-таки текст какой-то\r\nДобавлено +9 2009-06-20 Haskell Что интересно: на тесте thread-ring (создание 500 threads, разделяющих по 1 переменной с соседями в кольце), Haskell (ghc) и Erlang в несколько раз быстрее, чем C (gcc). Хотя на тесте n-body (моделирование движения 20 000 000 тел; double) они, как и ожидалось, в несколько раз медленнее.\r\n +7 2009-06-17 И ещё пост ## EASY CONVERSIONS BETWEEN _HASKELL_ TYPES\r\n\r\nConversions are powerful; for instance, you can call fromSql on a SqlInt32 and get a String or a Double out of it. This class attempts to Do The Right Thing whenever possible, and will raise an error when asked to do something incorrect. In particular, when converting to any type except a Maybe, SqlNull as the input will cause an error to be raised.\r\n\r\nConversions are implemented in terms of the Data.Convertible module, part of the convertible package. You can refer to its documentation, and import that module, if you wish to parse the Left result from safeFromSql yourself, or write your own conversion instances. +1 2009-06-19 First post ZZZZZZZZZ +6 2009-06-17 Ещё пост текст\r\n\r\n Сравнение языков программирования на наборе тестовых задач на различных CPU и дистрибутивах *Linux*.\r\n\r\nБольшой выбор языков программирования: C, C++, Objective-C, Java, C# и F# (Mono), Pascal, Ada, BASIC, Fortran, Lisp, Scheme, **Haskell**, OCaml, Erlang, Forth, Perl, PHP, Ruby, Python, Lua, Smalltalk, и др.\r\n\r\nУчитываются и разные реализации языков. +4 2009-06-17 пост русские буквы\r\n\r\nЕщё текст +5 2009-06-17 Заголовок Такой пост. *тест*\r\n\r\nТут ещё текст\r\n\r\nBlahblah +10 2009-07-07 Just a post ### 7.3.5. View patterns\r\n\r\nView patterns are enabled by the flag -XViewPatterns. More information and examples of view patterns can be found on the Wiki page.\r\n\r\nView patterns are somewhat like pattern guards that can be nested inside of other patterns. They are a convenient way of pattern-matching against values of abstract types. For example, in a programming language implementation, we might represent the syntax of the types of the language as follows:\r\n\r\ntype Typ\r\n \r\ndata TypView = Unit\r\n | Arrow Typ Typ\r\n\r\nview :: Type -> TypeView\r\n +\. + + +-- +-- Data for Name: test; Type: TABLE DATA; Schema: public; Owner: portnov +-- + +COPY test (id, name, value) FROM stdin; +1 UUU OOO +\. + + +-- +-- Name: comments_pkey; Type: CONSTRAINT; Schema: public; Owner: portnov; Tablespace: +-- + +ALTER TABLE ONLY comments + ADD CONSTRAINT comments_pkey PRIMARY KEY (id); + + +-- +-- Name: posts_pkey; Type: CONSTRAINT; Schema: public; Owner: portnov; Tablespace: +-- + +ALTER TABLE ONLY posts + ADD CONSTRAINT posts_pkey PRIMARY KEY (id); + + +-- +-- Name: test_pkey; Type: CONSTRAINT; Schema: public; Owner: portnov; Tablespace: +-- + +ALTER TABLE ONLY test + ADD CONSTRAINT test_pkey PRIMARY KEY (id); + + +-- +-- Name: public; Type: ACL; Schema: -; Owner: postgres +-- + +REVOKE ALL ON SCHEMA public FROM PUBLIC; +REVOKE ALL ON SCHEMA public FROM postgres; +GRANT ALL ON SCHEMA public TO postgres; +GRANT ALL ON SCHEMA public TO PUBLIC; + + +-- +-- PostgreSQL database dump complete +-- + diff --git a/Blog/templates/blogposts.html b/Blog/templates/blogposts.html index f85cdce..d9bdb0d 100644 --- a/Blog/templates/blogposts.html +++ b/Blog/templates/blogposts.html @@ -7,6 +7,10 @@ </head> <body> <h1>Blog posts</h1> + {%if username%} + <p>Hello, {{username}}!</p> + <p><a href='/logout/'>Log out</a></p> + {%endif%} {%if message%} <p>{{message}}</p> {%endif%} diff --git a/Blog/templates/login.html b/Blog/templates/login.html new file mode 100644 index 0000000..47cf468 --- /dev/null +++ b/Blog/templates/login.html @@ -0,0 +1,16 @@ +<!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>Login</title> + <meta name='author' content='Portnov'> + </head> + <body> + <h1>Login</h1> + {%if message%} + <p>{{message}}</p> + {%endif%} + + {{form}} + + </body> +</html> diff --git a/Framework/Forms/HTML.hs b/Framework/Forms/HTML.hs index 0d485b0..3cb89ae 100644 --- a/Framework/Forms/HTML.hs +++ b/Framework/Forms/HTML.hs @@ -1,7 +1,7 @@ {-# LANGUAGE ExistentialQuantification, TypeFamilies, NamedFieldPuns, FlexibleContexts #-} module Framework.Forms.HTML - (Inputbox, Textarea, - inputbox, textarea, + (Inputbox, Textarea, PasswordBox, + inputbox, textarea, passwordbox, tag, tagToHtml, toHtml, formrow, hiddenField, mangleName, @@ -103,18 +103,33 @@ data Inputbox = Inputbox { ibWidth :: Maybe Int } -- | Default input box inputbox = Inputbox Nothing +data PasswordBox = PasswordBox { pbWidth :: Maybe Int } +passwordbox = PasswordBox Nothing + data Textarea = Textarea { tbCols :: Maybe Int, tbRows :: Maybe Int } -- | Default textarea textarea = Textarea (Just 60) (Just 15) instance Widget Inputbox where type WContent Inputbox = String - html (Inputbox w) name value = tag "input" ["size" := show w, "name" := name, "value" := value] [] + html (Inputbox w) name value = tag "input" ["size" := show w, + "name" := name, + "value" := value] [] wRead = id instance Widget Textarea where type WContent Textarea = String - html (Textarea c r) name value = tagE "textarea" ["cols" := show c, "rows" := show r, "name" := name] [Text value] + html (Textarea c r) name value = tagE "textarea" ["cols" := show c, + "rows" := show r, + "name" := name] [Text value] + wRead = id + +instance Widget PasswordBox where + type WContent PasswordBox = String + html (PasswordBox w) name value = tag "input" ["type" := "password", + "size" := show w, + "name" := name, + "value" := value] [] wRead = id diff --git a/Framework/Forms/Validation.hs b/Framework/Forms/Validation.hs index f46179f..e95e23a 100644 --- a/Framework/Forms/Validation.hs +++ b/Framework/Forms/Validation.hs @@ -77,7 +77,7 @@ retryForm form fid pairs action = do rq <- asks request -- putStrLn $ "retryForm: Session read: "++(show filled) let defvals = decodePairs filled --- putStrLn $ "retryForm: defvals: "++(show defvals) +-- liftIO $ putStrLn $ "retryForm: defvals: "++(show defvals) let err = httpGetVar' rq "invalid" "" if null err then return (formToHtml $ createform form fid pairs action, "") @@ -145,7 +145,7 @@ defValidate form fid rq = else Left $ map fromLeft $ filter isLeft maybes where fields = map fromRight maybes maybes :: [Either String String] - maybes = zipWith ($) (map (\(Field _ _ _ v) -> v) (fFields form)) vars + maybes = zipWith ($) (map fValidate (fFields form)) vars vars :: [String] vars = formVarsValues form fid rq diff --git a/Framework/Modules/Auth/Controllers.hs b/Framework/Modules/Auth/Controllers.hs new file mode 100644 index 0000000..76a424e --- /dev/null +++ b/Framework/Modules/Auth/Controllers.hs @@ -0,0 +1,79 @@ +module Framework.Modules.Auth.Controllers where + +import Control.Monad.Reader.Class +import Database.HDBC +import Codec.Binary.UTF8.String +import qualified Data.Digest.SHA1 as SHA1 +import qualified Data.Map as M +import Numeric + +import Framework.Forms.Types +import Framework.API +import Framework.Utils + +import Framework.Modules.Auth.Models + +sha1 str = showHex (SHA1.toInteger $ SHA1.hash $ encode str) "" + +checkAuth' :: String + -> String + -> Form + -> HttpAction +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 + case d of + Right user -> + do send "pre_auth" user + let name = user -:> "name" + pass = user -:> "password" + objs <- querySQL' ((table model) `restrict` ("name" :==: "?")) [name] model + if length objs /= 1 + then loginFailed + else return () + let dbuser = head objs + dbpass = fromSql $ dbuser -:> "password" + if dbpass == (sha1 $ fromSql pass) + then loginSuccessed name + else loginFailed + where + loginSuccessed name = do + sessionSet "username" $ fromSql name + send "auth_ok" user + return $ redirect target + loginFailed = do + let values = tail $ urlencode $ map packParam vars + vars = formVars form "1" rq + sessionSet "filled" values + msg <- __ "Authentithication failed." + message msg + send "auth_fail" user + returnNow $ redirectG retry ["invalid" := "name password"] + + Left e -> returnInvalidForm form "1" e + +doLogout :: String + -> HttpAction +doLogout target = do + rq <- asks request + errorIf 400 "Invalid request method" $ rqMethod rq /= GET + send "logout" emptyModel + sessionUnset "username" + return $ redirect target + +checkAuth :: String + -> String + -> HttpAction +checkAuth target retry = checkAuth' target retry defaultLoginForm + +showLoginForm' :: String + -> Form + -> AController (String,String) +showLoginForm' target form = retryForm form "1" [] target + +showLoginForm :: String + -> AController (String,String) +showLoginForm target = showLoginForm' target defaultLoginForm diff --git a/Framework/Modules/Auth/Models.hs b/Framework/Modules/Auth/Models.hs new file mode 100644 index 0000000..4ccdef8 --- /dev/null +++ b/Framework/Modules/Auth/Models.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +module Framework.Modules.Auth.Models where +-- module Models where + +import Framework.Types +import Framework.Forms.Types +import Framework.Forms.HTML +import Framework.Forms.Validators +import Framework.ORM +import qualified Data.Map as M + +defaultUserModel = emptyModel { + mName = "user", + mTable = "users", + mFields = [ "uid" ::: PrimaryKey, + "name" ::: StringColumn, + "password" ::: StringColumn ] + } + +uid = show.(transformInt 1 id) +username = transformString 1 id + +defaultLoginForm = Form { + formName = "loginform", + formModel = defaultUserModel, + fFields = [ Field "name" "" inputbox (notEmpty "name"), + Field "password" "" passwordbox (notEmpty "password") ] + } + +onlyLogin = M.fromList [("loginform", defaultLoginForm)]