eidolon/Handler/Activate.hs

--  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 <http://www.gnu.org/licenses/>.
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" .=)