-- 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 $ getBy $ UniqueToken token -- case t of -- Nothing -> do -- setMessage "Invalid token!" -- redirect HomeR -- Just (Entity tId token) -> do -- master <- getYesod -- (Entity uId user) <- -- runDB $ getJust <$> getBy $ UniqueUser $ tokenUsername token -- let hexSalt = toHex $ userSalt user -- addWarn = "http://" `isPrefixOf` appRoot (appSettings master) -- defaultLayout $ do -- setTitle "Activate your account" -- $(widgetFile "activate") -- -- 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 $ getBy $ UniqueUser $ tokenUsername 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" .=)