1 {-# LANGUAGE OverloadedStrings #-}
    2 module Controller.Comment
    3   ( postComment
    4   ) where
    5 
    6 import Control.Monad (forM_, when)
    7 import Control.Monad.Trans.Class (lift)
    8 import Data.Function (on)
    9 import Data.Text (Text)
   10 
   11 import Ops
   12 import qualified JSON
   13 import Model.Permission
   14 import Model.Id
   15 import Model.Container
   16 import Model.Slot
   17 import Model.Notification.Types
   18 import Model.Party.Types
   19 import Model.Comment
   20 import HTTP.Form.Deform
   21 import HTTP.Path.Parser
   22 import Action
   23 import Controller.Paths
   24 import Controller.Permission
   25 import Controller.Form
   26 import Controller.Slot
   27 import Controller.Notification
   28 import View.Form (FormHtml)
   29 
   30 data CreateOrUpdateCommentRequest = CreateOrUpdateCommentRequest Text (Maybe (Id Comment))
   31 
   32 postComment :: ActionRoute (Id Slot)
   33 postComment = action POST (pathJSON >/> pathSlotId </< "comment") $ \si -> withAuth $ do
   34   u <- authAccount
   35   s <- getSlot PermissionSHARED si
   36   (c, p) <- runForm (Nothing :: Maybe (RequestContext -> FormHtml a)) $ do
   37     csrfForm
   38     text <- "text" .:> (deformRequired =<< deform)
   39     parent <- "parent" .:> deformNonEmpty (deformMaybe' "comment not found" =<< lift . lookupComment =<< deform)
   40     let _ = CreateOrUpdateCommentRequest text (fmap commentId parent)
   41     return ((blankComment u s)
   42       { commentText = text
   43       , commentParents = maybe [] (return . commentId) parent
   44       }, parent)
   45   c' <- addComment c
   46   top <- containerIsVolumeTop (slotContainer s)
   47   forM_ p $ \r -> when (on (/=) (partyId . partyRow . accountParty) (commentWho r) u) $
   48     createNotification (blankNotification (commentWho r) NoticeCommentReply)
   49       { notificationContainerId = top `unlessUse` (containerId . containerRow . slotContainer . commentSlot) c'
   50       , notificationSegment = Just $ (slotSegment . commentSlot) c'
   51       , notificationCommentId = Just $ commentId c'
   52       }
   53   createVolumeNotification ((containerVolume . slotContainer . commentSlot) c') $ \n -> (n NoticeCommentVolume)
   54     { notificationContainerId = top `unlessUse` (containerId . containerRow . slotContainer . commentSlot) c'
   55     , notificationSegment = Just $ (slotSegment . commentSlot) c'
   56     , notificationCommentId = Just $ commentId c'
   57     }
   58   return $ okResponse [] $ JSON.recordEncoding $ commentJSON c'