Optional activity summary, set it when handling a Note in C2S

This commit is contained in:
fr33domlover 2019-06-15 16:24:34 +00:00
parent 68bdaf65a7
commit 6452d239f2
4 changed files with 58 additions and 18 deletions

View file

@ -51,6 +51,7 @@ import Network.HTTP.Client
import Network.HTTP.Types.Header
import Network.HTTP.Types.URI
import Network.TLS hiding (SHA256)
import Text.Blaze.Html.Renderer.Text
import UnliftIO.Exception (try)
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
import Yesod.Persist.Core
@ -61,6 +62,7 @@ import qualified Data.List as L
import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Database.Esqueleto as E
import qualified Network.Wai as W
@ -221,7 +223,15 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
throwE "Remote parent belongs to a different discussion"
return mid
return (did, meparent, Nothing)
(lmid, obid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent source content
summary <-
withUrlRenderer
[hamlet|
<p>
<a href=@{SharerR shrUser}>{shr2text shrUser}
\ commented on a #
<a href=#{renderFedURI uContext}>ticket</a>.
|]
(lmid, obid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent source content summary
moreRemotes <- deliverLocal pid obid localRecips mcollections
unless (federation || null moreRemotes) $
throwE "Federation disabled but remote collection members found"
@ -411,8 +421,9 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
-> Maybe (Either MessageId FedURI)
-> Text
-> Text
-> Html
-> AppDB (LocalMessageId, OutboxItemId, Doc Activity)
insertMessage luAttrib shrUser pid uContext did muParent meparent source content = do
insertMessage luAttrib shrUser pid uContext did muParent meparent source content summary = do
now <- liftIO getCurrentTime
mid <- insert Message
{ messageCreated = now
@ -427,6 +438,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
let activity luAct luNote = Doc host Activity
{ activityId = luAct
, activityActor = luAttrib
, activitySummary =
Just $ TextHtml $ TL.toStrict $ renderHtml summary
, activityAudience = aud
, activitySpecific = CreateActivity Create
{ createObject = Note

View file

@ -48,6 +48,7 @@ import Text.Blaze.Html (toHtml)
import Text.Blaze.Html.Renderer.Text
--import Text.Email.QuasiQuotation (email
import Text.Email.Validate (unsafeEmailAddress)
import Text.Hamlet
import Web.Hashids
import Web.PathPieces (toPathPiece)
@ -318,13 +319,14 @@ changes hLocal ctx =
doc = Doc "x.y" Activity
{ activityId = localUri
, activityActor = localUri
, activitySummary = Nothing
, activityAudience = Audience [] [] [] [] [] []
, activitySpecific = AcceptActivity $ Accept fedUri
}
insertEntity $ OutboxItem201905 pid (PersistJSON doc) defaultTime
)
(Just $ \ (Entity obid ob) -> do
let actNoteId (Activity _ _ _ (CreateActivity (Create note))) = noteId note
let actNoteId (Activity _ _ _ _ (CreateActivity (Create note))) = noteId note
actNoteId _ = Nothing
obNoteId (Entity i o) =
if i == obid
@ -439,6 +441,7 @@ changes hLocal ctx =
activity luAct luNote = Doc hLocal Activity
{ activityId = luAct
, activityActor = luAttrib
, activitySummary = Nothing
, activityAudience = aud
, activitySpecific = CreateActivity Create
{ createObject = Note
@ -683,6 +686,7 @@ changes hLocal ctx =
doc = Doc "x.y" Activity
{ activityId = localUri
, activityActor = localUri
, activitySummary = Nothing
, activityAudience = Audience [] [] [] [] [] []
, activitySpecific = AcceptActivity $ Accept fedUri
}
@ -707,6 +711,7 @@ changes hLocal ctx =
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
renderUrl <- askUrlRenderParams
let recips = map encodeRouteHome
[ ProjectR shrProject prj
, ProjectTeamR shrProject prj
@ -732,9 +737,22 @@ changes hLocal ctx =
, ticketDependsOn = []
, ticketDependedBy = []
}
summary =
[hamlet|
<p>
<a href=@{SharerR shrAuthor}>
#{shr2text shrAuthor}
\ offered a ticket to project #
<a href=@{ProjectR shrProject prj}>
./s/#{shr2text shrProject}/p/#{prj2text prj}
: #{ticket20190612Title ticket}.
|]
doc luAct = Doc hLocal Activity
{ activityId = luAct
, activityActor = author
, activitySummary =
Just $ TextHtml $ TL.toStrict $ renderHtml $
summary renderUrl
, activityAudience = Audience recips [] [] [] [] []
, activitySpecific = OfferActivity Offer
{ offerObject = ticketAP

View file

@ -761,6 +761,7 @@ data SpecificActivity
data Activity = Activity
{ activityId :: LocalURI
, activityActor :: LocalURI
, activitySummary :: Maybe TextHtml
, activityAudience :: Audience
, activitySpecific :: SpecificActivity
}
@ -772,7 +773,8 @@ instance ActivityPub Activity where
actor <- withHost h $ f2l <$> o .: "actor"
fmap (h,) $
Activity id_ actor
<$> parseAudience o
<$> (fmap (TextHtml . sanitizeBalance) <$> o .:? "summary")
<*> parseAudience o
<*> do
typ <- o .: "type"
case typ of
@ -784,10 +786,11 @@ instance ActivityPub Activity where
_ ->
fail $
"Unrecognized activity type: " ++ T.unpack typ
toSeries host (Activity id_ actor audience specific)
toSeries host (Activity id_ actor summary audience specific)
= "type" .= activityType specific
<> "id" .= l2f host id_
<> "actor" .= l2f host actor
<> "summary" .=? summary
<> encodeAudience audience
<> encodeSpecific host actor specific
where

View file

@ -19,6 +19,7 @@
module Yesod.MonadSite
( Site (..)
, MonadSite (..)
, askUrlRender
, asksSite
, runSiteDB
, WorkerT ()
@ -60,26 +61,31 @@ class PersistConfig (SitePersistConfig site) => Site site where
class (MonadIO m, MonadLogger m) => MonadSite m where
type SiteEnv m
askSite :: m (SiteEnv m)
askUrlRender :: m (Route (SiteEnv m) -> Text)
askUrlRenderParams :: m (Route (SiteEnv m) -> [(Text, Text)] -> Text)
{-
forkSite :: (SomeException -> m ()) -> m () -> m ()
asyncSite :: m a -> m (m (Either SomeException a))
-}
askUrlRender :: MonadSite m => m (Route (SiteEnv m) -> Text)
askUrlRender = do
render <- askUrlRenderParams
return $ \ route -> render route []
instance MonadSite m => MonadSite (ReaderT r m) where
type SiteEnv (ReaderT r m) = SiteEnv m
askSite = lift askSite
askUrlRender = lift askUrlRender
askUrlRenderParams = lift askUrlRenderParams
instance MonadSite m => MonadSite (ExceptT e m) where
type SiteEnv (ExceptT e m) = SiteEnv m
askSite = lift askSite
askUrlRender = lift askUrlRender
askUrlRenderParams = lift askUrlRenderParams
instance (Monoid w, MonadSite m) => MonadSite (RWSL.RWST r w s m) where
type SiteEnv (RWSL.RWST r w s m) = SiteEnv m
askSite = lift askSite
askUrlRender = lift askUrlRender
askUrlRenderParams = lift askUrlRenderParams
asksSite :: MonadSite m => (SiteEnv m -> a) -> m a
asksSite f = f <$> askSite
@ -95,7 +101,7 @@ runSiteDB action = do
instance MonadSite (HandlerFor site) where
type SiteEnv (HandlerFor site) = site
askSite = getYesod
askUrlRender = getUrlRender
askUrlRenderParams = getUrlRenderParams
{-
forkSite = forkHandler
asyncSite action = do
@ -110,7 +116,7 @@ instance MonadSite (HandlerFor site) where
instance MonadSite (WidgetFor site) where
type SiteEnv (WidgetFor site) = site
askSite = getYesod
askUrlRender = getUrlRender
askUrlRenderParams = getUrlRenderParams
newtype WorkerT site m a = WorkerT
{ unWorkerT :: LoggingT (ReaderT site m) a
@ -133,9 +139,9 @@ instance MonadTrans (WorkerT site) where
instance (MonadUnliftIO m, Yesod site, Site site) => MonadSite (WorkerT site m) where
type SiteEnv (WorkerT site m) = site
askSite = WorkerT $ lift ask
askUrlRender = do
askUrlRenderParams = do
site <- askSite
return $ \ route -> yesodRender site (siteApproot site) route []
return $ yesodRender site (siteApproot site)
{-
forkSite handler action = void $ forkFinally action handler'
where