stuff
This commit is contained in:
parent
d2e2ce5fc6
commit
c10806fffc
9 changed files with 154 additions and 24 deletions
18
Handler/Activate.hs
Normal file
18
Handler/Activate.hs
Normal 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
9
Handler/Login.hs
Normal 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
71
Handler/Signup.hs
Normal 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
|
||||||
|
}]]
|
||||||
|
}
|
2
Model.hs
2
Model.hs
|
@ -4,6 +4,8 @@ import Yesod
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Database.Persist.Quasi
|
import Database.Persist.Quasi
|
||||||
import Data.Typeable (Typeable)
|
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 define all of your database entities in the entities file.
|
||||||
-- You can find more information on persistent and how to declare entities
|
-- You can find more information on persistent and how to declare entities
|
||||||
|
|
|
@ -44,32 +44,38 @@ library
|
||||||
NoMonomorphismRestriction
|
NoMonomorphismRestriction
|
||||||
DeriveDataTypeable
|
DeriveDataTypeable
|
||||||
|
|
||||||
build-depends: base >= 4 && < 5
|
build-depends: base >= 4
|
||||||
, yesod >= 1.2.5 && < 1.3
|
, yesod >= 1.2.5
|
||||||
, yesod-core >= 1.2.12 && < 1.3
|
, yesod-core >= 1.2.12
|
||||||
, yesod-auth >= 1.3 && < 1.4
|
, yesod-auth >= 1.3
|
||||||
, yesod-static >= 1.2 && < 1.3
|
, yesod-static >= 1.2
|
||||||
, yesod-form >= 1.3 && < 1.4
|
, yesod-form >= 1.3
|
||||||
, bytestring >= 0.9 && < 0.11
|
, bytestring >= 0.9
|
||||||
, text >= 0.11 && < 2.0
|
, text >= 0.11
|
||||||
, persistent >= 1.3 && < 1.4
|
, persistent >= 1.3
|
||||||
, persistent-sqlite >= 1.3 && < 1.4
|
, persistent-sqlite >= 1.3
|
||||||
, persistent-template >= 1.3 && < 1.4
|
, persistent-template >= 1.3
|
||||||
, template-haskell
|
, template-haskell
|
||||||
, shakespeare >= 2.0 && < 2.1
|
, shakespeare >= 2.0
|
||||||
, hjsmin >= 0.1 && < 0.2
|
, hjsmin >= 0.1
|
||||||
, monad-control >= 0.3 && < 0.4
|
, monad-control >= 0.3
|
||||||
, wai-extra >= 3.0 && < 3.1
|
, wai-extra >= 3.0
|
||||||
, yaml >= 0.8 && < 0.9
|
, yaml >= 0.8
|
||||||
, http-conduit >= 2.1 && < 2.2
|
, http-conduit >= 2.1
|
||||||
, directory >= 1.1 && < 1.3
|
, directory >= 1.1
|
||||||
, warp >= 3.0 && < 3.1
|
, warp >= 3.0
|
||||||
, data-default
|
, data-default
|
||||||
, aeson >= 0.6 && < 0.8
|
, aeson >= 0.6
|
||||||
, conduit >= 1.0 && < 2.0
|
, conduit >= 1.0
|
||||||
, monad-logger >= 0.3 && < 0.4
|
, monad-logger >= 0.3
|
||||||
, fast-logger >= 2.1.4 && < 2.2
|
, fast-logger >= 2.1.4
|
||||||
, wai-logger >= 2.1 && < 2.2
|
, wai-logger >= 2.1
|
||||||
|
-- custom dependencies
|
||||||
|
, random
|
||||||
|
, mime-mail
|
||||||
|
, blaze-html
|
||||||
|
, filepath
|
||||||
|
, time
|
||||||
|
|
||||||
executable eidolon
|
executable eidolon
|
||||||
if flag(library-only)
|
if flag(library-only)
|
||||||
|
|
1
static/tmp/autogen-SWBGXCgb.js
Normal file
1
static/tmp/autogen-SWBGXCgb.js
Normal file
|
@ -0,0 +1 @@
|
||||||
|
document.getElementById("hident4").innerHTML="This text was added by the Javascript part of the homepage widget."
|
8
static/tmp/autogen-vozS04Wr.css
Normal file
8
static/tmp/autogen-vozS04Wr.css
Normal file
|
@ -0,0 +1,8 @@
|
||||||
|
h1 {
|
||||||
|
text-align: center
|
||||||
|
;
|
||||||
|
}
|
||||||
|
h2#hident4 {
|
||||||
|
color: #990
|
||||||
|
;
|
||||||
|
}
|
9
templates/home.hamlet
Normal file
9
templates/home.hamlet
Normal 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
6
templates/signup.hamlet
Normal file
|
@ -0,0 +1,6 @@
|
||||||
|
<h3>Signup
|
||||||
|
|
||||||
|
<form method=post enctype=#{enctype}>
|
||||||
|
^{signupWidget}
|
||||||
|
<div>
|
||||||
|
<input type=submit value="Register">
|
Loading…
Add table
Reference in a new issue