2015-01-18 20:44:41 +01:00
|
|
|
-- eidolon -- A simple gallery in Haskell and Yesod
|
|
|
|
-- Copyright (C) 2015 Amedeo Molnár
|
|
|
|
--
|
|
|
|
-- This program is free software: you can redistribute it and/or modify
|
|
|
|
-- it under the terms of the GNU Affero General Public License as published
|
|
|
|
-- by the Free Software Foundation, either version 3 of the License, or
|
|
|
|
-- (at your option) any later version.
|
|
|
|
--
|
|
|
|
-- This program is distributed in the hope that it will be useful,
|
|
|
|
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
|
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
|
-- GNU Affero General Public License for more details.
|
|
|
|
--
|
|
|
|
-- You should have received a copy of the GNU Affero General Public License
|
2015-01-21 10:00:18 +01:00
|
|
|
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
2015-01-18 20:44:41 +01:00
|
|
|
|
2014-08-18 06:06:16 +02:00
|
|
|
module Handler.Medium where
|
|
|
|
|
|
|
|
import Import
|
|
|
|
import Data.Time
|
2014-12-07 03:54:02 +01:00
|
|
|
import Data.Maybe
|
2014-09-24 23:03:18 +02:00
|
|
|
import qualified Data.Text as T
|
2015-02-12 05:25:15 +01:00
|
|
|
import System.FilePath
|
2017-01-06 18:28:36 +01:00
|
|
|
import Text.Markdown
|
|
|
|
import Yesod.Text.Markdown
|
2015-09-26 11:15:20 +02:00
|
|
|
import Yesod.RssFeed
|
|
|
|
import Yesod.AtomFeed
|
2017-08-06 04:42:57 +02:00
|
|
|
import Control.Monad (unless)
|
2014-08-18 06:06:16 +02:00
|
|
|
|
|
|
|
getMediumR :: MediumId -> Handler Html
|
|
|
|
getMediumR mediumId = do
|
|
|
|
tempMedium <- runDB $ get mediumId
|
|
|
|
case tempMedium of
|
|
|
|
Just medium -> do
|
2015-09-14 18:54:46 +02:00
|
|
|
let ownerId = mediumOwner medium
|
2014-08-18 06:06:16 +02:00
|
|
|
owner <- runDB $ getJust ownerId
|
2015-09-14 18:54:46 +02:00
|
|
|
let ownerName = userName owner
|
|
|
|
let albumId = mediumAlbum medium
|
2014-09-05 21:00:03 +02:00
|
|
|
album <- runDB $ getJust albumId
|
2017-04-26 21:43:22 +02:00
|
|
|
musername <- maybeAuthId
|
|
|
|
userId <- case musername of
|
|
|
|
Just username -> do
|
|
|
|
(Just (Entity uId _)) <- runDB $ getBy $ UniqueUser username
|
|
|
|
return $ Just uId
|
2014-08-18 06:06:16 +02:00
|
|
|
Nothing ->
|
2014-12-07 03:54:02 +01:00
|
|
|
return Nothing
|
2015-09-14 18:54:46 +02:00
|
|
|
let presence = userId == (Just ownerId) || userId == Just (albumOwner album)
|
2015-10-19 08:32:47 +02:00
|
|
|
(commentWidget, enctype) <- generateFormPost $
|
|
|
|
renderBootstrap3 BootstrapBasicForm $
|
2016-10-23 03:21:59 +02:00
|
|
|
commentForm (fromJust userId) mediumId Nothing
|
|
|
|
userEnts <- runDB $ selectList [] [Asc UserId]
|
|
|
|
let authors = map (\ent -> (entityKey ent, (userSlug $ entityVal ent))) userEnts
|
2015-09-14 18:54:46 +02:00
|
|
|
comments <- runDB $ selectList
|
|
|
|
[ CommentOrigin ==. mediumId
|
|
|
|
, CommentParent ==. Nothing ]
|
2017-01-06 17:33:33 +01:00
|
|
|
[ Asc CommentTime ]
|
2015-09-14 18:54:46 +02:00
|
|
|
replies <- runDB $ selectList
|
|
|
|
[ CommentOrigin ==. mediumId
|
|
|
|
, CommentParent !=. Nothing ]
|
2017-01-06 17:33:33 +01:00
|
|
|
[ Asc CommentTime ]
|
2017-04-26 21:43:22 +02:00
|
|
|
let tr = StaticR $ StaticRoute
|
|
|
|
(drop 2 $ map T.pack $ splitDirectories $ mediumThumb medium) []
|
|
|
|
pr = StaticR $ StaticRoute
|
|
|
|
(drop 2 $ map T.pack $ splitDirectories $ mediumPreview medium) []
|
|
|
|
ir = StaticR $ StaticRoute
|
|
|
|
(drop 2 $ map T.pack $ splitDirectories $ mediumPath medium) []
|
2017-08-06 04:42:31 +02:00
|
|
|
lic = T.pack $ show $ mediumLicence medium
|
|
|
|
link = url $ mediumLicence medium
|
2016-08-30 14:22:00 +02:00
|
|
|
defaultLayout $ do
|
2014-09-24 23:03:18 +02:00
|
|
|
setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium))
|
2017-04-26 21:43:22 +02:00
|
|
|
rssLink (CommentFeedRssR mediumId) $
|
|
|
|
"Comment feed of medium " `T.append` mediumTitle medium
|
|
|
|
atomLink (CommentFeedAtomR mediumId) $
|
|
|
|
"Comment feed of medium " `T.append` mediumTitle medium
|
2014-08-18 06:06:16 +02:00
|
|
|
$(widgetFile "medium")
|
|
|
|
Nothing -> do
|
|
|
|
setMessage "This image does not exist"
|
2015-09-14 18:54:46 +02:00
|
|
|
redirect HomeR
|
2014-12-07 03:54:02 +01:00
|
|
|
|
|
|
|
postMediumR :: MediumId -> Handler Html
|
|
|
|
postMediumR mediumId = do
|
|
|
|
tempMedium <- runDB $ get mediumId
|
|
|
|
case tempMedium of
|
|
|
|
Just medium -> do
|
2017-04-26 21:43:22 +02:00
|
|
|
musername <- maybeAuthId
|
|
|
|
case musername of
|
|
|
|
Just username -> do
|
|
|
|
(Just (Entity userId u)) <- runDB $ getBy $ UniqueUser username
|
2015-09-26 11:14:49 +02:00
|
|
|
let userSl = userSlug u
|
2015-10-19 08:32:47 +02:00
|
|
|
((res, _), _) <- runFormPost $
|
|
|
|
renderBootstrap3 BootstrapBasicForm $
|
2016-10-23 03:21:59 +02:00
|
|
|
commentForm userId mediumId Nothing
|
2014-12-07 03:54:02 +01:00
|
|
|
case res of
|
|
|
|
FormSuccess temp -> do
|
2016-09-06 17:30:41 +02:00
|
|
|
runDB $ insert_ temp
|
2014-12-08 06:13:39 +01:00
|
|
|
--send mail to medium owner
|
|
|
|
owner <- runDB $ getJust $ mediumOwner medium
|
|
|
|
link <- ($ MediumR (commentOrigin temp)) <$> getUrlRender
|
2017-08-06 04:42:57 +02:00
|
|
|
unless (userId == mediumOwner medium) $
|
|
|
|
sendMail (userEmail owner) (userSl `T.append` " commented on your medium")
|
|
|
|
[shamlet|
|
|
|
|
<h1>Hello #{userSlug owner}
|
|
|
|
<p>#{userSl} commented on your medium #{mediumTitle medium}:
|
|
|
|
<p>#{commentContent temp}
|
|
|
|
<p>To read the comment thread follow
|
|
|
|
<a href=#{link}>
|
|
|
|
this link
|
|
|
|
.
|
|
|
|
|]
|
2014-12-07 03:54:02 +01:00
|
|
|
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"
|
2017-04-24 07:46:34 +02:00
|
|
|
redirect $ AuthR LoginR
|
2014-12-07 03:54:02 +01:00
|
|
|
Nothing -> do
|
|
|
|
setMessage "This image does not exist"
|
2015-09-14 18:54:46 +02:00
|
|
|
redirect HomeR
|
2014-12-07 03:54:02 +01:00
|
|
|
|
2016-10-23 03:21:59 +02:00
|
|
|
commentForm :: UserId -> MediumId -> Maybe CommentId -> AForm Handler Comment
|
|
|
|
commentForm authorId originId parentId = Comment
|
2014-12-07 03:54:02 +01:00
|
|
|
<$> pure authorId
|
|
|
|
<*> pure originId
|
|
|
|
<*> pure parentId
|
|
|
|
<*> lift (liftIO getCurrentTime)
|
2015-10-19 08:32:47 +02:00
|
|
|
<*> areq markdownField (bfs ("Comment this medium" :: T.Text)) Nothing
|
|
|
|
<* bootstrapSubmit ("Post comment" :: BootstrapSubmit Text)
|
2014-12-07 03:54:02 +01:00
|
|
|
|
|
|
|
getCommentReplyR :: CommentId -> Handler Html
|
|
|
|
getCommentReplyR commentId = do
|
|
|
|
tempComment <- runDB $ get commentId
|
|
|
|
case tempComment of
|
|
|
|
Just comment -> do
|
2017-04-26 21:43:22 +02:00
|
|
|
musername <- maybeAuthId
|
|
|
|
case musername of
|
|
|
|
Just username -> do
|
|
|
|
(Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username
|
2015-09-14 18:54:46 +02:00
|
|
|
let mediumId = commentOrigin comment
|
2016-10-23 03:21:59 +02:00
|
|
|
parAuth <- runDB $ get $ commentAuthor comment
|
|
|
|
let parSlug = fromMaybe "" $ userSlug <$> parAuth
|
2015-10-19 08:32:47 +02:00
|
|
|
(replyWidget, enctype) <- generateFormPost $
|
|
|
|
renderBootstrap3 BootstrapBasicForm $
|
2016-10-23 03:21:59 +02:00
|
|
|
commentForm userId mediumId (Just commentId)
|
2016-09-07 17:32:56 +02:00
|
|
|
defaultLayout $ do
|
2014-12-07 03:54:02 +01:00
|
|
|
setTitle "Eidolon :: Reply to comment"
|
|
|
|
$(widgetFile "commentReply")
|
|
|
|
Nothing -> do
|
|
|
|
setMessage "You need to be logged in to comment on media"
|
2017-04-24 07:46:34 +02:00
|
|
|
redirect $ AuthR LoginR
|
2014-12-07 03:54:02 +01:00
|
|
|
Nothing -> do
|
|
|
|
setMessage "This comment does not Exist"
|
2015-09-14 18:54:46 +02:00
|
|
|
redirect HomeR
|
2014-12-07 03:54:02 +01:00
|
|
|
|
|
|
|
postCommentReplyR :: CommentId -> Handler Html
|
|
|
|
postCommentReplyR commentId = do
|
|
|
|
tempComment <- runDB $ get commentId
|
|
|
|
case tempComment of
|
|
|
|
Just comment -> do
|
2017-04-26 21:43:22 +02:00
|
|
|
musername <- maybeAuthId
|
|
|
|
case musername of
|
|
|
|
Just username -> do
|
|
|
|
(Just (Entity userId u)) <- runDB $ getBy $ UniqueUser username
|
2015-09-26 11:14:49 +02:00
|
|
|
let userSl = userSlug u
|
2017-04-26 21:43:22 +02:00
|
|
|
mediumId = commentOrigin comment
|
2015-10-19 08:32:47 +02:00
|
|
|
((res, _), _) <- runFormPost $
|
|
|
|
renderBootstrap3 BootstrapBasicForm $
|
2016-10-23 03:21:59 +02:00
|
|
|
commentForm userId mediumId (Just commentId)
|
2014-12-07 03:54:02 +01:00
|
|
|
case res of
|
|
|
|
FormSuccess temp -> do
|
2016-09-06 17:30:41 +02:00
|
|
|
runDB $ insert_ temp
|
2014-12-08 06:13:39 +01:00
|
|
|
--send mail to parent author
|
|
|
|
parent <- runDB $ getJust $ fromJust $ commentParent temp
|
2015-09-26 11:14:49 +02:00
|
|
|
parAuth <- runDB $ getJust $ commentAuthor parent
|
2014-12-08 06:13:39 +01:00
|
|
|
link <- ($ MediumR (commentOrigin temp)) <$> getUrlRender
|
2016-10-23 03:21:59 +02:00
|
|
|
sendMail (userEmail parAuth) (userSl `T.append` " replied to your comment")
|
2014-12-08 06:13:39 +01:00
|
|
|
[shamlet|
|
|
|
|
<h1>Hello #{userSlug parAuth}
|
2016-10-23 03:21:59 +02:00
|
|
|
<p>#{userSl} replied to your comment:
|
2014-12-28 03:53:49 +01:00
|
|
|
#{commentContent temp}
|
2014-12-08 06:13:39 +01:00
|
|
|
<p>To see the comment thread follow
|
|
|
|
<a href=#{link}>
|
|
|
|
this link
|
2014-12-08 06:27:28 +01:00
|
|
|
.
|
2014-12-08 06:13:39 +01:00
|
|
|
|]
|
|
|
|
--send mail to medium owner
|
|
|
|
medium <- runDB $ getJust mediumId
|
|
|
|
owner <- runDB $ getJust $ mediumOwner medium
|
2016-10-23 03:21:59 +02:00
|
|
|
sendMail (userEmail owner) (userSl `T.append` " commented on your medium")
|
2014-12-08 06:13:39 +01:00
|
|
|
[shamlet|
|
|
|
|
<h1>Hello #{userSlug owner}
|
2016-10-23 03:21:59 +02:00
|
|
|
<p>#{userSl} commented your medium with:
|
2014-12-28 03:53:49 +01:00
|
|
|
#{commentContent temp}
|
2014-12-08 06:13:39 +01:00
|
|
|
<p>To see the comment thread follow
|
|
|
|
<a href=#{link}>
|
|
|
|
this link
|
2014-12-08 06:27:28 +01:00
|
|
|
.
|
2014-12-08 06:13:39 +01:00
|
|
|
|]
|
2014-12-07 03:54:02 +01:00
|
|
|
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"
|
2017-04-24 07:46:34 +02:00
|
|
|
redirect $ AuthR LoginR
|
2014-12-07 03:54:02 +01:00
|
|
|
Nothing -> do
|
|
|
|
setMessage "This comment does not exist!"
|
2015-09-14 18:54:46 +02:00
|
|
|
redirect HomeR
|
2014-12-07 03:54:02 +01:00
|
|
|
|
|
|
|
getCommentDeleteR :: CommentId -> Handler Html
|
2014-12-07 06:08:45 +01:00
|
|
|
getCommentDeleteR commentId = do
|
|
|
|
tempComment <- runDB $ get commentId
|
|
|
|
case tempComment of
|
|
|
|
Just comment -> do
|
2017-04-26 21:43:22 +02:00
|
|
|
musername <- maybeAuthId
|
|
|
|
case musername of
|
|
|
|
Just username -> do
|
|
|
|
(Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username
|
2015-09-14 18:54:46 +02:00
|
|
|
if
|
2015-09-26 11:14:49 +02:00
|
|
|
Just userId == Just (commentAuthor comment)
|
2015-09-14 18:54:46 +02:00
|
|
|
then do
|
2016-09-07 17:32:56 +02:00
|
|
|
defaultLayout $ do
|
2014-12-07 06:08:45 +01:00
|
|
|
setTitle "Eidolon :: Delete comment"
|
|
|
|
$(widgetFile "commentDelete")
|
2015-09-14 18:54:46 +02:00
|
|
|
else do
|
2014-12-07 06:08:45 +01:00
|
|
|
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"
|
2017-04-24 07:46:34 +02:00
|
|
|
redirect $ AuthR LoginR
|
2014-12-07 06:08:45 +01:00
|
|
|
Nothing -> do
|
|
|
|
setMessage "This comment does not exist"
|
2015-09-14 18:54:46 +02:00
|
|
|
redirect HomeR
|
2014-12-07 03:54:02 +01:00
|
|
|
|
|
|
|
postCommentDeleteR :: CommentId -> Handler Html
|
2014-12-07 06:08:45 +01:00
|
|
|
postCommentDeleteR commentId = do
|
|
|
|
tempComment <- runDB $ get commentId
|
|
|
|
case tempComment of
|
|
|
|
Just comment -> do
|
2017-04-26 21:43:22 +02:00
|
|
|
musername <- maybeAuthId
|
|
|
|
case musername of
|
|
|
|
Just username -> do
|
|
|
|
(Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username
|
2015-09-14 18:54:46 +02:00
|
|
|
if
|
2015-09-26 11:14:49 +02:00
|
|
|
Just userId == Just (commentAuthor comment)
|
2015-09-14 18:54:46 +02:00
|
|
|
then do
|
2014-12-07 06:08:45 +01:00
|
|
|
confirm <- lookupPostParam "confirm"
|
|
|
|
case confirm of
|
|
|
|
Just "confirm" -> do
|
|
|
|
-- delete comment children
|
|
|
|
childEnts <- runDB $ selectList [CommentParent ==. (Just commentId)] []
|
2015-10-16 21:57:18 +02:00
|
|
|
_ <- mapM (\ent -> do
|
2016-09-05 16:01:49 +02:00
|
|
|
-- delete comment children
|
2015-10-16 21:57:18 +02:00
|
|
|
runDB $ delete $ entityKey ent) childEnts
|
2014-12-07 06:08:45 +01:00
|
|
|
-- 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
|
2015-09-14 18:54:46 +02:00
|
|
|
else do
|
2014-12-07 06:08:45 +01:00
|
|
|
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"
|
2017-04-24 07:46:34 +02:00
|
|
|
redirect $ AuthR LoginR
|
2014-12-07 06:08:45 +01:00
|
|
|
Nothing -> do
|
|
|
|
setMessage "This comment does not exist"
|
2015-09-14 18:54:46 +02:00
|
|
|
redirect HomeR
|