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')))