<commit_before>-- Copyright 2008, 2009, 2010, 2011 <NAME>

-- This file is part of Vocabulink.

-- Vocabulink 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.

-- Vocabulink 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 Vocabulink. If not, see <http://www.gnu.org/licenses/>.

-- To register a new member we need their desired username, a password, and
-- optionally an email address.

module Vocabulink.Member.Registration ( usernameAvailable, emailAvailable
                                      , signup, confirmEmail, resendConfirmEmail
                                      , login, logout
                                      , sendPasswordReset, passwordResetPage, passwordReset
                                      ) where

import Vocabulink.App
import Vocabulink.CGI
import Vocabulink.Html
import Vocabulink.Member
import Vocabulink.Member.Auth
import Vocabulink.Page
import Vocabulink.Utils

import Prelude hiding (div, id, span)

-- Once a user registers, they can log in. However, they won't be able to use
-- most member-specific functions until they've confirmed their email address.
-- This is to make sure that people cannot impersonate or spam others.

-- Email confirmation consists of generating a unique random string and
-- emailing it to the member as a hyperlink. Once they click the hyperlink we
-- consider the email address confirmed.

signup :: App CGIResult
signup = do
  member <- asks appMember
  case member of
    Just _  -> error "You're already logged in."
    _       -> do
      username' <- getRequiredInput "username"
      email'    <- getRequiredInput "email"
      password' <- getRequiredInput "password"
      terms'    <- getInput "terms"
      userAvail <- usernameAvailable username'
      emailAvail <- emailAvailable email'
      when (not userAvail) $ error "The username you chose is unavailable or invalid."
      when (not emailAvail) $ error "The email address you gave is unavailable or invalid."
      when (isNothing terms') $ error "You must accept the Terms of Use."
      memberNo <- withConnection $ \c -> do
        withTransaction c $ do
          memberNo' <- fromJust <$> $(queryTuple
                                      "INSERT INTO member (username, password_hash) \
                                      \VALUES ({username'}, crypt({password'}, gen_salt('bf'))) \
                                      \RETURNING member_no") c
          hash <- fromJust <$> $(queryTuple
                                 "INSERT INTO member_confirmation (member_no, hash, email) \
                                 \VALUES ({memberNo'}, md5(random()::text), {email'}) \
                                 \RETURNING hash") c
          res <- liftIO $ sendConfirmationEmail email' username' hash
          maybe (rollback c >> return Nothing)
                (\_ -> do $(execute "UPDATE member_confirmation \
                                    \SET email_sent = current_timestamp \
                                    \WHERE member_no = {memberNo'}") c
                          return (Just memberNo')) res
      case memberNo of
        Just mn -> do ip <- remoteAddr
                      key <- fromJust <$> getOption "authtokenkey"
                      authTok <- liftIO $ authToken mn username' ip key
                      setAuthCookie authTok
                      redirect "http://www.vocabulink.com/?signedup"
        Nothing -> error "Registration failure (this is not your fault). Please try again later."

sendConfirmationEmail :: String -> String -> String -> IO (Maybe ())
sendConfirmationEmail email username hash =
  let body = unlines ["Welcome to Vocabulink, " ++ username ++ "."
                     ,""
                     ,"Please click http://www.vocabulink.com/member/confirmation/" ++
                      hash ++ " to confirm your email address."
                     ] in
  sendMail email "Please confirm your email address." body

resendConfirmEmail :: App CGIResult
resendConfirmEmail = do
  member <- asks appMember
  case member of
    Nothing -> do
      simplePage "Please Login to Resend Your Confirmation Email" mempty $ do
        script ! type_ "text/javascript" $ preEscapedString "jQuery(function () {V.loginPopup();});"
    Just m  -> do
      (hash, email) <- fromJust <$> $(queryTuple'
                         "SELECT hash, email FROM member_confirmation \
                         \WHERE member_no = {memberNumber m}")
      res <- liftIO $ sendConfirmationEmail email (memberName m) hash
      case res of
        Nothing -> error "Error sending confirmation email."
        Just _  -> simplePage "Your confirmation email has been sent." mempty mempty

-- To login a member, simply set their auth cookie. Reloading the page and such
-- is handled by the client.

login :: App CGIResult
login = do
  username' <- getRequiredInput "username"
  password' <- getRequiredInput "password"
  match <- $(queryTuple' "SELECT password_hash = crypt({password'}, password_hash) \
                         \FROM member WHERE username = {username'}")
  case match of
    Just (Just True) -> do
      ip      <- remoteAddr
      member' <- memberByName username'
      case member' of
        Nothing     -> error "Failed to lookup username."
        Just member -> do
          key <- fromJust <$> getOption "authtokenkey"
          authTok <- liftIO $ authToken (memberNumber member) username' ip key
          setAuthCookie authTok
          redirect =<< referrerOrVocabulink
    _         -> redirect "http://www.vocabulink.com/?badlogin" -- error "Username and password do not match (or don't exist)."

-- To logout a member, we simply clear their auth cookie and redirect them
-- to the front page.<commit_msg>Redirect to referring page on bad login.<commit_after>-- Copyright 2008, 2009, 2010, 2011 <NAME>

-- This file is part of Vocabulink.

-- Vocabulink 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.

-- Vocabulink 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 Vocabulink. If not, see <http://www.gnu.org/licenses/>.

-- To register a new member we need their desired username, a password, and
-- optionally an email address.

module Vocabulink.Member.Registration ( usernameAvailable, emailAvailable
                                      , signup, confirmEmail, resendConfirmEmail
                                      , login, logout
                                      , sendPasswordReset, passwordResetPage, passwordReset
                                      ) where

import Vocabulink.App
import Vocabulink.CGI
import Vocabulink.Html
import Vocabulink.Member
import Vocabulink.Member.Auth
import Vocabulink.Page
import Vocabulink.Utils

import Prelude hiding (div, id, span)
import Network.URI (parseURI, query)

-- Once a user registers, they can log in. However, they won't be able to use
-- most member-specific functions until they've confirmed their email address.
-- This is to make sure that people cannot impersonate or spam others.

-- Email confirmation consists of generating a unique random string and
-- emailing it to the member as a hyperlink. Once they click the hyperlink we
-- consider the email address confirmed.

signup :: App CGIResult
signup = do
  member <- asks appMember
  case member of
    Just _  -> error "You're already logged in."
    _       -> do
      username' <- getRequiredInput "username"
      email'    <- getRequiredInput "email"
      password' <- getRequiredInput "password"
      terms'    <- getInput "terms"
      userAvail <- usernameAvailable username'
      emailAvail <- emailAvailable email'
      when (not userAvail) $ error "The username you chose is unavailable or invalid."
      when (not emailAvail) $ error "The email address you gave is unavailable or invalid."
      when (isNothing terms') $ error "You must accept the Terms of Use."
      memberNo <- withConnection $ \c -> do
        withTransaction c $ do
          memberNo' <- fromJust <$> $(queryTuple
                                      "INSERT INTO member (username, password_hash) \
                                      \VALUES ({username'}, crypt({password'}, gen_salt('bf'))) \
                                      \RETURNING member_no") c
          hash <- fromJust <$> $(queryTuple
                                 "INSERT INTO member_confirmation (member_no, hash, email) \
                                 \VALUES ({memberNo'}, md5(random()::text), {email'}) \
                                 \RETURNING hash") c
          res <- liftIO $ sendConfirmationEmail email' username' hash
          maybe (rollback c >> return Nothing)
                (\_ -> do $(execute "UPDATE member_confirmation \
                                    \SET email_sent = current_timestamp \
                                    \WHERE member_no = {memberNo'}") c
                          return (Just memberNo')) res
      case memberNo of
        Just mn -> do ip <- remoteAddr
                      key <- fromJust <$> getOption "authtokenkey"
                      authTok <- liftIO $ authToken mn username' ip key
                      setAuthCookie authTok
                      redirect "http://www.vocabulink.com/?signedup"
        Nothing -> error "Registration failure (this is not your fault). Please try again later."

sendConfirmationEmail :: String -> String -> String -> IO (Maybe ())
sendConfirmationEmail email username hash =
  let body = unlines ["Welcome to Vocabulink, " ++ username ++ "."
                     ,""
                     ,"Please click http://www.vocabulink.com/member/confirmation/" ++
                      hash ++ " to confirm your email address."
                     ] in
  sendMail email "Please confirm your email address." body

resendConfirmEmail :: App CGIResult
resendConfirmEmail = do
  member <- asks appMember
  case member of
    Nothing -> do
      simplePage "Please Login to Resend Your Confirmation Email" mempty $ do
        script ! type_ "text/javascript" $ preEscapedString "jQuery(function () {V.loginPopup();});"
    Just m  -> do
      (hash, email) <- fromJust <$> $(queryTuple'
                         "SELECT hash, email FROM member_confirmation \
                         \WHERE member_no = {memberNumber m}")
      res <- liftIO $ sendConfirmationEmail email (memberName m) hash
      case res of
        Nothing -> error "Error sending confirmation email."
        Just _  -> simplePage "Your confirmation email has been sent." mempty mempty

-- To login a member, simply set their auth cookie. Reloading the page and such
-- is handled by the client.

login :: App CGIResult
login = do
  username' <- getRequiredInput "username"
  password' <- getRequiredInput "password"
  match <- $(queryTuple' "SELECT password_hash = crypt({password'}, password_hash) \
                         \FROM member WHERE username = {username'}")
  case match of
    Just (Just True) -> do
      ip      <- remoteAddr
      member' <- memberByName username'
      case member' of
        Nothing     -> error "Failed to lookup username."
        Just member -> do
          key <- fromJust <$> getOption "authtokenkey"
          authTok <- liftIO $ authToken (memberNumber member) username' ip key
          setAuthCookie authTok
          redirect =<< referrerOrVocabulink
    _         -> do -- error "Username and password do not match (or don't exist)."
      uri' <- parseURI <$> referrerOrVocabulink
      case uri' of
        Just uri -> let query' = case query uri of
                                   "" -> "?badlogin"
                                   q' -> "?" ++ q' ++ "&badlogin" in
                    redirect $ show $ uri {uriQuery = query'}
        Nothing  -> redirect "http://www.vocabulink.com/?badlogin"

-- To logout a member, we simply clear their auth cookie and redirect them
-- to the front page.
{'fraction_non_alphanumeric': 0.08531512440153834, 'fraction_numerical': 0.0028255238992229807, 'mean_word_length': 2.071101470233791, 'pattern_counts': {'":': 0, '<': 71, '<?xml version=': 0, '>': 60, 'https://': 0, 'lorem ipsum': 0, 'www.': 8, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 28, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '914520', 'n_tokens_mistral': 3254, 'n_tokens_neox': 3095, 'n_words': 1267}