{-# LANGUAGE TupleSections, OverloadedStrings #-} module Handler.Signup where import Import as I import System.Random import Data.Text as T import Data.Text.Encoding import Data.ByteString as B import Data.Maybe import Network.Mail.Mime import Text.Blaze.Html.Renderer.Utf8 getSignupR :: Handler Html getSignupR = do -- (signupWidget, enctype) <- generateFormPost signupForm defaultLayout $ do $(widgetFile "signup") postSignupR :: Handler Html postSignupR = do mUserName <- lookupPostParam "username" newUserName <- case validateLen (fromJust mUserName) of True -> return $ fromJust $ mUserName False -> do setMessage "Invalid username" redirect $ SignupR mEmail <- lookupPostParam "email" mTos1 <- lookupPostParam "tos-1" mTos2 <- lookupPostParam "tos-2" case (mTos1, mTos2) of (Just "tos-1", Just "tos-2") -> return () _ -> do setMessage "You need to agree to our terms." redirect $ SignupR -- create user namesakes <- runDB $ selectList [UserName ==. newUserName] [] case namesakes of [] -> do salt <- liftIO generateSalt newUser <- return $ User newUserName (fromJust mEmail) "" salt Nothing [] activatorText <- liftIO generateString aId <- runDB $ insert $ Activator activatorText newUser tId <- runDB $ insert $ Token (encodeUtf8 activatorText) "activate" Nothing activateLink <- ($ ActivateR activatorText) <$> getUrlRender sendMail (userEmail newUser) "Please activate your account!" $ [shamlet|

Welcome to Eidolon! To complete your sgnup please activate your account by visiting the following link: #{activateLink} |] setMessage "User pending activation" redirect $ HomeR _ -> do setMessage "This user already exists" redirect $ SignupR --signupForm :: Form User --signupForm = renderDivs $ User -- <$> areq textField "Username" Nothing -- <*> areq emailField "Email" Nothing -- <*> areq passwordField "Password" Nothing -- <*> pure ("" :: ByteString) -- <*> pure [] validateLen :: Text -> Bool validateLen a = (T.length a) > 3 generateString :: IO T.Text generateString = (toHex . B.pack . I.take 16 . randoms) <$> newStdGen sendMail :: MonadIO m => Text -> Text -> Html -> m () sendMail toEmail subject body = liftIO $ renderSendMail Mail { mailFrom = Address Nothing "noreply" -- TODO: set sender Address , mailTo = [Address Nothing toEmail] , mailCc = [] , mailBcc = [] , mailHeaders = [("Subject", subject)] , mailParts = [[Part { partType = "text/html; charset=utf-8" , partEncoding = None , partFilename = Nothing , partHeaders = [] , partContent = renderHtml body }]] }