+ {shr2text shrUser} + \ commented on a # + ticket. + |] + (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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index d3bebf4..4fc936f 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -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,14 +319,15 @@ 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 - actNoteId _ = Nothing + let actNoteId (Activity _ _ _ _ (CreateActivity (Create note))) = noteId note + actNoteId _ = Nothing obNoteId (Entity i o) = if i == obid then Nothing @@ -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| +
+ + #{shr2text shrAuthor} + \ offered a ticket to project # + + ./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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index afd5488..298b317 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -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) - = "type" .= activityType specific - <> "id" .= l2f host id_ - <> "actor" .= l2f host actor + 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 diff --git a/src/Yesod/MonadSite.hs b/src/Yesod/MonadSite.hs index a0bdcf1..aab9e05 100644 --- a/src/Yesod/MonadSite.hs +++ b/src/Yesod/MonadSite.hs @@ -19,6 +19,7 @@ module Yesod.MonadSite ( Site (..) , MonadSite (..) + , askUrlRender , asksSite , runSiteDB , WorkerT () @@ -59,27 +60,32 @@ 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) + askSite :: m (SiteEnv m) + 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