Commit b39983ea authored by Bryan Richter's avatar Bryan Richter

Merge branch 'release-0.1.0.1' into production

parents 960116ed 258cc422
...@@ -13,7 +13,9 @@ yesod-devel/ ...@@ -13,7 +13,9 @@ yesod-devel/
*.chs.h *.chs.h
codex.tags codex.tags
hscope.out hscope.out
/migrations *.tix
.hpc/
TAGS
# Intellij IDEA: # Intellij IDEA:
.idea .idea
......
...@@ -37,7 +37,7 @@ import System.Posix.Env.ByteString ...@@ -37,7 +37,7 @@ import System.Posix.Env.ByteString
import Yesod.Core.Types (loggerSet, Logger (Logger)) import Yesod.Core.Types (loggerSet, Logger (Logger))
import Yesod.Default.Config import Yesod.Default.Config
import Yesod.Default.Handlers import Yesod.Default.Handlers
import Yesod.Default.Main import Yesod.Default.Main hiding (LogFunc)
-- Import all relevant handler modules here. -- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file! -- Don't forget to add new modules to your cabal file!
...@@ -54,6 +54,7 @@ import Handler.Notification ...@@ -54,6 +54,7 @@ import Handler.Notification
import Handler.PostLogin import Handler.PostLogin
import Handler.Privacy import Handler.Privacy
import Handler.Project import Handler.Project
import Handler.Project.Signup
import Handler.ProjectBlog import Handler.ProjectBlog
import Handler.RepoFeed import Handler.RepoFeed
import Handler.ResetPassword import Handler.ResetPassword
...@@ -69,7 +70,7 @@ import Handler.Wiki.Comment ...@@ -69,7 +70,7 @@ import Handler.Wiki.Comment
import Widgets.Navbar import Widgets.Navbar
runSql :: MonadSqlPersist m => Text -> m () runSql :: MonadIO m => Text -> ReaderT SqlBackend m ()
runSql = flip rawExecute [] -- TODO quasiquoter? runSql = flip rawExecute [] -- TODO quasiquoter?
version :: (Text, Text) version :: (Text, Text)
...@@ -154,12 +155,10 @@ makeFoundation conf = do ...@@ -154,12 +155,10 @@ makeFoundation conf = do
-- Perform database migration using our application's logging settings. -- Perform database migration using our application's logging settings.
case appEnv conf of case appEnv conf of
Testing -> withEnv "PGDATABASE" "template1" (applyEnv $ persistConfig foundation) >>= \ dbconf' -> do Testing -> withEnv "PGDATABASE" "template1" (applyEnv $ persistConfig foundation) >>= \ dbconf' -> do
let runDBNoTransaction (SqlPersistT r) = runReaderT r
options <- maybe [] L.words <$> lookupEnv "SNOWDRIFT_TESTING_OPTIONS" options <- maybe [] L.words <$> lookupEnv "SNOWDRIFT_TESTING_OPTIONS"
unless (elem "nodrop" options) $ do unless (elem "nodrop" options) $ do
runStderrLoggingT $ runResourceT $ withPostgresqlConn (pgConnStr dbconf') $ runDBNoTransaction $ do runStderrLoggingT $ runResourceT $ withPostgresqlConn (pgConnStr dbconf') $ runReaderT $ do
liftIO $ putStrLn "dropping database..." liftIO $ putStrLn "dropping database..."
runSql "DROP DATABASE IF EXISTS snowdrift_test;" runSql "DROP DATABASE IF EXISTS snowdrift_test;"
liftIO $ putStrLn "creating database..." liftIO $ putStrLn "creating database..."
...@@ -172,7 +171,7 @@ makeFoundation conf = do ...@@ -172,7 +171,7 @@ makeFoundation conf = do
runSqlPool migrateTriggers p runSqlPool migrateTriggers p
runLoggingT void $ runLoggingT
migration migration
(messageLoggerSource foundation logger) (messageLoggerSource foundation logger)
...@@ -255,8 +254,8 @@ doMigration = do ...@@ -255,8 +254,8 @@ doMigration = do
maybe (return ()) (\ newer_last_migration -> update $ flip set [ DatabaseVersionLastMigration =. val newer_last_migration ]) maybe_newer_last_migration maybe (return ()) (\ newer_last_migration -> update $ flip set [ DatabaseVersionLastMigration =. val newer_last_migration ]) maybe_newer_last_migration
migrateTriggers :: (MonadSqlPersist m, MonadBaseControl IO m, MonadThrow m) => m () migrateTriggers :: MonadIO m => ReaderT SqlBackend m ()
migrateTriggers = runResourceT $ do migrateTriggers = do
runSql $ T.unlines runSql $ T.unlines
[ "CREATE OR REPLACE FUNCTION log_role_event_trigger() RETURNS trigger AS $role_event$" [ "CREATE OR REPLACE FUNCTION log_role_event_trigger() RETURNS trigger AS $role_event$"
, " BEGIN" , " BEGIN"
......
...@@ -12,7 +12,8 @@ import qualified Data.Set as S ...@@ -12,7 +12,8 @@ import qualified Data.Set as S
-- TODO: allow for building custom SQL queries based on filters -- TODO: allow for building custom SQL queries based on filters
data Filterable = Filterable data Filterable = Filterable
{ hasTag :: Text -> Bool { isClaimed :: Text -> Bool
, hasTag :: Text -> Bool
, getNamedTs :: Text -> Set UTCTime , getNamedTs :: Text -> Set UTCTime
, searchLiteral :: Text -> Bool , searchLiteral :: Text -> Bool
} }
...@@ -44,10 +45,18 @@ notTermP = stripP $ (not.) <$> (notP *> termP) <|> termP ...@@ -44,10 +45,18 @@ notTermP = stripP $ (not.) <$> (notP *> termP) <|> termP
termP :: Parser (Filterable -> Bool) termP :: Parser (Filterable -> Bool)
termP = stripP $ termP = stripP $
tagP claimedP
<|> unclaimedP
<|> tagP
<|> timeConstraintP <|> timeConstraintP
<|> "(" *> expressionP <* ")" <|> "(" *> expressionP <* ")"
claimedP :: Parser (Filterable -> Bool)
claimedP = flip isClaimed <$> stripP "CLAIMED"
unclaimedP :: Parser (Filterable -> Bool)
unclaimedP = (\x y -> not $ isClaimed y x) <$> stripP "UNCLAIMED"
timeConstraintP :: Parser (Filterable -> Bool) timeConstraintP :: Parser (Filterable -> Bool)
timeConstraintP = timeConstraintP =
foldl1 (<|>) $ [before, after, between] <*> ["CREATED", "LAST UPDATED"] foldl1 (<|>) $ [before, after, between] <*> ["CREATED", "LAST UPDATED"]
......
...@@ -12,7 +12,8 @@ import qualified Data.Set as S ...@@ -12,7 +12,8 @@ import qualified Data.Set as S
-- import Data.Time -- import Data.Time
data Orderable = Orderable data Orderable = Orderable
{ hasTag :: Text -> Bool { isClaimed :: Text -> Bool
, hasTag :: Text -> Bool
, getNamedTs :: Text -> Set UTCTime , getNamedTs :: Text -> Set UTCTime
, searchLiteral :: Text -> Bool , searchLiteral :: Text -> Bool
} }
...@@ -57,11 +58,21 @@ expTermP = stripP $ foldl (c (**)) <$> termP <*> many (stripP "^" *> termP) ...@@ -57,11 +58,21 @@ expTermP = stripP $ foldl (c (**)) <$> termP <*> many (stripP "^" *> termP)
termP :: Parser (Orderable -> Double) termP :: Parser (Orderable -> Double)
termP = stripP $ termP = stripP $
tagP claimedP
<|> unclaimedP
<|> tagP
<|> const <$> double <|> const <$> double
<|> timeValueP <|> timeValueP
<|> "(" *> expressionP <* ")" <|> "(" *> expressionP <* ")"
(<?$>) :: (Orderable -> a -> Bool) -> Parser a -> Parser (Orderable -> Double)
f <?$> p = (\x y -> if f y x then 1 else 0) <$> p
claimedP :: Parser (Orderable -> Double)
claimedP = isClaimed <?$> stripP "CLAIMED"
unclaimedP :: Parser (Orderable -> Double)
unclaimedP = (\y x -> not $ isClaimed y x) <?$> stripP "UNCLAIMED"
toTimeValue :: UTCTime -> Double toTimeValue :: UTCTime -> Double
toTimeValue = (/ 86400 {- seconds per day -}) . fromIntegral . (id :: Integer -> Integer) . round . diffUTCTime epoch toTimeValue = (/ 86400 {- seconds per day -}) . fromIntegral . (id :: Integer -> Integer) . round . diffUTCTime epoch
...@@ -101,7 +112,5 @@ timeConstraintP = ...@@ -101,7 +112,5 @@ timeConstraintP =
timeP :: Parser UTCTime timeP :: Parser UTCTime
timeP = fmap (`UTCTime` 0) $ stripP $ fromGregorian <$> (read <$> A.count 4 digit) <* "-" <*> (read <$> A.count 2 digit) <* "-" <*> (read <$> A.count 2 digit) timeP = fmap (`UTCTime` 0) $ stripP $ fromGregorian <$> (read <$> A.count 4 digit) <* "-" <*> (read <$> A.count 2 digit) <* "-" <*> (read <$> A.count 2 digit)
tagP :: Parser (Orderable -> Double) tagP :: Parser (Orderable -> Double)
tagP = (\ x y -> if hasTag y x then 1 else 0) <$> takeWhile1 (inClass "a-z-") tagP = hasTag <?$> takeWhile1 (inClass "a-z-")
...@@ -9,25 +9,27 @@ import Data.Attoparsec.Text ...@@ -9,25 +9,27 @@ import Data.Attoparsec.Text
import qualified Text.Blaze.Html5.Attributes as Attr import qualified Text.Blaze.Html5.Attributes as Attr
import qualified Text.Blaze.Html5 as Html import qualified Text.Blaze.Html5 as Html
import Data.Either
import Data.List as L import Data.List as L
import Data.String import Data.String
import Data.Text as T import Data.Text as T
import Control.Applicative import Control.Applicative
unlinesHtml :: [Html] -> Html unlinesHtml :: [Html] -> Html
unlinesHtml = sequence_ . L.intersperse Html.br unlinesHtml = sequence_ . L.intersperse Html.br
-- | Single step of a 'Data.List.foldr' to concatenate 'Right's in an 'Either'
-- and remove empty 'Right's.
concatRights :: Either a T.Text -> [Either a T.Text] -> [Either a T.Text]
concatRights (Right y) xs | T.null y = xs
concatRights (Right y) (Right x : xs) = Right (y `T.append` x) : xs
concatRights y xs = y : xs
prettyHtml :: (Monad m, HasGithubRepo (HandlerT site m)) => [Parser Pretty] -> Text -> HandlerT site m Html prettyHtml :: (Monad m, HasGithubRepo (HandlerT site m)) => [Parser Pretty] -> Text -> HandlerT site m Html
prettyHtml filters text = prettyHtml filters text =
case parseOnly (many $ (Left <$> choice filters) <|> (Right . T.singleton <$> anyChar)) text of case parseOnly (many $ (Left <$> choice filters) <|> (Right . T.singleton <$> anyChar)) text of
Right result -> do Right result -> do
let regroup = L.concatMap $ \(a, b) -> L.map Left a ++ [Right b | T.length b > 0] let pieces = L.foldr concatRights [] result
splitUp = fmap (fmap T.concat . partitionEithers) . L.groupBy ((==) `on` isRight)
pieces = regroup . splitUp $ result
fmap sequence_ $ forM pieces $ either renderPretty (return . toHtml) fmap sequence_ $ forM pieces $ either renderPretty (return . toHtml)
......
...@@ -23,7 +23,7 @@ import Control.Monad.Writer.Strict (WriterT, runWriterT) ...@@ -23,7 +23,7 @@ import Control.Monad.Writer.Strict (WriterT, runWriterT)
import qualified Data.ByteString.Lazy.Char8 as LB import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isSpace) import Data.Char (isSpace)
import Data.Int (Int64) import Data.Int (Int64)
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe, fromMaybe)
import Data.Monoid import Data.Monoid
import Data.Time import Data.Time
import Data.Text as T import Data.Text as T
...@@ -99,8 +99,8 @@ mkYesodData "App" $(parseRoutesFile "config/routes") ...@@ -99,8 +99,8 @@ mkYesodData "App" $(parseRoutesFile "config/routes")
type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget) type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
licenseText :: LB.ByteString licenseNotice :: LB.ByteString
licenseText = E.encodeUtf8 $ renderJavascriptUrl (\ _ _ -> T.empty) [julius| licenseNotice = E.encodeUtf8 $ renderJavascriptUrl (\ _ _ -> T.empty) [julius|
/* /*
@licstart The following is the entire license notice for the JavaScript code in this page. @licstart The following is the entire license notice for the JavaScript code in this page.
...@@ -206,8 +206,8 @@ instance Yesod App where ...@@ -206,8 +206,8 @@ instance Yesod App where
if LB.all isSpace content if LB.all isSpace content
then return Nothing then return Nothing
else else
let license = either Left (Right . LB.append licenseText) let license = either Left (Right . LB.append licenseNotice)
in addStaticContentExternal (license . minifym) base64md5 Settings.staticDir (StaticR . flip StaticRoute []) extension mime (LB.append licenseText content) in addStaticContentExternal (license . minifym) base64md5 Settings.staticDir (StaticR . flip StaticRoute []) extension mime (LB.append licenseNotice content)
-- Place Javascript at bottom of the body tag so the rest of the page loads first -- Place Javascript at bottom of the body tag so the rest of the page loads first
jsLoader _ = BottomOfBody jsLoader _ = BottomOfBody
...@@ -222,7 +222,7 @@ instance Yesod App where ...@@ -222,7 +222,7 @@ instance Yesod App where
-- How to run database actions. -- How to run database actions.
instance YesodPersist App where instance YesodPersist App where
type YesodPersistBackend App = SqlPersistT type YesodPersistBackend App = SqlBackend
runDB = defaultRunDB persistConfig connPool runDB = defaultRunDB persistConfig connPool
instance YesodPersistRunner App where instance YesodPersistRunner App where
...@@ -230,7 +230,7 @@ instance YesodPersistRunner App where ...@@ -230,7 +230,7 @@ instance YesodPersistRunner App where
-- set which project in the site runs the site itself -- set which project in the site runs the site itself
getSiteProject :: Handler (Entity Project) getSiteProject :: Handler (Entity Project)
getSiteProject = maybe (error "No project has been defined as the owner of this website.") id <$> getSiteProject = fromMaybe (error "No project has been defined as the owner of this website.") <$>
(getSiteProjectHandle >>= runYDB . getBy . UniqueProjectHandle) (getSiteProjectHandle >>= runYDB . getBy . UniqueProjectHandle)
getSiteProjectHandle :: Handler Text getSiteProjectHandle :: Handler Text
...@@ -348,6 +348,7 @@ instance YesodAuth App where ...@@ -348,6 +348,7 @@ instance YesodAuth App where
lift $ defaultLayout $(widgetFile "auth") lift $ defaultLayout $(widgetFile "auth")
instance YesodAuthPersist App
createUser :: Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text createUser :: Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text
-> Maybe Text -> Handler (Maybe UserId) -> Maybe Text -> Handler (Maybe UserId)
...@@ -374,7 +375,7 @@ createUser ident passwd name email avatar nick = do ...@@ -374,7 +375,7 @@ createUser ident passwd name email avatar nick = do
insertDefaultNotificationPrefs user_id insertDefaultNotificationPrefs user_id
welcome_route <- getUrlRender welcome_route <- getUrlRender
-- 'MonolingualWikiR' is deprecated. -- 'MonolingualWikiR' is deprecated.
<*> (pure $ MonolingualWikiR "snowdrift" "welcome" []) <*> pure (MonolingualWikiR "snowdrift" "welcome" [])
let notif_text = Markdown $ T.unlines let notif_text = Markdown $ T.unlines
[ "Thanks for registering!" [ "Thanks for registering!"
, "<br> Please read our [**welcome message**](" <> , "<br> Please read our [**welcome message**](" <>
......
This diff is collapsed.
...@@ -356,7 +356,7 @@ postCloseComment user@(Entity user_id _) comment_id comment make_comment_handler ...@@ -356,7 +356,7 @@ postCloseComment user@(Entity user_id _) comment_id comment make_comment_handler
lookupPostMode >>= \case lookupPostMode >>= \case
Just PostMode -> do Just PostMode -> do
runSDB $ do runSDB $ do
closing_id <- insert closing closing_id <- lift $ insert closing
tell [ECommentClosed closing_id closing] tell [ECommentClosed closing_id closing]
return Nothing return Nothing
...@@ -396,13 +396,20 @@ postEditComment ...@@ -396,13 +396,20 @@ postEditComment
-> Entity Comment -> Entity Comment
-> (CommentMods -> CommentHandlerInfo) -> (CommentMods -> CommentHandlerInfo)
-> Handler (Maybe (Widget, Widget)) -> Handler (Maybe (Widget, Widget))
postEditComment user (Entity comment_id comment) make_comment_handler_info = do postEditComment user@(Entity user_id _) (Entity comment_id comment) make_comment_handler_info = do
((result, _), _) <- runFormPost (editCommentForm "" (commentLanguage comment)) ((result, _), _) <- runFormPost (editCommentForm "" (commentLanguage comment))
case result of case result of
FormSuccess (EditComment new_text new_language) -> lookupPostMode >>= \case FormSuccess (EditComment new_text new_language) -> lookupPostMode >>= \case
Just PostMode -> do Just PostMode -> do
runSYDB (editCommentDB comment_id new_text new_language) let c = countMatches T.isPrefixOf "ticket:" $
alertSuccess "posted new edit" T.lines $ unMarkdown new_text
if c > 1
then alertDanger $
"each comment must contain at most one ticket; " <>
"found " <> T.pack (show c)
else do
runSYDB (editCommentDB user_id comment_id new_text new_language)
alertSuccess "posted new edit"
return Nothing return Nothing
_ -> do _ -> do
(form, _) <- generateFormPost (editCommentForm new_text new_language) (form, _) <- generateFormPost (editCommentForm new_text new_language)
...@@ -499,7 +506,7 @@ postNewComment mparent_id (Entity user_id user) discussion_id make_permissions_m ...@@ -499,7 +506,7 @@ postNewComment mparent_id (Entity user_id user) discussion_id make_permissions_m
then (Just now, Just user_id) then (Just now, Just user_id)
else (Nothing, Nothing) else (Nothing, Nothing)
comment = Entity comment = Entity
(Key $ PersistInt64 0) (key $ PersistInt64 0)
(Comment now approved_ts approved_by discussion_id mparent_id user_id contents depth visibility language) (Comment now approved_ts approved_by discussion_id mparent_id user_id contents depth visibility language)
max_depth <- getMaxDepthDefault 0 max_depth <- getMaxDepthDefault 0
...@@ -630,13 +637,13 @@ postRetractComment user comment_id comment make_comment_handler_info = do ...@@ -630,13 +637,13 @@ postRetractComment user comment_id comment make_comment_handler_info = do
_ -> error "Error when submitting form." _ -> error "Error when submitting form."
postUnclaimComment :: Entity User -> CommentId -> Comment -> (CommentMods -> CommentHandlerInfo) -> Handler (Maybe (Widget, Widget)) postUnclaimComment :: Entity User -> CommentId -> Comment -> (CommentMods -> CommentHandlerInfo) -> Handler (Maybe (Widget, Widget))
postUnclaimComment user@(Entity user_id _) comment_id comment make_comment_handler_info = do postUnclaimComment user comment_id comment make_comment_handler_info = do
((result, _), _) <- runFormPost (claimCommentForm Nothing) ((result, _), _) <- runFormPost (claimCommentForm Nothing)
case result of case result of
FormSuccess mnote -> do FormSuccess mnote -> do
lookupPostMode >>= \case lookupPostMode >>= \case
Just PostMode -> do Just PostMode -> do
runSDB (userUnclaimCommentDB user_id comment_id mnote) runSDB (userUnclaimCommentDB comment_id mnote)
return Nothing return Nothing
_ -> do _ -> do
(form, _) <- generateFormPost (claimCommentForm (Just mnote)) (form, _) <- generateFormPost (claimCommentForm (Just mnote))
......
...@@ -19,4 +19,5 @@ postHonorPledgeR = do ...@@ -19,4 +19,5 @@ postHonorPledgeR = do
runDB $ establishUserDB user_id elig_time reason runDB $ establishUserDB user_id elig_time reason
setMessage "Congratulations, you are now a fully established user!" setMessage "Congratulations, you are now a fully established user!"
redirect HomeR redirect HomeR
--TODO: add "already established" error for that case
_ -> error "You're not eligible for establishment." _ -> error "You're not eligible for establishment."
...@@ -22,7 +22,7 @@ getNotificationsR = do ...@@ -22,7 +22,7 @@ getNotificationsR = do
whenNotifId :: DBConstraint m => Text -> (NotificationId -> m ()) -> m () whenNotifId :: DBConstraint m => Text -> (NotificationId -> m ()) -> m ()
whenNotifId value action = whenNotifId value action =
F.forM_ (readMaybe $ T.unpack value :: Maybe Int) $ \notif_id -> F.forM_ (readMaybe $ T.unpack value :: Maybe Int) $ \notif_id ->
action $ Key $ toPersistValue notif_id action $ key $ toPersistValue notif_id
proxyNotifications :: RedirectUrl App route => Text -> Text proxyNotifications :: RedirectUrl App route => Text -> Text
-> (UserId -> DB ()) -> (UserId -> DB ()) -> (UserId -> DB ()) -> (UserId -> DB ())
......
...@@ -28,7 +28,6 @@ import Model.User ...@@ -28,7 +28,6 @@ import Model.User
import Model.Wiki import Model.Wiki
import System.Locale (defaultTimeLocale) import System.Locale (defaultTimeLocale)
import View.Comment import View.Comment
import View.PledgeButton
import View.Project import View.Project
import View.SnowdriftEvent import View.SnowdriftEvent
import Widgets.Preview import Widgets.Preview
...@@ -236,7 +235,7 @@ postProjectR project_handle = do ...@@ -236,7 +235,7 @@ postProjectR project_handle = do
project_update <- insert $ ProjectUpdate now project_id viewer_id $ diffMarkdown (projectDescription project) description project_update <- insert $ ProjectUpdate now project_id viewer_id $ diffMarkdown (projectDescription project) description
last_update <- getBy $ UniqueProjectLastUpdate project_id last_update <- getBy $ UniqueProjectLastUpdate project_id
case last_update of case last_update of
Just (Entity key _) -> repsert key $ ProjectLastUpdate project_id project_update Just (Entity k _) -> repsert k $ ProjectLastUpdate project_id project_update
Nothing -> void $ insert $ ProjectLastUpdate project_id project_update Nothing -> void $ insert $ ProjectLastUpdate project_id project_update
update $ \ p -> do update $ \ p -> do
...@@ -273,7 +272,7 @@ postProjectR project_handle = do ...@@ -273,7 +272,7 @@ postProjectR project_handle = do
redirect $ ProjectR project_handle redirect $ ProjectR project_handle
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- /application -- /applications (List of submitted applications)
getApplicationsR :: Text -> Handler Html getApplicationsR :: Text -> Handler Html
getApplicationsR project_handle = do getApplicationsR project_handle = do
...@@ -293,6 +292,9 @@ getApplicationsR project_handle = do ...@@ -293,6 +292,9 @@ getApplicationsR project_handle = do
setTitle . toHtml $ projectName project <> " Volunteer Applications | Snowdrift.coop" setTitle . toHtml $ projectName project <> " Volunteer Applications | Snowdrift.coop"
$(widgetFile "applications") $(widgetFile "applications")
--------------------------------------------------------------------------------
-- /application (Form for new application)
getApplicationR :: Text -> VolunteerApplicationId -> Handler Html getApplicationR :: Text -> VolunteerApplicationId -> Handler Html
getApplicationR project_handle application_id = do getApplicationR project_handle application_id = do
viewer_id <- requireAuthId viewer_id <- requireAuthId
...@@ -312,20 +314,6 @@ getApplicationR project_handle application_id = do ...@@ -312,20 +314,6 @@ getApplicationR project_handle application_id = do
setTitle . toHtml $ projectName project <> " Volunteer Application - " <> userDisplayName user <> " | Snowdrift.coop" setTitle . toHtml $ projectName project <> " Volunteer Application - " <> userDisplayName user <> " | Snowdrift.coop"
$(widgetFile "application") $(widgetFile "application")
--------------------------------------------------------------------------------
-- /button.png
getProjectPledgeButtonR :: Text -> Handler TypedContent
getProjectPledgeButtonR project_handle = do
pledges <- runYDB $ do
Entity project_id _project <- getBy404 $ UniqueProjectHandle project_handle
getProjectShares project_id
let png = overlayImage blankPledgeButton $
fillInPledgeCount (fromIntegral (length pledges))
respond "image/png" png
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- /edit -- /edit
...@@ -507,6 +495,8 @@ getProjectFeedR project_handle = do ...@@ -507,6 +495,8 @@ getProjectFeedR project_handle = do
provideRep $ atomFeed feed provideRep $ atomFeed feed
provideRep $ rssFeed feed provideRep $ rssFeed feed
provideRep $ defaultLayout $ do provideRep $ defaultLayout $ do
setTitle . toHtml $
projectName project <> " - Feed | Snowdrift.coop"
$(widgetFile "project_feed") $(widgetFile "project_feed")
toWidget $(cassiusFile "templates/comment.cassius") toWidget $(cassiusFile "templates/comment.cassius")
...@@ -641,10 +631,11 @@ getUpdateSharesR project_handle = do ...@@ -641,10 +631,11 @@ getUpdateSharesR project_handle = do
Entity project_id project <- runYDB $ getBy404 $ UniqueProjectHandle project_handle Entity project_id project <- runYDB $ getBy404 $ UniqueProjectHandle project_handle
((result, _), _) <- runFormGet $ pledgeForm project_id ((result, _), _) <- runFormGet $ pledgeForm project_id
let dangerRedirect msg = do
alertDanger msg
redirect $ ProjectR project_handle
case result of case result of
FormSuccess (SharesPurchaseOrder new_user_shares) -> do FormSuccess (SharesPurchaseOrder new_user_shares) -> do
-- TODO - refuse negative
user_id <- requireAuthId user_id <- requireAuthId
(confirm_form, _) <- generateFormPost $ projectConfirmSharesForm (Just new_user_shares) (confirm_form, _) <- generateFormPost $ projectConfirmSharesForm (Just new_user_shares)
...@@ -689,9 +680,9 @@ getUpdateSharesR project_handle = do ...@@ -689,9 +680,9 @@ getUpdateSharesR project_handle = do
setTitle . toHtml $ projectName project <> " - update pledge | Snowdrift.coop" setTitle . toHtml $ projectName project <> " - update pledge | Snowdrift.coop"
$(widgetFile "update_shares") $(widgetFile "update_shares")
FormMissing -> defaultLayout [whamlet| form missing |] FormMissing -> dangerRedirect "Form missing."
FormFailure _ -> defaultLayout [whamlet| form failure |] FormFailure errors ->
dangerRedirect $ T.snoc (T.intercalate "; " errors) '.'
postUpdateSharesR :: Text -> Handler Html postUpdateSharesR :: Text -> Handler Html
postUpdateSharesR project_handle = do postUpdateSharesR project_handle = do
...@@ -700,8 +691,6 @@ postUpdateSharesR project_handle = do ...@@ -700,8 +691,6 @@ postUpdateSharesR project_handle = do
case result of case result of
FormSuccess (SharesPurchaseOrder shares) -> do FormSuccess (SharesPurchaseOrder shares) -> do
-- TODO - refuse negative
if isConfirmed if isConfirmed
then do then do
Just pledge_render_id <- fmap (read . T.unpack) <$> lookupSession pledgeRenderKey Just pledge_render_id <- fmap (read . T.unpack) <$> lookupSession pledgeRenderKey
...@@ -1264,4 +1253,3 @@ postNewProjectDiscussionR project_handle = do ...@@ -1264,4 +1253,3 @@ postNewProjectDiscussionR project_handle = do
(makeProjectCommentActionPermissionsMap (Just user) project_handle def) >>= \case (makeProjectCommentActionPermissionsMap (Just user) project_handle def) >>= \case
Left comment_id -> redirect (ProjectCommentR project_handle comment_id) Left comment_id -> redirect (ProjectCommentR project_handle comment_id)
Right (widget, form) -> defaultLayout $ previewWidget form "post" (projectDiscussionPage project_handle widget) Right (widget, form) -> defaultLayout $ previewWidget form "post" (projectDiscussionPage project_handle widget)
module Handler.Project.Signup where
import Import
import Model.License (fetchLicensesDB)
import View.Project.Signup (projectSignupForm)
getProjectSignupR :: Handler Html
getProjectSignupR = do
licenses <- runDB fetchLicensesDB
render <- getUrlRender
(project_signup_form, _) <- generateFormPost $
projectSignupForm render licenses
defaultLayout $ do
setTitle "Project Sign Up | Snowdrift.coop"
$(widgetFile "project_signup")
postProjectSignupR :: Handler Html
postProjectSignupR = do
licenses <- runDB fetchLicensesDB
render <- getUrlRender
((result, project_signup_form), _) <- runFormPost $
projectSignupForm render licenses
case result of
FormSuccess res -> do
runDB $ insert_ res
alertSuccess "Application submitted"
redirect HomeR
FormMissing -> do
alertDanger "No data provided"
defaultLayout $(widgetFile "project_signup")
FormFailure _ -> do
alertDanger "Form failure"
defaultLayout $(widgetFile "project_signup")
...@@ -49,8 +49,8 @@ checkComment' muser_id project_handle post_name comment_id = do ...@@ -49,8 +49,8 @@ checkComment' muser_id project_handle post_name comment_id = do