eidolon/Handler/Medium.hs

274 lines
11 KiB
Haskell
Raw Permalink Normal View History

2015-01-18 19:44:41 +00: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 09:00:18 +00:00
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
2015-01-18 19:44:41 +00:00
2014-08-18 04:06:16 +00:00
module Handler.Medium where
import Import
import Data.Time
import Data.Maybe
2014-09-24 21:03:18 +00:00
import qualified Data.Text as T
import System.FilePath
import Text.Markdown
import Yesod.Text.Markdown
import Yesod.RssFeed
import Yesod.AtomFeed
2017-08-06 02:42:57 +00:00
import Control.Monad (unless)
2014-08-18 04:06:16 +00:00
getMediumR :: MediumId -> Handler Html
getMediumR mediumId = do
tempMedium <- runDB $ get mediumId
case tempMedium of
Just medium -> do
2015-09-14 16:54:46 +00:00
let ownerId = mediumOwner medium
2014-08-18 04:06:16 +00:00
owner <- runDB $ getJust ownerId
2015-09-14 16:54:46 +00:00
let ownerName = userName owner
let albumId = mediumAlbum medium
2014-09-05 19:00:03 +00:00
album <- runDB $ getJust albumId
2017-04-26 19:43:22 +00:00
musername <- maybeAuthId
userId <- case musername of
Just username -> do
(Just (Entity uId _)) <- runDB $ getBy $ UniqueUser username
return $ Just uId
2014-08-18 04:06:16 +00:00
Nothing ->
return Nothing
2015-09-14 16:54:46 +00:00
let presence = userId == (Just ownerId) || userId == Just (albumOwner album)
2015-10-19 06:32:47 +00:00
(commentWidget, enctype) <- generateFormPost $
renderBootstrap3 BootstrapBasicForm $
commentForm (fromJust userId) mediumId Nothing
userEnts <- runDB $ selectList [] [Asc UserId]
let authors = map (\ent -> (entityKey ent, (userSlug $ entityVal ent))) userEnts
2015-09-14 16:54:46 +00:00
comments <- runDB $ selectList
[ CommentOrigin ==. mediumId
, CommentParent ==. Nothing ]
2017-01-06 16:33:33 +00:00
[ Asc CommentTime ]
2015-09-14 16:54:46 +00:00
replies <- runDB $ selectList
[ CommentOrigin ==. mediumId
, CommentParent !=. Nothing ]
2017-01-06 16:33:33 +00:00
[ Asc CommentTime ]
2017-04-26 19:43:22 +00: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 02:42:31 +00:00
lic = T.pack $ show $ mediumLicence medium
link = url $ mediumLicence medium
2016-08-30 12:22:00 +00:00
defaultLayout $ do
2014-09-24 21:03:18 +00:00
setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium))
2017-04-26 19:43:22 +00: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 04:06:16 +00:00
$(widgetFile "medium")
Nothing -> do
setMessage "This image does not exist"
2015-09-14 16:54:46 +00:00
redirect HomeR
postMediumR :: MediumId -> Handler Html
postMediumR mediumId = do
tempMedium <- runDB $ get mediumId
case tempMedium of
Just medium -> do
2017-04-26 19:43:22 +00:00
musername <- maybeAuthId
case musername of
Just username -> do
(Just (Entity userId u)) <- runDB $ getBy $ UniqueUser username
let userSl = userSlug u
2015-10-19 06:32:47 +00:00
((res, _), _) <- runFormPost $
renderBootstrap3 BootstrapBasicForm $
commentForm userId mediumId Nothing
case res of
FormSuccess temp -> do
2016-09-06 15:30:41 +00:00
runDB $ insert_ temp
2014-12-08 05:13:39 +00:00
--send mail to medium owner
owner <- runDB $ getJust $ mediumOwner medium
link <- ($ MediumR (commentOrigin temp)) <$> getUrlRender
2017-08-06 02:42:57 +00: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
.
|]
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 05:46:34 +00:00
redirect $ AuthR LoginR
Nothing -> do
setMessage "This image does not exist"
2015-09-14 16:54:46 +00:00
redirect HomeR
commentForm :: UserId -> MediumId -> Maybe CommentId -> AForm Handler Comment
commentForm authorId originId parentId = Comment
<$> pure authorId
<*> pure originId
<*> pure parentId
<*> lift (liftIO getCurrentTime)
2015-10-19 06:32:47 +00:00
<*> areq markdownField (bfs ("Comment this medium" :: T.Text)) Nothing
<* bootstrapSubmit ("Post comment" :: BootstrapSubmit Text)
getCommentReplyR :: CommentId -> Handler Html
getCommentReplyR commentId = do
tempComment <- runDB $ get commentId
case tempComment of
Just comment -> do
2017-04-26 19:43:22 +00:00
musername <- maybeAuthId
case musername of
Just username -> do
(Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username
2015-09-14 16:54:46 +00:00
let mediumId = commentOrigin comment
parAuth <- runDB $ get $ commentAuthor comment
let parSlug = fromMaybe "" $ userSlug <$> parAuth
2015-10-19 06:32:47 +00:00
(replyWidget, enctype) <- generateFormPost $
renderBootstrap3 BootstrapBasicForm $
commentForm userId mediumId (Just commentId)
2016-09-07 15:32:56 +00:00
defaultLayout $ do
setTitle "Eidolon :: Reply to comment"
$(widgetFile "commentReply")
Nothing -> do
setMessage "You need to be logged in to comment on media"
2017-04-24 05:46:34 +00:00
redirect $ AuthR LoginR
Nothing -> do
setMessage "This comment does not Exist"
2015-09-14 16:54:46 +00:00
redirect HomeR
postCommentReplyR :: CommentId -> Handler Html
postCommentReplyR commentId = do
tempComment <- runDB $ get commentId
case tempComment of
Just comment -> do
2017-04-26 19:43:22 +00:00
musername <- maybeAuthId
case musername of
Just username -> do
(Just (Entity userId u)) <- runDB $ getBy $ UniqueUser username
let userSl = userSlug u
2017-04-26 19:43:22 +00:00
mediumId = commentOrigin comment
2015-10-19 06:32:47 +00:00
((res, _), _) <- runFormPost $
renderBootstrap3 BootstrapBasicForm $
commentForm userId mediumId (Just commentId)
case res of
FormSuccess temp -> do
2016-09-06 15:30:41 +00:00
runDB $ insert_ temp
2014-12-08 05:13:39 +00:00
--send mail to parent author
parent <- runDB $ getJust $ fromJust $ commentParent temp
parAuth <- runDB $ getJust $ commentAuthor parent
2014-12-08 05:13:39 +00:00
link <- ($ MediumR (commentOrigin temp)) <$> getUrlRender
sendMail (userEmail parAuth) (userSl `T.append` " replied to your comment")
2014-12-08 05:13:39 +00:00
[shamlet|
<h1>Hello #{userSlug parAuth}
<p>#{userSl} replied to your comment:
2014-12-28 02:53:49 +00:00
#{commentContent temp}
2014-12-08 05:13:39 +00:00
<p>To see the comment thread follow
<a href=#{link}>
this link
2014-12-08 05:27:28 +00:00
.
2014-12-08 05:13:39 +00:00
|]
--send mail to medium owner
medium <- runDB $ getJust mediumId
owner <- runDB $ getJust $ mediumOwner medium
sendMail (userEmail owner) (userSl `T.append` " commented on your medium")
2014-12-08 05:13:39 +00:00
[shamlet|
<h1>Hello #{userSlug owner}
<p>#{userSl} commented your medium with:
2014-12-28 02:53:49 +00:00
#{commentContent temp}
2014-12-08 05:13:39 +00:00
<p>To see the comment thread follow
<a href=#{link}>
this link
2014-12-08 05:27:28 +00:00
.
2014-12-08 05:13:39 +00: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 05:46:34 +00:00
redirect $ AuthR LoginR
Nothing -> do
setMessage "This comment does not exist!"
2015-09-14 16:54:46 +00:00
redirect HomeR
getCommentDeleteR :: CommentId -> Handler Html
2014-12-07 05:08:45 +00:00
getCommentDeleteR commentId = do
tempComment <- runDB $ get commentId
case tempComment of
Just comment -> do
2017-04-26 19:43:22 +00:00
musername <- maybeAuthId
case musername of
Just username -> do
(Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username
2015-09-14 16:54:46 +00:00
if
Just userId == Just (commentAuthor comment)
2015-09-14 16:54:46 +00:00
then do
2016-09-07 15:32:56 +00:00
defaultLayout $ do
2014-12-07 05:08:45 +00:00
setTitle "Eidolon :: Delete comment"
$(widgetFile "commentDelete")
2015-09-14 16:54:46 +00:00
else do
2014-12-07 05:08:45 +00: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 05:46:34 +00:00
redirect $ AuthR LoginR
2014-12-07 05:08:45 +00:00
Nothing -> do
setMessage "This comment does not exist"
2015-09-14 16:54:46 +00:00
redirect HomeR
postCommentDeleteR :: CommentId -> Handler Html
2014-12-07 05:08:45 +00:00
postCommentDeleteR commentId = do
tempComment <- runDB $ get commentId
case tempComment of
Just comment -> do
2017-04-26 19:43:22 +00:00
musername <- maybeAuthId
case musername of
Just username -> do
(Just (Entity userId _)) <- runDB $ getBy $ UniqueUser username
2015-09-14 16:54:46 +00:00
if
Just userId == Just (commentAuthor comment)
2015-09-14 16:54:46 +00:00
then do
2014-12-07 05:08:45 +00:00
confirm <- lookupPostParam "confirm"
case confirm of
Just "confirm" -> do
-- delete comment children
childEnts <- runDB $ selectList [CommentParent ==. (Just commentId)] []
_ <- mapM (\ent -> do
2016-09-05 14:01:49 +00:00
-- delete comment children
runDB $ delete $ entityKey ent) childEnts
2014-12-07 05:08:45 +00: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 16:54:46 +00:00
else do
2014-12-07 05:08:45 +00: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 05:46:34 +00:00
redirect $ AuthR LoginR
2014-12-07 05:08:45 +00:00
Nothing -> do
setMessage "This comment does not exist"
2015-09-14 16:54:46 +00:00
redirect HomeR