now possible to comment on media. COmment deletion is WIP

Handler/Medium.hs

@@ -2,8 +2,10 @@ 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
@@ -16,15 +18,117 @@ getMediumR mediumId = do
       albumId <- return $ mediumAlbum medium
       album <- runDB $ getJust albumId
       msu <- lookupSession "userId"
-      presence <- case msu of
+      userId <- case msu of
         Just tempUserId -> do
-          userId <- return $ getUserIdFromText tempUserId
+          return $ Just $ getUserIdFromText tempUserId
-          return (userId == ownerId)
         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
         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, 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"

Model.hs

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

config/models

@@ -33,5 +33,13 @@ Medium
     tags Texts
     album AlbumId
     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)

config/routes

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

eidolon.cabal

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

templates/commentReply.hamlet

@@ -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">

templates/medium.hamlet

@@ -24,3 +24,27 @@ by <a href=@{UserR ownerName}>#{ownerName}</a> from album <a href=@{AlbumR album
           <a href=@{TagR tag}>#{tag}
 $if presence == True
   <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">