232 lines
9.2 KiB
Haskell
232 lines
9.2 KiB
Haskell
module Handler.Medium where
|
|
|
|
import Import
|
|
import Data.Time
|
|
import Data.Maybe
|
|
import qualified Data.Text as T
|
|
import System.Locale
|
|
import Yesod.Markdown
|
|
|
|
getMediumR :: MediumId -> Handler Html
|
|
getMediumR mediumId = do
|
|
tempMedium <- runDB $ get mediumId
|
|
case tempMedium of
|
|
Just medium -> do
|
|
ownerId <- return $ mediumOwner medium
|
|
owner <- runDB $ getJust ownerId
|
|
ownerName <- return $ userName owner
|
|
albumId <- return $ mediumAlbum medium
|
|
album <- runDB $ getJust albumId
|
|
msu <- lookupSession "userId"
|
|
userId <- case msu of
|
|
Just tempUserId -> do
|
|
return $ Just $ getUserIdFromText tempUserId
|
|
Nothing ->
|
|
return Nothing
|
|
userSl <- 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 userSl mediumId Nothing
|
|
comments <- runDB $ selectList [CommentOrigin ==. mediumId, CommentParent ==. Nothing] [Desc CommentTime]
|
|
replies <- runDB $ selectList [CommentOrigin ==. mediumId, CommentParent !=. Nothing] [Desc CommentTime]
|
|
dataWidth <- case mediumWidth medium >= 850 of
|
|
True -> return 850
|
|
False -> return $ (mediumWidth medium)
|
|
formLayout $ do
|
|
setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium))
|
|
$(widgetFile "medium")
|
|
Nothing -> do
|
|
setMessage "This image does not exist"
|
|
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, _), _) <- runFormPost $ commentForm userId userSl mediumId Nothing
|
|
case res of
|
|
FormSuccess temp -> do
|
|
_ <- runDB $ insert temp
|
|
--send mail to medium owner
|
|
owner <- runDB $ getJust $ mediumOwner medium
|
|
link <- ($ MediumR (commentOrigin temp)) <$> getUrlRender
|
|
sendMail (userEmail owner) ((fromJust $ commentAuthorSlug temp) `T.append` " commented on your medium")
|
|
[shamlet|
|
|
<h1>Hello #{userSlug owner}
|
|
<p>#{fromJust $ commentAuthorSlug temp} commented on your medium:
|
|
<p>#{commentContent temp}
|
|
<p>To follow the comment thread follow
|
|
<a href=#{link}>
|
|
this link
|
|
.
|
|
|]
|
|
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)
|
|
formLayout $ 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, _), _) <- runFormPost $ commentForm userId userSl mediumId (Just commentId)
|
|
case res of
|
|
FormSuccess temp -> do
|
|
_ <- runDB $ insert temp
|
|
--send mail to parent author
|
|
parent <- runDB $ getJust $ fromJust $ commentParent temp
|
|
parAuth <- runDB $ getJust $ fromJust $ commentAuthor parent
|
|
link <- ($ MediumR (commentOrigin temp)) <$> getUrlRender
|
|
sendMail (userEmail parAuth) ((fromJust $ commentAuthorSlug temp) `T.append` " replied to your comment")
|
|
[shamlet|
|
|
<h1>Hello #{userSlug parAuth}
|
|
<p>#{fromJust $ commentAuthorSlug temp} replied to your comment:
|
|
#{commentContent temp}
|
|
<p>To see the comment thread follow
|
|
<a href=#{link}>
|
|
this link
|
|
.
|
|
|]
|
|
--send mail to medium owner
|
|
medium <- runDB $ getJust mediumId
|
|
owner <- runDB $ getJust $ mediumOwner medium
|
|
sendMail (userEmail owner) ((fromJust $ commentAuthorSlug temp) `T.append` " commented on your medium")
|
|
[shamlet|
|
|
<h1>Hello #{userSlug owner}
|
|
<p>#{fromJust $ commentAuthorSlug temp} commented your medium with:
|
|
#{commentContent temp}
|
|
<p>To see the comment thread follow
|
|
<a href=#{link}>
|
|
this link
|
|
.
|
|
|]
|
|
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 = do
|
|
tempComment <- runDB $ get commentId
|
|
case tempComment of
|
|
Just comment -> do
|
|
msu <- lookupSession "userId"
|
|
case msu of
|
|
Just tempUserId -> do
|
|
userId <- return $ getUserIdFromText tempUserId
|
|
presence <- return $ (Just userId) == (commentAuthor comment)
|
|
case presence of
|
|
True -> do
|
|
formLayout $ do
|
|
setTitle "Eidolon :: Delete comment"
|
|
$(widgetFile "commentDelete")
|
|
False -> do
|
|
setMessage "You must be the author of this comment to delete it"
|
|
redirect $ MediumR $ commentOrigin comment
|
|
Nothing -> do
|
|
setMessage "You must be logged in to delete comments"
|
|
redirect $ LoginR
|
|
Nothing -> do
|
|
setMessage "This comment does not exist"
|
|
redirect $ HomeR
|
|
|
|
postCommentDeleteR :: CommentId -> Handler Html
|
|
postCommentDeleteR commentId = do
|
|
tempComment <- runDB $ get commentId
|
|
case tempComment of
|
|
Just comment -> do
|
|
msu <- lookupSession "userId"
|
|
case msu of
|
|
Just tempUserId -> do
|
|
userId <- return $ getUserIdFromText tempUserId
|
|
presence <- return $ (Just userId) == (commentAuthor comment)
|
|
case presence of
|
|
True -> do
|
|
confirm <- lookupPostParam "confirm"
|
|
case confirm of
|
|
Just "confirm" -> do
|
|
-- delete comment children
|
|
childEnts <- runDB $ selectList [CommentParent ==. (Just commentId)] []
|
|
_ <- mapM (\ent -> runDB $ delete $ entityKey ent) childEnts
|
|
-- delete comment itself
|
|
runDB $ delete commentId
|
|
-- outro
|
|
setMessage "Your comment has been deleted"
|
|
redirect $ MediumR $ commentOrigin comment
|
|
_ -> do
|
|
setMessage "You must confirm the deletion"
|
|
redirect $ MediumR $ commentOrigin comment
|
|
False -> do
|
|
setMessage "You must be the author of this comment to delete it"
|
|
redirect $ MediumR $ commentOrigin comment
|
|
Nothing -> do
|
|
setMessage "You must be logged in to delete comments"
|
|
redirect $ LoginR
|
|
Nothing -> do
|
|
setMessage "This comment does not exist"
|
|
redirect $ HomeR
|