From 8a81217624c15b31bea6d06aaabf127dac84c3f3 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 12 Aug 2014 18:14:59 +0200 Subject: [PATCH] authentication works --- Foundation.hs | 5 +++- Handler/Login.hs | 41 +++++++++++++++++++++++++++++++-- config/routes | 1 + templates/default-layout.hamlet | 14 +++++++++++ templates/home.hamlet | 3 --- templates/login.hamlet | 6 +++++ 6 files changed, 64 insertions(+), 6 deletions(-) create mode 100644 templates/login.hamlet diff --git a/Foundation.hs b/Foundation.hs index 4ce8d7b..be4db98 100644 --- a/Foundation.hs +++ b/Foundation.hs @@ -14,10 +14,12 @@ import qualified Database.Persist import Database.Persist.Sql (SqlPersistT) import Settings.StaticFiles import Settings (widgetFile, Extra (..)) --- import Model +import Model import Text.Jasmine (minifym) import Text.Hamlet (hamletFile) import Yesod.Core.Types (Logger) +-- costom imports +import Data.Maybe -- | The site argument for your application. This can be a good place to -- keep settings and values requiring initialization before your application @@ -63,6 +65,7 @@ instance Yesod App where defaultLayout widget = do master <- getYesod mmsg <- getMessage + msu <- lookupSession "username" -- We break up the default layout into two components: -- default-layout is the contents of the body tag, and diff --git a/Handler/Login.hs b/Handler/Login.hs index b9fa9bb..33c7d1a 100644 --- a/Handler/Login.hs +++ b/Handler/Login.hs @@ -2,8 +2,45 @@ module Handler.Login where import Import +data Credentials = Credentials + { credentialsName :: Text + , credentialsPasswd :: Text + } + deriving Show + getLoginR :: Handler Html -getLoginR = error "Not yet implemented: getLoginR" +getLoginR = do + (loginWidget, enctype) <- generateFormPost loginForm + defaultLayout $ do + $(widgetFile "login") postLoginR :: Handler Html -postLoginR = error "Not yet implemented: postLoginR" +postLoginR = do + ((result, loginWidget), enctype) <- runFormPost loginForm + case result of + FormSuccess cred -> do + tuser <- runDB $ selectFirst [UserName ==. credentialsName cred] [] + case tuser of + Just user -> do + case credentialsPasswd cred == userPassword (entityVal user) of + True -> do + setSession "username" $ userName (entityVal user) + setMessage $ [shamlet|
Successfully logged in|]
+              redirect $ HomeR
+            False -> do
+              setMessage $ [shamlet|
Login error|]
+              redirect $ LoginR
+        Nothing -> do
+          setMessage $ [shamlet|
User does not exist|]
+          redirect $ LoginR
+
+loginForm :: Form Credentials
+loginForm = renderDivs $ Credentials
+  <$> areq textField "Username" Nothing
+  <*> areq passwordField "Password" Nothing
+
+getLogoutR :: Handler Html
+getLogoutR = do
+  deleteSession "username"
+  setMessage $ [shamlet|
Succesfully logged out|]
+  redirect $ HomeR
diff --git a/config/routes b/config/routes
index 6a73369..3674938 100644
--- a/config/routes
+++ b/config/routes
@@ -6,4 +6,5 @@
 / HomeR GET POST
 /signup SignupR GET POST
 /login LoginR GET POST
+/logout LogoutR GET
 /activate/#String ActivateR GET
diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet
index fa86744..b2cf2e5 100644
--- a/templates/default-layout.hamlet
+++ b/templates/default-layout.hamlet
@@ -1,3 +1,17 @@
+