UI, Web: Re-enable ticket/MR replies view and commenting forms/buttons
This commit is contained in:
fr33domlover
parent
d5e913d97a
commit
b99d864429
9 changed files with 340 additions and 369 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
{- This file is part of Vervis.
|
||||
-
|
||||
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
|
||||
- Written in 2016, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
|
||||
-
|
||||
- ♡ 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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
12
th/routes
12
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 --------------------------------------------------------
|
||||
|
||||
|
|
|
|||
Loading…
Reference in a new issue