threadCommentDB
    :: Maybe CommentId
    -> DiscussionId
    -> CommentId
    -> UserId
    -> Text
    -> Int
    -> SDB ()
rethreadCommentDB
        mnew_parent_id
        new_discussion_id
        root_comment_id
        user_id
        reason
        depth_offset = do

    (old_comment_ids, new_comment_ids) <- lift $ do
        descendants_ids <- fetchCommentAllCurrentDescendantsDB root_comment_id
        let old_comment_ids = root_comment_id : descendants_ids

        new_comment_ids <- flip State.evalStateT mempty $ forM old_comment_ids $ \comment_id -> do
            rethread_map <- State.get

            Just comment <- lift $ get comment_id

            let new_parent_id = maybe mnew_parent_id Just $ M.lookup (commentParent comment) rethread_map

            new_comment_id <- lift $ insert $ comment
                { commentDepth      = commentDepth comment - depth_offset
                , commentParent     = new_parent_id
                , commentDiscussion = new_discussion_id
                }

            State.put $ M.insert (Just comment_id) new_comment_id rethread_map

            return new_comment_id

        return (old_comment_ids, new_comment_ids)

    now <- liftIO getCurrentTime

    let new_root_comment_id = Prelude.head new_comment_ids -- This is kind of ugly, but it should be safe.
        rethread = Rethread now user_id root_comment_id new_root_comment_id reason
    rethread_id <- lift (insert rethread)
    tell [ECommentRethreaded rethread_id rethread]

    let updateForRethread :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend)
                          => EntityField val CommentId
                          -> (SqlExpr (Entity val) -> SqlExpr (Entity CommentRethread) -> SqlExpr (Insertion val))
                          -> DB ()
        updateForRethread comment_field constructor =
            insertSelect $
            from $ \(table `InnerJoin` cr) -> do
            on_ (table ^. comment_field ==. cr ^. CommentRethreadOldComment)
            where_ (table ^. comment_field `in_` valList old_comment_ids)
            return (constructor table cr)

    lift $ do
        forM_ (zip old_comment_ids new_comment_ids) $ \(old_comment_id, new_comment_id) -> do
            insert_ (CommentRethread rethread_id old_comment_id new_comment_id)

            -- TODO(mitchell, david): pull the stuff below out of the for-loop

            insertSelect $
             from $ \(c `InnerJoin` ca) -> do
             on_ (c ^. CommentParent ==. just (ca ^. CommentAncestorComment))
             where_ (c ^. CommentId ==. val new_comment_id)
             return (CommentAncestor <# val new_comment_id <&> (ca ^. CommentAncestorAncestor))

            [Value maybe_new_parent_id] <-
                select $
                from $ \c -> do
                where_ (c ^. CommentId ==. val new_comment_id)
                return (c ^. CommentParent)

            maybe (return ()) (insert_ . CommentAncestor new_comment_id) maybe_new_parent_id

            update $ \t -> do
                set t [ TicketComment =. val new_comment_id ]
                where_ $ t ^. TicketComment ==. val old_comment_id

        -- EVERYTHING with a foreign key on CommentId needs to be added here, for the
        -- new comments. We don't want to update in-place because we *do* show the
        -- rethreaded comments on Project feeds (for one thing).
        --
        -- The only table that's updated in-place is Ticket (see
        -- above) because we don't want to change the ticket number
        -- when we rethread a comment.

        updateForRethread CommentClosingComment
                          (\cc cr -> CommentClosing
                              <#  (cc  ^. CommentClosingTs)
                              <&> (cc  ^. CommentClosingClosedBy)
                              <&> (cc  ^. CommentClosingReason)
                              <&> (cr  ^. CommentRethreadNewComment))

        updateForRethread CommentFlaggingComment
                          (\cf cr -> CommentFlagging
                              <#  (cf  ^. CommentFlaggingTs)
                              <&> (cf  ^. CommentFlaggingFlagger)
                              <&> (cr  ^. CommentRethreadNewComment)
                              <&> (cf  ^. CommentFlaggingMessage))

        updateForRethread CommentRetractingComment
                          (\r cr -> CommentRetracting
                              <#  (r   ^. CommentRetractingTs)
                              <&> (r   ^. CommentRetractingReason)
                              <&> (cr  ^. CommentRethreadNewComment))

        updateForRethread CommentTagComment
                          (\ct cr -> CommentTag
                              <#  (cr  ^. CommentRethreadNewComment)
                              <&> (ct  ^. CommentTagTag)
                              <&> (ct  ^. CommentTagUser)
                              <&> (ct  ^. CommentTagCount))

        updateForRethread TicketClaimingTicket
                          (\tc cr -> TicketClaiming
                              <#  (tc  ^. TicketClaimingTs)
                              <&> (tc  ^. TicketClaimingUser)
                              <&> (cr  ^. CommentRethreadNewComment)
                              <&> (tc  ^. TicketClaimingNote))

        updateForRethread TicketOldClaimingTicket
                          (\toc cr -> TicketOldClaiming
                              <#  (toc  ^. TicketOldClaimingClaimTs)
                              <&> (toc  ^. TicketOldClaimingUser)
                              <&> (cr   ^. CommentRethreadNewComment)
                              <&> (toc  ^. TicketOldClaimingNote)
                              <&> (toc  ^. TicketOldClaimingReleaseNote)
                              <&> (toc  ^. TicketOldClaimingReleasedTs))

        updateForRethread UnapprovedCommentNotificationComment
                          (\ucn cr -> UnapprovedCommentNotification
                              <#  (cr  ^. CommentRethreadNewComment)
                              <&> (ucn ^. UnapprovedCommentNotificationNotification))

        updateForRethread ViewCommentComment
                          (\vc cr -> ViewComment
                              <#  (vc  ^. ViewCommentUser)
                              <&> (cr  ^. CommentRethreadNewComment))

        updateForRethread WatchedSubthreadRoot
                          (\ws cr -> WatchedSubthread
                              <#  (ws ^. WatchedSubthreadTs)
                              <&> (ws ^. WatchedSubthreadUser)
                              <&> (cr ^. CommentRethreadNewComment))


rethreadCommentDB
    :: Maybe CommentId
    -> DiscussionId
    -> CommentId
    -> UserId
    -> Text
    -> Int
    -> SDB ()
rethreadCommentDB
        mnew_parent_id
        new_discussion_id
        root_comment_id
        user_id
        reason
        depth_offset = do

    (old_comment_ids, new_comment_ids) <- lift $ do
        descendants_ids <- fetchCommentAllCurrentDescendantsDB root_comment_id
        let old_comment_ids = root_comment_id : descendants_ids

        new_comment_ids <- flip State.evalStateT mempty $ forM old_comment_ids $ \comment_id -> do
            rethread_map <- State.get

            Just comment <- lift $ get comment_id

            let new_parent_id = maybe mnew_parent_id Just $ M.lookup (commentParent comment) rethread_map

            new_comment_id <- lift $ insert $ comment
                { commentDepth      = commentDepth comment - depth_offset
                , commentParent     = new_parent_id
                , commentDiscussion = new_discussion_id
                }

            State.put $ M.insert (Just comment_id) new_comment_id rethread_map

            return new_comment_id

        return (old_comment_ids, new_comment_ids)

    now <- liftIO getCurrentTime

    let new_root_comment_id = Prelude.head new_comment_ids -- This is kind of ugly, but it should be safe.
        rethread = Rethread now user_id root_comment_id new_root_comment_id reason
    rethread_id <- lift (insert rethread)
    tell [ECommentRethreaded rethread_id rethread]

    let updateForRethread :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend)
                          => EntityField val CommentId
                          -> (SqlExpr (Entity val) -> SqlExpr (Entity CommentRethread) -> SqlExpr (Insertion val))
                          -> DB ()
        updateForRethread comment_field constructor =
            insertSelect $
            from $ \(table `InnerJoin` cr) -> do
            on_ (table ^. comment_field ==. cr ^. CommentRethreadOldComment)
            where_ (table ^. comment_field `in_` valList old_comment_ids)
            return (constructor table cr)

    lift $ do
        forM_ (zip old_comment_ids new_comment_ids) $ \(old_comment_id, new_comment_id) -> do
            insert_ (CommentRethread rethread_id old_comment_id new_comment_id)

            -- TODO(mitchell, david): pull the stuff below out of the for-loop

            insertSelect $
             from $ \(c `InnerJoin` ca) -> do
             on_ (c ^. CommentParent ==. just (ca ^. CommentAncestorComment))
             where_ (c ^. CommentId ==. val new_comment_id)
             return (CommentAncestor <# val new_comment_id <&> (ca ^. CommentAncestorAncestor))

            [Value maybe_new_parent_id] <-
                select $
                from $ \c -> do
                where_ (c ^. CommentId ==. val new_comment_id)
                return (c ^. CommentParent)

            maybe (return ()) (insert_ . CommentAncestor new_comment_id) maybe_new_parent_id

            update $ \t -> do
                set t [ TicketComment =. val new_comment_id ]
                where_ $ t ^. TicketComment ==. val old_comment_id

        -- EVERYTHING with a foreign key on CommentId needs to be added here, for the
        -- new comments. We don't want to update in-place because we *do* show the
        -- rethreaded comments on Project feeds (for one thing).
        --
        -- The only table that's updated in-place is Ticket (see
        -- above) because we don't want to change the ticket number
        -- when we rethread a comment.

        updateForRethread CommentClosingComment
                          (\cc cr -> CommentClosing
                              <#  (cc  ^. CommentClosingTs)
                              <&> (cc  ^. CommentClosingClosedBy)
                              <&> (cc  ^. CommentClosingReason)
                              <&> (cr  ^. CommentRethreadNewComment))

        updateForRethread CommentFlaggingComment
                          (\cf cr -> CommentFlagging
                              <#  (cf  ^. CommentFlaggingTs)
                              <&> (cf  ^. CommentFlaggingFlagger)
                              <&> (cr  ^. CommentRethreadNewComment)
                              <&> (cf  ^. CommentFlaggingMessage))

        updateForRethread CommentRetractingComment
                          (\r cr -> CommentRetracting
                              <#  (r   ^. CommentRetractingTs)
                              <&> (r   ^. CommentRetractingReason)
                              <&> (cr  ^. CommentRethreadNewComment))

        updateForRethread CommentTagComment
                          (\ct cr -> CommentTag
                              <#  (cr  ^. CommentRethreadNewComment)
                              <&> (ct  ^. CommentTagTag)
                              <&> (ct  ^. CommentTagUser)
                              <&> (ct  ^. CommentTagCount))

        updateForRethread TicketClaimingTicket
                          (\tc cr -> TicketClaiming
                              <#  (tc  ^. TicketClaimingTs)
                              <&> (tc  ^. TicketClaimingUser)
                              <&> (cr  ^. CommentRethreadNewComment)
                              <&> (tc  ^. TicketClaimingNote))

        updateForRethread TicketOldClaimingTicket
                          (\toc cr -> TicketOldClaiming
                              <#  (toc  ^. TicketOldClaimingClaimTs)
                              <&> (toc  ^. TicketOldClaimingUser)
                              <&> (cr   ^. CommentRethreadNewComment)
                              <&> (toc  ^. TicketOldClaimingNote)
                              <&> (toc  ^. TicketOldClaimingReleaseNote)
                              <&> (toc  ^. TicketOldClaimingReleasedTs))

        updateForRethread UnapprovedCommentNotificationComment
                          (\ucn cr -> UnapprovedCommentNotification
                              <#  (cr  ^. CommentRethreadNewComment)
                              <&> (ucn ^. UnapprovedCommentNotificationNotification))

        updateForRethread ViewCommentComment
                          (\vc cr -> ViewComment
                              <#  (vc  ^. ViewCommentUser)
                              <&> (cr  ^. CommentRethreadNewComment))

        updateForRethread WatchedSubthreadRoot
                          (\ws cr -> WatchedSubthread
                              <#  (ws ^. WatchedSubthreadTs)
                              <&> (ws ^. WatchedSubthreadUser)
                              <&> (cr ^. CommentRethreadNewComment))
rethreadCommentDB
        mnew_parent_id
        new_discussion_id
        root_comment_id
        user_id
        reason
        depth_offset = do

    (old_comment_ids, new_comment_ids) <- lift $ do
        descendants_ids <- fetchCommentAllCurrentDescendantsDB root_comment_id
        let old_comment_ids = root_comment_id : descendants_ids

        new_comment_ids <- flip State.evalStateT mempty $ forM old_comment_ids $ \comment_id -> do
            rethread_map <- State.get

            Just comment <- lift $ get comment_id

            let new_parent_id = maybe mnew_parent_id Just $ M.lookup (commentParent comment) rethread_map

            new_comment_id <- lift $ insert $ comment
                { commentDepth      = commentDepth comment - depth_offset
                , commentParent     = new_parent_id
                , commentDiscussion = new_discussion_id
                }

            State.put $ M.insert (Just comment_id) new_comment_id rethread_map

            return new_comment_id

        return (old_comment_ids, new_comment_ids)

    now <- liftIO getCurrentTime

    let new_root_comment_id = Prelude.head new_comment_ids -- This is kind of ugly, but it should be safe.
        rethread = Rethread now user_id root_comment_id new_root_comment_id reason
    rethread_id <- lift (insert rethread)
    tell [ECommentRethreaded rethread_id rethread]

    let updateForRethread :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend)
                          => EntityField val CommentId
                          -> (SqlExpr (Entity val) -> SqlExpr (Entity CommentRethread) -> SqlExpr (Insertion val))
                          -> DB ()
        updateForRethread comment_field constructor =
            insertSelect $
            from $ \(table `InnerJoin` cr) -> do
            on_ (table ^. comment_field ==. cr ^. CommentRethreadOldComment)
            where_ (table ^. comment_field `in_` valList old_comment_ids)
            return (constructor table cr)

    lift $ do
        forM_ (zip old_comment_ids new_comment_ids) $ \(old_comment_id, new_comment_id) -> do
            insert_ (CommentRethread rethread_id old_comment_id new_comment_id)

            -- TODO(mitchell, david): pull the stuff below out of the for-loop

            insertSelect $
             from $ \(c `InnerJoin` ca) -> do
             on_ (c ^. CommentParent ==. just (ca ^. CommentAncestorComment))
             where_ (c ^. CommentId ==. val new_comment_id)
             return (CommentAncestor <# val new_comment_id <&> (ca ^. CommentAncestorAncestor))

            [Value maybe_new_parent_id] <-
                select $
                from $ \c -> do
                where_ (c ^. CommentId ==. val new_comment_id)
                return (c ^. CommentParent)

            maybe (return ()) (insert_ . CommentAncestor new_comment_id) maybe_new_parent_id

            update $ \t -> do
                set t [ TicketComment =. val new_comment_id ]
                where_ $ t ^. TicketComment ==. val old_comment_id

        -- EVERYTHING with a foreign key on CommentId needs to be added here, for the
        -- new comments. We don't want to update in-place because we *do* show the
        -- rethreaded comments on Project feeds (for one thing).
        --
        -- The only table that's updated in-place is Ticket (see
        -- above) because we don't want to change the ticket number
        -- when we rethread a comment.

        updateForRethread CommentClosingComment
                          (\cc cr -> CommentClosing
                              <#  (cc  ^. CommentClosingTs)
                              <&> (cc  ^. CommentClosingClosedBy)
                              <&> (cc  ^. CommentClosingReason)
                              <&> (cr  ^. CommentRethreadNewComment))

        updateForRethread CommentFlaggingComment
                          (\cf cr -> CommentFlagging
                              <#  (cf  ^. CommentFlaggingTs)
                              <&> (cf  ^. CommentFlaggingFlagger)
                              <&> (cr  ^. CommentRethreadNewComment)
                              <&> (cf  ^. CommentFlaggingMessage))

        updateForRethread CommentRetractingComment
                          (\r cr -> CommentRetracting
                              <#  (r   ^. CommentRetractingTs)
                              <&> (r   ^. CommentRetractingReason)
                              <&> (cr  ^. CommentRethreadNewComment))

        updateForRethread CommentTagComment
                          (\ct cr -> CommentTag
                              <#  (cr  ^. CommentRethreadNewComment)
                              <&> (ct  ^. CommentTagTag)
                              <&> (ct  ^. CommentTagUser)
                              <&> (ct  ^. CommentTagCount))

        updateForRethread TicketClaimingTicket
                          (\tc cr -> TicketClaiming
                              <#  (tc  ^. TicketClaimingTs)
                              <&> (tc  ^. TicketClaimingUser)
                              <&> (cr  ^. CommentRethreadNewComment)
                              <&> (tc  ^. TicketClaimingNote))

        updateForRethread TicketOldClaimingTicket
                          (\toc cr -> TicketOldClaiming
                              <#  (toc  ^. TicketOldClaimingClaimTs)
                              <&> (toc  ^. TicketOldClaimingUser)
                              <&> (cr   ^. CommentRethreadNewComment)
                              <&> (toc  ^. TicketOldClaimingNote)
                              <&> (toc  ^. TicketOldClaimingReleaseNote)
                              <&> (toc  ^. TicketOldClaimingReleasedTs))

        updateForRethread UnapprovedCommentNotificationComment
                          (\ucn cr -> UnapprovedCommentNotification
                              <#  (cr  ^. CommentRethreadNewComment)
                              <&> (ucn ^. UnapprovedCommentNotificationNotification))

        updateForRethread ViewCommentComment
                          (\vc cr -> ViewComment
                              <#  (vc  ^. ViewCommentUser)
                              <&> (cr  ^. CommentRethreadNewComment))

        updateForRethread WatchedSubthreadRoot
                          (\ws cr -> WatchedSubthread
                              <#  (ws ^. WatchedSubthreadTs)
                              <&> (ws ^. WatchedSubthreadUser)
                              <&> (cr ^. CommentRethreadNewComment))