eidolon/Handler/Activate.hs

89 lines
3.5 KiB
Haskell
Raw Normal View History

2014-08-12 12:42:25 +00:00
module Handler.Activate where
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
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] []
2014-08-12 12:42:25 +00:00
case t of
2014-08-13 16:16:31 +00:00
Nothing -> do
2014-09-04 01:57:01 +00:00
mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] []
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)
hexSalt <- return $ toHex $ userSalt user
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!"
redirect $ HomeR
2014-12-28 06:12:25 +00:00
Just (Entity _ activator) -> do
2014-08-24 19:42:42 +00:00
uSalt <- return $ userSalt $ activatorUser activator
mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] []
case mToken of
2014-12-28 06:12:25 +00:00
Just (Entity _ _) -> do
2014-08-24 19:42:42 +00:00
hexSalt <- return $ toHex uSalt
defaultLayout $ do
$(widgetFile "activate")
_ -> do
2014-08-26 02:37:56 +00:00
setMessage "Invalid token!"
2014-09-04 01:57:33 +00:00
redirect $ HomeR
2014-08-24 19:42:42 +00:00
postActivateR :: Text -> Handler RepJson
postActivateR token = do
msalted <- fromJust <$> lookupPostParam "salted"
salted <- return $ fromHex' $ unpack msalted
mToken <- runDB $ selectFirst [TokenToken ==. (encodeUtf8 token), TokenKind ==. "activate"] []
case mToken of
Just (Entity uTokenId uToken) -> do
2014-09-04 01:57:01 +00:00
case tokenUser uToken == Nothing of
True -> do
newUser <- runDB $ selectFirst [ActivatorToken ==. token] []
case newUser of
Just (Entity aId activ) -> do
namesakes <- runDB $ selectList [UserName ==. (userName $ activatorUser activ)] []
case namesakes == [] of
True -> do
-- 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)
welcomeLink <- ($ ProfileR uId) <$> getUrlRender
returnJson ["welcome" .= welcomeLink]
False -> do
-- cleanup
runDB $ delete aId
runDB $ delete uTokenId
returnJsonError "Somebody already activated your username. Your token has been deleted"
2014-09-04 01:57:01 +00:00
Nothing -> do
returnJsonError "Invalid token"
False -> do
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]
_ -> do
returnJsonError "Invalid activation token!"
returnJson :: (Monad m, ToJSON a, a ~ Value) =>
[(Text, a)] -> m RepJson
returnJson = return . repJson . object
returnJsonError :: Text -> Handler RepJson
returnJsonError = returnJson . (:[]) . ("error" .=)