Skip to content

Snowdrift
Snowdrift
Commit b39983ea authored by Bryan Richter's avatar Bryan Richter
Browse files
Options

Merge branch 'release-0.1.0.1' into production

parents 960116ed 258cc422
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 2646 additions and 1191 deletions
.gitignore
View file @ b39983ea
......@@ -13,7 +13,9 @@ yesod-devel/
*.chs.h
codex.tags
hscope.out
/migrations
*.tix
.hpc/
TAGS
# Intellij IDEA:
.idea
......
Application.hs
View file @ b39983ea
......@@ -37,7 +37,7 @@ import System.Posix.Env.ByteString
import Yesod.Core.Types (loggerSet, Logger (Logger))
import Yesod.Default.Config
import Yesod.Default.Handlers
import Yesod.Default.Main
import Yesod.Default.Main hiding (LogFunc)
-- Import all relevant handler modules here.
-- Don't forget to add new modules to your cabal file!
......@@ -54,6 +54,7 @@ import Handler.Notification
import Handler.PostLogin
import Handler.Privacy
import Handler.Project
import Handler.Project.Signup
import Handler.ProjectBlog
import Handler.RepoFeed
import Handler.ResetPassword
......@@ -69,7 +70,7 @@ import Handler.Wiki.Comment
import Widgets.Navbar
runSql :: MonadSqlPersist m => Text -> m ()
runSql :: MonadIO m => Text -> ReaderT SqlBackend m ()
runSql = flip rawExecute [] -- TODO quasiquoter?
version :: (Text, Text)
......@@ -154,12 +155,10 @@ makeFoundation conf = do
-- Perform database migration using our application's logging settings.
case appEnv conf of
Testing -> withEnv "PGDATABASE" "template1" (applyEnv $ persistConfig foundation) >>= \ dbconf' -> do
let runDBNoTransaction (SqlPersistT r) = runReaderT r
options <- maybe [] L.words <$> lookupEnv "SNOWDRIFT_TESTING_OPTIONS"
unless (elem "nodrop" options) $ do
runStderrLoggingT $ runResourceT $ withPostgresqlConn (pgConnStr dbconf') $ runDBNoTransaction $ do
runStderrLoggingT $ runResourceT $ withPostgresqlConn (pgConnStr dbconf') $ runReaderT $ do
liftIO $ putStrLn "dropping database..."
runSql "DROP DATABASE IF EXISTS snowdrift_test;"
liftIO $ putStrLn "creating database..."
......@@ -172,7 +171,7 @@ makeFoundation conf = do
runSqlPool migrateTriggers p
runLoggingT
void $ runLoggingT
migration
(messageLoggerSource foundation logger)
......@@ -255,8 +254,8 @@ doMigration = do
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 = runResourceT $ do
migrateTriggers :: MonadIO m => ReaderT SqlBackend m ()
migrateTriggers = do
runSql $ T.unlines
[ "CREATE OR REPLACE FUNCTION log_role_event_trigger() RETURNS trigger AS $role_event$"
, " BEGIN"
......
Data/Filter.hs
View file @ b39983ea
......@@ -12,7 +12,8 @@ import qualified Data.Set as S
-- TODO: allow for building custom SQL queries based on filters
data Filterable = Filterable
{ hasTag :: Text -> Bool
{ isClaimed :: Text -> Bool
, hasTag :: Text -> Bool
, getNamedTs :: Text -> Set UTCTime
, searchLiteral :: Text -> Bool
}
......@@ -44,10 +45,18 @@ notTermP = stripP $ (not.) <$> (notP *> termP) <|> termP
termP :: Parser (Filterable -> Bool)
termP = stripP $
tagP
claimedP
<|> unclaimedP
<|> tagP
<|> timeConstraintP
<|> "(" *> 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 =
foldl1 (<|>) $ [before, after, between] <*> ["CREATED", "LAST UPDATED"]
......
Data/Order.hs
View file @ b39983ea
......@@ -12,7 +12,8 @@ import qualified Data.Set as S
-- import Data.Time
data Orderable = Orderable
{ hasTag :: Text -> Bool
{ isClaimed :: Text -> Bool
, hasTag :: Text -> Bool
, getNamedTs :: Text -> Set UTCTime
, searchLiteral :: Text -> Bool
}
......@@ -57,11 +58,21 @@ expTermP = stripP $ foldl (c (**)) <$> termP <*> many (stripP "^" *> termP)
termP :: Parser (Orderable -> Double)
termP = stripP $
tagP
claimedP
<|> unclaimedP
<|> tagP
<|> const <$> double
<|> timeValueP
<|> "(" *> 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 = (/ 86400 {- seconds per day -}) . fromIntegral . (id :: Integer -> Integer) . round . diffUTCTime epoch
......@@ -101,7 +112,5 @@ timeConstraintP =
timeP :: Parser UTCTime
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 = (\ x y -> if hasTag y x then 1 else 0) <$> takeWhile1 (inClass "a-z-")
tagP = hasTag <?$> takeWhile1 (inClass "a-z-")
Data/Text/PrettyHtml.hs
View file @ b39983ea
......@@ -9,25 +9,27 @@ import Data.Attoparsec.Text
import qualified Text.Blaze.Html5.Attributes as Attr
import qualified Text.Blaze.Html5 as Html
import Data.Either
import Data.List as L
import Data.String
import Data.Text as T
import Control.Applicative
unlinesHtml :: [Html] -> Html
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 filters text =
case parseOnly (many $ (Left <$> choice filters) <|> (Right . T.singleton <$> anyChar)) text of
Right result -> do
let regroup = L.concatMap $ \(a, b) -> L.map Left a ++ [Right b | T.length b > 0]
splitUp = fmap (fmap T.concat . partitionEithers) . L.groupBy ((==) `on` isRight)
pieces = regroup . splitUp $ result
let pieces = L.foldr concatRights [] result
fmap sequence_ $ forM pieces $ either renderPretty (return . toHtml)
......
Foundation.hs
View file @ b39983ea
......@@ -23,7 +23,7 @@ import Control.Monad.Writer.Strict (WriterT, runWriterT)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Char (isSpace)
import Data.Int (Int64)
import Data.Maybe (mapMaybe)
import Data.Maybe (mapMaybe, fromMaybe)
import Data.Monoid
import Data.Time
import Data.Text as T
......@@ -99,8 +99,8 @@ mkYesodData "App" $(parseRoutesFile "config/routes")
type Form x = Html -> MForm (HandlerT App IO) (FormResult x, Widget)
licenseText :: LB.ByteString
licenseText = E.encodeUtf8 $ renderJavascriptUrl (\ _ _ -> T.empty) [julius|
licenseNotice :: LB.ByteString
licenseNotice = E.encodeUtf8 $ renderJavascriptUrl (\ _ _ -> T.empty) [julius|
/*
@licstart The following is the entire license notice for the JavaScript code in this page.
......@@ -206,8 +206,8 @@ instance Yesod App where
if LB.all isSpace content
then return Nothing
else
let license = either Left (Right . LB.append licenseText)
in addStaticContentExternal (license . minifym) base64md5 Settings.staticDir (StaticR . flip StaticRoute []) extension mime (LB.append licenseText content)
let license = either Left (Right . LB.append licenseNotice)
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
jsLoader _ = BottomOfBody
......@@ -222,7 +222,7 @@ instance Yesod App where
-- How to run database actions.
instance YesodPersist App where
type YesodPersistBackend App = SqlPersistT
type YesodPersistBackend App = SqlBackend
runDB = defaultRunDB persistConfig connPool
instance YesodPersistRunner App where
......@@ -230,7 +230,7 @@ instance YesodPersistRunner App where
-- set which project in the site runs the site itself
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 :: Handler Text
......@@ -348,6 +348,7 @@ instance YesodAuth App where
lift $ defaultLayout $(widgetFile "auth")
instance YesodAuthPersist App
createUser :: Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text
-> Maybe Text -> Handler (Maybe UserId)
......@@ -374,7 +375,7 @@ createUser ident passwd name email avatar nick = do
insertDefaultNotificationPrefs user_id
welcome_route <- getUrlRender
-- 'MonolingualWikiR' is deprecated.
<*> (pure $ MonolingualWikiR "snowdrift" "welcome" [])
<*> pure (MonolingualWikiR "snowdrift" "welcome" [])
let notif_text = Markdown $ T.unlines
[ "Thanks for registering!"
, "<br> Please read our [**welcome message**](" <>
......
GUIDE.md
View file @ b39983ea
This diff is collapsed.
Handler/Comment.hs
View file @ b39983ea
......@@ -356,7 +356,7 @@ postCloseComment user@(Entity user_id _) comment_id comment make_comment_handler
lookupPostMode >>= \case
Just PostMode -> do
runSDB $ do
closing_id <- insert closing
closing_id <- lift $ insert closing
tell [ECommentClosed closing_id closing]
return Nothing
......@@ -396,13 +396,20 @@ postEditComment
-> Entity Comment
-> (CommentMods -> CommentHandlerInfo)
-> 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))
case result of
FormSuccess (EditComment new_text new_language) -> lookupPostMode >>= \case
Just PostMode -> do
runSYDB (editCommentDB comment_id new_text new_language)
alertSuccess "posted new edit"
let c = countMatches T.isPrefixOf "ticket:" $
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
_ -> do
(form, _) <- generateFormPost (editCommentForm new_text new_language)
......@@ -499,7 +506,7 @@ postNewComment mparent_id (Entity user_id user) discussion_id make_permissions_m
then (Just now, Just user_id)
else (Nothing, Nothing)
comment = Entity
(Key $ PersistInt64 0)
(key $ PersistInt64 0)
(Comment now approved_ts approved_by discussion_id mparent_id user_id contents depth visibility language)
max_depth <- getMaxDepthDefault 0
......@@ -630,13 +637,13 @@ postRetractComment user comment_id comment make_comment_handler_info = do
_ -> error "Error when submitting form."
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)
case result of
FormSuccess mnote -> do
lookupPostMode >>= \case
Just PostMode -> do
runSDB (userUnclaimCommentDB user_id comment_id mnote)
runSDB (userUnclaimCommentDB comment_id mnote)
return Nothing
_ -> do
(form, _) <- generateFormPost (claimCommentForm (Just mnote))
......
Handler/HonorPledge.hs
View file @ b39983ea
......@@ -19,4 +19,5 @@ postHonorPledgeR = do
runDB $ establishUserDB user_id elig_time reason
setMessage "Congratulations, you are now a fully established user!"
redirect HomeR
--TODO: add "already established" error for that case
_ -> error "You're not eligible for establishment."
Handler/Notification.hs
View file @ b39983ea
......@@ -22,7 +22,7 @@ getNotificationsR = do
whenNotifId :: DBConstraint m => Text -> (NotificationId -> m ()) -> m ()
whenNotifId value action =
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
-> (UserId -> DB ()) -> (UserId -> DB ())
......
Handler/Project.hs
View file @ b39983ea
......@@ -28,7 +28,6 @@ import Model.User
import Model.Wiki
import System.Locale (defaultTimeLocale)
import View.Comment
import View.PledgeButton
import View.Project
import View.SnowdriftEvent
import Widgets.Preview
......@@ -236,7 +235,7 @@ postProjectR project_handle = do
project_update <- insert $ ProjectUpdate now project_id viewer_id $ diffMarkdown (projectDescription project) description
last_update <- getBy $ UniqueProjectLastUpdate project_id
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
update $ \ p -> do
......@@ -273,7 +272,7 @@ postProjectR project_handle = do
redirect $ ProjectR project_handle
--------------------------------------------------------------------------------
-- /application
-- /applications (List of submitted applications)
getApplicationsR :: Text -> Handler Html
getApplicationsR project_handle = do
......@@ -293,6 +292,9 @@ getApplicationsR project_handle = do
setTitle . toHtml $ projectName project <> " Volunteer Applications | Snowdrift.coop"
$(widgetFile "applications")
--------------------------------------------------------------------------------
-- /application (Form for new application)
getApplicationR :: Text -> VolunteerApplicationId -> Handler Html
getApplicationR project_handle application_id = do
viewer_id <- requireAuthId
......@@ -312,20 +314,6 @@ getApplicationR project_handle application_id = do
setTitle . toHtml $ projectName project <> " Volunteer Application - " <> userDisplayName user <> " | Snowdrift.coop"
$(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
......@@ -507,6 +495,8 @@ getProjectFeedR project_handle = do
provideRep $ atomFeed feed
provideRep $ rssFeed feed
provideRep $ defaultLayout $ do
setTitle . toHtml $
projectName project <> " - Feed | Snowdrift.coop"
$(widgetFile "project_feed")
toWidget $(cassiusFile "templates/comment.cassius")
......@@ -641,10 +631,11 @@ getUpdateSharesR project_handle = do
Entity project_id project <- runYDB $ getBy404 $ UniqueProjectHandle project_handle
((result, _), _) <- runFormGet $ pledgeForm project_id
let dangerRedirect msg = do
alertDanger msg
redirect $ ProjectR project_handle
case result of
FormSuccess (SharesPurchaseOrder new_user_shares) -> do
-- TODO - refuse negative
user_id <- requireAuthId
(confirm_form, _) <- generateFormPost $ projectConfirmSharesForm (Just new_user_shares)
......@@ -689,9 +680,9 @@ getUpdateSharesR project_handle = do
setTitle . toHtml $ projectName project <> " - update pledge | Snowdrift.coop"
$(widgetFile "update_shares")
FormMissing -> defaultLayout [whamlet| form missing |]
FormFailure _ -> defaultLayout [whamlet| form failure |]
FormMissing -> dangerRedirect "Form missing."
FormFailure errors ->
dangerRedirect $ T.snoc (T.intercalate "; " errors) '.'
postUpdateSharesR :: Text -> Handler Html
postUpdateSharesR project_handle = do
......@@ -700,8 +691,6 @@ postUpdateSharesR project_handle = do
case result of
FormSuccess (SharesPurchaseOrder shares) -> do
-- TODO - refuse negative
if isConfirmed
then do
Just pledge_render_id <- fmap (read . T.unpack) <$> lookupSession pledgeRenderKey
......@@ -1264,4 +1253,3 @@ postNewProjectDiscussionR project_handle = do
(makeProjectCommentActionPermissionsMap (Just user) project_handle def) >>= \case
Left comment_id -> redirect (ProjectCommentR project_handle comment_id)
Right (widget, form) -> defaultLayout $ previewWidget form "post" (projectDiscussionPage project_handle widget)
Handler/Project/Signup.hs 0 → 100644
View file @ b39983ea
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")
Handler/ProjectBlog.hs
View file @ b39983ea
......@@ -49,8 +49,8 @@ checkComment' muser_id project_handle post_name comment_id = do
redirectIfRethreaded comment_id
(project, blog_post, ecomment) <- runYDB $ do
project@(Entity project_id _) <- getBy404 $ UniqueProjectHandle project_handle
Entity _ blog_post <- getBy404 $ UniqueBlogPost project_id post_name
(project@(Entity project_id _), Entity _ blog_post) <-
fetchProjectBlogPostDB project_handle post_name
let has_permission = exprCommentProjectPermissionFilter muser_id (val project_id)
......@@ -174,7 +174,7 @@ requireRolesAny roles project_handle err_msg = do
getProjectBlogR :: Text -> Handler Html
getProjectBlogR project_handle = do
maybe_from <- fmap (Key . PersistInt64 . read . T.unpack) <$> lookupGetParam "from"
maybe_from <- fmap (key . PersistInt64 . read . T.unpack) <$> lookupGetParam "from"
post_count <- fromMaybe 10 <$> fmap (read . T.unpack) <$> lookupGetParam "from"
Entity project_id project <- runYDB $ getBy404 $ UniqueProjectHandle project_handle
......@@ -219,29 +219,18 @@ postNewBlogPostR project_handle = do
(viewer_id, Entity project_id _) <-
requireRolesAny [Admin, TeamMember] project_handle "You do not have permission to post to this project's blog."
now <- liftIO getCurrentTime
((result, _), _) <- runFormPost $ projectBlogForm Nothing
case result of
FormSuccess (title, handle, Markdown content) -> do
FormSuccess project_blog@ProjectBlog {..} -> do
lookupPostMode >>= \case
Just PostMode -> do
void $ runSDB $ postBlogPostDB title handle viewer_id project_id (Markdown content)
void $ runSDB $ postBlogPostDB
projectBlogTitle projectBlogHandle
viewer_id project_id projectBlogContent
alertSuccess "posted"
redirect $ ProjectBlogR project_handle
_ -> do
let (top_content', bottom_content') = break (== "***") $ T.lines content
top_content = T.unlines top_content'
bottom_content = if bottom_content' == [] then Nothing else Just (Markdown $ T.unlines bottom_content')
blog_post = BlogPost now title handle viewer_id project_id (Key $ PersistInt64 0) (Markdown top_content) bottom_content
(form, _) <- generateFormPost $ projectBlogForm $ Just (title, handle, Markdown content)
defaultLayout $ previewWidget form "post" $ renderBlogPost project_handle blog_post
_ -> previewBlogPost viewer_id project_handle project_blog
x -> do
alertDanger $ T.pack $ show x
redirect $ NewBlogPostR project_handle
......@@ -252,16 +241,54 @@ postNewBlogPostR project_handle = do
getBlogPostR :: Text -> Text -> Handler Html
getBlogPostR project_handle blog_post_handle = do
(project, blog_post) <- runYDB $ do
Entity project_id project <- getBy404 $ UniqueProjectHandle project_handle
Entity _ blog_post <- getBy404 $ UniqueBlogPost project_id blog_post_handle
return (project, blog_post)
(Entity _ project, Entity _ blog_post) <-
runYDB $ fetchProjectBlogPostDB project_handle blog_post_handle
defaultLayout $ do
setTitle . toHtml $ projectName project <> " Blog - " <> blogPostTitle blog_post <> " | Snowdrift.coop"
renderBlogPost project_handle blog_post
renderBlogPost project_handle blog_post NotPreview
--------------------------------------------------------------------------------
-- /p/#Text/blog/#Text/edit
checkEditBlogPostPermissions :: Text -> Handler UserId
checkEditBlogPostPermissions project_handle = do
fst <$> requireRolesAny [Admin, TeamMember] project_handle
"only the admin or a team member can edit a blog post"
getEditBlogPostR :: Text -> Text -> Handler Html
getEditBlogPostR project_handle blog_post_handle = do
(Entity _ project, Entity _ BlogPost {..}) <-
runYDB $ fetchProjectBlogPostDB project_handle blog_post_handle
void $ checkEditBlogPostPermissions project_handle
(blog_form, enctype) <- generateFormPost $ projectBlogForm $
Just $ ProjectBlog blogPostTitle blog_post_handle $
concatContent blogPostTopContent blogPostBottomContent
defaultLayout $ do
setTitle $ toHtml $ projectName project <> " Blog - Edit | Snowdrift.coop"
$(widgetFile "edit_blog_post")
postEditBlogPostR :: Text -> Text -> Handler Html
postEditBlogPostR project_handle blog_post_handle = do
(_, Entity blog_post_id BlogPost {..}) <-
runYDB $ fetchProjectBlogPostDB project_handle blog_post_handle
viewer_id <- checkEditBlogPostPermissions project_handle
((result, _), _) <- runFormPost $ projectBlogForm Nothing
case result of
FormSuccess project_blog@ProjectBlog {..} -> do
lookupPostMode >>= \case
Just PostMode -> do
runDB $ updateBlogPostDB viewer_id blog_post_id project_blog
alertSuccess "Blog post updated"
redirect $ BlogPostR project_handle projectBlogHandle
_ -> previewBlogPost viewer_id project_handle project_blog
FormMissing -> do
alertDanger "No data provided"
redirect $ BlogPostR project_handle blog_post_handle
FormFailure errs -> do
alertDanger $ "Form failure: " <> (T.intercalate ", " errs)
redirect $ BlogPostR project_handle blog_post_handle
--------------------------------------------------------------------------------
-- /p/#Text/blog/#Text/c/#CommentId
......
Handler/RepoFeed.hs
View file @ b39983ea
......@@ -18,7 +18,9 @@ import Data.Text.PrettyHtml
import Prelude (head)
import Data.Time (addUTCTime)
import Data.Time (addUTCTime, secondsToDiffTime, UTCTime(..), fromGregorian)
import Data.Hourglass ( timeGetDate, dateYear, dateMonth, dateDay
, timeGetTimeOfDay, todHour, todMin, todSec, toSeconds )
import Data.List (sortBy)
import Data.Tree (unfoldTreeM_BF, levels)
......@@ -43,7 +45,6 @@ getRepoFeedR = do
author = "Snowdrift.coop Team"
description = "Commits to the Snowdrift.coop repository."
lang = "en"
-- commitTime = toUTCTime . personTime . commitAuthor
time = commitTime $ head commits
entries <- forM commits $ \ commit -> do
......@@ -53,9 +54,24 @@ getRepoFeedR = do
newsFeed $ Feed title feed_url home_url author description lang time entries
-- Remove as soon as it's available in hit:
-- https://github.com/vincenthz/hit/pull/20
gitTimeToUTC :: GitTime -> UTCTime
gitTimeToUTC gt = UTCTime utcDay diffTime
where
date = timeGetDate gt
year = toInteger $ dateYear date
month = succ $ fromEnum $ dateMonth date
day = dateDay date
utcDay = fromGregorian year month day
tod = timeGetTimeOfDay gt
hours = toInteger $ toSeconds $ todHour tod
minutes = toInteger $ toSeconds $ todMin tod
seconds = toInteger $ todSec tod
diffTime = secondsToDiffTime $ hours + minutes + seconds
commitTime :: Commit -> UTCTime
commitTime = toUTCTime . personTime . commitAuthor
commitTime = gitTimeToUTC . personTime . commitAuthor
getCommits :: Git -> Ref -> UTCTime -> IO [Commit]
getCommits repo ref bound = do
......
Handler/User.hs
View file @ b39983ea
......@@ -56,7 +56,7 @@ getUsersR = do
userProjects :: Entity User -> Maybe (Map (Text, Text) (Set (Role)))
userProjects u = M.lookup (entityKey u) allProjects
getUserKey :: Entity User -> Text
getUserKey (Entity key _) = either (error . T.unpack) id . fromPersistValue . unKey $ key
getUserKey = either (error . T.unpack) id . fromPersistValue . toPersistValue . entityKey
defaultLayout $ do
setTitle "Users | Snowdrift.coop"
......@@ -129,9 +129,19 @@ getUserR user_id = do
<> "you will not be able to receive email notifications."
defaultLayout $ do
setTitle . toHtml $ "User Profile - " <> userDisplayName (Entity user_id user) <> " | Snowdrift.coop"
setTitle $ toHtml $ "User Profile - " <>
userDisplayName (Entity user_id user) <> " | Snowdrift.coop"
renderUser mviewer_id user_id user projects_and_roles
postUserR :: UserId -> Handler Html
postUserR user_id = do
void $ checkEditUser user_id
memail <- runDB $ fetchUserEmail user_id
case memail of
Nothing -> alertDanger "No email address is associated with your account."
Just email -> startEmailVerification user_id email
redirect $ UserR user_id
--------------------------------------------------------------------------------
-- /#UserId/balance
......@@ -181,7 +191,8 @@ getUserBalanceR' user_id = do
(add_funds_form, _) <- generateFormPost addTestCashForm
defaultLayout $ do
setTitle . toHtml $ "User Balance - " <> userDisplayName (Entity user_id user) <> " | Snowdrift.coop"
setTitle $ toHtml $ "User Balance - " <>
userDisplayName (Entity user_id user) <> " | Snowdrift.coop"
$(widgetFile "user_balance")
postUserBalanceR :: UserId -> Handler Html
......@@ -260,7 +271,8 @@ getUserDiscussionR' user_id get_root_comments = do
(comment_form, _) <- generateFormPost commentNewTopicForm
defaultLayout $ do
setTitle . toHtml $ userDisplayName (Entity user_id user) <> " User Discussion | Snowdrift.coop"
setTitle $ toHtml $ userDisplayName (Entity user_id user) <>
" User Discussion | Snowdrift.coop"
$(widgetFile "user_discuss")
--------------------------------------------------------------------------------
......@@ -297,7 +309,7 @@ getUserChangePasswordR user_id = do
user <- runYDB $ get404 user_id
(form, enctype) <- generateFormPost changePasswordForm
defaultLayout $ do
setTitle . toHtml $ "Change Passphrase - " <>
setTitle $ toHtml $ "Change Passphrase - " <>
userDisplayName (Entity user_id user) <> " | Snowdrift.coop"
$(widgetFile "change_password")
......@@ -335,6 +347,70 @@ postUserChangePasswordR user_id = do
alertDanger "Oops, failed to update the passphrase."
defaultLayout $(widgetFile "change_password")
--------------------------------------------------------------------------------
-- /#UserId/delete
startDeleteConfirmation :: UserId -> Handler ()
startDeleteConfirmation user_id = do
hash <- liftIO newHash
confirm_uri <- getUrlRender <*> (pure $ UserConfirmDeleteR user_id hash)
muser_email <- runDB $ fetchUserEmailVerified user_id