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
import System.Random (randomIO)
import Text.Printf
--------------------------------------------------------------------------------
-- Utility functions
......@@ -39,12 +40,17 @@ lookupGetParamDefault name def = do
requireRolesAny :: [Role] -> Text -> Text -> Handler (UserId, Entity Project)
requireRolesAny roles project_handle err_msg = do
user_id <- requireAuthId
(project, ok) <- runYDB $ do
project@(Entity project_id _) <- getBy404 (UniqueProjectHandle project_handle)
ok <- userHasRolesAnyDB roles user_id project_id
return (project, ok)
unless ok $
permissionDenied err_msg
return (user_id, project)
-------------------------------------------------------------------------------
......@@ -211,51 +217,81 @@ getProjectBlogR project_handle = do
defaultLayout $ do
setTitle . toHtml $ projectName project <> " Blog | Snowdrift.coop"
$(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 _) <-
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
((result, _), _) <- runFormPost $ projectBlogForm now viewer_id project_id
((result, _), _) <- runFormPost $ projectBlogForm Nothing
case result of
FormSuccess blog_post' -> do
let blog_post :: ProjectBlog
blog_post = blog_post' { projectBlogTime = now, projectBlogUser = viewer_id }
FormSuccess mk_blog_post -> do
mode <- lookupPostParam "mode"
let action :: Text = "post"
case mode of
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
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"
redirect $ ProjectR project_handle
redirect $ ProjectBlogR project_handle
_ -> do
addAlertEm "danger" "unrecognized mode" "Error: "
redirect $ ProjectR project_handle
x -> do
addAlertEm "danger" ("unrecognized mode: " <> T.pack (show x)) "Error: "
redirect $ NewProjectBlogPostR project_handle
x -> do
alertDanger $ T.pack $ show x
redirect $ ProjectR project_handle
redirect $ NewProjectBlogPostR project_handle
getProjectBlogPostR :: Text -> ProjectBlogId -> Handler Html
getProjectBlogPostR project_handle blog_post_id = do
(Entity _ project, blog_post) <- runYDB $ (,)
<$> getBy404 (UniqueProjectHandle project_handle)
<*> get404 blog_post_id
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
return (project, blog_post)
defaultLayout $ do
setTitle . toHtml $ projectName project <> " Blog - " <> projectBlogTitle blog_post <> " | Snowdrift.coop"
renderBlogPost project_handle blog_post
--------------------------------------------------------------------------------
......@@ -263,7 +299,7 @@ getProjectBlogPostR project_handle blog_post_id = do
getEditProjectR :: Text -> Handler Html
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."
tags <- runDB $
......@@ -347,7 +383,7 @@ getProjectFeedR project_handle = do
getInviteR :: Text -> Handler Html
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
maybe_invite_code <- lookupSession "InviteCode"
......@@ -516,7 +552,8 @@ getProjectTransactionsR project_handle = do
getWikiPagesR :: Text -> Handler Html
getWikiPagesR project_handle = do
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
pages <- getProjectWikiPages project_id
......
......@@ -62,9 +62,10 @@ renderProject maybe_project_id project pledges pledge = do
renderBlogPost :: Text -> ProjectBlog -> WidgetT App IO ()
renderBlogPost project_handle blog_post = do
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
content = markdownWidget project_handle $ Markdown $ T.snoc top_content '\n' <> bottom_content
$(widgetFile "blog_post")
editProjectForm :: Maybe (Project, [Text]) -> Form UpdateProject
......@@ -75,16 +76,22 @@ editProjectForm project =
<*> (maybe [] (map T.strip . T.splitOn ",") <$> aopt' textField "Tags" (Just . T.intercalate ", " . snd <$> project))
<*> aopt' textField "Github Repository" (projectGithubRepo . fst <$> project)
projectBlogForm :: UTCTime -> UserId -> ProjectId -> Form ProjectBlog
projectBlogForm now user_id project_id =
renderBootstrap3 $ mkBlog
<$> areq' textField "Post Title" Nothing
<*> areq' snowdriftMarkdownField "Post" Nothing
projectBlogForm :: Maybe (Text, Text, Markdown) -> Form (UTCTime -> UserId -> ProjectId -> DiscussionId -> ProjectBlog)
projectBlogForm defaults = renderBootstrap3 $
let getTitle (title, _, _) = title
getHandle (_, handle, _) = handle
getContent (_, _, content) = content
in mkBlog
<$> areq' textField "Post Title" (getTitle <$> defaults)
<*> areq' textField "Post Handle" (getHandle <$> defaults)
<*> areq' snowdriftMarkdownField "Content" (getContent <$> defaults)
where
mkBlog :: Text -> Markdown -> ProjectBlog
mkBlog title (Markdown 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)
mkBlog :: Text -> Text -> Markdown -> (UTCTime -> UserId -> ProjectId -> DiscussionId -> ProjectBlog)
mkBlog title handle (Markdown content) now user_id project_id discussion_id =
let (top_content, bottom_content) = break (== "***") $ T.lines 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 = renderBootstrap3 $ (,)
......
......@@ -31,7 +31,7 @@ renderCommentPendingEvent comment_id comment =
|]
renderWikiPageEvent :: WikiPageId -> WikiPage -> Widget
renderWikiPageEvent wiki_page_id wiki_page =
renderWikiPageEvent _ wiki_page =
[whamlet|
<div>Wiki page: #{wikiPageTarget wiki_page}
|]
......@@ -43,14 +43,14 @@ renderWikiEditEvent _ _ (Entity _ wiki_page) =
|]
renderNewPledgeEvent :: SharesPledgedId -> SharesPledged -> UserMap -> Widget
renderNewPledgeEvent shares_pledged_id SharesPledged{..} users_map = do
renderNewPledgeEvent _ SharesPledged{..} users_map = do
let pledger = users_map ! sharesPledgedUser
[whamlet|
<div>#{userDisplayName (Entity sharesPledgedUser pledger)} pledged #{show sharesPledgedShares} new shares!
|]
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
(verb, punc) = if old_shares < sharesPledgedShares
then ("increased", "!")
......
......@@ -98,11 +98,13 @@ Project
ProjectBlog
time UTCTime
title Text
handle Text
user UserId
project ProjectId
discussion DiscussionId
topContent Markdown
bottomContent Markdown Maybe
UniqueProjectBlogPost project handle
deriving Show
ProjectUserRole
......
......@@ -37,8 +37,9 @@
/p/#Text ProjectR GET POST
/p/#Text/applications ApplicationsR GET
/p/#Text/application/#VolunteerApplicationId ApplicationR GET
/p/#Text/b ProjectBlogR GET POST
/p/#Text/b/#ProjectBlogId ProjectBlogPostR GET
/p/#Text/blog ProjectBlogR GET
/p/#Text/blog/!new NewProjectBlogPostR GET POST
/p/#Text/blog/#Text ProjectBlogPostR GET
/p/#Text/contact ContactR GET POST
/p/#Text/edit EditProjectR GET
/p/#Text/feed ProjectFeedR GET
......
<h2>
<div .post>
<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
<div>
<a href=@{ProjectBlogPostR project_handle post_id}>
$forall Entity _ post <- posts
<div .post>
<a href=@{ProjectBlogPostR project_handle (projectBlogHandle post)}>
#{projectBlogTitle post}
\ - #
<small>
^{renderTime $ projectBlogTime post}
<p>
^{markdownWidget project_handle $ projectBlogTopContent post}
<hr>
$case next
$of [Entity 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
comment_map <- fmap M.fromList $ forM [1..10] $ \ i -> do
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)
......
......@@ -87,7 +87,6 @@ submitLogin user pass = do
addPostParam "username" user
addPostParam "password" pass
extractLocation >>= liftIO . print
extractLocation :: YesodExample site (Maybe B.ByteString)
extractLocation = do
......@@ -110,14 +109,10 @@ needsLogin method url = do
--
login :: (Yesod site) => YesodExample site ()
login = do
liftIO $ putStrLn "Logging in..."
get $ urlPath $ testRoot `T.append` "/auth/login"
statusIs 200
liftIO $ putStrLn "Submitting login."
submitLogin "test" "test"
liftIO $ putStrLn "Logged in."
statusIsResp :: Int -> YesodExample site ()
statusIsResp number = withResponse $ \ SResponse { simpleStatus = s } -> do
......
......@@ -4,15 +4,6 @@ module WikiTest
) 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 Data.Text as T
import Control.Monad
wikiSpecs :: Spec
wikiSpecs =
......
......@@ -13,6 +13,7 @@ import Application (makeFoundation)
import DiscussionTest
import WikiTest
import BlogTest
import System.IO
......@@ -35,3 +36,5 @@ main = do
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