diff --git a/src/Vervis/Discussion.hs b/src/Vervis/Discussion.hs index 57947dc..aff4bdb 100644 --- a/src/Vervis/Discussion.hs +++ b/src/Vervis/Discussion.hs @@ -35,8 +35,9 @@ import Data.Tree.Local (sortForestOn) import Vervis.Foundation import Vervis.Model -getMessages :: DiscussionId -> Handler [(Entity Message, Sharer)] -getMessages did = fmap (map $ second entityVal) $ runDB $ +getMessages :: AppDB DiscussionId -> Handler [(Entity Message, Sharer)] +getMessages getdid = fmap (map $ second entityVal) $ runDB $ do + did <- getdid select $ from $ \ (message, person, sharer) -> do where_ $ message ^. MessageRoot ==. val did &&. @@ -67,5 +68,5 @@ sortByTime = sortForestOn $ messageCreated . fst -- | Get the tree of messages in a given discussion, with siblings sorted from -- old to new. -getDiscussionTree :: DiscussionId -> Handler (Forest (Message, Sharer)) -getDiscussionTree did = sortByTime . discussionTree <$> getMessages did +getDiscussionTree :: AppDB DiscussionId -> Handler (Forest (Message, Sharer)) +getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index ba26664..8041960 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/src/Vervis/Handler/Discussion.hs @@ -35,17 +35,18 @@ import Yesod.Form.Types (FormResult (..)) import Yesod.Persist.Core (runDB, get404, getBy404) import Vervis.Form.Discussion -import Vervis.Foundation (App, Handler) +import Vervis.Foundation (App, Handler, AppDB) import Vervis.Model import Vervis.Settings (widgetFile) import Vervis.Widget.Discussion -getDiscussion :: (Int -> Route App) -> DiscussionId -> Handler Html -getDiscussion reply did = defaultLayout $ discussionW did reply +getDiscussion :: (Int -> Route App) -> AppDB DiscussionId -> Handler Html +getDiscussion reply getdid = defaultLayout $ discussionW getdid reply -getMessage :: (Int -> Route App) -> DiscussionId -> Int -> Handler Html -getMessage reply did num = do +getMessage :: (Int -> Route App) -> AppDB DiscussionId -> Int -> Handler Html +getMessage reply getdid num = do (msg, shr) <- runDB $ do + did <- getdid Entity _mid m <- getBy404 $ UniqueMessage did num p <- get404 $ messageAuthor m s <- get404 $ personIdent p @@ -56,11 +57,12 @@ getMessage reply did num = do getReply :: (Int -> Route App) -> (Int -> Route App) - -> DiscussionId + -> AppDB DiscussionId -> Int -> Handler Html -getReply replyG replyP did num = do +getReply replyG replyP getdid num = do (msg, shr) <- runDB $ do + did <- getdid Entity _mid m <- getBy404 $ UniqueMessage did num p <- get404 $ messageAuthor m s <- get404 $ personIdent p @@ -73,16 +75,17 @@ postReply :: (Int -> Route App) -> (Int -> Route App) -> (Int -> Route App) - -> DiscussionId + -> AppDB DiscussionId -> Int -> Handler Html -postReply replyG replyP after did cnum = do +postReply replyG replyP after getdid cnum = do ((result, widget), enctype) <- runFormPost newMessageForm now <- liftIO getCurrentTime case result of FormSuccess nm -> do author <- requireAuthId mnum <- runDB $ do + did <- getdid (parent, next) <- do discussion <- get404 did Entity mid _message <- getBy404 $ UniqueMessage did cnum @@ -103,6 +106,7 @@ postReply replyG replyP after did cnum = do FormMissing -> do setMessage "Field(s) missing." (msg, shr) <- runDB $ do + did <- getdid Entity _mid m <- getBy404 $ UniqueMessage did cnum p <- get404 $ messageAuthor m s <- get404 $ personIdent p @@ -111,6 +115,7 @@ postReply replyG replyP after did cnum = do FormFailure _l -> do setMessage "Message submission failed, see errors below." (msg, shr) <- runDB $ do + did <- getdid Entity _mid m <- getBy404 $ UniqueMessage did cnum p <- get404 $ messageAuthor m s <- get404 $ personIdent p diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index dc2aa01..ff65c4c 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -192,33 +192,34 @@ selectDiscussionId shar proj tnum = do return $ ticketDiscuss ticket getTicketDiscussionR :: Text -> Text -> Int -> Handler Html -getTicketDiscussionR shar proj num = do - did <- runDB $ selectDiscussionId shar proj num - getDiscussion (TicketReplyR shar proj num) did +getTicketDiscussionR shar proj num = + getDiscussion + (TicketReplyR shar proj num) + (selectDiscussionId shar proj num) getTicketMessageR :: Text -> Text -> Int -> Int -> Handler Html -getTicketMessageR shar proj tnum cnum = do - did <- runDB $ selectDiscussionId shar proj tnum - getMessage (TicketReplyR shar proj tnum) did cnum +getTicketMessageR shar proj tnum cnum = + getMessage + (TicketReplyR shar proj tnum) + (selectDiscussionId shar proj tnum) + cnum postTicketMessageR :: Text -> Text -> Int -> Int -> Handler Html -postTicketMessageR shar proj tnum cnum = do - did <- runDB $ selectDiscussionId shar proj tnum +postTicketMessageR shar proj tnum cnum = postReply (TicketReplyR shar proj tnum) (TicketMessageR shar proj tnum) (const $ TicketR shar proj tnum) - did + (selectDiscussionId shar proj tnum) cnum getTicketTopReplyR :: Text -> Text -> Int -> Handler Html getTicketTopReplyR shar proj num = error "Not implemented yet" getTicketReplyR :: Text -> Text -> Int -> Int -> Handler Html -getTicketReplyR shar proj tnum cnum = do - did <- runDB $ selectDiscussionId shar proj tnum +getTicketReplyR shar proj tnum cnum = getReply (TicketReplyR shar proj tnum) (TicketMessageR shar proj tnum) - did + (selectDiscussionId shar proj tnum) cnum diff --git a/src/Vervis/Widget/Discussion.hs b/src/Vervis/Widget/Discussion.hs index 9b1e988..94c4b10 100644 --- a/src/Vervis/Widget/Discussion.hs +++ b/src/Vervis/Widget/Discussion.hs @@ -61,9 +61,9 @@ messageTreeW reply cReplies now t = go t ^{go tree} |] -discussionW :: DiscussionId -> (Int -> Route App) -> Widget -discussionW did reply = do - forest <- handlerToWidget $ getDiscussionTree did +discussionW :: AppDB DiscussionId -> (Int -> Route App) -> Widget +discussionW getdid reply = do + forest <- handlerToWidget $ getDiscussionTree getdid cReplies <- newIdent now <- liftIO getCurrentTime toWidget $(cassiusFile "templates/discussion/widget/tree.cassius") diff --git a/templates/ticket/one.hamlet b/templates/ticket/one.hamlet index 941a61e..109f8b0 100644 --- a/templates/ticket/one.hamlet +++ b/templates/ticket/one.hamlet @@ -37,4 +37,4 @@ $# .

Discussion -^{discussionW (ticketDiscuss ticket) (TicketReplyR shar proj num)} +^{discussionW (return $ ticketDiscuss ticket) (TicketReplyR shar proj num)}