We are no longer offering accounts on this server. Consider https://gitlab.freedesktop.org/ as a place to host projects.

Commit 3897cd30 authored by David L. L. Thomas's avatar David L. L. Thomas

Initial public commit

parents
:set -i.:config:dist/build/autogen
:set -XTemplateHaskell -XQuasiQuotes -XTypeFamilies -XFlexibleContexts -XGADTs -XOverloadedStrings -XMultiParamTypeClasses -XGeneralizedNewtypeDeriving -XEmptyDataDecls -XScopedTypeVariables
dist/
static/tmp/
config/client_session_key.aes
cabal-dev
*.hi
*.o
*.chi
*.chs.h
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( makeApplication
, getApplicationDev
, makeFoundation
) where
import Import
import Settings
import Yesod.Default.Config
import Yesod.Default.Main
import Yesod.Default.Handlers
import Network.Wai.Middleware.RequestLogger (logStdout, logStdoutDev)
import qualified Database.Persist.Store
import Database.Persist.GenericSql (printMigration, runMigration)
import Network.HTTP.Conduit (newManager, def)
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
import Handler.Home
import Handler.About
import Handler.Faq
import Handler.User
import Handler.Widget
import Handler.Project
import Handler.Invitation
import Handler.Invite
import Handler.UpdateShares
import Handler.Committee
import Handler.Contact
import Handler.Who
import Handler.PostLogin
import Handler.Tos
import Handler.Privacy
import Handler.Messages
import Handler.Application
import Handler.Applications
import Handler.JsLicense
import Handler.MarkdownTutorial
import Handler.UserBalance
import Handler.UserPledges
import Handler.Wiki
-- 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
-- comments there for more details.
mkYesodDispatch "App" resourcesApp
-- This function allocates resources (such as a database connection pool),
-- performs initialization and creates a WAI application. This is also the
-- place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeApplication :: AppConfig DefaultEnv Extra -> IO Application
makeApplication conf = do
foundation <- makeFoundation conf
app <- toWaiAppPlain foundation
return $ logWare app
where
logWare = if development then logStdoutDev
else logStdout
makeFoundation :: AppConfig DefaultEnv Extra -> IO App
makeFoundation conf = do
manager <- newManager def
s <- staticSite
dbconf <- withYamlEnvironment "config/postgresql.yml" (appEnv conf)
Database.Persist.Store.loadConfig >>=
Database.Persist.Store.applyEnv
p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)
Database.Persist.Store.runPool dbconf (printMigration migrateAll >> runMigration migrateAll) p
return $ App conf s p manager dbconf
-- for yesod devel
getApplicationDev :: IO (Int, Application)
getApplicationDev =
defaultDevelApp loader makeApplication
where
loader = loadConfig (configSettings Development)
{ csParseExtra = parseExtra
}
This diff is collapsed.
This diff is collapsed.
module Handler.Application where
import Import
import Model.User
import Widgets.Sidebar
getApplicationR :: CommitteeApplicationId -> Handler RepHtml
getApplicationR application_id = do
(application, user) <- runDB $ do
application <- get404 application_id
let user_id = committeeApplicationUser application
user <- get404 user_id
return (application, Entity user_id user)
defaultLayout $(widgetFile "application")
module Handler.Applications where
import Import
import Model.Role
import Widgets.Sidebar
getApplicationsR :: Handler RepHtml
getApplicationsR = do
Entity viewer_id viewer <- requireAuth
now <- liftIO getCurrentTime
applications <-
if userRole viewer == CommitteeMember || userRole viewer == Admin
then runDB $ selectList [] [ Desc CommitteeApplicationCreatedTs ]
else return []
_ <- runDB $ update viewer_id [ UserReadApplications =. Just now ]
defaultLayout $(widgetFile "applications")
module Handler.Committee where
import Import
import Widgets.Sidebar
committeeForm :: UTCTime -> Entity User -> Form CommitteeApplication
committeeForm now (Entity user_id user) = renderBootstrap $
CommitteeApplication now user_id
<$> areq textField "Full name:" Nothing
<*> areq emailField "E-mail:" (Just . userIdent $ user)
<*> aopt textField "Other contact info (phone, chat ID, etc):" Nothing
<*> areq textField "Occupation:" Nothing
<*> areq textField "Location:" Nothing
<*> aopt textareaField "Relevant expertise:" Nothing
<*> areq textareaField "Personal statement (why you want to join the committee):" Nothing
<*> aopt textareaField "Any other comments:" Nothing
getCommitteeR :: Handler RepHtml
getCommitteeR = do
user <- requireAuth
now <- liftIO getCurrentTime
(committee_form, _) <- generateFormPost $ committeeForm now user
defaultLayout $(widgetFile "committee")
postCommitteeR :: Handler RepHtml
postCommitteeR = do
user <- requireAuth
now <- liftIO getCurrentTime
((result, _), _) <- runFormPost $ committeeForm now user
case result of
FormSuccess application -> do
_ <- runDB $ insert application
setMessage "application submitted"
redirect CommitteeR
_ -> do
setMessage "error submitting application"
redirect CommitteeR
module Handler.Contact where
import Import
import Widgets.Sidebar
contactForm :: Form Textarea
contactForm = renderDivs $ areq textareaField "" Nothing
getContactR :: Handler RepHtml
getContactR = do
(contact_form, _) <- generateFormPost contactForm
defaultLayout $(widgetFile "contact")
postContactR :: Handler RepHtml
postContactR = do
user_id <- requireAuthId
now <- liftIO getCurrentTime
((result, _), _) <- runFormPost contactForm
case result of
FormSuccess content -> do
_ <- runDB $ insert $ Message now user_id Nothing content
setMessage "Comment submitted. Thank you for your input!"
_ -> do
setMessage "Error occurred when submitting form."
redirect ContactR
module Handler.Faq where
import Import
-- import Widgets.Sidebar
getFaqR :: Handler RepHtml
getFaqR = do
setMessage "We don't have a list of frequently asked questions yet - hopefully the about page will answer yours."
redirect AboutR
{-# LANGUAGE TupleSections, OverloadedStrings #-}
module Handler.Home where
import Import
import Widgets.Sidebar
getHomeR :: Handler RepHtml
getHomeR = defaultLayout $(widgetFile "homepage")
module Handler.Invitation where
import Import
import Model.Role
import Widgets.Sidebar
getInvitationR :: Text -> Handler RepHtml
getInvitationR code = do
Entity invite_id invite <- runDB $ getBy404 $ UniqueInvite code
maybe_user_id <- maybeAuthId
when (maybe_user_id == Nothing)
setUltDestCurrent
alreadyExpired
let redeemed = inviteRedeemed invite || inviteRedeemedBy invite /= Nothing
defaultLayout $ $(widgetFile "invitation")
postInvitationR :: Text -> Handler RepHtml
postInvitationR code = do
viewer_id <- requireAuthId
now <- liftIO getCurrentTime
role <- runDB $ do
Entity invite_id invite <- getBy404 $ UniqueInvite code
if inviteRedeemed invite
then return Nothing
else do
update invite_id [ InviteRedeemed =. True
, InviteRedeemedTs =. Just now
, InviteRedeemedBy =. Just viewer_id
]
update viewer_id [ UserRole =. inviteRole invite ]
return $ Just $ inviteRole invite
redirect $ maybe (InvitationR code) roleDefaultTarget role
module Handler.Invite where
import Import
import System.Random
import Text.Printf
import Data.Text (pack, unpack)
import qualified Data.Map as M
import Data.Maybe (fromJust)
import Model.Role
import Widgets.Sidebar
inviteForm :: Role -> Form (Text, Role)
inviteForm role = renderBootstrap $ (,)
<$> areq textField "About this invitation:" Nothing
<*> areq (roleField role) "Type of Invite:" (Just GeneralPublic)
getInviteR :: Handler RepHtml
getInviteR = do
Entity viewer_id viewer <- requireAuth
now <- liftIO getCurrentTime
maybe_invite_code <- lookupSession "InviteCode"
maybe_invite_role <- fmap (read . unpack) <$> lookupSession "InviteRole"
deleteSession "InviteCode"
deleteSession "InviteRole"
let maybe_link = InvitationR <$> maybe_invite_code
(invite_form, _) <- generateFormPost $ inviteForm (userRole viewer)
let outstanding_invite_filter =
(case userRole viewer of
CommitteeMember -> []
Admin -> []
_ -> [ InviteUser ==. viewer_id ]
) ++ [ InviteRedeemed ==. False ]
redeemed_invite_filter =
(case userRole viewer of
CommitteeMember -> []
Admin -> []
_ -> [ InviteUser ==. viewer_id ]
) ++ [ InviteRedeemed ==. True ]
outstanding_invites <- runDB $ selectList outstanding_invite_filter [ Desc InviteCreatedTs ]
redeemed_invites <- runDB $ selectList redeemed_invite_filter [ Desc InviteRedeemedTs, LimitTo 20 ]
redeemed_users <- runDB $ selectList [ UserId <-. map (fromJust . inviteRedeemedBy . entityVal) redeemed_invites ] []
let redeemed_users_map = M.fromList $ map (\ (Entity a b) -> (a, b)) redeemed_users
let format_user Nothing = "NULL"
format_user (Just user_id) =
let user = redeemed_users_map M.! user_id
in fromMaybe (userIdent user) $ userName user
defaultLayout $(widgetFile "invite")
postInviteR :: Handler RepHtml
postInviteR = do
Entity user_id user <- requireAuth
now <- liftIO getCurrentTime
invite <- liftIO randomIO
((result, _), _) <- runFormPost $ inviteForm (userRole user)
case result of
FormSuccess (tag, role) -> do
let invite_code = pack $ printf "%016x" (invite :: Int64)
_ <- runDB $ insert $ Invite now invite_code user_id role tag False Nothing Nothing
setSession "InviteCode" invite_code
setSession "InviteRole" (pack $ show role)
_ -> setMessage "Error in submitting form."
redirect InviteR
module Handler.JsLicense where
import Import
import qualified Data.Text as T
import Yesod.Form.Jquery
data Lib =
Lib { libName :: Text
, libRoute :: Text
, libLicenseName :: Text
, libLicenseRoute :: Text
, libOrigName :: Text
, libOrigRoute :: Text
}
getJsLicenseR :: Handler RepHtml
getJsLicenseR = do
app <- getYesod
render <- getUrlRender
let jqueryUrl = either render id $ urlJqueryJs app
unMin lib = fromMaybe lib $ fmap (`T.append` "js") $ T.stripSuffix "min.js" $ fst $ T.breakOnEnd "?" lib
libs :: [Lib]
libs =
[ Lib "jquery.min.js" jqueryUrl "Expat License" "http://www.jclark.com/xml/copying.txt" "jquery.js" (unMin jqueryUrl)
, Lib "bootstrap.min.js" (render $ StaticR js_bootstrap_min_js) "Apache License, Version 2.0" "http://www.apache.org/licenses/LICENSE-2.0" "bootstrap.js" (render $ StaticR js_bootstrap_js)
, Lib "modernizr.js" (render $ StaticR js_modernizr_js) "Expat License" "http://www.jclark.com/xml/copying.txt" "modernizr.js" (render $ StaticR js_modernizr_js)
, Lib "include.js" "https://browserid.org/include.js" "Mozilla Public License Version 2.0" "http://www.mozilla.org/MPL/2.0/" "include.orig.js" "https://login.persona.org/include.orig.js"
, 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)
]
defaultLayout [whamlet|
<table .table id="jslicense-labels1">
$forall lib <- libs
<tr>
<td>
<a href="#{libRoute lib}">
#{libName lib}
<td>
<a href="#{libLicenseRoute lib}">
#{libLicenseName lib}
<td>
<a href="#{libOrigRoute lib}">
#{libOrigName lib}
|]
module Handler.MarkdownTutorial where
import Import
import Widgets.Sidebar
getMarkdownTutorialR :: Handler RepHtml
getMarkdownTutorialR = defaultLayout $(widgetFile "markdown")
module Handler.Messages where
import Import
import Model.Role
import Control.Arrow
import qualified Data.Map as M
import Widgets.Sidebar
getMessagesR :: Handler RepHtml
getMessagesR = do
Entity viewer_id viewer <- requireAuth
now <- liftIO getCurrentTime
messages <-
if userRole viewer == CommitteeMember || userRole viewer == Admin
then runDB $ selectList
( [ MessageTo ==. Just viewer_id ]
||. [ MessageTo ==. Nothing ]
) [ Desc MessageCreatedTs ]
else runDB $ selectList [ MessageTo ==. Just viewer_id ] [ Desc MessageCreatedTs ]
users <- runDB $ selectList [ UserId <-. map (messageFrom . entityVal) messages ] []
let user_map = M.fromList $ map (entityKey &&& entityVal) users
getUserName user_id =
let user = user_map M.! user_id
in fromMaybe (userIdent user) (userName user)
_ <- runDB $ update viewer_id [ UserReadMessages =. Just now ]
defaultLayout $(widgetFile "messages")
module Handler.PostLogin where
import Import
getPostLoginR :: Handler RepHtml
getPostLoginR = do
app <- getYesod
redirectUltDest $ loginDest app
module Handler.Privacy where
import Import
getPrivacyR :: Handler RepHtml
getPrivacyR = defaultLayout $(widgetFile "priv")
module Handler.Project where
import Import
import Model.Currency
import Model.Project
import Model.Shares
import Model.Markdown.Diff
import Model.Role
import qualified Data.Text as T
import Widgets.Sidebar
lookupGetParamDefault :: Read a => Text -> a -> Handler a
lookupGetParamDefault name def = do
maybe_value <- lookupGetParam name
return $ fromMaybe def $ maybe_value >>= readMaybe . T.unpack
getProjectsR :: Handler RepHtml
getProjectsR = do
page <- lookupGetParamDefault "page" 0
per_page <- lookupGetParamDefault "count" 20
projects <- runDB $ selectList [] [ Asc ProjectCreatedTs, LimitTo per_page, OffsetBy page ]
defaultLayout $(widgetFile "projects")
getProjectR :: ProjectId -> Handler RepHtml
getProjectR project_id = do
maybe_viewer_id <- maybeAuthId
(project, pledges, pledge) <- runDB $ do
project <- get404 project_id
pledges <- getProjectShares project_id
pledge <- case maybe_viewer_id of
Nothing -> return Nothing
Just viewer_id -> getBy $ UniquePledge viewer_id project_id
return (project, pledges, pledge)
let share_value = projectShareValue project
users = fromIntegral $ length pledges
shares = sum pledges
project_value = share_value $* (fromIntegral shares)
description = markdownToHtml $ projectDescription project
((_, update_shares), _) <- generateFormGet $ buySharesForm $ fromMaybe 0 $ pledgeShares . entityVal <$> pledge
defaultLayout $(widgetFile "project")
guardCanEdit :: ProjectId -> Entity User -> Handler ()
guardCanEdit project_id (Entity user_id user) =
when (userRole user /= Admin) $ do
match <- runDB $ selectList [ ProjectUserUser ==. user_id, ProjectUserProject ==. project_id, ProjectUserCanEdit ==. True ] [ LimitTo 1 ]
when (null match) $
permissionDenied "You do not have permission to edit this project."
data UpdateProject = UpdateProject { updateProjectName :: Text, updateDescription :: Markdown }
editProjectForm :: Maybe Project -> Form UpdateProject
editProjectForm project =
renderDivs $ UpdateProject
<$> areq textField "Project Name" (projectName <$> project)
<*> areq markdownField "Description" (projectDescription <$> project)
getEditProjectR :: ProjectId -> Handler RepHtml
getEditProjectR project_id = do
requireAuth >>= guardCanEdit project_id
project <- runDB $ get project_id
(project_form, _) <- generateFormPost $ editProjectForm project
defaultLayout $(widgetFile "edit_project")
postProjectR :: ProjectId -> Handler RepHtml
postProjectR project_id = do
viewer <- requireAuth
guardCanEdit project_id viewer
((result, _), _) <- runFormPost $ editProjectForm Nothing
now <- liftIO getCurrentTime
case result of
FormSuccess (UpdateProject name description) -> do
processed <- runDB $ do
maybe_project <- get project_id
case maybe_project of
Nothing -> return False
Just project -> do
when (projectDescription project /= description) $ do
project_update <- insert $ ProjectUpdate now project_id (entityKey viewer) $ diffMarkdown (projectDescription project) description
last_update <- getBy $ UniqueProjectLastUpdate project_id
case last_update of
Just (Entity key _) -> repsert key $ ProjectLastUpdate project_id project_update
Nothing -> (insert $ ProjectLastUpdate project_id project_update) >> return ()
update project_id [ ProjectName =. name, ProjectDescription =. description ]
return True
if processed
then setMessage "project updated"
else notFound
_ -> setMessage "error"
redirect $ ProjectR project_id
module Handler.Tos where
import Import
getTosR :: Handler RepHtml
getTosR = defaultLayout $(widgetFile "tos")
module Handler.UpdateShares where
import Import
import Model.Currency
import Model.Shares
import Model.Project