eidolon/Handler/Signup.hs

94 lines
3.2 KiB
Haskell
Raw Normal View History

2015-01-18 19:44:41 +00:00
-- eidolon -- A simple gallery in Haskell and Yesod
-- Copyright (C) 2015 Amedeo Molnár
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as published
-- by the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
2015-01-21 09:00:18 +00:00
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
2015-01-18 19:44:41 +00:00
2014-08-12 12:42:25 +00:00
{-# LANGUAGE TupleSections, OverloadedStrings #-}
module Handler.Signup where
import Import as I
import Data.Text as T
2014-08-24 19:42:42 +00:00
import Data.Text.Encoding
import Data.Maybe
2014-08-12 12:42:25 +00:00
getSignupR :: Handler Html
getSignupR = do
master <- getYesod
block <- return $ appSignupBlocked $ appSettings master
2014-12-08 14:47:19 +00:00
case block of
False -> do
formLayout $ do
2015-04-04 08:34:19 +00:00
master <- getYesod
2014-12-08 14:47:19 +00:00
setTitle "Eidolon :: Signup"
$(widgetFile "signup")
True -> do
setMessage "User signup has been disabled"
redirect $ HomeR
2014-08-12 12:42:25 +00:00
postSignupR :: Handler Html
postSignupR = do
master <- getYesod
block <- return $ appSignupBlocked $ appSettings master
2014-12-08 14:47:19 +00:00
case block of
2014-08-24 19:42:42 +00:00
False -> do
2014-12-08 14:47:19 +00:00
mUserName <- lookupPostParam "username"
newUserName <- case validateLen (fromJust mUserName) of
True -> return $ fromJust $ mUserName
False -> do
setMessage "Invalid username"
redirect $ SignupR
mEmail <- lookupPostParam "email"
mTos1 <- lookupPostParam "tos-1"
mTos2 <- lookupPostParam "tos-2"
case (mTos1, mTos2) of
(Just "tos-1", Just "tos-2") ->
return ()
_ -> do
setMessage "You need to agree to our terms."
redirect $ SignupR
-- create user
namesakes <- runDB $ selectList [UserName ==. newUserName] []
case namesakes of
[] -> do
salt <- liftIO generateSalt
newUser <- return $ User newUserName
newUserName
(fromJust mEmail)
salt
""
[]
False
activatorText <- liftIO generateString
2014-12-28 06:12:25 +00:00
_ <- runDB $ insert $ Activator activatorText newUser
_ <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing
2014-12-08 14:47:19 +00:00
activateLink <- ($ ActivateR activatorText) <$> getUrlRender
sendMail (userEmail newUser) "Please activate your account!" $
[shamlet|
<h1>Hello #{userSlug newUser} and Welcome to Eidolon!
2014-12-19 21:00:37 +00:00
To complete your signup please activate your account by visiting the following link:
2014-12-08 14:47:19 +00:00
<a href="#{activateLink}">#{activateLink}
|]
setMessage "User pending activation"
redirect $ HomeR
_ -> do
setMessage "This user already exists"
redirect $ SignupR
True -> do
setMessage "User signup is disabled"
2014-08-24 19:42:42 +00:00
redirect $ HomeR
2014-08-12 12:42:25 +00:00
validateLen :: Text -> Bool
validateLen a =
2015-01-17 13:31:42 +00:00
(T.length a) > 2