From c10806fffc4b61864638db9793e1d68e650f8421 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 12 Aug 2014 14:42:25 +0200 Subject: [PATCH] stuff --- Handler/Activate.hs | 18 +++++++++ Handler/Login.hs | 9 +++++ Handler/Signup.hs | 71 +++++++++++++++++++++++++++++++++ Model.hs | 2 + eidolon.cabal | 54 ++++++++++++++----------- static/tmp/autogen-SWBGXCgb.js | 1 + static/tmp/autogen-vozS04Wr.css | 8 ++++ templates/home.hamlet | 9 +++++ templates/signup.hamlet | 6 +++ 9 files changed, 154 insertions(+), 24 deletions(-) create mode 100644 Handler/Activate.hs create mode 100644 Handler/Login.hs create mode 100644 Handler/Signup.hs create mode 100644 static/tmp/autogen-SWBGXCgb.js create mode 100644 static/tmp/autogen-vozS04Wr.css create mode 100644 templates/home.hamlet create mode 100644 templates/signup.hamlet diff --git a/Handler/Activate.hs b/Handler/Activate.hs new file mode 100644 index 0000000..c44e6f3 --- /dev/null +++ b/Handler/Activate.hs @@ -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|
Invalid Token!|]
+      redirect $ HomeR
+    [x] -> do
+      _ <- runDB $ insert $ tokenUser (entityVal x)
+      setMessage $ [shamlet|
User activated|]
+      redirect $ HomeR
+    _ -> do
+      error "unexpected error"
diff --git a/Handler/Login.hs b/Handler/Login.hs
new file mode 100644
index 0000000..b9fa9bb
--- /dev/null
+++ b/Handler/Login.hs
@@ -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"
diff --git a/Handler/Signup.hs b/Handler/Signup.hs
new file mode 100644
index 0000000..23cf419
--- /dev/null
+++ b/Handler/Signup.hs
@@ -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|
+              

Welcome to Eidolon! + To complete your sgnup please activate your account by visiting the following link + #{activateLink} + |] + setMessage $ [shamlet|
User created|]
+          redirect $ HomeR
+        False -> do
+          setMessage $ [shamlet|
Username error|]
+          redirect $ SignupR
+    _ -> do
+      setMessage $ [shamlet|
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
+        }]]
+      }
diff --git a/Model.hs b/Model.hs
index 5de285c..f99ab04 100644
--- a/Model.hs
+++ b/Model.hs
@@ -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
diff --git a/eidolon.cabal b/eidolon.cabal
index 0bec6c2..9553427 100644
--- a/eidolon.cabal
+++ b/eidolon.cabal
@@ -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)
diff --git a/static/tmp/autogen-SWBGXCgb.js b/static/tmp/autogen-SWBGXCgb.js
new file mode 100644
index 0000000..dd273a1
--- /dev/null
+++ b/static/tmp/autogen-SWBGXCgb.js
@@ -0,0 +1 @@
+document.getElementById("hident4").innerHTML="This text was added by the Javascript part of the homepage widget."
\ No newline at end of file
diff --git a/static/tmp/autogen-vozS04Wr.css b/static/tmp/autogen-vozS04Wr.css
new file mode 100644
index 0000000..b8e1b5c
--- /dev/null
+++ b/static/tmp/autogen-vozS04Wr.css
@@ -0,0 +1,8 @@
+h1 {
+    text-align: center
+;
+}
+h2#hident4 {
+    color: #990
+;
+}
diff --git a/templates/home.hamlet b/templates/home.hamlet
new file mode 100644
index 0000000..d87a9f1
--- /dev/null
+++ b/templates/home.hamlet
@@ -0,0 +1,9 @@
+Login
+Signup
+
+$if null recentMedia
+  

This gallery is still empty. +$else + $forall (Entity mediaId medium) <- recentMedia +

+
diff --git a/templates/signup.hamlet b/templates/signup.hamlet new file mode 100644 index 0000000..534b6d9 --- /dev/null +++ b/templates/signup.hamlet @@ -0,0 +1,6 @@ +

Signup + +
+ ^{signupWidget} +
+