Unverified Commit 7163ad47 authored by Bryan Richter's avatar Bryan Richter

Merge branch 'css-footnotes-forms'

Includes template cleanup
parents 87b61925 02d8b85e
......@@ -98,7 +98,6 @@ library
Model.Project.Signup.Internal
Model.ResetPassphrase
Model.Role
Model.Shares
Model.User
Model.User.Internal
Model.Volunteer
......
......@@ -7,7 +7,7 @@ import Control.Exception.Lifted (throwIO, handle)
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Char (isSpace)
import Data.Text as T
import Data.List as List (tail)
import Network.HTTP.Conduit (Manager)
import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym)
......@@ -26,6 +26,7 @@ import qualified Data.Text.Lazy.Encoding as E
import qualified Database.Persist
import qualified Settings
import qualified Yesod as Y
import qualified Data.Text as T
import Avatar
import Model.Currency
......@@ -400,3 +401,10 @@ defaultLayoutNew pageName widget = do
$(widgetFile "default/grid")
$(widgetFile "default-layout-new")
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
where
pageClasses :: (Text, Text)
pageClasses = ("class", classes pageName)
classes = T.append "container "
. T.unwords
. List.tail
. T.splitOn "/"
......@@ -9,7 +9,7 @@ getHonorPledgeR :: Handler Html
getHonorPledgeR = do
is_elig <- curUserIsEligibleEstablish
muser <- maybeAuth
$(widget "honor-pledge" "Honor Pledge")
$(widget "page/honor-pledge" "Honor Pledge")
postHonorPledgeR :: Handler Html
postHonorPledgeR = do
......
......@@ -37,4 +37,4 @@ getJsLicensesR = do
, Lib "jquery.jqplot.min.js" (render $ StaticR js_jquery_jqplot_min_js) "Expat License" "http://www.jclark.com/xml/copying.txt" "jquery.jqplot.js" (render $ StaticR js_jquery_jqplot_js)
, Lib "jqplot.logAxisRenderer.min.js" (render $ StaticR js_plugins_jqplot_logAxisRenderer_min_js) "Expat License" "http://www.jclark.com/xml/copying.txt" "jqplot.logAxisRenderer.js" (render $ StaticR js_plugins_jqplot_logAxisRenderer_js)
]
$(widget "js-licenses" "Javascript Licenses")
$(widget "page/js-licenses" "Javascript Licenses")
......@@ -21,14 +21,12 @@ import Model.User
import View.User (renderUser, createUserForm)
getWelcomeR :: Handler Html
getWelcomeR = defaultLayoutNew "homepage" $ do
setTitle "Snowdrift.coop — Free the Commons"
$(widgetFile "homepage")
getWelcomeR = $(widget "page/welcome" "Snowdrift.coop — Free the Commons")
getSearchR :: Handler Html
getSearchR = do
q <- lookupGetParam "q"
$(widget "search" "Search")
$(widget "page/search" "Search")
getPUpdatesR,
getPTransactionsR
......@@ -79,25 +77,22 @@ getHomeR,
-- the dashboard for logged-in viewers.
getHomeR = do
u <- maybeAuth
maybe (defaultLayoutNew "homepage" $ do
setTitle "Snowdrift.coop — Free the Commons"
$(widgetFile "homepage"))
(\user ->
$(widget "dashboard/overview" "Dashboard"))
maybe getWelcomeR
(\user -> $(widget "page/dashboard/overview" "Dashboard"))
u
getUDashboardR = do
user <- requireAuth
$(widget "dashboard/overview" "Dashboard")
$(widget "page/dashboard/overview" "Dashboard")
getUTransactionsR = do
user <- requireAuth
$(widget "dashboard/transactions" "Transactions")
$(widget "page/dashboard/transactions" "Transactions")
getUPledgesR = do
user <- requireAuth
$(widget "dashboard/pledges" "Pledges")
$(widget "page/dashboard/pledges" "Pledges")
getUEditR = do
user <- requireAuth
$(widget "dashboard/edit-profile" "Edit Profile")
$(widget "page/dashboard/edit-profile" "Edit Profile")
--
-- #### NEEDS REVIEW. COPIED FROM EXISTING PAGES.
......@@ -107,7 +102,7 @@ getUEditR = do
getProjectsR :: Handler Html
getProjectsR = do
projects <- runDB fetchPublicProjectsDB
$(widget "projects" "Projects")
$(widget "page/projects" "Projects")
-- | Public page for a project
getPHomeR :: ProjectHandle -> Handler Html
......@@ -122,14 +117,7 @@ getPHomeR handle = do
getCreateAccountR :: Handler Html
getCreateAccountR = do
(form, _) <- generateFormPost $ createUserForm Nothing
defaultLayoutNew "create-account" $ do
snowdriftTitle "Free the Commons"
[whamlet|
^{alphaRewriteNotice}
<form method=POST>
^{form}
<input type=submit>
|]
$(widget "page/create-account" "Free the Commons")
-- | Handles form posting for a user signing up.
postCreateAccountR :: Handler Html
......
......@@ -14,7 +14,7 @@ import qualified View.ResetPassphrase as View
getResetPassphraseR :: Handler Html
getResetPassphraseR = do
(form, enctype) <- generateFormPost resetPassphraseForm
$(widget "reset-passphrase" "Reset Passphrase")
$(widget "page/reset-passphrase" "Reset Passphrase")
initResetPassphrase :: UserId -> Text -> Handler Html
initResetPassphrase user_id email = do
......@@ -29,7 +29,7 @@ postResetPassphraseR = do
((result, form), enctype) <- runFormPost resetPassphraseForm
let alertAndRefresh msg = do
alertDanger msg
$(widget "reset-passphrase" "Reset Passphrase")
$(widget "page/reset-passphrase" "Reset Passphrase")
case result of
FormSuccess View.ResetPassphrase {..} ->
if | isNothing rpHandle && isNothing rpEmail ->
......
......@@ -21,21 +21,21 @@ getIntroR,
getDonateR,
getMerchandiseR
:: Handler Html
getIntroR = $(widget "how-it-works/intro" "Intro")
getFloR = $(widget "how-it-works/flo" "FLO")
getNetworkEffectR = $(widget "how-it-works/network-effect"
getIntroR = $(widget "page/how-it-works/intro" "Intro")
getFloR = $(widget "page/how-it-works/flo" "FLO")
getNetworkEffectR = $(widget "page/how-it-works/network-effect"
"Network Effect")
getSustainableFundingR = $(widget "how-it-works/sustainable-funding"
getSustainableFundingR = $(widget "page/how-it-works/sustainable-funding"
"Sustainable Funding")
getCoOpR = $(widget "how-it-works/co-op" "Co-op")
getPSignupR = $(widget "project-signup" "Project Signup")
getAboutHomeR = $(widget "about/old-homepage" "About")
getContactR = $(widget "contact" "Contact")
getTeamR = $(widget "team" "Team")
getPressR = $(widget "press" "Press")
getSponsorsR = $(widget "sponsors" "Sponsors")
getDonateR = $(widget "donate" "Donate")
getMerchandiseR = $(widget "merchandise" "Merchandise")
getCoOpR = $(widget "page/how-it-works/co-op" "Co-op")
getPSignupR = $(widget "page/project-signup" "Project Signup")
getAboutHomeR = $(widget "page/about/old-homepage" "About")
getContactR = $(widget "page/contact" "Contact")
getTeamR = $(widget "page/team" "Team")
getPressR = $(widget "page/press" "Press")
getSponsorsR = $(widget "page/sponsors" "Sponsors")
getDonateR = $(widget "page/donate" "Donate")
getMerchandiseR = $(widget "page/merchandise" "Merchandise")
-- * TODO: Convert these.
getTermsR,
......
......@@ -32,4 +32,4 @@ getUsersR = do
isVisible :: Entity User -> Bool
isVisible = (>= (0::Int)) . getUserKey
$(widget "users" "Users")
$(widget "page/users" "Users")
{-# LANGUAGE TupleSections #-}
module Model.Shares where
import Import
import Data.String (fromString)
import System.Random (randomIO)
import Text.Julius (rawJS)
import qualified Data.Text as T
import qualified Data.Text.Read as T
import Model.Currency
pledgeSizes :: [[Int64]]
pledgeSizes =
[ [1,2,4,8]
, [1,2,4,8,16]
, [1,2,3,5,10]
, [1,2,5,10]
]
pledgeListKey :: Text
pledgeListKey = "pledge_list"
newtype SharesPurchaseOrder = SharesPurchaseOrder Int64
pledgeField :: ProjectId -> Field Handler SharesPurchaseOrder
pledgeField _project_id = Field
{ fieldParse = parse
, fieldView = view
, fieldEnctype = UrlEncoded
}
where
parse [] _ = return $ Left $ SomeMessage MsgValueRequired
parse (x:_) _
| "-other" `T.isSuffixOf` x = do
mv <- lookupGetParam x
case mv of
Nothing -> return $ Left $ SomeMessage MsgValueRequired
Just v -> return $ parseValue v
| otherwise = return $ parseValue x
parseValue v =
let shares = Right . Just . SharesPurchaseOrder
invalidInteger i = Left $ SomeMessage $ fromString
"Number of shares must be an integer: " <> i
in case T.decimal v of
Right (a, "") -> shares a
Right (a, bs) ->
if T.all (== '0') $ T.tail bs
then shares a
else invalidInteger v
_ -> invalidInteger v
view ident name attrs v req = do
list <- handlerToWidget get_list
let value = either (const 2) (\(SharesPurchaseOrder s) -> s) v
hasValue = value `elem` list
otherValue = if hasValue then "" else show value
pledgeOptions = zip list $ map (show . millMilray) list
$(widgetFile "pledge-field")
get_list = do
mlist <- lookupSession pledgeListKey
case mlist of
Nothing -> do
r <- liftIO randomIO
let idx = mod r $ length pledgeSizes
sizes = pledgeSizes !! idx
setSession pledgeListKey $ T.pack $ show sizes
return sizes
Just t -> return $ read $ T.unpack t
pledgeForm :: ProjectId -> Form SharesPurchaseOrder
pledgeForm project_id extra = do
muser <- lift maybeAuthId
shares <- case muser of
Nothing -> return 0
Just user_id ->
fmap (sum . map unValue) $ lift $ runDB $
select $ from $ \pledge -> do
where_ $ pledge ^. PledgeProject ==. val project_id
&&. pledge ^. PledgeUser ==. val user_id
return $ pledge ^. PledgeShares
(result, pledge_view) <-
mreq (pledgeField project_id)
""
(if shares > 0 then Just (SharesPurchaseOrder shares) else Nothing)
let view = $(widgetFile "pledge-form")
return (result, view)
-- |previewPledgeForm is used for previewing a project page when editing
previewPledgeForm :: Form SharesPurchaseOrder
previewPledgeForm extra = do
let view = [whamlet|
#{extra}
<p>
<strong>
[Pledge form…]
|]
return (FormSuccess $ SharesPurchaseOrder 0, view)
......@@ -5,7 +5,6 @@ module View.Project
, projectContactForm
, inviteForm
, Preview (..)
, projectConfirmPledgeForm
, viewForm
) where
......@@ -20,7 +19,6 @@ import Data.Order
import DeprecatedBootstrap
import Handler.Utils
import Model.Project
import Model.Shares
import Model.Role
import Widgets.Markdown
......@@ -66,8 +64,3 @@ viewForm = renderBootstrap3 BootstrapBasicForm $ liftA2 (,)
(fmap (either (const defaultOrder) id . parseOrderExpression
. fromMaybe "")
(aopt' textField "sort" Nothing))
projectConfirmPledgeForm :: Maybe Int64 -> Form SharesPurchaseOrder
projectConfirmPledgeForm =
renderBootstrap3 BootstrapBasicForm . fmap SharesPurchaseOrder
. areq hiddenField ""
......@@ -41,7 +41,7 @@ createUserForm ident extra = do
(avatarRes, avatarView) <- mopt textField "" Nothing
(nickRes, nickView) <- mopt textField "" Nothing
let view = $(widgetFile "auth/create-user-form")
let view = $(widgetFile "form/create-user")
passphRes = case (passph1Res, passph2Res) of
(FormSuccess a, FormSuccess b)
| a == b -> FormSuccess a
......
......@@ -33,7 +33,7 @@
<td>
<a href=#{website}>#{website}
$maybe location <- volunteerApplicationLocation application
$maybe location <- volunteerApplicationLocation application
<tr>
<td>
Location:
......
......@@ -23,4 +23,3 @@ $else
<td>
$maybe location <- volunteerApplicationLocation application
#{location}
^{extra}
<p>
By registering, you agree to Snowdrift.coop's (exceptionally ethical)
<a href=@{TermsR}>Terms&nbsp;of&nbsp;Use
and
<a href=@{PrivacyR}>Privacy&nbsp;Policy</a>.
<table>
<tr>
<td>
<label for=#{fvId identView}>
Account name (private, used for logging in):
<td>
^{fvInput identView}
<tr>
<td>
<label for=#{fvId passph1View}>
Passphrase:
<td>
^{fvInput passph1View}
<tr>
<td>
<label for=#{fvId passph2View}>
Repeat passphrase:
<td>
^{fvInput passph2View}
<tr>
<td>
<label for=#{fvId nameView}>
Name (public, optional):
<td>
^{fvInput nameView}
<tr>
<td>
<label for=#{fvId emailView}>
Email (private, optional):
<td>
^{fvInput emailView}
<tr>
<td>
<label for=#{fvId avatarView}>
Avatar (link, optional):
<td>
^{fvInput avatarView}
<tr>
<td>
<label for=#{fvId nickView}>
IRC Nick (irc.freenode.net, optional):
<td>
^{fvInput nickView}
......@@ -2,25 +2,12 @@
max-width: 36rem
margin: 0 auto
.login
h1
margin: 3rem 0 0 0
padding-bottom: 3rem
font-weight: 400
form
label
color: #{BrightBlueText}
padding: 1rem 0
display: block
input
background-color: #{White}
border: 0.1rem solid #{DarkBlue}
border-radius: 0.3rem
padding: 0.5rem 0.3rem
font-size: 2rem
font-family: "Nunito"
color: #{DarkBlue}
font-weight: 400
width: 95%
margin: 0
.bigbutton
margin: 1rem auto 3rem
display: block
......@@ -40,8 +27,6 @@
/*break2*/
@media (min-width: 391px)
.login
h1
margin: 6rem 0 0 0
form
input
width: 35rem
......
<article .blog-post>
<h1>
#{title}
<br>
<small>
<span .author> by ^{userNameWidget author}
<span .post-time> ^{renderTime $ blogPostTs blog_post}
$if preview == NotPreview
<a href=@{EditBlogPostR project_handle (blogPostHandle blog_post)}>edit
^{content}
<div .text-center>
<a href=@{BlogPostDiscussionR project_handle (blogPostHandle blog_post)}>
discuss this post
<span .badge>
#{comment_count}
.comment
padding: 0 1em
margin: 2em 0
border-bottom-left-radius: 0.8em
font-size: small
.comment
p, ul, ol, h1, h2, h3, h4, h5, h6
margin: 0
figure
text-align: left
h1
font-size: large
margin-bottom: .5em
h2
font-size: medium
blockquote
font-size: 14px
margin: 1em
.comment-date span
color: gray
font-style: italic
.comment-head-item, .comment-action
display: inline-block
margin: 0 3px
.comment-actions
margin-bottom: 0.5em
.comment-action a, .comment-action a:visited
color: gray
margin-right: 1px
.comment-body
font-size: 1.12em
margin: 0.5em 0
.ticket-num
color: gray
.inner-widget
margin-top: 1em
.awaiting-approval
color: green
font-style: italic
.claimed-by
color: gray
.top_level
border-left: solid black 0.2em
margin-bottom: 4em
.even_depth
border-left: solid lightblue 0.2em
.odd_depth
border-left: solid steelblue 0.2em
.small_avatar
width: 2.5em
height: 2.5em
padding: 0em
margin-right: 0.3em
border-radius: 5px
.ticket-title
background-color: #CCDDFF
border-radius: 1em
padding: 0.5em
display: inline-block
max-width: 35em
margin: 0 1em
text-align: center
.closed
color: goldenrod
border-left: solid goldenrod 0.25em
padding-left: 0.5em
.retracted
color: darkred
border-left: solid darkred 0.25em
padding-left: 0.5em
.flagged
border: thin solid darkred
border-left: solid red
padding: .5em
margin: .5em 0
display: table
.flag-reasons
color: darkred
max-width: 41em
.flag-reasons, .flag-markdown
background: whitesmoke
padding: .5em
margin: .5em 0
display: table
.expand
font-style: italic
.preview a
pointer-events: none
<div .h-entry .comment :is_unapproved:.unapproved :is_top_level:.top_level :is_even_depth:.even_depth :is_odd_depth:.odd_depth>
<div .comment-head>
<div .h-card .p-author .comment-head-item>
$if user_id == anonymousUser
<span .p-name>
#{userDisplayName (Entity user_id user)}
$else
<a .u-url .p-name href=@{UserR user_id}>
$maybe author_avatar <- userAvatar user
<img .u-photo .small_avatar src=#{author_avatar}> #
#{userDisplayName (Entity user_id user)}
$if can_establish
<div .comment-head-item>
<a href=@{UserR user_id}>
(establish user)
$with ts <- fromMaybe (commentCreatedTs comment) (commentApprovedTs comment)
<time .dt-modified datetime=#{iso8601 ts} .comment-head-item .comment-date>
^{renderTime ts}
<div .comment-head-item :is_preview:.preview>
|
<div .comment-head-item :is_preview:.preview>
<a .u-url href=@{comment_route_permalink comment_id}>
permalink
$maybe parent_id <- commentParent comment
<div .comment-head-item :is_preview:.preview>
|
<div .comment-head-item :is_preview:.preview>
<a href=@{comment_route_permalink parent_id}>
parent
$if is_private
<i style="color: brown">private comment
$if can_watch
<div .comment-head-item :is_preview:.preview>
|
<div .comment-action :is_preview:.preview>
<a href=@{comment_route_watch comment_id}>
watch
$if can_unwatch
<div .comment-head-item :is_preview:.preview>
|
<div .comment-action :is_preview:.preview>
<a href=@{comment_route_unwatch comment_id}>
unwatch
$maybe PersistInt64 ticket_id <- fmap (toPersistValue . entityKey) mticket
<span .glyphicon .glyphicon-tag>
<span .ticket-num>SD-#{show ticket_id}
$if can_claim && not is_closed
<div :is_preview:.preview .comment-action>
<a href=@{comment_route_claim comment_id}>
claim
$else
$maybe claim <- mclaim
$with claiming_user_id <- ticketClaimingUser claim
$maybe claiming_user <- M.lookup claiming_user_id user_map
<span .claimed-by>
claimed
^{renderTime (ticketClaimingTs claim)}
by
<a href=@{UserR claiming_user_id}>#{userDisplayName $ Entity claiming_user_id claiming_user}#
$maybe note <- ticketClaimingNote claim
: #{note}
$if can_unclaim && not is_closed
<div :is_preview:.preview .comment-action>
<a href=@{comment_route_unclaim comment_id}>
(unclaim)
$if is_unapproved
<div .awaiting-approval>
<span .glyphicon .glyphicon-arrow-right>
awaiting moderator approval
$if can_approve
<a href=@{comment_route_approve comment_id}>
\ (approve)
$forall closure <- earlier_closures
<div .closed>
A comment above was closed at ^{renderTime (commentClosingTs closure)}
#{commentClosingReason closure}
$forall retract <- earlier_retracts
<div .retracted>
A comment above was retracted ^{renderTime (commentRetractingTs retract)}
#{commentRetractingReason retract}
$maybe closure <- mclosure
<div .closed>
$if commentClosingClosedBy closure == user_id
The author
$else
^{userNameWidget $ commentClosingClosedBy closure}
\ closed this comment ^{renderTime (commentClosingTs closure)}
#{commentClosingReason closure}
$maybe retract <- mretract
<div .retracted>
The author retracted this comment ^{renderTime (commentRetractingTs retract)}
#{commentRetractingReason retract}
$maybe (flagging, flag_reasons) <- mflag
<div .flagged>
A user flagged this comment as a violation of the
<a href=@{WikiR "snowdrift" LangEn "conduct"}>
Code of Conduct
due to:
<div .flag-reasons>#{T.intercalate ", " $ map descFlagReason flag_reasons}
$maybe flag_markdown <- commentFlaggingMessage flagging
<div .flag-markdown>
Additional comments:
#{flag_markdown}
<i>Please edit to address these concerns and repost.
<div .e-content .p-name .comment-body>
^{markdownWidgetWith commentTextTransform (commentText comment)}
<div>
$forall tag <- tags
^{tagWidget tag}
<div :is_preview:.preview .comment-actions>
$if can_edit
<div .comment-action>
<a href=@{comment_route_edit comment_id}>
edit
$if can_close
<div .comment-action>
<a href=@{comment_route_close comment_id}>
close