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'