now possible to comment on media. COmment deletion is WIP

This commit is contained in:
nek0 2014-12-07 03:54:02 +01:00
parent d14c2113f2
commit 71dc85f94b
7 changed files with 154 additions and 5 deletions

View file

@ -2,8 +2,10 @@ module Handler.Medium where
import Import import Import
import Data.Time import Data.Time
import Data.Maybe
import qualified Data.Text as T import qualified Data.Text as T
import System.Locale import System.Locale
import Yesod.Markdown
getMediumR :: MediumId -> Handler Html getMediumR :: MediumId -> Handler Html
getMediumR mediumId = do getMediumR mediumId = do
@ -16,15 +18,117 @@ getMediumR mediumId = do
albumId <- return $ mediumAlbum medium albumId <- return $ mediumAlbum medium
album <- runDB $ getJust albumId album <- runDB $ getJust albumId
msu <- lookupSession "userId" msu <- lookupSession "userId"
presence <- case msu of userId <- case msu of
Just tempUserId -> do Just tempUserId -> do
userId <- return $ getUserIdFromText tempUserId return $ Just $ getUserIdFromText tempUserId
return (userId == ownerId)
Nothing -> Nothing ->
return False return Nothing
userSlug <- case userId of
Just uId -> do
u <- runDB $ getJust uId
return $ Just $ userSlug u
Nothing ->
return Nothing
presence <- return $ (userId == (Just ownerId) || userId == Just (albumOwner album))
(commentWidget, enctype) <- generateFormPost $ commentForm userId userSlug mediumId Nothing
comments <- runDB $ selectList [CommentOrigin ==. mediumId, CommentParent ==. Nothing] [Desc CommentTime]
replies <- runDB $ selectList [CommentOrigin ==. mediumId, CommentParent !=. Nothing] [Desc CommentTime]
defaultLayout $ do defaultLayout $ do
setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium)) setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium))
$(widgetFile "medium") $(widgetFile "medium")
Nothing -> do Nothing -> do
setMessage "This image does not exist" setMessage "This image does not exist"
redirect $ HomeR redirect $ HomeR
postMediumR :: MediumId -> Handler Html
postMediumR mediumId = do
tempMedium <- runDB $ get mediumId
case tempMedium of
Just medium -> do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ Just $ getUserIdFromText tempUserId
u <- runDB $ getJust $ fromJust userId
userSl <- return $ Just $ userSlug u
((res, commentiwdget), enctype) <- runFormPost $ commentForm userId userSl mediumId Nothing
case res of
FormSuccess temp -> do
cId <- runDB $ insert temp
setMessage "Your Comment has been posted"
redirect $ MediumR mediumId
_ -> do
setMessage "There has been an error whith your comment"
redirect $ MediumR mediumId
Nothing -> do
setMessage "You need to be looged in to comment on media"
redirect LoginR
Nothing -> do
setMessage "This image does not exist"
redirect $ HomeR
commentForm :: Maybe UserId -> Maybe Text -> MediumId -> Maybe CommentId -> Form Comment
commentForm authorId authorSlug originId parentId = renderDivs $ Comment
<$> pure authorId
<*> pure authorSlug
<*> pure originId
<*> pure parentId
<*> lift (liftIO getCurrentTime)
<*> areq markdownField "Comment this medium" Nothing
getCommentReplyR :: CommentId -> Handler Html
getCommentReplyR commentId = do
tempComment <- runDB $ get commentId
case tempComment of
Just comment -> do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ Just $ getUserIdFromText tempUserId
u <- runDB $ getJust $ fromJust userId
userSl <- return $ Just $ userSlug u
mediumId <- return $ commentOrigin comment
(replyWidget, enctype) <- generateFormPost $ commentForm userId userSl mediumId (Just commentId)
defaultLayout $ do
setTitle "Eidolon :: Reply to comment"
$(widgetFile "commentReply")
Nothing -> do
setMessage "You need to be logged in to comment on media"
redirect $ LoginR
Nothing -> do
setMessage "This comment does not Exist"
redirect $ HomeR
postCommentReplyR :: CommentId -> Handler Html
postCommentReplyR commentId = do
tempComment <- runDB $ get commentId
case tempComment of
Just comment -> do
msu <- lookupSession "userId"
case msu of
Just tempUserId -> do
userId <- return $ Just $ getUserIdFromText tempUserId
u <- runDB $ getJust $ fromJust userId
userSl <- return $ Just $ userSlug u
mediumId <- return $ commentOrigin comment
((res, commentWidget), enctype) <- runFormPost $ commentForm userId userSl mediumId (Just commentId)
case res of
FormSuccess temp -> do
cId <- runDB $ insert temp
setMessage "Your reply has been posted"
redirect $ MediumR mediumId
_ -> do
setMessage "There has been an error with your reply"
redirect $ CommentReplyR commentId
Nothing -> do
setMessage "You need to be logged in to post replies"
redirect $ LoginR
Nothing -> do
setMessage "This comment does not exist!"
redirect $ HomeR
getCommentDeleteR :: CommentId -> Handler Html
getCommentDeleteR commentId = error "Not yet implemented"
postCommentDeleteR :: CommentId -> Handler Html
postCommentDeleteR commentId = error "Not yet implemented"

View file

@ -1,6 +1,7 @@
module Model where module Model where
import Yesod import Yesod
import Yesod.Markdown (Markdown)
import Data.Text (Text) import Data.Text (Text)
import Database.Persist.Quasi import Database.Persist.Quasi
import Database.Persist import Database.Persist

View file

@ -33,5 +33,13 @@ Medium
tags Texts tags Texts
album AlbumId album AlbumId
deriving Eq Show deriving Eq Show
Comment
author UserId Maybe
authorSlug Text Maybe
origin MediumId
parent CommentId Maybe
time UTCTime
content Markdown
deriving Show
-- By default this file is used in Model.hs (which is imported by Foundation.hs) -- By default this file is used in Model.hs (which is imported by Foundation.hs)

View file

@ -13,12 +13,14 @@
/upload UploadR GET POST /upload UploadR GET POST
/newalbum NewAlbumR GET POST /newalbum NewAlbumR GET POST
/album/#AlbumId AlbumR GET /album/#AlbumId AlbumR GET
/medium/#MediumId MediumR GET /medium/#MediumId MediumR GET POST
/album/#AlbumId/upload DirectUploadR GET POST /album/#AlbumId/upload DirectUploadR GET POST
/album/#AlbumId/settings AlbumSettingsR GET POST /album/#AlbumId/settings AlbumSettingsR GET POST
/album/#AlbumId/delete AlbumDeleteR GET POST /album/#AlbumId/delete AlbumDeleteR GET POST
/medium/#MediumId/settings MediumSettingsR GET POST /medium/#MediumId/settings MediumSettingsR GET POST
/medium/#MediumId/delete MediumDeleteR GET POST /medium/#MediumId/delete MediumDeleteR GET POST
/comment/#CommentId/reply CommentReplyR GET POST
/comment/#CommentId/delcom CommentDeleteR GET POST
/reactivate ReactivateR GET POST /reactivate ReactivateR GET POST
/profile/#UserId/settings ProfileSettingsR GET POST /profile/#UserId/settings ProfileSettingsR GET POST
/profile/#UserId/delete ProfileDeleteR GET POST /profile/#UserId/delete ProfileDeleteR GET POST

View file

@ -101,6 +101,7 @@ library
, crypto-api , crypto-api
, imagemagick , imagemagick
, resourcet , resourcet
, yesod-markdown >= 0.8
executable eidolon executable eidolon
if flag(library-only) if flag(library-only)

View file

@ -0,0 +1,9 @@
<h4>Reply to comment
<strong>#{fromJust $ commentAuthorSlug comment}</strong> posted on #{formatTime defaultTimeLocale "%A %F %H:%M" (commentTime comment)}:
<hr>
<p>#{markdownToHtml $ commentContent comment}
<hr>
<form method=post enctype=#{enctype}>
^{replyWidget}
<div>
<input type=submit value="Post reply">

View file

@ -24,3 +24,27 @@ by <a href=@{UserR ownerName}>#{ownerName}</a> from album <a href=@{AlbumR album
<a href=@{TagR tag}>#{tag} <a href=@{TagR tag}>#{tag}
$if presence == True $if presence == True
<a href=@{MediumSettingsR mediumId}>Change medium settings <a href=@{MediumSettingsR mediumId}>Change medium settings
$if null comments
<p>There are no Comments yet
$else
$forall (Entity commentId comment) <- comments
<pre>
<a href=@{ProfileR $ fromJust $ commentAuthor comment}>#{fromJust $ commentAuthorSlug comment}</a> wrote on #{formatTime defaultTimeLocale "%A %F %H:%M" $ commentTime comment}:
<hr>
#{commentContent comment}
$if userId /= Nothing
<hr>
<a href=@{CommentReplyR commentId}>Reply to this comment
$forall (Entity replyId reply) <- replies
$if commentParent reply == Just commentId
<pre class="reply">
<a href=@{ProfileR $ fromJust $ commentAuthor reply}>#{fromJust $ commentAuthorSlug reply}</a> wrote on #{formatTime defaultTimeLocale "%A %F %H:%M" $ commentTime reply}:
<hr>
#{commentContent reply}
$if userId /= Nothing
<form method=post enctype=#{enctype}>
^{commentWidget}
<div>
<input type=submit value="Post comment">