mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 17:24:53 +09:00
Move reply authoring code from Vervis.Handler.Discussion to Vervis.Client
This commit is contained in:
fr33domlover
parent
5a7700ffe4
commit
72cba96958
2 changed files with 117 additions and 78 deletions
|
|
@ -14,7 +14,9 @@
|
|||
-}
|
||||
|
||||
module Vervis.Client
|
||||
( follow
|
||||
( createThread
|
||||
, createReply
|
||||
, follow
|
||||
, followSharer
|
||||
, followProject
|
||||
, followTicket
|
||||
|
|
@ -22,25 +24,119 @@ module Vervis.Client
|
|||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Trans.Except
|
||||
import Database.Persist
|
||||
import Data.Text (Text)
|
||||
import Text.Blaze.Html.Renderer.Text
|
||||
import Text.Hamlet
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Handler
|
||||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub
|
||||
import Web.ActivityPub hiding (Follow)
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
import Yesod.RenderSource
|
||||
|
||||
import qualified Web.ActivityPub as AP
|
||||
|
||||
import Database.Persist.Local
|
||||
|
||||
import Vervis.FedURI
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
|
||||
createThread
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
=> ShrIdent
|
||||
-> TextPandocMarkdown
|
||||
-> Host
|
||||
-> [Route App]
|
||||
-> [Route App]
|
||||
-> Route App
|
||||
-> m (Either Text (Note URIMode))
|
||||
createThread shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context = runExceptT $ do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
|
||||
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg
|
||||
let uContext = encodeRecipRoute context
|
||||
recips = recipsA ++ recipsC
|
||||
return Note
|
||||
{ noteId = Nothing
|
||||
, noteAttrib = encodeRouteLocal $ SharerR shrAuthor
|
||||
, noteAudience = Audience
|
||||
{ audienceTo = map encodeRecipRoute recips
|
||||
, audienceBto = []
|
||||
, audienceCc = []
|
||||
, audienceBcc = []
|
||||
, audienceGeneral = []
|
||||
, audienceNonActors = map encodeRecipRoute recipsC
|
||||
}
|
||||
, noteReplyTo = Just uContext
|
||||
, noteContext = Just uContext
|
||||
, notePublished = Nothing
|
||||
, noteSource = msg
|
||||
, noteContent = contentHtml
|
||||
}
|
||||
|
||||
createReply
|
||||
:: ShrIdent
|
||||
-> TextPandocMarkdown
|
||||
-> Host
|
||||
-> [Route App]
|
||||
-> [Route App]
|
||||
-> Route App
|
||||
-> MessageId
|
||||
-> Handler (Either Text (Note URIMode))
|
||||
createReply shrAuthor (TextPandocMarkdown msg) hDest recipsA recipsC context midParent = runExceptT $ do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
|
||||
uParent <- lift $ runDB $ do
|
||||
_m <- get404 midParent
|
||||
mlocal <- getBy $ UniqueLocalMessage midParent
|
||||
mremote <- getValBy $ UniqueRemoteMessage midParent
|
||||
case (mlocal, mremote) of
|
||||
(Nothing, Nothing) -> error "Message with no author"
|
||||
(Just _, Just _) -> error "Message used as both local and remote"
|
||||
(Just (Entity lmidParent lm), Nothing) -> do
|
||||
p <- getJust $ localMessageAuthor lm
|
||||
s <- getJust $ personIdent p
|
||||
lmkhid <- encodeKeyHashid lmidParent
|
||||
return $ encodeRouteHome $ MessageR (sharerIdent s) lmkhid
|
||||
(Nothing, Just rm) -> do
|
||||
i <- getJust $ remoteMessageInstance rm
|
||||
return $ ObjURI (instanceHost i) (remoteMessageIdent rm)
|
||||
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg
|
||||
let uContext = encodeRecipRoute context
|
||||
recips = recipsA ++ recipsC
|
||||
return Note
|
||||
{ noteId = Nothing
|
||||
, noteAttrib = encodeRouteLocal $ SharerR shrAuthor
|
||||
, noteAudience = Audience
|
||||
{ audienceTo = map encodeRecipRoute recips
|
||||
, audienceBto = []
|
||||
, audienceCc = []
|
||||
, audienceBcc = []
|
||||
, audienceGeneral = []
|
||||
, audienceNonActors = map encodeRecipRoute recipsC
|
||||
}
|
||||
, noteReplyTo = Just uParent
|
||||
, noteContext = Just uContext
|
||||
, notePublished = Nothing
|
||||
, noteSource = msg
|
||||
, noteContent = contentHtml
|
||||
}
|
||||
|
||||
follow
|
||||
:: (MonadHandler m, HandlerSite m ~ App)
|
||||
=> ShrIdent -> ObjURI URIMode -> ObjURI URIMode -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
|
||||
=> ShrIdent -> ObjURI URIMode -> ObjURI URIMode -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
|
||||
follow shrAuthor uObject@(ObjURI hObject luObject) uRecip hide = do
|
||||
summary <-
|
||||
TextHtml . TL.toStrict . renderHtml <$>
|
||||
|
|
@ -54,7 +150,7 @@ follow shrAuthor uObject@(ObjURI hObject luObject) uRecip hide = do
|
|||
#{renderAuthority hObject}#{localUriPath luObject}
|
||||
\.
|
||||
|]
|
||||
let followAP = Follow
|
||||
let followAP = AP.Follow
|
||||
{ followObject = uObject
|
||||
, followContext =
|
||||
if uObject == uRecip
|
||||
|
|
@ -67,7 +163,7 @@ follow shrAuthor uObject@(ObjURI hObject luObject) uRecip hide = do
|
|||
|
||||
followSharer
|
||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> ShrIdent -> ShrIdent -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
|
||||
=> ShrIdent -> ShrIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
|
||||
followSharer shrAuthor shrObject hide = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let uObject = encodeRouteHome $ SharerR shrObject
|
||||
|
|
@ -75,7 +171,7 @@ followSharer shrAuthor shrObject hide = do
|
|||
|
||||
followProject
|
||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> ShrIdent -> ShrIdent -> PrjIdent -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
|
||||
=> ShrIdent -> ShrIdent -> PrjIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
|
||||
followProject shrAuthor shrObject prjObject hide = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let uObject = encodeRouteHome $ ProjectR shrObject prjObject
|
||||
|
|
@ -83,7 +179,7 @@ followProject shrAuthor shrObject prjObject hide = do
|
|||
|
||||
followTicket
|
||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> ShrIdent -> ShrIdent -> PrjIdent -> Int -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
|
||||
=> ShrIdent -> ShrIdent -> PrjIdent -> Int -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
|
||||
followTicket shrAuthor shrObject prjObject numObject hide = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let uObject = encodeRouteHome $ TicketR shrObject prjObject numObject
|
||||
|
|
@ -92,7 +188,7 @@ followTicket shrAuthor shrObject prjObject numObject hide = do
|
|||
|
||||
followRepo
|
||||
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
|
||||
=> ShrIdent -> ShrIdent -> RpIdent -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode)
|
||||
=> ShrIdent -> ShrIdent -> RpIdent -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
|
||||
followRepo shrAuthor shrObject rpObject hide = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let uObject = encodeRouteHome $ RepoR shrObject rpObject
|
||||
|
|
|
|||
|
|
@ -46,14 +46,17 @@ import Data.Aeson.Encode.Pretty.ToEncoding
|
|||
import Database.Persist.JSON
|
||||
import Network.FedURI
|
||||
import Web.ActivityPub
|
||||
import Yesod.ActivityPub
|
||||
import Yesod.Auth.Unverified
|
||||
import Yesod.FedURI
|
||||
import Yesod.Hashids
|
||||
import Yesod.MonadSite
|
||||
|
||||
import Database.Persist.Local
|
||||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.API
|
||||
import Vervis.Client
|
||||
import Vervis.Discussion
|
||||
import Vervis.Federation
|
||||
import Vervis.FedURI
|
||||
|
|
@ -197,35 +200,13 @@ postTopReply hDest recipsA recipsC context replyP after = do
|
|||
msg <- case result of
|
||||
FormMissing -> throwE "Field(s) missing."
|
||||
FormFailure _l -> throwE "Message submission failed, see errors below."
|
||||
FormSuccess nm -> return $ nmContent nm
|
||||
encodeRouteFed <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
|
||||
FormSuccess nm ->
|
||||
return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
|
||||
shrAuthor <- do
|
||||
Entity _ p <- requireVerifiedAuth
|
||||
lift $ runDB $ sharerIdent <$> get404 (personIdent p)
|
||||
let msg' = T.filter (/= '\r') msg
|
||||
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
|
||||
let ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
|
||||
uContext = encodeRecipRoute context
|
||||
recips = recipsA ++ recipsC
|
||||
note = Note
|
||||
{ noteId = Nothing
|
||||
, noteAttrib = luAuthor
|
||||
, noteAudience = Audience
|
||||
{ audienceTo = map encodeRecipRoute recips
|
||||
, audienceBto = []
|
||||
, audienceCc = []
|
||||
, audienceBcc = []
|
||||
, audienceGeneral = []
|
||||
, audienceNonActors = map encodeRecipRoute recipsC
|
||||
}
|
||||
, noteReplyTo = Just uContext
|
||||
, noteContext = Just uContext
|
||||
, notePublished = Nothing
|
||||
, noteSource = msg'
|
||||
, noteContent = contentHtml
|
||||
}
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
note <- ExceptT $ createThread shrAuthor msg hDest recipsA recipsC context
|
||||
ExceptT $ createNoteC hLocal note
|
||||
case elmid of
|
||||
Left e -> do
|
||||
|
|
@ -264,51 +245,13 @@ postReply hDest recipsA recipsC context replyG replyP after getdid midParent = d
|
|||
msg <- case result of
|
||||
FormMissing -> throwE "Field(s) missing."
|
||||
FormFailure _l -> throwE "Message submission failed, see errors below."
|
||||
FormSuccess nm -> return $ nmContent nm
|
||||
encodeRouteFed <- getEncodeRouteHome
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
|
||||
(shrAuthor, uParent) <- do
|
||||
FormSuccess nm ->
|
||||
return $ TextPandocMarkdown $ T.filter (/= '\r') $ nmContent nm
|
||||
shrAuthor <- do
|
||||
Entity _ p <- requireVerifiedAuth
|
||||
lift $ runDB $ do
|
||||
_m <- get404 midParent
|
||||
shr <- sharerIdent <$> get404 (personIdent p)
|
||||
mlocal <- getBy $ UniqueLocalMessage midParent
|
||||
mremote <- getValBy $ UniqueRemoteMessage midParent
|
||||
parent <- case (mlocal, mremote) of
|
||||
(Nothing, Nothing) -> error "Message with no author"
|
||||
(Just _, Just _) -> error "Message used as both local and remote"
|
||||
(Just (Entity lmidParent lm), Nothing) -> do
|
||||
p <- getJust $ localMessageAuthor lm
|
||||
s <- getJust $ personIdent p
|
||||
lmkhid <- encodeKeyHashid lmidParent
|
||||
return $ encodeRouteFed $ MessageR (sharerIdent s) lmkhid
|
||||
(Nothing, Just rm) -> do
|
||||
i <- getJust $ remoteMessageInstance rm
|
||||
return $ ObjURI (instanceHost i) (remoteMessageIdent rm)
|
||||
return (shr, parent)
|
||||
let msg' = T.filter (/= '\r') msg
|
||||
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
|
||||
let ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
|
||||
uContext = encodeRecipRoute context
|
||||
recips = recipsA ++ recipsC
|
||||
note = Note
|
||||
{ noteId = Nothing
|
||||
, noteAttrib = luAuthor
|
||||
, noteAudience = Audience
|
||||
{ audienceTo = map encodeRecipRoute recips
|
||||
, audienceBto = []
|
||||
, audienceCc = []
|
||||
, audienceBcc = []
|
||||
, audienceGeneral = []
|
||||
, audienceNonActors = map encodeRecipRoute recipsC
|
||||
}
|
||||
, noteReplyTo = Just uParent
|
||||
, noteContext = Just uContext
|
||||
, notePublished = Nothing
|
||||
, noteSource = msg'
|
||||
, noteContent = contentHtml
|
||||
}
|
||||
lift $ runDB $ sharerIdent <$> get404 (personIdent p)
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
note <- ExceptT $ createReply shrAuthor msg hDest recipsA recipsC context midParent
|
||||
ExceptT $ createNoteC hLocal note
|
||||
case elmid of
|
||||
Left e -> do
|
||||
|
|
|
|||
Loading…
Reference in a new issue