This commit is contained in:
nek0 2014-08-12 14:42:25 +02:00
parent d2e2ce5fc6
commit c10806fffc
9 changed files with 154 additions and 24 deletions

18
Handler/Activate.hs Normal file
View file

@ -0,0 +1,18 @@
module Handler.Activate where
import Import as I
import Data.Text as T
getActivateR :: String -> Handler Html
getActivateR token = do
t <- runDB $ selectList [TokenToken ==. (T.pack token)] []
case t of
[] -> do
setMessage $ [shamlet|<pre>Invalid Token!|]
redirect $ HomeR
[x] -> do
_ <- runDB $ insert $ tokenUser (entityVal x)
setMessage $ [shamlet|<pre>User activated|]
redirect $ HomeR
_ -> do
error "unexpected error"

9
Handler/Login.hs Normal file
View file

@ -0,0 +1,9 @@
module Handler.Login where
import Import
getLoginR :: Handler Html
getLoginR = error "Not yet implemented: getLoginR"
postLoginR :: Handler Html
postLoginR = error "Not yet implemented: postLoginR"

71
Handler/Signup.hs Normal file
View file

@ -0,0 +1,71 @@
{-# LANGUAGE TupleSections, OverloadedStrings #-}
module Handler.Signup where
import Import as I
import System.Random
import Data.Text as T
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
((result, signupWidget), enctype) <- runFormPost signupForm
case result of
FormSuccess user -> do
namesakes <- runDB $ selectList [UserName ==. (userName user)] []
case (validateLen (userName user)) && ((I.length namesakes) == 0) of
True -> do
tokenString <- liftIO generateString
uId <- runDB $ insert $ Token tokenString user
activateLink <- ($ ActivateR $ T.unpack tokenString) <$> getUrlRender
sendMail (userEmail user) "Please activate your account!" $
[shamlet|
<h1> Welcome to Eidolon!
To complete your sgnup please activate your account by visiting the following link
<a href="#{activateLink}">#{activateLink}</a>
|]
setMessage $ [shamlet|<pre>User created|]
redirect $ HomeR
False -> do
setMessage $ [shamlet|<pre>Username error|]
redirect $ SignupR
_ -> do
setMessage $ [shamlet|<pre>Please try again|]
redirect $ SignupR
signupForm :: Form User
signupForm = renderDivs $ User
<$> areq textField "Username" Nothing
<*> areq emailField "Email" Nothing
<*> areq passwordField "Password" Nothing
validateLen :: Text -> Bool
validateLen a =
(T.length a) > 3
generateString :: IO Text
generateString = (T.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
}]]
}

View file

@ -4,6 +4,8 @@ import Yesod
import Data.Text (Text)
import Database.Persist.Quasi
import Data.Typeable (Typeable)
import Data.Time (UTCTime)
import System.FilePath (FilePath)
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities

View file

@ -44,32 +44,38 @@ library
NoMonomorphismRestriction
DeriveDataTypeable
build-depends: base >= 4 && < 5
, yesod >= 1.2.5 && < 1.3
, yesod-core >= 1.2.12 && < 1.3
, yesod-auth >= 1.3 && < 1.4
, yesod-static >= 1.2 && < 1.3
, yesod-form >= 1.3 && < 1.4
, bytestring >= 0.9 && < 0.11
, text >= 0.11 && < 2.0
, persistent >= 1.3 && < 1.4
, persistent-sqlite >= 1.3 && < 1.4
, persistent-template >= 1.3 && < 1.4
build-depends: base >= 4
, yesod >= 1.2.5
, yesod-core >= 1.2.12
, yesod-auth >= 1.3
, yesod-static >= 1.2
, yesod-form >= 1.3
, bytestring >= 0.9
, text >= 0.11
, persistent >= 1.3
, persistent-sqlite >= 1.3
, persistent-template >= 1.3
, template-haskell
, shakespeare >= 2.0 && < 2.1
, hjsmin >= 0.1 && < 0.2
, monad-control >= 0.3 && < 0.4
, wai-extra >= 3.0 && < 3.1
, yaml >= 0.8 && < 0.9
, http-conduit >= 2.1 && < 2.2
, directory >= 1.1 && < 1.3
, warp >= 3.0 && < 3.1
, shakespeare >= 2.0
, hjsmin >= 0.1
, monad-control >= 0.3
, wai-extra >= 3.0
, yaml >= 0.8
, http-conduit >= 2.1
, directory >= 1.1
, warp >= 3.0
, data-default
, aeson >= 0.6 && < 0.8
, conduit >= 1.0 && < 2.0
, monad-logger >= 0.3 && < 0.4
, fast-logger >= 2.1.4 && < 2.2
, wai-logger >= 2.1 && < 2.2
, aeson >= 0.6
, conduit >= 1.0
, monad-logger >= 0.3
, fast-logger >= 2.1.4
, wai-logger >= 2.1
-- custom dependencies
, random
, mime-mail
, blaze-html
, filepath
, time
executable eidolon
if flag(library-only)

View file

@ -0,0 +1 @@
document.getElementById("hident4").innerHTML="This text was added by the Javascript part of the homepage widget."

View file

@ -0,0 +1,8 @@
h1 {
text-align: center
;
}
h2#hident4 {
color: #990
;
}

9
templates/home.hamlet Normal file
View file

@ -0,0 +1,9 @@
<a href=@{LoginR}>Login
<a href=@{SignupR}>Signup
$if null recentMedia
<p>This gallery is still empty.
$else
$forall (Entity mediaId medium) <- recentMedia
<div class="thumbnails">
<div class="single">

6
templates/signup.hamlet Normal file
View file

@ -0,0 +1,6 @@
<h3>Signup
<form method=post enctype=#{enctype}>
^{signupWidget}
<div>
<input type=submit value="Register">