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

src/Vervis/API.hs

@@ -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

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,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

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)
+    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

src/Yesod/MonadSite.hs

@@ -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