Optional activity summary, set it when handling a Note in C2S
This commit is contained in:
fr33domlover
parent
68bdaf65a7
commit
6452d239f2
4 changed files with 58 additions and 18 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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|
|
||||
<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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in a new issue