Commit 625d0ee1 authored by Christopher League's avatar Christopher League
Browse files

Better handling of titles, front-page widgets

parent 4885ae13
......@@ -30,6 +30,7 @@ module App.Foundation
conRw,
runMailer,
requireAuth,
maybeAuth,
module Yesod,
module Yesod.Auth,
setpassR,
......@@ -243,7 +244,10 @@ $doctype 5
<div .container .mt-3>
$forall m <- msgs
^{messageAlert m}
^{pageBody pc}
<h1 .h3 .mb-4>
#{pageTitle pc}
<div .row>
^{pageBody pc}
|]
instance YesodAuth App where
......@@ -265,10 +269,15 @@ instance YesodAuth App where
loginDest _ = HomeR
logoutDest _ = AuthR LoginR
logoutDest _ = HomeR
authLayout =
liftHandler . defaultLayout . (>> toWidget style)
authLayout widget =
liftHandler . defaultLayout $ do
toWidget style
[whamlet|
<div .col-12>
^{widget}
|]
where
style =
[lucius|
......@@ -282,6 +291,26 @@ body {
padding: 15px;
margin: auto;
}
#authPanel .form-control {
position: relative;
box-sizing: border-box;
height: auto;
padding: 10px;
font-size: 16px;
}
#authPanel .form-control:focus {
z-index: 2;
}
#authPanel input[type="text"] {
margin-bottom: -1px;
border-bottom-right-radius: 0;
border-bottom-left-radius: 0;
}
#authPanel input[type="password"] {
margin-bottom: 10px;
border-top-left-radius: 0;
border-top-right-radius: 0;
}
|]
......@@ -357,32 +386,9 @@ about a day.
emailLoginHandler toParent = do
(widget, enctype) <- generateFormPost loginForm
toWidget
[lucius|
#authPanel .form-control {
position: relative;
box-sizing: border-box;
height: auto;
padding: 10px;
font-size: 16px;
}
#authPanel .form-control:focus {
z-index: 2;
}
#authPanel input[type="text"] {
margin-bottom: -1px;
border-bottom-right-radius: 0;
border-bottom-left-radius: 0;
}
#authPanel input[type="password"] {
margin-bottom: 10px;
border-top-left-radius: 0;
border-top-right-radius: 0;
}
|]
setTitle "Please sign in"
[whamlet|
<form #authPanel .text-center method=post action=@{toParent loginR} enctype=#{enctype}>
<h1 .h3 .mb-3>Please sign in
^{widget}
<button .mt-3 .mb-3 .btn .btn-lg .btn-primary .btn-block type=submit>Sign in
......@@ -393,7 +399,7 @@ about a day.
renderDivsNoLabels $
(,)
<$> authUserField
<*> areq passwordField (authField "Password" "password") Nothing
<*> authPassField "Password" "password"
forgotPasswordHandler = do
(widget, enctype) <- generateFormPost $ renderDivsNoLabels authUserField
......@@ -402,11 +408,28 @@ about a day.
setTitleI PasswordResetTitle
[whamlet|
<form #authPanel .text-center method=post action=@{toParent forgotPasswordR} enctype=#{enctype}>
<h1 .h3 .mb-3>Reset password
^{widget}
<button .mt-3 .mb-3 .btn .btn-lg .btn-primary .btn-block type=submit>Send verification link
|]
setPasswordHandler needOld = do
(widget, enctype) <- generateFormPost setPassForm
toParent <- getRouteToParent
selectRep $ provideRep $ authLayout $ do
setTitle "Set Password"
[whamlet|
<form #authPanel .text-center method=post action=@{toParent setpassR} enctype=#{enctype}>
^{widget}
<button .mt-3 .mb-3 .btn .btn-lg .btn-primary .btn-block type=submit>Set Password
|]
where
setPassForm =
renderDivsNoLabels $
(,,)
<$> (if needOld then authPassField "Current Password" "current" else pure "")
<*> authPassField "New Password" "new"
<*> authPassField "Confirm Password" "confirm"
authField :: String -> Text -> FieldSettings App
authField label name =
FieldSettings
......@@ -425,19 +448,26 @@ authUserField =
(authField "Email, username, or student ID" "email")
Nothing
authPassField :: AppHandler m => String -> Text -> AForm m Text
authPassField label name =
areq
passwordField
(authField label name)
Nothing
newtype CachedAuth
= CachedAuth {unCachedAuth :: UserEntity}
deriving (Typeable)
cachedAuth :: UserId -> Handler UserEntity
cachedAuth :: AppHandler m => UserId -> m UserEntity
cachedAuth uid =
unCachedAuth <$> cached (CachedAuth . (uid,) <$> (putStrLn @Text "CACHELOADUSER" >> runRo (loadY uid)))
maybeAuth :: Handler (Maybe UserEntity)
maybeAuth :: AppHandler m => m (Maybe UserEntity)
maybeAuth =
maybeAuthId >>= mapM cachedAuth
requireAuth :: Handler UserEntity
requireAuth :: AppHandler m => m UserEntity
requireAuth =
requireAuthId >>= cachedAuth
......
......@@ -50,7 +50,7 @@ deleteMetaCacheR = do
cacheRef <- appMetaCache <$> getYesod
num <- Map.size <$> readIORef cacheRef
writeIORef cacheRef mempty
return $ "Dropped " <> show num <> " entries.\n"
return $ "meta cache: dropped " <> show num <> " entries.\n"
getSubmitR :: Text -> Handler Html
getSubmitR sid = do
......
......@@ -109,10 +109,6 @@ formatDay :: Day -> String
formatDay =
formatTime defaultTimeLocale "%a %e %b"
isNewPost :: User -> (PostId, PageTitle) -> (PostId, PageTitle, Bool)
isNewPost user (pid, title) =
(pid, title, not (Set.member pid (user ^. userReadPosts)))
-- The home page should still have *some* information even when not logged in:
-- link to PDF syllabus,
......@@ -121,48 +117,86 @@ formatTitle meta =
eitherThrow . runPure $ writeHtml5 def $
Pandoc nullMeta [Plain (docTitle meta)]
listPosts :: Handler [(PostId, Html)]
listPosts =
runRo listPostIds >>= mapM \k -> (k,) <$> (getPageMeta k >>= formatTitle)
essentialLinks :: Widget
essentialLinks = do
let syllabusId = AssetId "cs101s20.pdf"
syllabusOk <- runRo $ existsObj syllabusId
[whamlet|
<div .col-lg-6>
<div .card .mb-4>
<div .card-header>
Essential information #
<ul .list-group .list-group-flush>
$if syllabusOk
<li .list-group-item>
<a href=@{PageAssetR syllabusId}>Syllabus (pdf)
<li .list-group-item>
<b>Meets:
MW 9–10:50 AM in Pratt 610
<li .list-group-item>
<b>Instructor:
Christopher League
<a href=mailto:christopher.league@liu.edu>email
<li .list-group-item>
<b>Office hours:
MW 4–4:50 PM and
<a href=//bookme.liucs.net/>and by appointment
in Sloane 101
|]
recentPosts :: Widget
recentPosts =
maybeAuth >>= mapM_ \(_, user) -> do
postIds <- runRo listPostIds
unless (null postIds) $ do
posts <- forM postIds \pid -> do
title <- getPageMeta pid >>= formatTitle
return (pid, title, not (Set.member pid (user ^. userReadPosts)))
let newCount = length $ filter thd3 posts
[whamlet|
<div .col-lg-6>
<div .card .mb-4>
<div .card-header>
Announcements #
$if newCount > 0
<span .badge .badge-primary>
#{newCount}
<ul .list-group .list-group-flush>
$forall (post, title, newp) <- posts
<li .list-group-item>
<a href=@{PostR post}>
$if newp
<span .font-weight-bold .text-muted>
⇒ #{formatDay (postDay post)}
$else
<span .text-muted>
#{formatDay (postDay post)}
#{preEscapedToMarkup title}
|]
unit1 =
[whamlet|
<div .col-lg-6>
<div .card .mb-4>
<div .card-header>
<span .text-muted>
Unit 1:
Digital representations
<div .card-body>
Body goes here…
|]
getHomeR :: Handler Html
getHomeR = do
(_, user) <- requireAuth
posts <- map (isNewPost user) <$> listPosts
uidOpt <- maybeAuthId
(out, units) <- runRo $ do
out <- loadY TheOutline
let nums = [1 ..] :: [Int]
units = zip nums $ out ^. outUnits
return (out, units)
let newCount = length $ filter thd3 posts
defaultLayout
[whamlet|
<h1 .h3>
#{out ^. outTitle}
<div .row>
$if not (null posts)
<div .col-lg-6>
<div .card .mb-4>
<div .card-header>
Announcements #
$if newCount > 0
<span .badge .badge-primary>
#{newCount}
<ul .list-group .list-group-flush>
$forall (post, title, newp) <- posts
<li .list-group-item :newp:style="font-weight:bold">
<a href=@{PostR post}>
<span .text-muted>
#{formatDay (postDay post)}:
#{preEscapedToMarkup title}
$forall (num, unit) <- units
<div .col-lg-6>
<div .card .mb-4>
<div .card-header>
<i data-feather=chevron-right stroke-width=2 width=20 height=20>
<span .text-muted>
Unit #{num}:
#{unit ^. outSubtitle}
<div .card-body>
Body goes here…
|]
defaultLayout $ do
setTitle $ toHtml $ out ^. outTitle
recentPosts
essentialLinks
maybeAuthId >>= mapM_ \_ -> do
unit1
......@@ -10,7 +10,7 @@ module App.Post
)
where
import App.ByteStoreWorkDir
import App.ByteStore
import App.Page
import App.Prelude
import Data.Aeson as Js
......
......@@ -74,6 +74,8 @@ module App.Prelude
forM,
forM_,
zipWithM_,
when,
unless,
(<$>),
($>),
(<&>),
......
......@@ -35,45 +35,46 @@ getProfileR :: Handler Html
getProfileR = do
(uid, user) <- requireAuth
((_, widget), enctype) <- runFormPost $ profileForm (user ^. userNickName)
defaultLayout
[whamlet|
defaultLayout $ do
setTitle "Your profile"
<h1 .h3>Your profile
<table .table .table-borderless .table-sm>
<tr>
<th>Last name:
<td>#{user ^. userLastName}
<tr>
<th>First name:
<td>#{user ^. userFirstName}
<tr>
<th>Username:
<td>
<tt>#{uid}
<tr>
<th>Student ID:
<td>#{user ^. userStudentId}
<tr>
<th>Email address:
<td>
<a href=mailto:#{user ^. userEmail}>
#{user ^. userEmail}
<form method=post enctype=#{enctype}>
^{widget}
[whamlet|
<div .col-12>
<table .table .table-borderless .table-sm>
<tr>
<th>Last name:
<td>#{user ^. userLastName}
<tr>
<th>First name:
<td>#{user ^. userFirstName}
<tr>
<th>Username:
<td>
<tt>#{uid}
<tr>
<th>Student ID:
<td>#{user ^. userStudentId}
<tr>
<th>
<th>Email address:
<td>
<button .btn .btn-primary>Save
<a href=mailto:#{user ^. userEmail}>
#{user ^. userEmail}
<form method=post enctype=#{enctype}>
^{widget}
<tr>
<th>
<td>
<button .btn .btn-primary>Save
<p>
<a href=@{AuthR setpassR}>
Change your password
<p>
<a href=@{AuthR setpassR}>
Change your password
<p>
To change your profile image,
<a href=https://en.gravatar.com/support/>
sign up for Gravatar
using the above email address.
<p>
To change your profile image,
<a href=https://en.gravatar.com/support/>
sign up for Gravatar
using the above email address.
|]
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment