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

Commit 2b5b6650 authored by David L. L. Thomas's avatar David L. L. Thomas

Blogging ready for chrome.

parent fe83c1d9
...@@ -27,6 +27,7 @@ import qualified Data.Text as T ...@@ -27,6 +27,7 @@ import qualified Data.Text as T
import System.Random (randomIO) import System.Random (randomIO)
import Text.Printf import Text.Printf
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- Utility functions -- Utility functions
...@@ -39,12 +40,17 @@ lookupGetParamDefault name def = do ...@@ -39,12 +40,17 @@ lookupGetParamDefault name def = do
requireRolesAny :: [Role] -> Text -> Text -> Handler (UserId, Entity Project) requireRolesAny :: [Role] -> Text -> Text -> Handler (UserId, Entity Project)
requireRolesAny roles project_handle err_msg = do requireRolesAny roles project_handle err_msg = do
user_id <- requireAuthId user_id <- requireAuthId
(project, ok) <- runYDB $ do (project, ok) <- runYDB $ do
project@(Entity project_id _) <- getBy404 (UniqueProjectHandle project_handle) project@(Entity project_id _) <- getBy404 (UniqueProjectHandle project_handle)
ok <- userHasRolesAnyDB roles user_id project_id ok <- userHasRolesAnyDB roles user_id project_id
return (project, ok) return (project, ok)
unless ok $ unless ok $
permissionDenied err_msg permissionDenied err_msg
return (user_id, project) return (user_id, project)
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
...@@ -211,51 +217,81 @@ getProjectBlogR project_handle = do ...@@ -211,51 +217,81 @@ getProjectBlogR project_handle = do
defaultLayout $ do defaultLayout $ do
setTitle . toHtml $ projectName project <> " Blog | Snowdrift.coop" setTitle . toHtml $ projectName project <> " Blog | Snowdrift.coop"
$(widgetFile "project_blog") $(widgetFile "project_blog")
postProjectBlogR :: Text -> Handler Html
postProjectBlogR project_handle = do getNewProjectBlogPostR :: Text -> Handler Html
getNewProjectBlogPostR project_handle = do
(_, Entity _ project) <- requireRolesAny [Admin, TeamMember] project_handle "You do not have permission to post to this project's blog."
(blog_form, _) <- generateFormPost $ projectBlogForm Nothing
defaultLayout $ do
setTitle . toHtml $ "Post To " <> projectName project <> " Blog | Snowdrift.coop"
$(widgetFile "new_blog_post")
postNewProjectBlogPostR :: Text -> Handler Html
postNewProjectBlogPostR project_handle = do
(viewer_id, Entity project_id _) <- (viewer_id, Entity project_id _) <-
requireRolesAny [Admin, TeamMember] project_handle "You do not have permission to edit this project." requireRolesAny [Admin, TeamMember] project_handle "You do not have permission to post to this project's blog."
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
((result, _), _) <- runFormPost $ projectBlogForm now viewer_id project_id ((result, _), _) <- runFormPost $ projectBlogForm Nothing
case result of case result of
FormSuccess blog_post' -> do FormSuccess mk_blog_post -> do
let blog_post :: ProjectBlog
blog_post = blog_post' { projectBlogTime = now, projectBlogUser = viewer_id }
mode <- lookupPostParam "mode" mode <- lookupPostParam "mode"
let action :: Text = "post" let action :: Text = "post"
case mode of case mode of
Just "preview" -> do Just "preview" -> do
let blog_post :: ProjectBlog
blog_post = mk_blog_post now viewer_id project_id (Key $ PersistInt64 0)
title = projectBlogTitle blog_post
handle = projectBlogHandle blog_post
top_content = projectBlogTopContent blog_post
bottom_content = fromMaybe "" $ projectBlogBottomContent blog_post
content = top_content <> bottom_content
(form, _) <- generateFormPost $ projectBlogForm now viewer_id project_id (form, _) <- generateFormPost $ projectBlogForm $ Just (title, handle, content)
defaultLayout $ previewWidget form action $ renderBlogPost project_handle blog_post defaultLayout $ previewWidget form action $ renderBlogPost project_handle blog_post
Just x | x == action -> do Just x | x == action -> do
void $ runDB $ insert blog_post void $ runDB $ do
discussion_id <- insert $ Discussion 0
let blog_post :: ProjectBlog
blog_post = mk_blog_post now viewer_id project_id discussion_id
insert blog_post
alertSuccess "posted" alertSuccess "posted"
redirect $ ProjectR project_handle redirect $ ProjectBlogR project_handle
_ -> do x -> do
addAlertEm "danger" "unrecognized mode" "Error: " addAlertEm "danger" ("unrecognized mode: " <> T.pack (show x)) "Error: "
redirect $ ProjectR project_handle redirect $ NewProjectBlogPostR project_handle
x -> do x -> do
alertDanger $ T.pack $ show x alertDanger $ T.pack $ show x
redirect $ ProjectR project_handle redirect $ NewProjectBlogPostR project_handle
getProjectBlogPostR :: Text -> Text -> Handler Html
getProjectBlogPostR project_handle blog_post_handle = do
(project, blog_post) <- runYDB $ do
Entity project_id project <- getBy404 $ UniqueProjectHandle project_handle
Entity _ blog_post <- getBy404 $ UniqueProjectBlogPost project_id blog_post_handle
getProjectBlogPostR :: Text -> ProjectBlogId -> Handler Html return (project, blog_post)
getProjectBlogPostR project_handle blog_post_id = do
(Entity _ project, blog_post) <- runYDB $ (,)
<$> getBy404 (UniqueProjectHandle project_handle)
<*> get404 blog_post_id
defaultLayout $ do defaultLayout $ do
setTitle . toHtml $ projectName project <> " Blog - " <> projectBlogTitle blog_post <> " | Snowdrift.coop" setTitle . toHtml $ projectName project <> " Blog - " <> projectBlogTitle blog_post <> " | Snowdrift.coop"
renderBlogPost project_handle blog_post renderBlogPost project_handle blog_post
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
...@@ -263,7 +299,7 @@ getProjectBlogPostR project_handle blog_post_id = do ...@@ -263,7 +299,7 @@ getProjectBlogPostR project_handle blog_post_id = do
getEditProjectR :: Text -> Handler Html getEditProjectR :: Text -> Handler Html
getEditProjectR project_handle = do getEditProjectR project_handle = do
(viewer_id, Entity project_id project) <- (_, Entity project_id project) <-
requireRolesAny [Admin] project_handle "You do not have permission to edit this project." requireRolesAny [Admin] project_handle "You do not have permission to edit this project."
tags <- runDB $ tags <- runDB $
...@@ -347,7 +383,7 @@ getProjectFeedR project_handle = do ...@@ -347,7 +383,7 @@ getProjectFeedR project_handle = do
getInviteR :: Text -> Handler Html getInviteR :: Text -> Handler Html
getInviteR project_handle = do getInviteR project_handle = do
(viewer_id, Entity _ project) <- requireRolesAny [Admin] project_handle "You must be a project admin to invite." (_, Entity _ project) <- requireRolesAny [Admin] project_handle "You must be a project admin to invite."
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
maybe_invite_code <- lookupSession "InviteCode" maybe_invite_code <- lookupSession "InviteCode"
...@@ -516,7 +552,8 @@ getProjectTransactionsR project_handle = do ...@@ -516,7 +552,8 @@ getProjectTransactionsR project_handle = do
getWikiPagesR :: Text -> Handler Html getWikiPagesR :: Text -> Handler Html
getWikiPagesR project_handle = do getWikiPagesR project_handle = do
muser_id <- maybeAuthId muser_id <- maybeAuthId
(project, pages, unviewed_comments, unviewed_edits) <- runYDB $ do -- TODO: should be be using unviewed_comments and unviewed_edits?
(project, pages, _, _) <- runYDB $ do
Entity project_id project <- getBy404 $ UniqueProjectHandle project_handle Entity project_id project <- getBy404 $ UniqueProjectHandle project_handle
pages <- getProjectWikiPages project_id pages <- getProjectWikiPages project_id
......
...@@ -62,9 +62,10 @@ renderProject maybe_project_id project pledges pledge = do ...@@ -62,9 +62,10 @@ renderProject maybe_project_id project pledges pledge = do
renderBlogPost :: Text -> ProjectBlog -> WidgetT App IO () renderBlogPost :: Text -> ProjectBlog -> WidgetT App IO ()
renderBlogPost project_handle blog_post = do renderBlogPost project_handle blog_post = do
let (Markdown top_content) = projectBlogTopContent blog_post let (Markdown top_content) = projectBlogTopContent blog_post
(Markdown bottom_content) = fromMaybe (Markdown "") $ projectBlogBottomContent blog_post (Markdown bottom_content) = maybe (Markdown "") ("***\n" <>) $ projectBlogBottomContent blog_post
title = projectBlogTitle blog_post title = projectBlogTitle blog_post
content = markdownWidget project_handle $ Markdown $ T.snoc top_content '\n' <> bottom_content content = markdownWidget project_handle $ Markdown $ T.snoc top_content '\n' <> bottom_content
$(widgetFile "blog_post") $(widgetFile "blog_post")
editProjectForm :: Maybe (Project, [Text]) -> Form UpdateProject editProjectForm :: Maybe (Project, [Text]) -> Form UpdateProject
...@@ -75,16 +76,22 @@ editProjectForm project = ...@@ -75,16 +76,22 @@ editProjectForm project =
<*> (maybe [] (map T.strip . T.splitOn ",") <$> aopt' textField "Tags" (Just . T.intercalate ", " . snd <$> project)) <*> (maybe [] (map T.strip . T.splitOn ",") <$> aopt' textField "Tags" (Just . T.intercalate ", " . snd <$> project))
<*> aopt' textField "Github Repository" (projectGithubRepo . fst <$> project) <*> aopt' textField "Github Repository" (projectGithubRepo . fst <$> project)
projectBlogForm :: UTCTime -> UserId -> ProjectId -> Form ProjectBlog projectBlogForm :: Maybe (Text, Text, Markdown) -> Form (UTCTime -> UserId -> ProjectId -> DiscussionId -> ProjectBlog)
projectBlogForm now user_id project_id = projectBlogForm defaults = renderBootstrap3 $
renderBootstrap3 $ mkBlog let getTitle (title, _, _) = title
<$> areq' textField "Post Title" Nothing getHandle (_, handle, _) = handle
<*> areq' snowdriftMarkdownField "Post" Nothing getContent (_, _, content) = content
in mkBlog
<$> areq' textField "Post Title" (getTitle <$> defaults)
<*> areq' textField "Post Handle" (getHandle <$> defaults)
<*> areq' snowdriftMarkdownField "Content" (getContent <$> defaults)
where where
mkBlog :: Text -> Markdown -> ProjectBlog mkBlog :: Text -> Text -> Markdown -> (UTCTime -> UserId -> ProjectId -> DiscussionId -> ProjectBlog)
mkBlog title (Markdown content) = mkBlog title handle (Markdown content) now user_id project_id discussion_id =
let (top_content, bottom_content) = break (== "---") $ T.lines content let (top_content, bottom_content) = break (== "***") $ T.lines content
in ProjectBlog now title user_id project_id undefined (Markdown $ T.unlines top_content) (if null bottom_content then Nothing else Just $ Markdown $ T.unlines bottom_content) in ProjectBlog now title handle user_id project_id
discussion_id (Markdown $ T.unlines top_content)
(if null bottom_content then Nothing else Just $ Markdown $ T.unlines bottom_content)
inviteForm :: Form (Text, Role) inviteForm :: Form (Text, Role)
inviteForm = renderBootstrap3 $ (,) inviteForm = renderBootstrap3 $ (,)
......
...@@ -31,7 +31,7 @@ renderCommentPendingEvent comment_id comment = ...@@ -31,7 +31,7 @@ renderCommentPendingEvent comment_id comment =
|] |]
renderWikiPageEvent :: WikiPageId -> WikiPage -> Widget renderWikiPageEvent :: WikiPageId -> WikiPage -> Widget
renderWikiPageEvent wiki_page_id wiki_page = renderWikiPageEvent _ wiki_page =
[whamlet| [whamlet|
<div>Wiki page: #{wikiPageTarget wiki_page} <div>Wiki page: #{wikiPageTarget wiki_page}
|] |]
...@@ -43,14 +43,14 @@ renderWikiEditEvent _ _ (Entity _ wiki_page) = ...@@ -43,14 +43,14 @@ renderWikiEditEvent _ _ (Entity _ wiki_page) =
|] |]
renderNewPledgeEvent :: SharesPledgedId -> SharesPledged -> UserMap -> Widget renderNewPledgeEvent :: SharesPledgedId -> SharesPledged -> UserMap -> Widget
renderNewPledgeEvent shares_pledged_id SharesPledged{..} users_map = do renderNewPledgeEvent _ SharesPledged{..} users_map = do
let pledger = users_map ! sharesPledgedUser let pledger = users_map ! sharesPledgedUser
[whamlet| [whamlet|
<div>#{userDisplayName (Entity sharesPledgedUser pledger)} pledged #{show sharesPledgedShares} new shares! <div>#{userDisplayName (Entity sharesPledgedUser pledger)} pledged #{show sharesPledgedShares} new shares!
|] |]
renderUpdatedPledgeEvent :: Int64 -> SharesPledgedId -> SharesPledged -> UserMap -> Widget renderUpdatedPledgeEvent :: Int64 -> SharesPledgedId -> SharesPledged -> UserMap -> Widget
renderUpdatedPledgeEvent old_shares shares_pledged_id SharesPledged{..} users_map = do renderUpdatedPledgeEvent old_shares _ SharesPledged{..} users_map = do
let pledger = users_map ! sharesPledgedUser let pledger = users_map ! sharesPledgedUser
(verb, punc) = if old_shares < sharesPledgedShares (verb, punc) = if old_shares < sharesPledgedShares
then ("increased", "!") then ("increased", "!")
......
...@@ -98,11 +98,13 @@ Project ...@@ -98,11 +98,13 @@ Project
ProjectBlog ProjectBlog
time UTCTime time UTCTime
title Text title Text
handle Text
user UserId user UserId
project ProjectId project ProjectId
discussion DiscussionId discussion DiscussionId
topContent Markdown topContent Markdown
bottomContent Markdown Maybe bottomContent Markdown Maybe
UniqueProjectBlogPost project handle
deriving Show deriving Show
ProjectUserRole ProjectUserRole
......
...@@ -37,8 +37,9 @@ ...@@ -37,8 +37,9 @@
/p/#Text ProjectR GET POST /p/#Text ProjectR GET POST
/p/#Text/applications ApplicationsR GET /p/#Text/applications ApplicationsR GET
/p/#Text/application/#VolunteerApplicationId ApplicationR GET /p/#Text/application/#VolunteerApplicationId ApplicationR GET
/p/#Text/b ProjectBlogR GET POST /p/#Text/blog ProjectBlogR GET
/p/#Text/b/#ProjectBlogId ProjectBlogPostR GET /p/#Text/blog/!new NewProjectBlogPostR GET POST
/p/#Text/blog/#Text ProjectBlogPostR GET
/p/#Text/contact ContactR GET POST /p/#Text/contact ContactR GET POST
/p/#Text/edit EditProjectR GET /p/#Text/edit EditProjectR GET
/p/#Text/feed ProjectFeedR GET /p/#Text/feed ProjectFeedR GET
......
<h2> <div .post>
#{title} <h2>
#{title}
^{content} ^{content}
<form method=POST>
^{blog_form}
<input type=submit name=mode value=preview>
<input type=submit name=mode value=post>
$forall Entity post_id post <- posts $forall Entity _ post <- posts
<div> <div .post>
<a href=@{ProjectBlogPostR project_handle post_id}> <a href=@{ProjectBlogPostR project_handle (projectBlogHandle post)}>
#{projectBlogTitle post} #{projectBlogTitle post}
\ - #
<small>
^{renderTime $ projectBlogTime post}
<p> <p>
^{markdownWidget project_handle $ projectBlogTopContent post} ^{markdownWidget project_handle $ projectBlogTopContent post}
<hr>
$case next $case next
$of [Entity next_id _] $of [Entity next_id _]
<a href=#{nextRoute next_id}> <a href=#{nextRoute next_id}>
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module BlogTest
( blogSpecs
) where
import TestImport
import qualified Data.Map as M
import qualified Text.XML as XML
import qualified Text.HTML.DOM as HTML
import Database.Esqueleto hiding (get)
import Network.Wai.Test (SResponse (..))
import Data.Text as T
import Data.Text.Encoding
import qualified Data.ByteString.Char8 as BSC
import Control.Monad
import Data.Maybe (fromMaybe)
blogSpecs :: Spec
blogSpecs = do
let postBlog route stmts = do
get route
statusIs 200
[ form ] <- htmlQuery "form"
let getAttrs = XML.elementAttributes . XML.documentRoot . HTML.parseLBS
request $ do
addNonce
setMethod "POST"
let route' = maybe (Left route) Right $ M.lookup "action" $ getAttrs form
either setUrl setUrl route'
addPostParam "mode" "post"
stmts
statusIsResp 302
previewBlog route stmts = do
get route
statusIs 200
[ form ] <- htmlQuery "form"
let getAttrs = XML.elementAttributes . XML.documentRoot . HTML.parseLBS
request $ do
addNonce
setMethod "POST"
maybe (setUrl route) setUrl $ M.lookup "action" $ getAttrs form
addPostParam "mode" "preview"
stmts
statusIs 200
ydescribe "blog" $ do
yit "loads the project page - no blog post" $ do
login
get $ ProjectR "snowdrift"
statusIs 200
{-
htmlNoneContain "#post" "Above fold."
htmlNoneContain "#post" "Below fold."
-}
yit "loads the project blog - no blog post" $ do
login
get $ ProjectBlogR "snowdrift"
statusIs 200
htmlNoneContain ".post" "Above fold."
htmlNoneContain ".post" "Below fold."
yit "previews blog post" $ do
login
previewBlog (NewProjectBlogPostR "snowdrift") $ do
byLabel "Post Title" "Test"
byLabel "Post Handle" "test"
byLabel "Content" "Above fold.\n***\nBelow fold."
bodyContains "Above fold."
bodyContains "Below fold."
yit "posts blog post" $ do
login
postBlog (NewProjectBlogPostR "snowdrift") $ do
byLabel "Post Title" "Test"
byLabel "Post Handle" "test"
byLabel "Content" "Above fold.\n***\nBelow fold."
Just route <- extractLocation
get $ decodeUtf8 route
statusIs 200
htmlAnyContain ".post" "Above fold."
htmlNoneContain ".post" "Below fold."
get $ ProjectBlogPostR "snowdrift" "test"
htmlAnyContain ".post" "Above fold."
htmlAnyContain ".post" "Below fold."
yit "loads the project blog - with blog post" $ do
login
get $ ProjectBlogR "snowdrift"
statusIs 200
htmlAnyContain ".post" "Above fold."
htmlNoneContain ".post" "Below fold."
{-
yit "loads the project page - with blog post" $ do
login
get $ ProjectR "snowdrift"
statusIs 200
htmlAllContain "#post" "Above fold."
htmlNoneContain "#post" "Below fold."
-}
...@@ -59,7 +59,7 @@ discussionSpecs = do ...@@ -59,7 +59,7 @@ discussionSpecs = do
comment_map <- fmap M.fromList $ forM [1..10] $ \ i -> do comment_map <- fmap M.fromList $ forM [1..10] $ \ i -> do
comment_id <- getLatestCommentId comment_id <- getLatestCommentId
postComment (ReplyCommentR "snowdrift" "about" comment_id) $ byLabel "Reply" $ T.pack $ "Thread 1 - reply " ++ show i postComment (ReplyCommentR "snowdrift" "about" comment_id) $ byLabel "Reply" $ T.pack $ "Thread 1 - reply " ++ show (i :: Integer)
return (i, comment_id) return (i, comment_id)
......
...@@ -87,7 +87,6 @@ submitLogin user pass = do ...@@ -87,7 +87,6 @@ submitLogin user pass = do
addPostParam "username" user addPostParam "username" user
addPostParam "password" pass addPostParam "password" pass
extractLocation >>= liftIO . print
extractLocation :: YesodExample site (Maybe B.ByteString) extractLocation :: YesodExample site (Maybe B.ByteString)
extractLocation = do extractLocation = do
...@@ -110,14 +109,10 @@ needsLogin method url = do ...@@ -110,14 +109,10 @@ needsLogin method url = do
-- --
login :: (Yesod site) => YesodExample site () login :: (Yesod site) => YesodExample site ()
login = do login = do
liftIO $ putStrLn "Logging in..."
get $ urlPath $ testRoot `T.append` "/auth/login" get $ urlPath $ testRoot `T.append` "/auth/login"
statusIs 200 statusIs 200
liftIO $ putStrLn "Submitting login."
submitLogin "test" "test" submitLogin "test" "test"
liftIO $ putStrLn "Logged in."
statusIsResp :: Int -> YesodExample site () statusIsResp :: Int -> YesodExample site ()
statusIsResp number = withResponse $ \ SResponse { simpleStatus = s } -> do statusIsResp number = withResponse $ \ SResponse { simpleStatus = s } -> do
......
...@@ -4,15 +4,6 @@ module WikiTest ...@@ -4,15 +4,6 @@ module WikiTest
) where ) where
import TestImport import TestImport
import qualified Data.Map as M
import qualified Text.XML as XML
import qualified Text.HTML.DOM as HTML
import Database.Esqueleto hiding (get)
import Data.Text as T
import Control.Monad
wikiSpecs :: Spec wikiSpecs :: Spec
wikiSpecs = wikiSpecs =
......
...@@ -13,6 +13,7 @@ import Application (makeFoundation) ...@@ -13,6 +13,7 @@ import Application (makeFoundation)
import DiscussionTest import DiscussionTest
import WikiTest import WikiTest
import BlogTest
import System.IO import System.IO
...@@ -35,3 +36,5 @@ main = do ...@@ -35,3 +36,5 @@ main = do
discussionSpecs discussionSpecs
blogSpecs
Markdown is supported
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