diff --git a/config/models b/config/models index 56bbe15..c0f4878 100644 --- a/config/models +++ b/config/models @@ -226,9 +226,6 @@ Message content Text -- Assume this is Pandoc Markdown parent MessageId Maybe root DiscussionId - number Int - - UniqueMessage root number RepoCollab repo RepoId diff --git a/config/routes b/config/routes index 76b916e..c97ad1c 100644 --- a/config/routes +++ b/config/routes @@ -127,9 +127,9 @@ /s/#ShrIdent/p/#PrjIdent/t/#Int/cr ClaimRequestsTicketR GET POST /s/#ShrIdent/p/#PrjIdent/t/#Int/cr/new ClaimRequestNewR GET /s/#ShrIdent/p/#PrjIdent/t/#Int/d TicketDiscussionR GET POST -/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Int TicketMessageR GET POST +/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Text TicketMessageR GET POST /s/#ShrIdent/p/#PrjIdent/t/#Int/d/!reply TicketTopReplyR GET -/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Int/reply TicketReplyR GET +/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Text/reply TicketReplyR GET /s/#ShrIdent/p/#PrjIdent/t/#Int/deps TicketDepsR GET POST /s/#ShrIdent/p/#PrjIdent/t/#Int/deps/!new TicketDepNewR GET /s/#ShrIdent/p/#PrjIdent/t/#Int/deps/#Int TicketDepR POST DELETE diff --git a/src/Vervis/Discussion.hs b/src/Vervis/Discussion.hs index aff4bdb..f6dd67d 100644 --- a/src/Vervis/Discussion.hs +++ b/src/Vervis/Discussion.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -45,28 +45,27 @@ getMessages getdid = fmap (map $ second entityVal) $ runDB $ do person ^. PersonIdent ==. sharer ^. SharerId return (message, sharer) -discussionTree :: [(Entity Message, Sharer)] -> Forest (Message, Sharer) +discussionTree :: [(Entity Message, Sharer)] -> Forest (Entity Message, Sharer) discussionTree mss = - let numbered = zip [1..] mss + let nodes = zip [1..] mss mkEntry n ((Entity mid _m), _s) = (mid, n) - nodeMap = M.fromList $ map (uncurry mkEntry) numbered - mkEdge n (m, _s) = + nodeMap = M.fromList $ map (uncurry mkEntry) nodes + mkEdge n (Entity _ m, _s) = case messageParent m of Nothing -> Nothing Just mid -> case M.lookup mid nodeMap of Nothing -> error "message parent not in discussion" Just p -> Just (p, n, ()) - nodes = map (\ (n, (Entity _ m, s)) -> (n, (m, s))) numbered edges = mapMaybe (uncurry mkEdge) nodes - graph = mkGraph nodes edges :: Gr (Message, Sharer) () - roots = [n | (n, (m, _s)) <- nodes, isNothing $ messageParent m] + graph = mkGraph nodes edges :: Gr (Entity Message, Sharer) () + roots = [n | (n, (Entity _ m, _s)) <- nodes, isNothing $ messageParent m] in dffWith lab' roots graph -sortByTime :: Forest (Message, Sharer) -> Forest (Message, Sharer) -sortByTime = sortForestOn $ messageCreated . fst +sortByTime :: Forest (Entity Message, Sharer) -> Forest (Entity Message, Sharer) +sortByTime = sortForestOn $ messageCreated . entityVal . fst -- | Get the tree of messages in a given discussion, with siblings sorted from -- old to new. -getDiscussionTree :: AppDB DiscussionId -> Handler (Forest (Message, Sharer)) +getDiscussionTree :: AppDB DiscussionId -> Handler (Forest (Entity Message, Sharer)) getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index 2227019..512d675 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/src/Vervis/Handler/Discussion.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -15,7 +15,7 @@ module Vervis.Handler.Discussion ( getDiscussion - , getMessage + , getDiscussionMessage , getTopReply , postTopReply , getReply @@ -25,13 +25,14 @@ where import Prelude +import Control.Monad import Control.Monad.IO.Class (liftIO) import Data.Time.Clock (getCurrentTime) import Database.Persist import Text.Blaze.Html (Html) import Yesod.Auth (requireAuthId) import Yesod.Core (Route, defaultLayout) -import Yesod.Core.Handler (setMessage, redirect) +import Yesod.Core.Handler import Yesod.Form.Functions (runFormPost) import Yesod.Form.Types (FormResult (..)) import Yesod.Persist.Core (runDB, get404, getBy404) @@ -43,20 +44,28 @@ import Vervis.Settings (widgetFile) import Vervis.Widget.Discussion getDiscussion - :: (Int -> Route App) -> Route App -> AppDB DiscussionId -> Handler Html + :: (MessageId -> Route App) + -> Route App + -> AppDB DiscussionId + -> Handler Html getDiscussion reply topic getdid = defaultLayout $ discussionW getdid topic reply -getMessage :: (Int -> Route App) -> AppDB DiscussionId -> Int -> Handler Html -getMessage reply getdid num = do +getDiscussionMessage + :: (MessageId -> Route App) + -> AppDB DiscussionId + -> MessageId + -> Handler Html +getDiscussionMessage reply getdid mid = do (msg, shr) <- runDB $ do did <- getdid - Entity _mid m <- getBy404 $ UniqueMessage did num + m <- get404 mid + unless (messageRoot m == did) notFound p <- get404 $ messageAuthor m s <- get404 $ personIdent p return (m, s) now <- liftIO getCurrentTime - defaultLayout $ messageW now shr msg reply + defaultLayout $ messageW now shr (Entity mid msg) reply getTopReply :: Route App -> Handler Html getTopReply replyP = do @@ -65,7 +74,7 @@ getTopReply replyP = do postTopReply :: Route App - -> (Int -> Route App) + -> (MessageId -> Route App) -> AppDB DiscussionId -> Handler Html postTopReply replyP after getdid = do @@ -76,20 +85,14 @@ postTopReply replyP after getdid = do author <- requireAuthId mnum <- runDB $ do did <- getdid - next <- do - discussion <- get404 did - return $ discussionNextMessage discussion - update did [DiscussionNextMessage +=. 1] let message = Message { messageAuthor = author , messageCreated = now , messageContent = nmContent nm , messageParent = Nothing , messageRoot = did - , messageNumber = next } - insert_ message - return $ messageNumber message + insert message setMessage "Message submitted." redirect $ after mnum FormMissing -> do @@ -100,15 +103,16 @@ postTopReply replyP after getdid = do defaultLayout $(widgetFile "discussion/top-reply") getReply - :: (Int -> Route App) - -> (Int -> Route App) + :: (MessageId -> Route App) + -> (MessageId -> Route App) -> AppDB DiscussionId - -> Int + -> MessageId -> Handler Html -getReply replyG replyP getdid num = do +getReply replyG replyP getdid mid = do (msg, shr) <- runDB $ do did <- getdid - Entity _mid m <- getBy404 $ UniqueMessage did num + m <- get404 mid + unless (messageRoot m == did) notFound p <- get404 $ messageAuthor m s <- get404 $ personIdent p return (m, s) @@ -117,42 +121,40 @@ getReply replyG replyP getdid num = do defaultLayout $(widgetFile "discussion/reply") postReply - :: (Int -> Route App) - -> (Int -> Route App) - -> (Int -> Route App) + :: (MessageId -> Route App) + -> (MessageId -> Route App) + -> (MessageId -> Route App) -> AppDB DiscussionId - -> Int + -> MessageId -> Handler Html -postReply replyG replyP after getdid cnum = do +postReply replyG replyP after getdid mid = do ((result, widget), enctype) <- runFormPost newMessageForm now <- liftIO getCurrentTime case result of FormSuccess nm -> do author <- requireAuthId - mnum <- runDB $ do + msgid <- runDB $ do did <- getdid - (parent, next) <- do - discussion <- get404 did - Entity mid _message <- getBy404 $ UniqueMessage did cnum - return (mid, discussionNextMessage discussion) - update did [DiscussionNextMessage +=. 1] + parent <- do + message <- get404 mid + unless (messageRoot message == did) notFound + return mid let message = Message { messageAuthor = author , messageCreated = now , messageContent = nmContent nm , messageParent = Just parent , messageRoot = did - , messageNumber = next } - insert_ message - return $ messageNumber message + insert message setMessage "Message submitted." - redirect $ after mnum + redirect $ after msgid FormMissing -> do setMessage "Field(s) missing." (msg, shr) <- runDB $ do did <- getdid - Entity _mid m <- getBy404 $ UniqueMessage did cnum + m <- get404 mid + unless (messageRoot m == did) notFound p <- get404 $ messageAuthor m s <- get404 $ personIdent p return (m, s) @@ -161,7 +163,8 @@ postReply replyG replyP after getdid cnum = do setMessage "Message submission failed, see errors below." (msg, shr) <- runDB $ do did <- getdid - Entity _mid m <- getBy404 $ UniqueMessage did cnum + m <- get404 mid + unless (messageRoot m == did) notFound p <- get404 $ messageAuthor m s <- get404 $ personIdent p return (m, s) diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 125e342..5ed47ff 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -72,7 +72,7 @@ import Network.HTTP.Types (StdMethod (DELETE, POST)) import Text.Blaze.Html (Html, toHtml) import Yesod.Auth (requireAuthId, maybeAuthId) import Yesod.Core (defaultLayout) -import Yesod.Core.Handler hiding (getMessage) +import Yesod.Core.Handler import Yesod.Form.Functions (runFormGet, runFormPost) import Yesod.Form.Types (FormResult (..)) import Yesod.Persist.Core (runDB, get404, getBy404) @@ -241,12 +241,13 @@ getTicketR shar proj num = do , author, massignee, closer, ticket, tparams, eparams , deps, rdeps ) + encodeHid <- getsYesod appHashidEncode let desc = renderSourceT Markdown $ T.filter (/= '\r') $ ticketDesc ticket discuss = discussionW (return $ ticketDiscuss ticket) (TicketTopReplyR shar proj num) - (TicketReplyR shar proj num) + (TicketReplyR shar proj num . encodeHid . fromSqlKey) cRelevant <- newIdent cIrrelevant <- newIdent let relevant filt = @@ -631,9 +632,10 @@ selectDiscussionId shar proj tnum = do return $ ticketDiscuss ticket getTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html -getTicketDiscussionR shar proj num = +getTicketDiscussionR shar proj num = do + encodeHid <- getsYesod appHashidEncode getDiscussion - (TicketReplyR shar proj num) + (TicketReplyR shar proj num . encodeHid . fromSqlKey) (TicketTopReplyR shar proj num) (selectDiscussionId shar proj num) @@ -644,33 +646,51 @@ postTicketDiscussionR shar proj num = (const $ TicketR shar proj num) (selectDiscussionId shar proj num) -getTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html -getTicketMessageR shar proj tnum cnum = - getMessage - (TicketReplyR shar proj tnum) +getTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Text -> Handler Html +getTicketMessageR shar proj tnum hid = do + decodeHid <- getsYesod appHashidDecode + encodeHid <- getsYesod appHashidEncode + mid <- + case toSqlKey <$> decodeHid hid of + Nothing -> notFound + Just k -> return k + getDiscussionMessage + (TicketReplyR shar proj tnum . encodeHid . fromSqlKey) (selectDiscussionId shar proj tnum) - cnum + mid -postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html -postTicketMessageR shar proj tnum cnum = +postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Text -> Handler Html +postTicketMessageR shar proj tnum hid = do + decodeHid <- getsYesod appHashidDecode + encodeHid <- getsYesod appHashidEncode + mid <- + case toSqlKey <$> decodeHid hid of + Nothing -> notFound + Just k -> return k postReply - (TicketReplyR shar proj tnum) - (TicketMessageR shar proj tnum) + (TicketReplyR shar proj tnum . encodeHid . fromSqlKey) + (TicketMessageR shar proj tnum . encodeHid . fromSqlKey) (const $ TicketR shar proj tnum) (selectDiscussionId shar proj tnum) - cnum + mid getTicketTopReplyR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketTopReplyR shar proj num = getTopReply $ TicketDiscussionR shar proj num -getTicketReplyR :: ShrIdent -> PrjIdent -> Int -> Int -> Handler Html -getTicketReplyR shar proj tnum cnum = +getTicketReplyR :: ShrIdent -> PrjIdent -> Int -> Text -> Handler Html +getTicketReplyR shar proj tnum hid = do + decodeHid <- getsYesod appHashidDecode + encodeHid <- getsYesod appHashidEncode + mid <- + case toSqlKey <$> decodeHid hid of + Nothing -> notFound + Just k -> return k getReply - (TicketReplyR shar proj tnum) - (TicketMessageR shar proj tnum) + (TicketReplyR shar proj tnum . encodeHid . fromSqlKey) + (TicketMessageR shar proj tnum . encodeHid . fromSqlKey) (selectDiscussionId shar proj tnum) - cnum + mid getTicketDeps :: Bool -> ShrIdent -> PrjIdent -> Int -> Handler Html getTicketDeps forward shr prj num = do diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index dee555a..bd6b490 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -193,6 +193,10 @@ changes = , unchecked $ lift $ do deleteWhere ([] :: [Filter (VerifKeySharedUsage2019Generic SqlBackend)]) deleteWhere ([] :: [Filter (VerifKey2019Generic SqlBackend)]) + -- 43 + , removeUnique "Message" "UniqueMessage" + -- 44 + , removeField "Message" "number" ] migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int)) diff --git a/src/Vervis/Widget/Discussion.hs b/src/Vervis/Widget/Discussion.hs index 2f8207f..d9d81d4 100644 --- a/src/Vervis/Widget/Discussion.hs +++ b/src/Vervis/Widget/Discussion.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -22,15 +22,13 @@ where import Prelude import Control.Monad.IO.Class (liftIO) -import Data.Foldable (traverse_) -import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) import Data.Tree (Tree (..)) -import Text.Cassius (cassiusFile) +import Database.Persist.Types (Entity (..)) import Yesod.Core (Route) import Yesod.Core.Handler (newIdent) -import Yesod.Core.Widget (whamlet, toWidget, handlerToWidget) +import Yesod.Core.Widget import qualified Data.Text as T (filter) @@ -44,8 +42,8 @@ import Vervis.Render (renderSourceT) import Vervis.Settings (widgetFile) import Vervis.Widget.Sharer (personLinkW) -messageW :: UTCTime -> Sharer -> Message -> (Int -> Route App) -> Widget -messageW now shr msg reply = +messageW :: UTCTime -> Sharer -> Entity Message -> (MessageId -> Route App) -> Widget +messageW now shr (Entity msgid msg) reply = let showTime = showEventTime . intervalToEventTime . @@ -55,10 +53,10 @@ messageW now shr msg reply = in $(widgetFile "discussion/widget/message") messageTreeW - :: (Int -> Route App) + :: (MessageId -> Route App) -> Text -> UTCTime - -> Tree (Message, Sharer) + -> Tree (Entity Message, Sharer) -> Widget messageTreeW reply cReplies now t = go t where @@ -70,7 +68,7 @@ messageTreeW reply cReplies now t = go t ^{go tree} |] -discussionW :: AppDB DiscussionId -> Route App -> (Int -> Route App) -> Widget +discussionW :: AppDB DiscussionId -> Route App -> (MessageId -> Route App) -> Widget discussionW getdid topic reply = do forest <- handlerToWidget $ getDiscussionTree getdid cReplies <- newIdent diff --git a/templates/discussion/reply.hamlet b/templates/discussion/reply.hamlet index 460a267..d3f7250 100644 --- a/templates/discussion/reply.hamlet +++ b/templates/discussion/reply.hamlet @@ -1,6 +1,6 @@ $# This file is part of Vervis. $# -$# Written in 2016 by fr33domlover . +$# Written in 2016, 2019 by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -12,8 +12,8 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . -^{messageW now shr msg replyG} +^{messageW now shr (Entity mid msg) replyG} -
+ ^{widget} diff --git a/templates/discussion/widget/message.hamlet b/templates/discussion/widget/message.hamlet index 01df6f0..935bbf6 100644 --- a/templates/discussion/widget/message.hamlet +++ b/templates/discussion/widget/message.hamlet @@ -18,4 +18,4 @@ $# .
^{showContent $ messageContent msg}