eidolon/Handler/Activate.hs

190 lines
7.8 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 20:25:49 +00:00
module Handler.Activate where
2014-08-12 12:42:25 +00:00
2014-08-24 19:42:42 +00:00
import Import as I hiding (returnJson)
2014-08-14 00:24:28 +00:00
import Data.Text
2014-08-24 19:42:42 +00:00
import Data.Text.Encoding
import Data.Maybe
2014-08-14 00:24:28 +00:00
import System.Directory
import System.FilePath
2014-08-12 12:42:25 +00:00
import qualified Data.ByteString.Char8 as BC
import Handler.Login
getActivateR :: Text -> Handler Html
2014-08-12 12:42:25 +00:00
getActivateR token = do
2014-08-24 19:42:42 +00:00
t <- runDB $ selectFirst [ActivatorToken ==. token] []
(activateRawWidget, _) <- generateFormPost $
renderBootstrap3 BootstrapBasicForm activateForm
2014-08-12 12:42:25 +00:00
case t of
2014-08-13 16:16:31 +00:00
Nothing -> do
2015-09-14 16:54:46 +00:00
mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
2014-09-04 01:57:01 +00:00
case mToken of
2014-12-28 06:12:25 +00:00
Just (Entity _ uToken) -> do
2014-09-04 01:57:01 +00:00
user <- runDB $ getJust (fromJust $ tokenUser uToken)
2015-09-14 16:54:46 +00:00
let hexSalt = toHex $ userSalt user
master <- getYesod
let addWarn = "http://" `isPrefixOf` appRoot (appSettings master)
2016-09-07 15:32:56 +00:00
defaultLayout $ do
2014-09-24 21:03:18 +00:00
setTitle "Activate your account"
2014-09-04 01:57:01 +00:00
$(widgetFile "activate")
_ -> do
setMessage "Invalid token!"
2015-09-14 16:54:46 +00:00
redirect HomeR
2014-12-28 06:12:25 +00:00
Just (Entity _ activator) -> do
2015-09-14 16:54:46 +00:00
let uSalt = userSalt $ activatorUser activator
mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
2014-08-24 19:42:42 +00:00
case mToken of
2014-12-28 06:12:25 +00:00
Just (Entity _ _) -> do
2015-09-14 16:54:46 +00:00
let hexSalt = toHex uSalt
master <- getYesod
let addWarn = "http://" `isPrefixOf` appRoot (appSettings master)
2016-09-07 15:32:56 +00:00
defaultLayout $
2014-08-24 19:42:42 +00:00
$(widgetFile "activate")
_ -> do
2014-08-26 02:37:56 +00:00
setMessage "Invalid token!"
2015-09-14 16:54:46 +00:00
redirect HomeR
2014-08-24 19:42:42 +00:00
postActivateR :: Text -> Handler RepJson
postActivateR token = do
msalted <- fromJust <$> lookupPostParam "salted"
2015-09-14 16:54:46 +00:00
let salted = fromHex' $ unpack msalted
mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
2014-08-24 19:42:42 +00:00
case mToken of
2015-09-14 16:54:46 +00:00
Just (Entity uTokenId uToken) ->
if
isNothing (tokenUser uToken)
then do
2014-09-04 01:57:01 +00:00
newUser <- runDB $ selectFirst [ActivatorToken ==. token] []
case newUser of
Just (Entity aId activ) -> do
2015-09-14 16:54:46 +00:00
namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] []
if
I.null namesakes
then do
-- putting user in active state
uId <- runDB $ insert $ activatorUser activ
runDB $ update uId [UserSalted =. salted]
-- create user directory
liftIO $ createDirectoryIfMissing True $
2015-09-14 16:54:46 +00:00
"static" </> "data" </> unpack (extractKey uId)
-- cleanup
runDB $ delete aId
runDB $ delete uTokenId
-- login and redirect
setSession "userId" (extractKey uId)
welcomeLink <- ($ ProfileR uId) <$> getUrlRender
returnJson ["welcome" .= welcomeLink]
2015-09-14 16:54:46 +00:00
else do
-- cleanup
runDB $ delete aId
runDB $ delete uTokenId
returnJsonError ("Somebody already activated your username. Your token has been deleted" :: String)
2015-09-14 16:54:46 +00:00
Nothing ->
returnJsonError ("Invalid token" :: String)
2015-09-14 16:54:46 +00:00
else do
2014-09-04 01:57:01 +00:00
runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted]
2014-08-24 19:42:42 +00:00
-- cleanup
runDB $ delete uTokenId
2014-09-04 01:57:01 +00:00
setSession "userId" (extractKey $ fromJust $ tokenUser uToken)
welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender
2014-08-24 19:42:42 +00:00
returnJson ["welcome" .= welcomeLink]
2015-09-14 16:54:46 +00:00
_ ->
returnJsonError ("Invalid activation token!" :: String)
data ActivateFormRes = ActivateFormRes
{ pass1 :: Text
, pass2 :: Text
}
activateForm :: AForm Handler ActivateFormRes
activateForm = ActivateFormRes
<$> areq passwordField (bfs ("Password" :: Text)) Nothing
<*> areq passwordField (bfs ("Repeat Password" :: Text)) Nothing
<* bootstrapSubmit ("Activate" :: BootstrapSubmit Text)
postActivateRawR :: Text -> Handler Html
postActivateRawR token = do
((res, _), _) <- runFormPost $
renderBootstrap3 BootstrapBasicForm activateForm
case res of
FormSuccess pwd -> do
if pass1 pwd == pass2 pwd
then do
mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] []
case mToken of
Just (Entity uTokenId uToken) ->
if
isNothing (tokenUser uToken)
then do
newUser <- runDB $ selectFirst [ActivatorToken ==. token] []
case newUser of
Just (Entity aId activ) -> do
namesakes <- runDB $ selectList [UserName ==. userName (activatorUser activ)] []
if
I.null namesakes
then do
let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt $ activatorUser activ) (encodeUtf8 $ pass1 pwd)
-- putting user in active state
uId <- runDB $ insert $ activatorUser activ
runDB $ update uId [UserSalted =. salted]
-- create user directory
liftIO $ createDirectoryIfMissing True $
"static" </> "data" </> unpack (extractKey uId)
-- cleanup
runDB $ delete aId
runDB $ delete uTokenId
-- login and redirect
setSession "userId" (extractKey uId)
setMessage "Successfully activated"
redirect $ ProfileR uId
else do
-- cleanup
runDB $ delete aId
runDB $ delete uTokenId
setMessage "Somebody already activated your username. Your token has been deleted"
redirect HomeR
Nothing -> do
setMessage "Invalid token"
redirect HomeR
else do
uuser <- runDB $ getJust $ fromJust $ tokenUser uToken
let salted = fromHex' $ BC.unpack $ hmacKeccak (userSalt uuser) (encodeUtf8 $ pass1 pwd)
runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted]
-- cleanup
runDB $ delete uTokenId
setSession "userId" (extractKey $ fromJust $ tokenUser uToken)
setMessage "Successfully activated"
redirect $ ProfileR (fromJust $ tokenUser uToken)
Nothing -> do
setMessage "Invalid activation token!"
redirect HomeR
else do
setMessage "Passwords must match!"
redirect $ ActivateR token
_ -> do
setMessage "Activation error"
redirect HomeR
2014-08-24 19:42:42 +00:00
-- returnJson :: (Monad m, a ~ Value) =>
-- [(Text, a)] -> m RepJson
-- returnJson = return . repJson . object
2014-08-24 19:42:42 +00:00
-- returnJsonError :: Text -> Handler RepJson
-- returnJsonError = returnJson . (:[]) . ("error" .=)