eidolon/Handler/Activate.hs

205 lines
8.8 KiB
Haskell
Raw Permalink 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
2017-04-24 05:46:34 +00:00
-- 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
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" .=)