sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 16:14:51 +09:00
Code Issues Activity

Switch ticket comment IDs to use Hashids-of-MessageId instead of custom number

Browse source
This commit is contained in:
fr33domlover 2019-03-15 16:36:02 +00:00
parent 9e881554ea
commit 475e398d6d
9 changed files with 109 additions and 88 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

3
config/models
View file

@ -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

4
config/routes
View file

@ -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

21
src/Vervis/Discussion.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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

79
src/Vervis/Handler/Discussion.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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)

60
src/Vervis/Handler/Ticket.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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

4
src/Vervis/Migration.hs
View file

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

18
src/Vervis/Widget/Discussion.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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

6
templates/discussion/reply.hamlet
View file

@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ 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
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{messageW now shr msg replyG}
^{messageW now shr (Entity mid msg) replyG}
<form method=POST action=@{replyP $ messageNumber msg} enctype=#{enctype}>
<form method=POST action=@{replyP mid} enctype=#{enctype}>
^{widget}
<input type=submit>

2
templates/discussion/widget/message.hamlet
View file

@ -18,4 +18,4 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div>
^{showContent $ messageContent msg}
<div>
<a href=@{reply $ messageNumber msg}>reply
<a href=@{reply msgid}>reply