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