diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 2b30089..b9312aa 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -16,6 +16,7 @@ module Vervis.Client ( makeServerInput + , comment --, createThread --, createReply --, follow @@ -112,19 +113,42 @@ makeServerInput maybeCapURI maybeSummary audience specific = do } return (recipientSet, remoteActors, fwdHosts, action) +comment + :: KeyHashid Person + -> PandocMarkdown + -> [LocalActorBy KeyHashid] + -> [LocalStageBy KeyHashid] + -> Route App + -> Maybe FedURI + -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Note URIMode) +comment senderHash source actors stages topicR muParent = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + content <- ExceptT . pure $ renderPandocMarkdown source + let audience = [AudLocal actors stages] + uTopic = encodeRouteHome topicR + note = AP.Note + { AP.noteId = Nothing + , AP.noteAttrib = encodeRouteLocal $ PersonR senderHash + , AP.noteAudience = emptyAudience + , AP.noteReplyTo = Just $ fromMaybe uTopic muParent + , AP.noteContext = Just uTopic + , AP.notePublished = Nothing + , AP.noteSource = source + , AP.noteContent = content + } + return (Nothing, audience, note) + {- createThread - :: (MonadSite m, SiteEnv m ~ App) - => ShrIdent - -> TextPandocMarkdown + :: KeyHashid Person + -> PandocMarkdown -> Host -> [Route App] -> [Route App] -> Route App - -> m (Either Text (Note URIMode)) -createThread shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context = runExceptT $ do - error "Temporarily disabled" - {- + -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Note URIMode) +createThread senderHash source hDest recipsA recipsC context = runExceptT $ do encodeRouteLocal <- getEncodeRouteLocal let encodeRecipRoute = ObjURI hDest . encodeRouteLocal contentHtml <- ExceptT . pure $ renderPandocMarkdown msg @@ -147,7 +171,6 @@ createThread shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context = , noteSource = msg , noteContent = contentHtml } - -} createReply :: ShrIdent diff --git a/src/Vervis/Form/Discussion.hs b/src/Vervis/Form/Discussion.hs index a1d7e39..388c136 100644 --- a/src/Vervis/Form/Discussion.hs +++ b/src/Vervis/Form/Discussion.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019 by fr33domlover . + - Written in 2016, 2019, 2022 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -14,8 +14,7 @@ -} module Vervis.Form.Discussion - ( NewMessage (..) - , newMessageForm + ( newMessageForm ) where @@ -24,16 +23,15 @@ import Yesod.Form import qualified Data.Text as T +import Web.Text + import Vervis.Foundation (Form, Handler) import Vervis.Model -data NewMessage = NewMessage - { nmContent :: Text - } +newMessageAForm :: AForm Handler PandocMarkdown +newMessageAForm = + pandocMarkdownFromText . T.filter (/= '\r') . unTextarea <$> + areq textareaField "" Nothing -newMessageAForm :: AForm Handler NewMessage -newMessageAForm = NewMessage - <$> (T.filter (/= '\r') . unTextarea <$> areq textareaField "" Nothing) - -newMessageForm :: Form NewMessage +newMessageForm :: Form PandocMarkdown newMessageForm = renderDivs newMessageAForm diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 7253d1c..56ad0c1 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -838,8 +838,6 @@ instance YesodBreadcrumbs App where PersonFollowR _ -> ("", Nothing) PersonUnfollowR _ -> ("", Nothing) - ReplyR _ -> ("", Nothing) - PersonStampR p k -> ("Stamp #" <> keyHashidText k, Just $ PersonR p) GroupR g -> ("Team &" <> keyHashidText g, Just HomeR) @@ -910,9 +908,10 @@ instance YesodBreadcrumbs App where TicketDepsR d t -> ("Dependencies", Just $ TicketR d t) TicketReverseDepsR d t -> ("Dependants", Just $ TicketR d t) - TicketFollowR _ _ -> ("", Nothing) - TicketUnfollowR _ _ -> ("", Nothing) - TicketReplyR _ _ -> ("", Nothing) + TicketFollowR _ _ -> ("", Nothing) + TicketUnfollowR _ _ -> ("", Nothing) + TicketReplyR d t -> ("Reply", Just $ TicketR d t) + TicketReplyOnR d t _ -> ("Reply", Just $ TicketR d t) TicketDepR d t p -> (keyHashidText p, Just $ TicketDepsR d t) @@ -941,9 +940,10 @@ instance YesodBreadcrumbs App where BundleR l c b -> ("Bundle " <> keyHashidText b, Just $ ClothR l c) PatchR l c b p -> ("Patch " <> keyHashidText p, Just $ BundleR l c b) - ClothApplyR _ _ -> ("", Nothing) - ClothFollowR _ _ -> ("", Nothing) - ClothUnfollowR _ _ -> ("", Nothing) - ClothReplyR _ _ -> ("", Nothing) + ClothApplyR _ _ -> ("", Nothing) + ClothFollowR _ _ -> ("", Nothing) + ClothUnfollowR _ _ -> ("", Nothing) + ClothReplyR l c -> ("Reply", Just $ ClothR l c) + ClothReplyOnR l c _ -> ("Reply", Just $ ClothR l c) ClothDepR l c p -> (keyHashidText p, Just $ ClothDepsR l c) diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs index afce458..f39932d 100644 --- a/src/Vervis/Handler/Cloth.hs +++ b/src/Vervis/Handler/Cloth.hs @@ -29,7 +29,11 @@ module Vervis.Handler.Cloth , postClothApplyR , postClothFollowR , postClothUnfollowR + + , getClothReplyR , postClothReplyR + , getClothReplyOnR + , postClothReplyOnR @@ -120,6 +124,7 @@ import Vervis.Style import Vervis.Ticket import Vervis.Time (showDate) import Vervis.Web.Actor +import Vervis.Web.Discussion import Vervis.Web.Repo import Vervis.Widget import Vervis.Widget.Discussion @@ -127,6 +132,10 @@ import Vervis.Widget.Person import qualified Vervis.Client as C +selectDiscussionID loomHash clothHash = do + (_, _, Entity _ ticket, _, _, _) <- getCloth404 loomHash clothHash + return $ ticketDiscuss ticket + getClothR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent getClothR loomHash clothHash = do (repoID, mbranch, ticket, author, resolve, proposal) <- runDB $ do @@ -329,7 +338,7 @@ getClothR loomHash clothHash = do discussionW (return $ ticketDiscuss ticket) (ClothReplyR loomHash clothHash) - (ReplyR . hashMessageKey) + (ClothReplyOnR loomHash clothHash . hashMessageKey) cRelevant <- newIdent cIrrelevant <- newIdent let relevant filt = @@ -377,15 +386,13 @@ getClothR loomHash clothHash = do getClothDiscussionR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent -getClothDiscussionR _ _ = do - error "Temporarily disabled" - {- - encodeHid <- getEncodeKeyHashid - getDiscussion - (ProjectClothReplyR shar proj ltkhid . encodeHid) - (ProjectClothTopReplyR shar proj ltkhid) - (selectDiscussionId shar proj ltkhid) - -} +getClothDiscussionR loomHash clothHash = do + hashMsg <- getEncodeKeyHashid + serveDiscussion + (ClothDiscussionR loomHash clothHash) + (ClothReplyOnR loomHash clothHash . hashMsg) + (ClothReplyR loomHash clothHash) + (selectDiscussionID loomHash clothHash) getClothEventsR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent @@ -671,22 +678,49 @@ postClothFollowR _ = error "Temporarily disabled" postClothUnfollowR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler () postClothUnfollowR _ = error "Temporarily disabled" +getClothReplyR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler Html +getClothReplyR loomHash clothHash = + getTopReply $ ClothReplyR loomHash clothHash + postClothReplyR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler Html -postClothReplyR _ _ = error "Temporarily disabled" - {- - hLocal <- getsYesod $ appInstanceHost . appSettings - postTopReply - hLocal - [ProjectR shr prj] - [ ProjectFollowersR shr prj - , ProjectTicketParticipantsR shr prj ltkhid - , ProjectTicketTeamR shr prj ltkhid +postClothReplyR loomHash clothHash = + postReply + (ClothReplyR loomHash clothHash) + [LocalActorLoom loomHash] + [ LocalStageLoomFollowers loomHash + , LocalStageClothFollowers loomHash clothHash ] - (ProjectTicketR shr prj ltkhid) - (ProjectR shr prj) - (ProjectTicketDiscussionR shr prj ltkhid) - (const $ ProjectTicketR shr prj ltkhid) - -} + (ClothR loomHash clothHash) + Nothing + +getClothReplyOnR + :: KeyHashid Loom + -> KeyHashid TicketLoom + -> KeyHashid Message + -> Handler Html +getClothReplyOnR loomHash clothHash msgHash = do + msgID <- decodeKeyHashid404 msgHash + hashMsg <- getEncodeKeyHashid + getReply + (ClothReplyOnR loomHash clothHash . hashMsg) + (selectDiscussionID loomHash clothHash) + msgID + +postClothReplyOnR + :: KeyHashid Loom + -> KeyHashid TicketLoom + -> KeyHashid Message + -> Handler Html +postClothReplyOnR loomHash clothHash msgHash = do + msgID <- decodeKeyHashid404 msgHash + postReply + (ClothReplyOnR loomHash clothHash msgHash) + [LocalActorLoom loomHash] + [ LocalStageLoomFollowers loomHash + , LocalStageClothFollowers loomHash clothHash + ] + (ClothR loomHash clothHash) + (Just (selectDiscussionID loomHash clothHash, msgID)) @@ -853,13 +887,6 @@ getSharerProposalR shr talkhid = do where here = SharerProposalR shr talkhid -getSharerProposalDiscussionR - :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerProposalDiscussionR shr talkhid = - getRepliesCollection (SharerProposalDiscussionR shr talkhid) $ do - (_, Entity _ lt, _, _, _, _) <- getSharerProposal404 shr talkhid - return $ localTicketDiscuss lt - getSharerProposalDepsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent getSharerProposalDepsR shr talkhid = @@ -1196,13 +1223,6 @@ getRepoProposalR shr rp ltkhid = do where here = RepoProposalR shr rp ltkhid -getRepoProposalDiscussionR - :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent -getRepoProposalDiscussionR shr rp ltkhid = - getRepliesCollection (RepoProposalDiscussionR shr rp ltkhid) $ do - (_, _, _, Entity _ lt, _, _, _, _, _) <- getRepoProposal404 shr rp ltkhid - return $ localTicketDiscuss lt - getRepoProposalDepsR :: ShrIdent -> RpIdent -> KeyHashid LocalTicket -> Handler TypedContent getRepoProposalDepsR shr rp ltkhid = diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 6864fd4..993de83 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -28,8 +28,6 @@ module Vervis.Handler.Person , postPersonFollowR , postPersonUnfollowR - , postReplyR - , getPersonStampR ) where @@ -402,8 +400,5 @@ postPersonFollowR _ = error "Temporarily disabled" postPersonUnfollowR :: KeyHashid Person -> Handler () postPersonUnfollowR _ = error "Temporarily disabled" -postReplyR :: KeyHashid Message -> Handler () -postReplyR _ = error "Temporarily disabled" - getPersonStampR :: KeyHashid Person -> KeyHashid SigKey -> Handler TypedContent getPersonStampR = servePerActorKey personActor LocalActorPerson diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 41c7085..9f3f8fd 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -26,7 +26,11 @@ module Vervis.Handler.Ticket , postTicketFollowR , postTicketUnfollowR + + , getTicketReplyR , postTicketReplyR + , getTicketReplyOnR + , postTicketReplyOnR @@ -53,11 +57,6 @@ module Vervis.Handler.Ticket , getClaimRequestsTicketR , postClaimRequestsTicketR , getClaimRequestNewR - , postProjectTicketDiscussionR - , getMessageR - , postProjectTicketMessageR - , getProjectTicketTopReplyR - , getProjectTicketReplyR , postProjectTicketDepsR , getProjectTicketDepNewR , postTicketDepOldR @@ -67,7 +66,6 @@ module Vervis.Handler.Ticket , getSharerTicketsR , getSharerTicketR - , getSharerTicketDiscussionR , getSharerTicketDepsR , getSharerTicketReverseDepsR , getSharerTicketTeamR @@ -160,6 +158,10 @@ import Vervis.Web.Discussion import Vervis.Widget.Discussion import Vervis.Widget.Person +selectDiscussionID deckHash taskHash = do + (_, _, Entity _ ticket, _, _) <- getTicket404 deckHash taskHash + return $ ticketDiscuss ticket + getTicketR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent getTicketR deckHash ticketHash = do (ticket, author, resolve) <- runDB $ do @@ -275,7 +277,7 @@ getTicketR deckHash ticketHash = do discussionW (return $ ticketDiscuss ticket) (TicketReplyR deckHash ticketHash) - (ReplyR . hashMessageKey) + (TicketReplyOnR deckHash ticketHash . hashMessageKey) cRelevant <- newIdent cIrrelevant <- newIdent let relevant filt = @@ -293,15 +295,13 @@ getTicketR deckHash ticketHash = do getTicketDiscussionR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent -getTicketDiscussionR _ _ = do - error "Temporarily disabled" - {- - encodeHid <- getEncodeKeyHashid - getDiscussion - (ProjectTicketReplyR shar proj ltkhid . encodeHid) - (ProjectTicketTopReplyR shar proj ltkhid) - (selectDiscussionId shar proj ltkhid) - -} +getTicketDiscussionR deckHash taskHash = do + hashMsg <- getEncodeKeyHashid + serveDiscussion + (TicketDiscussionR deckHash taskHash) + (TicketReplyOnR deckHash taskHash . hashMsg) + (TicketReplyR deckHash taskHash) + (selectDiscussionID deckHash taskHash) getTicketEventsR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler TypedContent @@ -426,22 +426,49 @@ postTicketFollowR _ = error "Temporarily disabled" postTicketUnfollowR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler () postTicketUnfollowR _ = error "Temporarily disabled" +getTicketReplyR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler Html +getTicketReplyR deckHash taskHash = + getTopReply $ TicketReplyR deckHash taskHash + postTicketReplyR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler Html -postTicketReplyR _ _ = error "Temporarily disabled" - {- - hLocal <- getsYesod $ appInstanceHost . appSettings - postTopReply - hLocal - [ProjectR shr prj] - [ ProjectFollowersR shr prj - , ProjectTicketParticipantsR shr prj ltkhid - , ProjectTicketTeamR shr prj ltkhid +postTicketReplyR deckHash taskHash = + postReply + (TicketReplyR deckHash taskHash) + [LocalActorDeck deckHash] + [ LocalStageDeckFollowers deckHash + , LocalStageTicketFollowers deckHash taskHash ] - (ProjectTicketR shr prj ltkhid) - (ProjectR shr prj) - (ProjectTicketDiscussionR shr prj ltkhid) - (const $ ProjectTicketR shr prj ltkhid) - -} + (TicketR deckHash taskHash) + Nothing + +getTicketReplyOnR + :: KeyHashid Deck + -> KeyHashid TicketDeck + -> KeyHashid Message + -> Handler Html +getTicketReplyOnR deckHash taskHash msgHash = do + msgID <- decodeKeyHashid404 msgHash + hashMsg <- getEncodeKeyHashid + getReply + (TicketReplyOnR deckHash taskHash . hashMsg) + (selectDiscussionID deckHash taskHash) + msgID + +postTicketReplyOnR + :: KeyHashid Deck + -> KeyHashid TicketDeck + -> KeyHashid Message + -> Handler Html +postTicketReplyOnR deckHash taskHash msgHash = do + msgID <- decodeKeyHashid404 msgHash + postReply + (TicketReplyOnR deckHash taskHash msgHash) + [LocalActorDeck deckHash] + [ LocalStageDeckFollowers deckHash + , LocalStageTicketFollowers deckHash taskHash + ] + (TicketR deckHash taskHash) + (Just (selectDiscussionID deckHash taskHash, msgID)) @@ -803,58 +830,6 @@ postClaimRequestsTicketR shr prj ltkhid = do setMessage "Submission failed, see errors below." defaultLayout $(widgetFile "ticket/claim-request/new") -selectDiscussionId - :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB DiscussionId -selectDiscussionId shr prj ltkhid = do - (_es, _ej, _et, Entity _ lticket, _etcl, _etpl, _author, _) <- getProjectTicket404 shr prj ltkhid - return $ localTicketDiscuss lticket - -getMessageR :: ShrIdent -> KeyHashid LocalMessage -> Handler TypedContent -getMessageR shr hid = do - lmid <- decodeKeyHashid404 hid - getDiscussionMessage shr lmid - -postProjectTicketMessageR - :: ShrIdent - -> PrjIdent - -> KeyHashid LocalTicket - -> KeyHashid Message - -> Handler Html -postProjectTicketMessageR shr prj ltkhid mkhid = do - encodeHid <- getEncodeKeyHashid - mid <- decodeKeyHashid404 mkhid - hLocal <- getsYesod $ appInstanceHost . appSettings - postReply - hLocal - [ProjectR shr prj] - [ ProjectFollowersR shr prj - , ProjectTicketParticipantsR shr prj ltkhid - , ProjectTicketTeamR shr prj ltkhid - ] - (ProjectTicketR shr prj ltkhid) - (ProjectR shr prj) - (ProjectTicketReplyR shr prj ltkhid . encodeHid) - (ProjectTicketMessageR shr prj ltkhid . encodeHid) - (const $ ProjectTicketR shr prj ltkhid) - (selectDiscussionId shr prj ltkhid) - mid - -getProjectTicketTopReplyR - :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html -getProjectTicketTopReplyR shr prj ltkhid = - getTopReply $ ProjectTicketDiscussionR shr prj ltkhid - -getProjectTicketReplyR - :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid Message -> Handler Html -getProjectTicketReplyR shr prj ltkhid mkhid = do - encodeHid <- getEncodeKeyHashid - mid <- decodeKeyHashid404 mkhid - getReply - (ProjectTicketReplyR shr prj ltkhid . encodeHid) - (ProjectTicketMessageR shr prj ltkhid . encodeHid) - (selectDiscussionId shr prj ltkhid) - mid - postProjectTicketDepsR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html postProjectTicketDepsR _shr _prj _ltkhid = error "Temporarily disabled" @@ -1104,13 +1079,6 @@ getSharerTicketR shr talkhid = do where here = SharerTicketR shr talkhid -getSharerTicketDiscussionR - :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent -getSharerTicketDiscussionR shr talkhid = - getRepliesCollection (SharerTicketDiscussionR shr talkhid) $ do - (_, Entity _ lt, _, _, _) <- getSharerTicket404 shr talkhid - return $ localTicketDiscuss lt - getSharerTicketDepsR :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent getSharerTicketDepsR shr talkhid = diff --git a/src/Vervis/Persist/Discussion.hs b/src/Vervis/Persist/Discussion.hs index c0e51e6..a12184f 100644 --- a/src/Vervis/Persist/Discussion.hs +++ b/src/Vervis/Persist/Discussion.hs @@ -17,9 +17,9 @@ module Vervis.Persist.Discussion ( MessageTreeNodeAuthor (..) , MessageTreeNode (..) , getDiscussionTree - --, getRepliesCollection , getLocalParentMessageId , getMessageParent + , getMessageFromID ) where @@ -35,8 +35,9 @@ import Data.Maybe (isNothing, mapMaybe) import Data.Text (Text) import Data.Tree (Forest) import Database.Esqueleto hiding (isNothing) +import Yesod.Core import Yesod.Core.Content -import Yesod.Persist.Core (runDB) +import Yesod.Persist.Core import qualified Data.HashMap.Lazy as M (fromList, lookup) import qualified Database.Esqueleto as E @@ -71,8 +72,29 @@ data MessageTreeNode = MessageTreeNode , mtnAuthor :: MessageTreeNodeAuthor } -getMessages :: AppDB DiscussionId -> Handler [MessageTreeNode] -getMessages getdid = runDB $ do +getLocalAuthor lmid aid name = do + authorByKey <- getLocalActor aid + code <- + case authorByKey of + LocalActorPerson personID -> do + person <- getJust personID + return $ "~" <> username2text (personUsername person) + LocalActorGroup groupID -> do + groupHash <- encodeKeyHashid groupID + return $ "&" <> keyHashidText groupHash + LocalActorRepo repoID -> do + repoHash <- encodeKeyHashid repoID + return $ "^" <> keyHashidText repoHash + LocalActorDeck deckID -> do + deckHash <- encodeKeyHashid deckID + return $ "=" <> keyHashidText deckHash + LocalActorLoom loomID -> do + loomHash <- encodeKeyHashid loomID + return $ "+" <> keyHashidText loomHash + return $ MessageTreeNodeLocal lmid authorByKey code name + +getAllMessages :: AppDB DiscussionId -> Handler [MessageTreeNode] +getAllMessages getdid = runDB $ do did <- getdid l <- select $ from $ \ (lm `InnerJoin` m `InnerJoin` a) -> do on $ lm ^. LocalMessageAuthor ==. a ^. ActorId @@ -103,25 +125,8 @@ getMessages getdid = runDB $ do return $ locals ++ remotes where mklocal (Entity mid m, Value lmid, Value aid, Value name) = do - authorByKey <- getLocalActor aid - code <- - case authorByKey of - LocalActorPerson personID -> do - person <- getJust personID - return $ "~" <> username2text (personUsername person) - LocalActorGroup groupID -> do - groupHash <- encodeKeyHashid groupID - return $ "&" <> keyHashidText groupHash - LocalActorRepo repoID -> do - repoHash <- encodeKeyHashid repoID - return $ "^" <> keyHashidText repoHash - LocalActorDeck deckID -> do - deckHash <- encodeKeyHashid deckID - return $ "=" <> keyHashidText deckHash - LocalActorLoom loomID -> do - loomHash <- encodeKeyHashid loomID - return $ "+" <> keyHashidText loomHash - return $ MessageTreeNode mid m $ MessageTreeNodeLocal lmid authorByKey code name + author <- getLocalAuthor lmid aid name + return $ MessageTreeNode mid m author mkremote (Entity mid m, Value h, Value luMsg, Value luAuthor, Value name) = MessageTreeNode mid m $ MessageTreeNodeRemote h luMsg luAuthor name @@ -149,57 +154,10 @@ 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 MessageTreeNode) -getDiscussionTree getdid = sortByTime . discussionTree <$> getMessages getdid +getDiscussionTree getdid = + sortByTime . discussionTree <$> getAllMessages getdid -{- -getRepliesCollection :: Route App -> AppDB DiscussionId -> Handler TypedContent -getRepliesCollection here getDiscussionId404 = do - (locals, remotes) <- runDB $ do - did <- getDiscussionId404 - (,) <$> selectLocals did <*> selectRemotes did - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - encodeHid <- getEncodeKeyHashid - hashPerson <- getEncodeKeyHashid - let localUri' = localUri hashPerson encodeRouteHome encodeHid - replies = Collection - { collectionId = encodeRouteLocal here - , collectionType = CollectionTypeUnordered - , collectionTotalItems = Just $ length locals + length remotes - , collectionCurrent = Nothing - , collectionFirst = Nothing - , collectionLast = Nothing - , collectionItems = - map localUri' locals ++ map remoteUri remotes - } - provideHtmlAndAP replies $ redirectToPrettyJSON here - where - selectLocals did = - E.select $ E.from $ - \ (m `E.InnerJoin` lm) -> do - E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest - E.where_ $ - m E.^. MessageRoot E.==. E.val did E.&&. - E.isNothing (m E.^. MessageParent) E.&&. - E.isNothing (lm E.^. LocalMessageUnlinkedParent) - return (lm E.^. LocalMessageAuthor, lm E.^. LocalMessageId) - selectRemotes did = - E.select $ E.from $ - \ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do - E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId - E.on $ rm E.^. RemoteMessageIdent E.==. ro E.^. RemoteObjectId - E.on $ m E.^. MessageId E.==. rm E.^. RemoteMessageRest - E.where_ $ - m E.^. MessageRoot E.==. E.val did E.&&. - E.isNothing (m E.^. MessageParent) E.&&. - E.isNothing (rm E.^. RemoteMessageLostParent) - return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent) - localUri hashPerson encR encH (E.Value pid, E.Value lmid) = - encR $ PersonMessageR (hashPerson pid) (encH lmid) - remoteUri (E.Value h, E.Value lu) = ObjURI h lu --} - -getMessage +getMessageFromRoute :: LocalActorBy Key -> LocalMessageId -> ExceptT Text AppDB @@ -208,7 +166,7 @@ getMessage , Entity LocalMessage , Entity Message ) -getMessage authorByKey localMsgID = do +getMessageFromRoute authorByKey localMsgID = do authorByEntity <- do maybeActor <- lift $ getLocalActorEntity authorByKey fromMaybeE maybeActor "No such author in DB" @@ -233,7 +191,7 @@ getLocalParentMessageId -> (LocalActorBy Key, LocalMessageId) -> ExceptT Text AppDB MessageId getLocalParentMessageId discussionID (authorByKey, localMsgID) = do - (_, _, _, Entity msgID msg) <- getMessage authorByKey localMsgID + (_, _, _, Entity msgID msg) <- getMessageFromRoute authorByKey localMsgID unless (messageRoot msg == discussionID) $ throwE "Local parent belongs to a different discussion" return msgID @@ -259,3 +217,30 @@ getMessageParent did (Right p@(ObjURI hParent luParent)) = do throwE "Remote parent belongs to a different discussion" return mid Nothing -> return $ Right p + +getMessageFromID :: AppDB DiscussionId -> MessageId -> AppDB MessageTreeNode +getMessageFromID 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 + let actorID = localMessageAuthor lm + name <- actorName <$> getJust actorID + getLocalAuthor lmid actorID name + (Nothing, Just (Entity _rmid rm)) -> do + ra <- getJust $ remoteMessageAuthor rm + roA <- getJust $ remoteActorIdent ra + roM <- getJust $ remoteMessageIdent rm + i <- getJust $ remoteObjectInstance roA + return $ + MessageTreeNodeRemote + (instanceHost i) + (remoteObjectIdent roM) + (remoteObjectIdent roA) + (remoteActorName ra) + return $ MessageTreeNode mid m author diff --git a/src/Vervis/Web/Discussion.hs b/src/Vervis/Web/Discussion.hs index 132e4f1..b21468b 100644 --- a/src/Vervis/Web/Discussion.hs +++ b/src/Vervis/Web/Discussion.hs @@ -14,11 +14,10 @@ -} module Vervis.Web.Discussion - ( getDiscussion - --, getTopReply - --, postTopReply - --, getReply - --, postReply + ( serveDiscussion + , getTopReply + , getReply + , postReply , serveMessage ) where @@ -42,6 +41,7 @@ import Yesod.Form.Types (FormResult (..)) import Yesod.Persist.Core (runDB, get404, getBy404) import qualified Data.Text as T +import qualified Database.Esqueleto as E import Data.Aeson.Encode.Pretty.ToEncoding import Database.Persist.JSON @@ -57,6 +57,7 @@ import qualified Web.ActivityPub as AP import Data.Either.Local import Database.Persist.Local +import Yesod.Form.Local import Yesod.Persist.Local import Vervis.API @@ -73,41 +74,65 @@ import Vervis.Settings import Vervis.Ticket import Vervis.Widget.Discussion -getDiscussion - :: (MessageId -> Route App) +import qualified Vervis.Client as C + +getRepliesCollection + :: Route App -> AppDB DiscussionId -> Handler (AP.Collection FedURI URIMode) +getRepliesCollection here getDiscussionId404 = do + (locals, remotes) <- runDB $ do + did <- getDiscussionId404 + (,) <$> selectLocals did <*> selectRemotes did + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hashMsg <- getEncodeKeyHashid + hashActor <- getHashLocalActor + let localUri (authorByKey, localMsgID) = + encodeRouteHome $ + messageRoute (hashActor authorByKey) (hashMsg localMsgID) + return AP.Collection + { AP.collectionId = encodeRouteLocal here + , AP.collectionType = AP.CollectionTypeUnordered + , AP.collectionTotalItems = Just $ length locals + length remotes + , AP.collectionCurrent = Nothing + , AP.collectionFirst = Nothing + , AP.collectionLast = Nothing + , AP.collectionItems = + map localUri locals ++ map remoteUri remotes + } + where + selectLocals did = do + locals <- E.select $ E.from $ \ (m `E.InnerJoin` lm) -> do + E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest + E.where_ $ + m E.^. MessageRoot E.==. E.val did E.&&. + E.isNothing (m E.^. MessageParent) E.&&. + E.isNothing (lm E.^. LocalMessageUnlinkedParent) + return (lm E.^. LocalMessageAuthor, lm E.^. LocalMessageId) + for locals $ \ (E.Value actorID, E.Value localMsgID) -> do + actorByKey <- getLocalActor actorID + return (actorByKey, localMsgID) + selectRemotes did = + E.select $ E.from $ + \ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ rm E.^. RemoteMessageIdent E.==. ro E.^. RemoteObjectId + E.on $ m E.^. MessageId E.==. rm E.^. RemoteMessageRest + E.where_ $ + m E.^. MessageRoot E.==. E.val did E.&&. + E.isNothing (m E.^. MessageParent) E.&&. + E.isNothing (rm E.^. RemoteMessageLostParent) + return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent) + remoteUri (E.Value h, E.Value lu) = ObjURI h lu + +serveDiscussion + :: Route App + -> (MessageId -> Route App) -> Route App -> AppDB DiscussionId - -> Handler Html -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 - ra <- getJust $ remoteMessageAuthor rm - roA <- getJust $ remoteActorIdent ra - roM <- getJust $ remoteMessageIdent rm - i <- getJust $ remoteObjectInstance roA - return $ - MessageTreeNodeRemote - (instanceHost i) - (remoteObjectIdent roM) - (remoteObjectIdent roA) - (remoteActorName ra) - return $ MessageTreeNode mid m author + -> Handler TypedContent +serveDiscussion here reply topic getdid = do + replies <- getRepliesCollection here getdid + provideHtmlAndAP replies (discussionW getdid topic reply) {- getNodeL :: AppDB DiscussionId -> LocalMessageId -> AppDB MessageTreeNode @@ -127,111 +152,68 @@ getTopReply replyP = do ((_result, widget), enctype) <- runFormPost newMessageForm defaultLayout $(widgetFile "discussion/top-reply") -postTopReply - :: Host - -> [Route App] - -> [Route App] - -> Route App - -> Route App - -> Route App - -> (LocalMessageId -> Route App) - -> Handler Html -postTopReply hDest recipsA recipsC context recipF replyP after = do - ((result, widget), enctype) <- runFormPost newMessageForm - (eperson, sharer) <- do - ep@(Entity _ p) <- requireVerifiedAuth - s <- runDB $ get404 (personIdent p) - return (ep, s) - let shrAuthor = sharerIdent sharer - eobiid <- runExceptT $ do - msg <- case result of - FormMissing -> throwE "Field(s) missing." - FormFailure _l -> throwE "Message submission failed, see errors below." - FormSuccess nm -> - return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm - note <- ExceptT $ createThread shrAuthor msg hDest recipsA recipsC context - noteC eperson sharer note - case eobiid of - Left e -> do - setMessage $ toHtml e - defaultLayout $(widgetFile "discussion/top-reply") - Right obiid -> do - setMessage "Message submitted." - - encodeRouteFed <- getEncodeRouteFed - let encodeRecipRoute = encodeRouteFed hDest - (summary, audience, follow) <- C.follow shrAuthor (encodeRecipRoute context) (encodeRecipRoute recipF) False - eobiidFollow <- runExceptT $ followC shrAuthor (Just summary) audience follow - case eobiidFollow of - Left e -> setMessage $ toHtml $ "Following failed: " <> e - Right _ -> return () - - mlmid <- runDB $ getKeyBy $ UniqueLocalMessageCreate obiid - case mlmid of - Nothing -> error "noteC succeeded but no lmid found for obiid" - Just lmid -> redirect $ after lmid - -getReply +getReply' :: (MessageId -> Route App) -> (MessageId -> Route App) -> AppDB DiscussionId -> MessageId -> Handler Html -getReply replyG replyP getdid midParent = do - mtn <- runDB $ getNode getdid midParent +getReply' replyG replyP getdid midParent = do + mtn <- runDB $ getMessageFromID getdid midParent now <- liftIO getCurrentTime ((_result, widget), enctype) <- runFormPost newMessageForm defaultLayout $(widgetFile "discussion/reply") -postReply - :: Host - -> [Route App] - -> [Route App] - -> Route App - -> Route App - -> (MessageId -> Route App) - -> (MessageId -> Route App) - -> (LocalMessageId -> Route App) +getReply + :: (MessageId -> Route App) -> AppDB DiscussionId -> MessageId -> Handler Html -postReply hDest recipsA recipsC context recipF replyG replyP after getdid midParent = do - ((result, widget), enctype) <- runFormPost newMessageForm - (eperson, sharer) <- do - ep@(Entity _ p) <- requireVerifiedAuth - s <- runDB $ get404 (personIdent p) - return (ep, s) - let shrAuthor = sharerIdent sharer - eobiid <- runExceptT $ do - msg <- case result of - FormMissing -> throwE "Field(s) missing." - FormFailure _l -> throwE "Message submission failed, see errors below." - FormSuccess nm -> - return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm - note <- ExceptT $ createReply shrAuthor msg hDest recipsA recipsC context midParent - noteC eperson sharer note - case eobiid of +getReply replyR = getReply' replyR replyR + +postReply + :: Route App + -> [LocalActorBy KeyHashid] + -> [LocalStageBy KeyHashid] + -> Route App + -> Maybe (AppDB DiscussionId, MessageId) + -> Handler Html +postReply formR actors stages topicR maybeParent = do + source <- runFormPostRedirect formR newMessageForm + person@(Entity senderID sender) <- requireAuth + senderHash <- encodeKeyHashid senderID + errorOrCreate <- runExceptT $ do + muParent <- for maybeParent $ \ (getdid, midParent) -> do + MessageTreeNode _ _ author <- + lift $ runDB $ getMessageFromID getdid midParent + case author of + MessageTreeNodeLocal localMsgID authorByKey _ _ -> do + encodeRouteHome <- getEncodeRouteHome + localMsgHash <- encodeKeyHashid localMsgID + authorByHash <- hashLocalActor authorByKey + return $ encodeRouteHome $ + messageRoute authorByHash localMsgHash + MessageTreeNodeRemote h _ luAuthor _ -> + return $ ObjURI h luAuthor + (maybeSummary, audience, note) <- + C.comment senderHash source actors stages topicR muParent + hLocal <- asksSite siteInstanceHost + let specific = + AP.CreateActivity $ + AP.Create (AP.CreateNote hLocal note) Nothing + (localRecips, remoteRecips, fwdHosts, action) <- + lift $ C.makeServerInput Nothing maybeSummary audience specific + actor <- lift $ runDB $ getJust $ personActor sender + createNoteC + person actor Nothing localRecips remoteRecips fwdHosts + action note Nothing + case errorOrCreate of Left e -> do setMessage $ toHtml e - mtn <- runDB $ getNode getdid midParent - now <- liftIO getCurrentTime - defaultLayout $(widgetFile "discussion/reply") - Right obiid -> do + redirect formR + Right createID -> do setMessage "Message submitted." - - encodeRouteFed <- getEncodeRouteFed - let encodeRecipRoute = encodeRouteFed hDest - (summary, audience, follow) <- C.follow shrAuthor (encodeRecipRoute context) (encodeRecipRoute recipF) False - eobiidFollow <- runExceptT $ followC shrAuthor (Just summary) audience follow - case eobiidFollow of - Left e -> setMessage $ toHtml $ "Following failed: " <> e - Right _ -> return () - - mlmid <- runDB $ getKeyBy $ UniqueLocalMessageCreate obiid - case mlmid of - Nothing -> error "noteC succeeded but no lmid found for obiid" - Just lmid -> redirect $ after lmid --} + redirect topicR serveMessage authorHash localMessageHash = do authorID <- decodeKeyHashid404 authorHash diff --git a/th/routes b/th/routes index 94835a4..a892a3f 100644 --- a/th/routes +++ b/th/routes @@ -148,8 +148,6 @@ /people/#PersonKeyHashid/follow PersonFollowR POST /people/#PersonKeyHashid/unfollow PersonUnfollowR POST -/reply/#MessageKeyHashid ReplyR POST - /people/#PersonKeyHashid/stamps/#SigKeyKeyHashid PersonStampR GET ---- Group ------------------------------------------------------------------ @@ -236,9 +234,10 @@ -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/unclaim TicketUnclaimR POST -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/assign TicketAssignR GET POST -- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/unassign TicketUnassignR POST -/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/follow TicketFollowR POST -/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/unfollow TicketUnfollowR POST -/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/reply TicketReplyR POST +/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/follow TicketFollowR POST +/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/unfollow TicketUnfollowR POST +/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/reply TicketReplyR GET POST +/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/reply/#MessageKeyHashid TicketReplyOnR GET POST ---- Ticket Dependency ------------------------------------------------------- @@ -291,7 +290,8 @@ /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/apply ClothApplyR POST /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/follow ClothFollowR POST /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/unfollow ClothUnfollowR POST -/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/reply ClothReplyR POST +/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/reply ClothReplyR GET POST +/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/reply/#MessageKeyHashid ClothReplyOnR GET POST ---- Cloth Dependency --------------------------------------------------------