Skip to content
Permalink
Browse files

login form

  • Loading branch information...
3v0k4 committed Jul 15, 2019
1 parent bb89035 commit 8d89a7101a979b06ea324c8d6d9aa0373f49d6ee
Showing with 51 additions and 7 deletions.
  1. +2 −1 config/routes
  2. +1 −0 src/Application.hs
  3. +9 −0 src/Foundation.hs
  4. +20 −6 src/Handler/Landing.hs
  5. +6 −0 src/Handler/Posts.hs
  6. +3 −0 templates/landing.hamlet
  7. +10 −0 test/Handler/PostsSpec.hs
@@ -12,4 +12,5 @@
/comments CommentR POST

/profile ProfileR GET
/ LandingR GET
/ LandingR GET POST
/posts PostsR GET
@@ -45,6 +45,7 @@ import Handler.Home
import Handler.Comment
import Handler.Profile
import Handler.Landing
import Handler.Posts

-- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@@ -173,6 +173,8 @@ instance Yesod App where

isAuthorized LandingR _ = return Authorized

isAuthorized PostsR _ = return Authorized

-- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows
-- expiration dates to be set far in the future without worry of
@@ -297,3 +299,10 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- https://github.com/yesodweb/yesod/wiki/Sending-email
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding

emptyLayout :: Widget -> Handler Html
emptyLayout widget = do
pc <- widgetToPageContent $ do
$(widgetFile "empty-layout")
withUrlRenderer $(hamletFile "templates/empty-layout-wrapper.hamlet")

@@ -3,19 +3,33 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}

module Handler.Landing where

import Import
import Text.Hamlet (hamletFile)

emptyLayout :: Widget -> Handler Html
emptyLayout widget = do
pc <- widgetToPageContent $ do
$(widgetFile "empty-layout")
withUrlRenderer $(hamletFile "templates/empty-layout-wrapper.hamlet")
data Login =
Login { username :: Text, password :: Text }
deriving Show

loginForm :: Form Login
loginForm =
renderDivs $
Login <$> areq textField "Username" Nothing <*> areq textField "Password" Nothing

getLandingR :: Handler Html
getLandingR = do
(widget, enctype) <- generateFormPost loginForm
emptyLayout $ do
$(widgetFile "landing")

postLandingR :: Handler Html
postLandingR = do
((result, widget), enctype) <- runFormPost loginForm
case result of
FormSuccess _ ->
redirect PostsR
_ ->
emptyLayout $ do
$(widgetFile "landing")
@@ -0,0 +1,6 @@
module Handler.Posts where

import Import

getPostsR :: Handler Html
getPostsR = error "Not yet implemented: getPostsR"
@@ -1 +1,4 @@
<h1>Login
<form method=post action=@{LandingR} enctype=#{enctype}>
^{widget}
<button>Login
@@ -0,0 +1,10 @@
module Handler.PostsSpec (spec) where

import TestImport

spec :: Spec
spec = withApp $ do

describe "getPostsR" $ do
error "Spec not implemented: getPostsR"

0 comments on commit 8d89a71

Please sign in to comment.
You can’t perform that action at this time.