From 72cba96958a64cfc50e7d5040250abf2f2fd31f9 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 30 Sep 2019 06:27:42 +0000 Subject: [PATCH] Move reply authoring code from Vervis.Handler.Discussion to Vervis.Client --- src/Vervis/Client.hs | 112 ++++++++++++++++++++++++++++--- src/Vervis/Handler/Discussion.hs | 83 ++++------------------- 2 files changed, 117 insertions(+), 78 deletions(-) diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 487f929..810a2c1 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -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 diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index 3cf4213..f54bbc9 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/src/Vervis/Handler/Discussion.hs @@ -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