diff --git a/config/models b/config/models index 24a6777..741bcb7 100644 --- a/config/models +++ b/config/models @@ -220,12 +220,23 @@ TicketClaimRequest Discussion Message - author PersonId created UTCTime content Text -- Assume this is Pandoc Markdown parent MessageId Maybe root DiscussionId +LocalMessage + author PersonId + rest MessageId + + UniqueLocalMessage rest + +RemoteMessage + author RemoteSharerId + rest MessageId + + UniqueRemoteMessage rest + RepoCollab repo RepoId person PersonId diff --git a/migrations/2019_03_18_message.model b/migrations/2019_03_18_message.model new file mode 100644 index 0000000..32dcf0b --- /dev/null +++ b/migrations/2019_03_18_message.model @@ -0,0 +1,20 @@ +-- This file is used for generating a Persistent entity for the 2019 Message, +-- which we use it for the SQL query that moves the author field to a separate +-- table. + +Person + +Discussion + +Message + author PersonId + created UTCTime + content Text -- Assume this is Pandoc Markdown + parent MessageId Maybe + root DiscussionId + +LocalMessage + author PersonId + rest MessageId + + UniqueLocalMessage rest diff --git a/migrations/2019_03_19.model b/migrations/2019_03_19.model new file mode 100644 index 0000000..b610217 --- /dev/null +++ b/migrations/2019_03_19.model @@ -0,0 +1,11 @@ +LocalMessage + author PersonId + rest MessageId + + UniqueLocalMessage rest + +RemoteMessage + author RemoteSharerId + rest MessageId + + UniqueRemoteMessage rest diff --git a/src/Vervis/Discussion.hs b/src/Vervis/Discussion.hs index f6dd67d..f652f03 100644 --- a/src/Vervis/Discussion.hs +++ b/src/Vervis/Discussion.hs @@ -14,7 +14,9 @@ -} module Vervis.Discussion - ( getDiscussionTree + ( MessageTreeNodeAuthor (..) + , MessageTreeNode (..) + , getDiscussionTree ) where @@ -31,41 +33,66 @@ import Yesod.Persist.Core (runDB) import qualified Data.HashMap.Lazy as M (fromList, lookup) +import Network.FedURI + import Data.Tree.Local (sortForestOn) import Vervis.Foundation import Vervis.Model -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 &&. - message ^. MessageAuthor ==. person ^. PersonId &&. - person ^. PersonIdent ==. sharer ^. SharerId - return (message, sharer) +data MessageTreeNodeAuthor + = MessageTreeNodeLocal LocalMessageId Sharer + | MessageTreeNodeRemote FedURI -discussionTree :: [(Entity Message, Sharer)] -> Forest (Entity Message, Sharer) +data MessageTreeNode = MessageTreeNode + { mtnMessageId :: MessageId + , mtnMessage :: Message + , mtnAuthor :: MessageTreeNodeAuthor + } + +getMessages :: AppDB DiscussionId -> Handler [MessageTreeNode] +getMessages getdid = runDB $ do + did <- getdid + l <- select $ from $ \ (lm `InnerJoin` m `InnerJoin` p `InnerJoin` s) -> do + on $ p ^. PersonIdent ==. s ^. SharerId + on $ lm ^. LocalMessageAuthor ==. p ^. PersonId + on $ lm ^. LocalMessageRest ==. m ^. MessageId + where_ $ m ^. MessageRoot ==. val did + return (m, lm ^. LocalMessageId, s) + r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` rs `InnerJoin` i) -> do + on $ rs ^. RemoteSharerInstance ==. i ^. InstanceId + on $ rm ^. RemoteMessageAuthor ==. rs ^. RemoteSharerId + on $ rm ^. RemoteMessageRest ==. m ^. MessageId + where_ $ m ^. MessageRoot ==. val did + return (m, i ^. InstanceHost, rs ^. RemoteSharerIdent) + return $ map mklocal l ++ map mkremote r + where + mklocal (Entity mid m, Value lmid, Entity _ s) = + MessageTreeNode mid m $ MessageTreeNodeLocal lmid s + mkremote (Entity mid m, Value h, Value lu) = + MessageTreeNode mid m $ MessageTreeNodeRemote $ l2f h lu + +discussionTree :: [MessageTreeNode] -> Forest MessageTreeNode discussionTree mss = let nodes = zip [1..] mss - mkEntry n ((Entity mid _m), _s) = (mid, n) + mkEntry n mtn = (mtnMessageId mtn, n) nodeMap = M.fromList $ map (uncurry mkEntry) nodes - mkEdge n (Entity _ m, _s) = - case messageParent m of + mkEdge n mtn = + case messageParent $ mtnMessage mtn of Nothing -> Nothing Just mid -> case M.lookup mid nodeMap of Nothing -> error "message parent not in discussion" Just p -> Just (p, n, ()) edges = mapMaybe (uncurry mkEdge) nodes - graph = mkGraph nodes edges :: Gr (Entity Message, Sharer) () - roots = [n | (n, (Entity _ m, _s)) <- nodes, isNothing $ messageParent m] + graph = mkGraph nodes edges :: Gr MessageTreeNode () + roots = + [n | (n, mtn) <- nodes, isNothing $ messageParent $ mtnMessage mtn] in dffWith lab' roots graph -sortByTime :: Forest (Entity Message, Sharer) -> Forest (Entity Message, Sharer) -sortByTime = sortForestOn $ messageCreated . entityVal . fst +sortByTime :: Forest MessageTreeNode -> Forest MessageTreeNode +sortByTime = sortForestOn $ messageCreated . mtnMessage -- | Get the tree of messages in a given discussion, with siblings sorted from -- old to new. -getDiscussionTree :: AppDB DiscussionId -> Handler (Forest (Entity Message, Sharer)) +getDiscussionTree :: AppDB DiscussionId -> Handler (Forest MessageTreeNode) getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index 512d675..80e41a6 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/src/Vervis/Handler/Discussion.hs @@ -37,6 +37,9 @@ import Yesod.Form.Functions (runFormPost) import Yesod.Form.Types (FormResult (..)) import Yesod.Persist.Core (runDB, get404, getBy404) +import Network.FedURI + +import Vervis.Discussion import Vervis.Form.Discussion import Vervis.Foundation (App, Handler, AppDB) import Vervis.Model @@ -51,21 +54,36 @@ getDiscussion getDiscussion reply topic getdid = defaultLayout $ discussionW getdid topic reply +getNode :: AppDB DiscussionId -> MessageId -> AppDB MessageTreeNode +getNode getdid mid = do + did <- getdid + m <- get404 mid + unless (messageRoot m == did) notFound + mlocal <- getBy $ UniqueLocalMessage mid + mremote <- getBy $ UniqueRemoteMessage mid + author <- case (mlocal, mremote) of + (Nothing, Nothing) -> fail "Message with no author" + (Just _, Just _) -> fail "Message used as both local and remote" + (Just (Entity lmid lm), Nothing) -> do + p <- getJust $ localMessageAuthor lm + s <- getJust $ personIdent p + return $ MessageTreeNodeLocal lmid s + (Nothing, Just (Entity _rmid rm)) -> do + rs <- getJust $ remoteMessageAuthor rm + i <- getJust $ remoteSharerInstance rs + return $ MessageTreeNodeRemote $ + l2f (instanceHost i) (remoteSharerIdent rs) + return $ MessageTreeNode mid m author + getDiscussionMessage :: (MessageId -> Route App) -> AppDB DiscussionId -> MessageId -> Handler Html getDiscussionMessage reply getdid mid = do - (msg, shr) <- runDB $ do - did <- getdid - m <- get404 mid - unless (messageRoot m == did) notFound - p <- get404 $ messageAuthor m - s <- get404 $ personIdent p - return (m, s) + mtn <- runDB $ getNode getdid mid now <- liftIO getCurrentTime - defaultLayout $ messageW now shr (Entity mid msg) reply + defaultLayout $ messageW now mtn reply getTopReply :: Route App -> Handler Html getTopReply replyP = do @@ -74,7 +92,7 @@ getTopReply replyP = do postTopReply :: Route App - -> (MessageId -> Route App) + -> (LocalMessageId -> Route App) -> AppDB DiscussionId -> Handler Html postTopReply replyP after getdid = do @@ -85,14 +103,17 @@ postTopReply replyP after getdid = do author <- requireAuthId mnum <- runDB $ do did <- getdid - let message = Message - { messageAuthor = author - , messageCreated = now - , messageContent = nmContent nm - , messageParent = Nothing - , messageRoot = did - } - insert message + mid <- insert Message + { messageCreated = now + , messageContent = nmContent nm + , messageParent = Nothing + , messageRoot = did + } + lmid <- insert LocalMessage + { localMessageAuthor = author + , localMessageRest = mid + } + return lmid setMessage "Message submitted." redirect $ after mnum FormMissing -> do @@ -109,13 +130,7 @@ getReply -> MessageId -> Handler Html getReply replyG replyP getdid mid = do - (msg, shr) <- runDB $ do - did <- getdid - m <- get404 mid - unless (messageRoot m == did) notFound - p <- get404 $ messageAuthor m - s <- get404 $ personIdent p - return (m, s) + mtn <- runDB $ getNode getdid mid now <- liftIO getCurrentTime ((_result, widget), enctype) <- runFormPost newMessageForm defaultLayout $(widgetFile "discussion/reply") @@ -123,7 +138,7 @@ getReply replyG replyP getdid mid = do postReply :: (MessageId -> Route App) -> (MessageId -> Route App) - -> (MessageId -> Route App) + -> (LocalMessageId -> Route App) -> AppDB DiscussionId -> MessageId -> Handler Html @@ -139,33 +154,24 @@ postReply replyG replyP after getdid mid = 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 - } - insert message + mid <- insert Message + { messageCreated = now + , messageContent = nmContent nm + , messageParent = Just parent + , messageRoot = did + } + lmid <- insert LocalMessage + { localMessageAuthor = author + , localMessageRest = mid + } + return lmid setMessage "Message submitted." redirect $ after msgid FormMissing -> do setMessage "Field(s) missing." - (msg, shr) <- runDB $ do - did <- getdid - m <- get404 mid - unless (messageRoot m == did) notFound - p <- get404 $ messageAuthor m - s <- get404 $ personIdent p - return (m, s) + mtn <- runDB $ getNode getdid mid defaultLayout $(widgetFile "discussion/reply") FormFailure _l -> do setMessage "Message submission failed, see errors below." - (msg, shr) <- runDB $ do - did <- getdid - m <- get404 mid - unless (messageRoot m == did) notFound - p <- get404 $ messageAuthor m - s <- get404 $ personIdent p - return (m, s) + mtn <- runDB $ getNode getdid mid defaultLayout $(widgetFile "discussion/reply") diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 4f81a70..8fe1b14 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -38,7 +38,7 @@ import Database.Persist import Database.Persist.BackendDataType (backendDataType, PersistDefault (..)) import Database.Persist.Migration import Database.Persist.Schema (SchemaT, Migration) -import Database.Persist.Schema.Types +import Database.Persist.Schema.Types hiding (Entity) import Database.Persist.Schema.PostgreSQL (schemaBackend) import Database.Persist.Sql (SqlBackend, toSqlKey) --import Text.Email.QuasiQuotation (email @@ -191,14 +191,23 @@ changes = , addEntities model_2019_02_03_verifkey -- 42 , unchecked $ lift $ do - deleteWhere ([] :: [Filter (VerifKeySharedUsage2019Generic SqlBackend)]) - deleteWhere ([] :: [Filter (VerifKey2019Generic SqlBackend)]) + deleteWhere ([] :: [Filter VerifKeySharedUsage2019]) + deleteWhere ([] :: [Filter VerifKey2019]) -- 43 , removeUnique "Message" "UniqueMessage" -- 44 , removeField "Message" "number" -- 45 , removeField "Discussion" "nextMessage" + -- 46 + , addEntities model_2019_03_19 + -- 47 + , unchecked $ lift $ do + msgs <- selectList ([] :: [Filter Message2019]) [] + let mklocal (Entity mid m) = LocalMessage2019 (message2019Author m) mid + insertMany_ $ map mklocal msgs + -- 48 + , removeField "Message" "author" ] migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int)) diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 451f0d9..08fb209 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -22,7 +22,14 @@ module Vervis.Migration.Model , model_2016_09_01_rest , model_2019_02_03_verifkey , VerifKey2019Generic (..) + , VerifKey2019 , VerifKeySharedUsage2019Generic (..) + , VerifKeySharedUsage2019 + , Message2019Generic (..) + , Message2019 + , LocalMessage2019Generic (..) + , LocalMessage2019 + , model_2019_03_19 ) where @@ -66,3 +73,9 @@ model_2019_02_03_verifkey = $(schema "2019_02_03_verifkey") makeEntitiesMigration "2019" $(modelFile "migrations/2019_02_03_verifkey.model") + +makeEntitiesMigration "2019" + $(modelFile "migrations/2019_03_18_message.model") + +model_2019_03_19 :: [Entity SqlBackend] +model_2019_03_19 = $(schema "2019_03_19") diff --git a/src/Vervis/Widget/Discussion.hs b/src/Vervis/Widget/Discussion.hs index d9d81d4..de40473 100644 --- a/src/Vervis/Widget/Discussion.hs +++ b/src/Vervis/Widget/Discussion.hs @@ -32,18 +32,27 @@ import Yesod.Core.Widget import qualified Data.Text as T (filter) +import Network.FedURI + import Data.EventTime.Local import Data.Time.Clock.Local () -import Vervis.Discussion (getDiscussionTree) +import Vervis.Discussion import Vervis.Foundation import Vervis.MediaType (MediaType (Markdown)) import Vervis.Model +import Vervis.Model.Ident import Vervis.Render (renderSourceT) import Vervis.Settings (widgetFile) import Vervis.Widget.Sharer (personLinkW) -messageW :: UTCTime -> Sharer -> Entity Message -> (MessageId -> Route App) -> Widget -messageW now shr (Entity msgid msg) reply = +actorLinkW :: MessageTreeNodeAuthor -> Widget +actorLinkW actor = $(widgetFile "widget/actor-link") + where + shortURI (FedURI h p f) = h <> p <> f + +messageW + :: UTCTime -> MessageTreeNode -> (MessageId -> Route App) -> Widget +messageW now (MessageTreeNode msgid msg author) reply = let showTime = showEventTime . intervalToEventTime . @@ -56,12 +65,12 @@ messageTreeW :: (MessageId -> Route App) -> Text -> UTCTime - -> Tree (Entity Message, Sharer) + -> Tree MessageTreeNode -> Widget messageTreeW reply cReplies now t = go t where - go (Node (message, sharer) trees) = do - messageW now sharer message reply + go (Node mtn trees) = do + messageW now mtn reply [whamlet|
$forall tree <- trees diff --git a/templates/discussion/reply.hamlet b/templates/discussion/reply.hamlet index d3f7250..8d87ff7 100644 --- a/templates/discussion/reply.hamlet +++ b/templates/discussion/reply.hamlet @@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . -^{messageW now shr (Entity mid msg) replyG} +^{messageW now mtn replyG}
^{widget} diff --git a/templates/discussion/widget/message.hamlet b/templates/discussion/widget/message.hamlet index 935bbf6..5a802b2 100644 --- a/templates/discussion/widget/message.hamlet +++ b/templates/discussion/widget/message.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,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along $# with this software. If not, see $# . -^{personLinkW shr} +^{actorLinkW author}
#{showTime $ messageCreated msg}
diff --git a/templates/widget/actor-link.hamlet b/templates/widget/actor-link.hamlet new file mode 100644 index 0000000..8a2a657 --- /dev/null +++ b/templates/widget/actor-link.hamlet @@ -0,0 +1,28 @@ +$# This file is part of Vervis. +$# +$# Written in 2016, 2019 by fr33domlover . +$# +$# ♡ Copying is an act of love. Please copy, reuse and share. +$# +$# The author(s) have dedicated all copyright and related and neighboring +$# rights to this software to the public domain worldwide. This software is +$# distributed without any warranty. +$# +$# You should have received a copy of the CC0 Public Domain Dedication along +$# with this software. If not, see +$# . + +$case actor + $of MessageTreeNodeLocal _lmid s + + $maybe name <- sharerName s + #{name} + $nothing + #{shr2text $ sharerIdent s} + + ./#{shr2text $ sharerIdent s} + $of MessageTreeNodeRemote uAuthor + + (?) + + #{shortURI uAuthor}