eidolon/Handler/Medium.hs

190 lines
7.1 KiB
Haskell
Raw Normal View History

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
2014-08-18 04:06:16 +00:00
import System.Locale
import Yesod.Markdown
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
ownerId <- return $ mediumOwner medium
owner <- runDB $ getJust ownerId
ownerName <- return $ userName owner
2014-09-05 19:00:03 +00:00
albumId <- return $ mediumAlbum medium
album <- runDB $ getJust albumId
2014-08-18 04:06:16 +00:00
msu <- lookupSession "userId"
userId <- case msu of
2014-08-18 04:06:16 +00:00
Just tempUserId -> do
return $ Just $ getUserIdFromText tempUserId
2014-08-18 04:06:16 +00:00
Nothing ->
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]
2014-08-18 04:06:16 +00:00
defaultLayout $ do
2014-09-24 21:03:18 +00:00
setTitle $ toHtml ("Eidolon :: Medium " `T.append` (mediumTitle medium))
2014-08-18 04:06:16 +00:00
$(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, 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
2014-12-07 05:08:45 +00:00
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
defaultLayout $ 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
2014-12-07 05:08:45 +00:00
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