diff --git a/Blog/Blog.hs b/Blog/Blog.hs index e53a19e..238b5ec 100644 --- a/Blog/Blog.hs +++ b/Blog/Blog.hs @@ -9,6 +9,7 @@ import Framework.Utils import Framework.Modules.Auth.Controllers import Framework.Modules.Auth.Utils import Framework.Modules.TextCaptcha.FormProcessors +import Framework.Modules.Registration.Forms import Models @@ -19,6 +20,7 @@ urlconf = "blog" // "new" --> newpost <|> "blog" --> allposts <|> "login" --> login <|> "logout" --> (doLogout "/blog/") + <|> "register" --> registration <|> "form" --> testform <|> "i18n" --> i18ntest <|> RawFunction serveStatic @@ -28,6 +30,17 @@ login = do loginPage "/blog" "/login" renderToResponseM "login.html" [] +registration :: HttpAction +registration = do + rq <- asks request + case rqMethod rq of + GET -> do + (form,err) <- showRegistrationForm "/register" + return $ renderToResponse "register.html" [("form", C form), + ("invalid", C err)] + POST -> do + doRegister "/blog" + testform :: HttpAction testform = do rq <- asks request diff --git a/Blog/blog.conf b/Blog/blog.conf index 860be9d..365921c 100644 --- a/Blog/blog.conf +++ b/Blog/blog.conf @@ -5,7 +5,7 @@ port = 8080 staticdir = static/ [database] -path = host=rtfm-server password=31415 +path = host=localhost password=31415 [cache] backend = filesystem diff --git a/Blog/blog.sql b/Blog/blog.sql index ec0679f..bf6502c 100644 --- a/Blog/blog.sql +++ b/Blog/blog.sql @@ -53,7 +53,7 @@ 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); +SELECT pg_catalog.setval('comments_id_seq', 13, true); -- @@ -94,7 +94,7 @@ 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); +SELECT pg_catalog.setval('posts_id_seq', 9, true); -- @@ -138,6 +138,46 @@ SELECT pg_catalog.setval('test_id_seq', 1, true); -- +-- Name: users; Type: TABLE; Schema: public; Owner: portnov; Tablespace: +-- + +CREATE TABLE users ( + uid integer NOT NULL, + name character varying(32), + password character varying(42) +); + + +ALTER TABLE public.users OWNER TO portnov; + +-- +-- Name: users_uid_seq; Type: SEQUENCE; Schema: public; Owner: portnov +-- + +CREATE SEQUENCE users_uid_seq + INCREMENT BY 1 + NO MAXVALUE + NO MINVALUE + CACHE 1; + + +ALTER TABLE public.users_uid_seq OWNER TO portnov; + +-- +-- Name: users_uid_seq; Type: SEQUENCE OWNED BY; Schema: public; Owner: portnov +-- + +ALTER SEQUENCE users_uid_seq OWNED BY users.uid; + + +-- +-- Name: users_uid_seq; Type: SEQUENCE SET; Schema: public; Owner: portnov +-- + +SELECT pg_catalog.setval('users_uid_seq', 1, true); + + +-- -- Name: id; Type: DEFAULT; Schema: public; Owner: portnov -- @@ -159,6 +199,13 @@ ALTER TABLE test ALTER COLUMN id SET DEFAULT nextval('test_id_seq'::regclass); -- +-- Name: uid; Type: DEFAULT; Schema: public; Owner: portnov +-- + +ALTER TABLE users ALTER COLUMN uid SET DEFAULT nextval('users_uid_seq'::regclass); + + +-- -- Data for Name: comments; Type: TABLE DATA; Schema: public; Owner: portnov -- @@ -176,19 +223,6 @@ COPY comments (id, pid, dt, author, body) FROM stdin; 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 \. @@ -197,16 +231,15 @@ COPY comments (id, pid, dt, author, body) FROM stdin; -- COPY posts (id, dt, title, body) FROM stdin; +1 2009-06-19 First post First post\r\nQQQ 3 2009-06-19 Абракадабра Тут была абракадабра +4 2009-06-17 пост русские буквы 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 +5 2009-06-17 Заголовок Такой пост. *тест*\r\n\r\nParagraph \. @@ -220,6 +253,15 @@ COPY test (id, name, value) FROM stdin; -- +-- Data for Name: users; Type: TABLE DATA; Schema: public; Owner: portnov +-- + +COPY users (uid, name, password) FROM stdin; +1 portnov 23ec8fc8f2af38dd90d8defb3b54d163dcfb5ffa +\. + + +-- -- Name: comments_pkey; Type: CONSTRAINT; Schema: public; Owner: portnov; Tablespace: -- @@ -244,6 +286,14 @@ ALTER TABLE ONLY test -- +-- Name: users_pkey; Type: CONSTRAINT; Schema: public; Owner: portnov; Tablespace: +-- + +ALTER TABLE ONLY users + ADD CONSTRAINT users_pkey PRIMARY KEY (uid); + + +-- -- Name: public; Type: ACL; Schema: -; Owner: postgres -- diff --git a/Blog/templates/register.html b/Blog/templates/register.html new file mode 100644 index 0000000..af00789 --- /dev/null +++ b/Blog/templates/register.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>Registration</title> + <meta name='author' content='Portnov'> + </head> + <body> + <h1>Register</h1> + {%if message%} + <p>{{message}} </p> + {%endif%} + + {{form}} + + </body> +</html> diff --git a/Framework/API/Sessions.hs b/Framework/API/Sessions.hs index 08dfdec..06911b5 100644 --- a/Framework/API/Sessions.hs +++ b/Framework/API/Sessions.hs @@ -31,5 +31,6 @@ sessionUnset :: String -> Controller ActionConfig r () sessionUnset name = do ac <- get let m' = M.delete name $ sessionMap ac + liftIO $ sPush (sessionsBackend ac) (sessionID ac) m' put $ ac {sessionMap = m'} diff --git a/Framework/Modules/Auth/Controllers.hs b/Framework/Modules/Auth/Controllers.hs index ba04d49..4a1a23e 100644 --- a/Framework/Modules/Auth/Controllers.hs +++ b/Framework/Modules/Auth/Controllers.hs @@ -2,19 +2,15 @@ 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.SHA1 import Framework.Modules.Auth.Models -sha1 str = showHex (SHA1.toInteger $ SHA1.hash $ encode str) "" - -- | Check user name and password. checkAuth' :: String -- ^ Where to redirect if login ok -> String -- ^ Where to redirect if login failed @@ -22,7 +18,7 @@ checkAuth' :: String -- ^ Where to redirect if login ok -> HttpAction checkAuth' target retry form = do rq <- asks request - errorIf 400 "Invalid request method" $ rqMethod rq /= POST + methodOnly POST let model = formModel form (d,_) = getForm form rq $ formName form case d of @@ -85,8 +81,7 @@ loginPage target retry = do doLogout :: String -- ^ Where to redirect after logout -> HttpAction doLogout target = do - rq <- asks request - errorIf 400 "Invalid request method" $ rqMethod rq /= GET + methodOnly GET send "logout" emptyModel sessionUnset "username" return $ redirect target diff --git a/Framework/Modules/Registration/Forms.hs b/Framework/Modules/Registration/Forms.hs index 2bb4800..6a4b2f2 100644 --- a/Framework/Modules/Registration/Forms.hs +++ b/Framework/Modules/Registration/Forms.hs @@ -1,12 +1,26 @@ {-# LANGUAGE TypeFamilies #-} module Framework.Modules.Registration.Forms where +import Control.Monad.Reader.Class +import Database.HDBC (SqlValue (..), fromSql) +import Network.HTTP + +import Framework.Types +import Framework.Controller +import Framework.Exceptions import Framework.ORM +import Framework.Signals import Framework.Forms.Types import Framework.Forms.Validators import Framework.Forms.Validation import Framework.Forms.HTML import Framework.Http.Vars +import Framework.Http.Response +import Framework.API.SQL +import Framework.API.Storage +import Framework.API.SQLUtils +import Framework.Modules.Auth.Models +import Framework.Modules.SHA1 data TwoPasswordBoxes = TwoPasswordBoxes {tpWidth :: Maybe Int} @@ -28,21 +42,36 @@ validatePasswords rq name str = where str' = httpPostVar' rq (name++"check") "" -registrationModel = emptyModel { - mName = "register", - mFields = [ - "name" ::: StringColumn, - "password" ::: StringColumn ] - } - registrationForm = Form { formName = "register", - formModel = registrationModel, + formModel = defaultUserModel, fFields = [ Field "name" "Name" inputbox notEmpty, Field "password" "Password" twoPasswordBoxes validatePasswords ] } +showRegistrationForm' :: Form-> String-> Controller ActionConfig r (String, String) showRegistrationForm' form target = retryForm form "1" [] target -showRegistrationForm target = showRegistrationForm registrationForm +showRegistrationForm :: String-> Controller ActionConfig r (String, String) +showRegistrationForm target = showRegistrationForm' registrationForm target + +doRegister' :: Form -> String -> AController a +doRegister' form target = do + rq <- asks request + methodOnly POST + let model = formModel form + (d,_) = getForm form rq $ formName form + case d of + Right user -> do + send "pre_register" user + let name = user -:> "name" + pass = user -:> "password" + pass' = SqlString $ sha1 $ fromSql pass + queryListSQL (insertM model) $ [name,pass'] + commit + returnNow $ redirect target + Left e -> returnInvalidForm form "1" e + +doRegister :: String -> AController a +doRegister = doRegister' registrationForm diff --git a/Framework/Modules/SHA1.hs b/Framework/Modules/SHA1.hs new file mode 100644 index 0000000..ef1a77d --- /dev/null +++ b/Framework/Modules/SHA1.hs @@ -0,0 +1,8 @@ +module Framework.Modules.SHA1 where + +import Codec.Binary.UTF8.String +import qualified Data.Digest.SHA1 as SHA1 +import Numeric + +sha1 str = showHex (SHA1.toInteger $ SHA1.hash $ encode str) "" + diff --git a/Framework/ORM/SQL.hs b/Framework/ORM/SQL.hs index 84f295b..b3f48f6 100644 --- a/Framework/ORM/SQL.hs +++ b/Framework/ORM/SQL.hs @@ -96,7 +96,7 @@ table m = Query allFields (TableList [mTable m]) NoCondition (defaultOrdering m) insertM :: Model -> Query insertM m = InsertQuery (mTable m) (map fieldName insfields) temps where insfields = filter notid $ mFields m - notid s = not ("id" == (fieldName s)) + notid s = not $ fieldType s == PrimaryKey temps = map (\f -> if (fieldType f)==CurrentDateColumn then "current_timestamp" else "?") insfields