Pass AppDB action instead of DiscussionId

Passing `AppDB DiscussionId` from ticket handlers to the actual
discussion handlers allows the DB queries to run in a single
transaction.

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

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

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

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

templates/ticket/one.hamlet

@@ -37,4 +37,4 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 <h3>Discussion
 
-^{discussionW (ticketDiscuss ticket) (TicketReplyR shar proj num)}
+^{discussionW (return $ ticketDiscuss ticket) (TicketReplyR shar proj num)}