-- 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 -- along with this program. If not, see . module Handler.Activate where import Import as I hiding (returnJson) import Data.Text import Data.Text.Encoding import Data.Maybe import System.Directory import System.FilePath import qualified Data.ByteString.Char8 as BC import Handler.Login getActivateR :: Text -> Handler Html getActivateR token = do t <- runDB $ selectFirst [ActivatorToken ==. token] [] (activateRawWidget, _) <- generateFormPost $ renderBootstrap3 BootstrapBasicForm activateForm case t of Nothing -> do mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] case mToken of Just (Entity _ uToken) -> do user <- runDB $ getJust (fromJust $ tokenUser uToken) let hexSalt = toHex $ userSalt user master <- getYesod let addWarn = "http://" `isPrefixOf` appRoot (appSettings master) defaultLayout $ do setTitle "Activate your account" $(widgetFile "activate") _ -> do setMessage "Invalid token!" redirect HomeR Just (Entity _ activator) -> do let uSalt = userSalt $ activatorUser activator mToken <- runDB $ selectFirst [TokenToken ==. encodeUtf8 token, TokenKind ==. "activate"] [] case mToken of Just (Entity _ _) -> do let hexSalt = toHex uSalt master <- getYesod let addWarn = "http://" `isPrefixOf` appRoot (appSettings master) defaultLayout $ $(widgetFile "activate") _ -> do setMessage "Invalid token!" redirect HomeR postActivateR :: Text -> Handler RepJson postActivateR token = do msalted <- fromJust <$> lookupPostParam "salted" let salted = fromHex' $ unpack msalted 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 -- 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] else do -- cleanup runDB $ delete aId runDB $ delete uTokenId returnJsonError ("Somebody already activated your username. Your token has been deleted" :: String) Nothing -> returnJsonError ("Invalid token" :: String) else do runDB $ update (fromJust $ tokenUser uToken) [UserSalted =. salted] -- cleanup runDB $ delete uTokenId setSession "userId" (extractKey $ fromJust $ tokenUser uToken) welcomeLink <- ($ ProfileR (fromJust $ tokenUser uToken)) <$> getUrlRender returnJson ["welcome" .= welcomeLink] _ -> 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 -- returnJson :: (Monad m, a ~ Value) => -- [(Text, a)] -> m RepJson -- returnJson = return . repJson . object -- returnJsonError :: Text -> Handler RepJson -- returnJsonError = returnJson . (:[]) . ("error" .=)