Provide ActivityPub representation of tickets in getTicketR

config/routes

@@ -145,5 +145,6 @@
 /s/#ShrIdent/p/#PrjIdent/t/#Int/rdeps        TicketReverseDepsR    GET
 /s/#ShrIdent/p/#PrjIdent/t/#Int/participants TicketParticipantsR   GET
 /s/#ShrIdent/p/#PrjIdent/t/#Int/team         TicketTeamR           GET
+/s/#ShrIdent/p/#PrjIdent/t/#Int/events       TicketEventsR         GET
 
 /s/#ShrIdent/p/#PrjIdent/w/+Texts            WikiPageR             GET

src/Vervis/Foundation.hs

@@ -681,6 +681,7 @@ instance YesodRemoteActorStore App where
     siteActorFetchShare  = appActorFetchShare
 
 instance YesodActivityPub App where
+    siteInstanceHost = appInstanceHost . appSettings
     sitePostSignedHeaders _ =
         hRequestTarget :| [hHost, hDate, hDigest, hActivityPubActor]
     siteGetHttpSign = do
@@ -904,5 +905,8 @@ instance YesodBreadcrumbs App where
         TicketTeamR shr prj num          -> ( "Team"
                                             , Just $ TicketR shr prj num
                                             )
+        TicketEventsR shr prj num        -> ( "Events"
+                                            , Just $ TicketR shr prj num
+                                            )
 
         WikiPageR shr prj _page          -> ("Wiki", Just $ ProjectR shr prj)

src/Vervis/Handler/Ticket.hs

@@ -50,6 +50,7 @@ module Vervis.Handler.Ticket
     , getTicketReverseDepsR
     , getTicketParticipantsR
     , getTicketTeamR
+    , getTicketEventsR
     )
 where
 
@@ -72,6 +73,7 @@ import Data.Traversable (for)
 import Database.Persist
 import Network.HTTP.Types (StdMethod (DELETE, POST))
 import Text.Blaze.Html (Html, toHtml)
+import Text.Blaze.Html.Renderer.Text
 import Yesod.Auth (requireAuthId, maybeAuthId)
 import Yesod.Core
 import Yesod.Core.Handler
@@ -80,16 +82,20 @@ import Yesod.Form.Types (FormResult (..))
 import Yesod.Persist.Core (runDB, get404, getBy404)
 
 import qualified Data.Text as T (filter, intercalate, pack)
+import qualified Data.Text.Lazy as TL
 import qualified Database.Esqueleto as E
 
 import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)
 
 import Data.Aeson.Encode.Pretty.ToEncoding
 import Network.FedURI
-import Web.ActivityPub
+import Web.ActivityPub hiding (Ticket (..))
+import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
 
+import qualified Web.ActivityPub as AP
+
 import Data.Maybe.Local (partitionMaybePairs)
 import Database.Persist.Local
 import Yesod.Persist.Local
@@ -211,7 +217,7 @@ getTicketNewR shar proj = do
     ((_result, widget), enctype) <- runFormPost $ newTicketForm wid
     defaultLayout $(widgetFile "ticket/new")
 
-getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
+getTicketR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
 getTicketR shar proj num = do
     mpid <- maybeAuthId
     ( wshr, wfl,
@@ -276,7 +282,39 @@ getTicketR shar proj num = do
                 TSNew    -> wffNew filt
                 TSTodo   -> wffTodo filt
                 TSClosed -> wffClosed filt
-    defaultLayout $(widgetFile "ticket/one")
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    let siblingUri =
+            encodeRouteHome . TicketR shar proj . ticketNumber . entityVal
+        ticketAP = AP.Ticket
+            { AP.ticketId           =
+                Just $ encodeRouteLocal $ TicketR shar proj num
+            , AP.ticketAttributedTo =
+                encodeRouteHome $ SharerR $ sharerIdent author
+            , AP.ticketPublished    = Just $ ticketCreated ticket
+            , AP.ticketUpdated      = Nothing
+            , AP.ticketContext      = encodeRouteLocal $ ProjectR shar proj
+            , AP.ticketName         = Just $ "#" <> T.pack (show num)
+            , AP.ticketSummary      =
+                TextHtml $ TL.toStrict $ renderHtml $ toHtml $
+                    ticketTitle ticket
+            , AP.ticketContent      = TextHtml $ ticketDescription ticket
+            , AP.ticketSource       = TextPandocMarkdown $ ticketSource ticket
+            , AP.ticketReplies      =
+                encodeRouteLocal $ TicketDiscussionR shar proj num
+            , AP.ticketAssignedTo   =
+                encodeRouteHome . SharerR . sharerIdent . fst <$> massignee
+            , AP.ticketIsResolved   = ticketStatus ticket == TSClosed
+            , AP.ticketParticipants =
+                encodeRouteLocal $ TicketParticipantsR shar proj num
+            , AP.ticketTeam         =
+                encodeRouteLocal $ TicketTeamR shar proj num
+            , AP.ticketDependsOn    = map siblingUri deps
+            , AP.ticketDependedBy   = map siblingUri rdeps
+            , AP.ticketEvents       =
+                encodeRouteLocal $ TicketEventsR shar proj num
+            }
+    provideHtmlAndAP ticketAP $(widgetFile "ticket/one")
 
 putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html
 putTicketR shar proj num = do
@@ -898,3 +936,6 @@ getTicketTeamR shr prj num = do
         mk (Just _) (Just _) = error errBoth
         mk (Just x) Nothing  = Left x
         mk Nothing  (Just y) = Right y
+
+getTicketEventsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent
+getTicketEventsR shr prj num = error "TODO not implemented"

src/Web/ActivityPub.hs

@@ -37,8 +37,13 @@ module Web.ActivityPub
     , CollectionPage (..)
     , Recipient (..)
 
-      -- * Activity
+      -- * Content objects
     , Note (..)
+    , TextHtml (..)
+    , TextPandocMarkdown (..)
+    , Ticket (..)
+
+      -- * Activity
     , Accept (..)
     , Create (..)
     , Follow (..)
@@ -600,6 +605,101 @@ encodeNote host (Note id_ mreply mcontext mpublished content) attrib =
         <> "content"      .=  content
 -}
 
+newtype TextHtml = TextHtml
+    { unTextHtml :: Text
+    }
+    deriving (FromJSON, ToJSON)
+
+newtype TextPandocMarkdown = TextPandocMarkdown
+    { unTextPandocMarkdown :: Text
+    }
+    deriving (FromJSON, ToJSON)
+
+data Ticket = Ticket
+    { ticketId           :: Maybe LocalURI
+    , ticketAttributedTo :: FedURI
+    , ticketPublished    :: Maybe UTCTime
+    , ticketUpdated      :: Maybe UTCTime
+    , ticketContext      :: LocalURI
+    , ticketName         :: Maybe Text
+    , ticketSummary      :: TextHtml
+    , ticketContent      :: TextHtml
+    , ticketSource       :: TextPandocMarkdown
+    , ticketReplies      :: LocalURI
+    , ticketAssignedTo   :: Maybe FedURI
+    , ticketIsResolved   :: Bool
+    , ticketParticipants :: LocalURI
+    , ticketTeam         :: LocalURI
+    , ticketDependsOn    :: [FedURI]
+    , ticketDependedBy   :: [FedURI]
+    , ticketEvents       :: LocalURI
+    }
+
+instance ActivityPub Ticket where
+    jsonldContext _ = ContextAS2
+    parseObject o = do
+        typ <- o .: "type"
+        unless (typ == ("Ticket" :: Text)) $
+            fail "type isn't Ticket"
+
+        mediaType <- o .: "mediaType"
+        unless (mediaType == ("text/html" :: Text)) $
+            fail "mediaType isn't HTML"
+
+        source <- o .: "source"
+        sourceType <- source .: "mediaType"
+        unless (sourceType == ("text/markdown; variant=Pandoc" :: Text)) $
+            fail "source mediaType isn't Pandoc Markdown"
+
+        (h, context) <- f2l <$> o .: "context"
+
+        fmap (h,) $
+            Ticket
+                <$> withHostMaybe h (fmap f2l <$> o .:? "id")
+                <*> o .: "attributedTo"
+                <*> o .:? "published"
+                <*> o .:? "updated"
+                <*> pure context
+                <*> o .:? "name"
+                <*> (TextHtml . sanitizeBalance <$> o .: "summary")
+                <*> (TextHtml . sanitizeBalance <$> o .: "content")
+                <*> source .: "content"
+                <*> withHost h (f2l <$> o .: "replies")
+                <*> o .:? (frg <> "assignedTo")
+                <*> o .: (frg <> "isResolved")
+                <*> withHost h (f2l <$> o .: (frg <> "participants"))
+                <*> withHost h (f2l <$> o .: (frg <> "team"))
+                <*> o .:? (frg <> "dependsOn") .!= []
+                <*> o .:? (frg <> "dependedBy") .!= []
+                <*> withHost h (f2l <$> o .: (frg <> "events"))
+
+    toSeries host
+        (Ticket id_ attributedTo published updated context name summary content
+                source replies assignedTo isResolved participants team
+                dependsOn dependedBy events)
+            =  "type"         .=  ("Ticket" :: Text)
+            <> "id"           .=? (l2f host <$> id_)
+            <> "attributedTo" .=  attributedTo
+            <> "published"    .=? published
+            <> "updated"      .=? updated
+            <> "context"      .=  l2f host context
+            <> "name"         .=? name
+            <> "summary"      .=  summary
+            <> "content"      .=  content
+            <> "mediaType"    .=  ("text/html" :: Text)
+            <> "source"       .=  object
+                    [ "content"   .= source
+                    , "mediaType" .= ("text/markdown; variant=Pandoc" :: Text)
+                    ]
+            <> "replies"      .=  l2f host replies
+            <> (frg <> "assignedTo")   .=? assignedTo
+            <> (frg <> "isResolved")   .=  isResolved
+            <> (frg <> "participants") .=  l2f host participants
+            <> (frg <> "team")         .=  l2f host team
+            <> (frg <> "dependsOn")    .=% dependsOn
+            <> (frg <> "dependedBy")   .=% dependedBy
+            <> (frg <> "events")       .=  l2f host events
+
 data Accept = Accept
     { acceptObject :: FedURI
     }

src/Yesod/ActivityPub.hs

@@ -17,6 +17,7 @@ module Yesod.ActivityPub
     ( YesodActivityPub (..)
     , deliverActivity
     , forwardActivity
+    , provideHtmlAndAP
     )
 where
 
@@ -36,11 +37,13 @@ import qualified Data.Text as T
 
 import Network.HTTP.Signature
 
+import Data.Aeson.Encode.Pretty.ToEncoding
 import Network.FedURI
 import Web.ActivityPub
 import Yesod.MonadSite
 
 class Yesod site => YesodActivityPub site where
+    siteInstanceHost          :: site -> Text
     sitePostSignedHeaders     :: site -> NonEmpty HeaderName
     siteGetHttpSign           :: (MonadSite m, SiteEnv m ~ site)
                               => m (KeyId, ByteString -> Signature)
@@ -111,3 +114,21 @@ forwardActivity inbox sig rSender body = do
                 , "> success: ", T.pack $ show $ responseStatus resp
                 ]
     return result
+
+provideHtmlAndAP
+    :: (YesodActivityPub site, ActivityPub a)
+    => a -> WidgetFor site () -> HandlerFor site TypedContent
+provideHtmlAndAP object widget = do
+    host <- getsYesod siteInstanceHost
+    let doc = Doc host object
+    selectRep $ do
+        provideAP $ pure doc
+        provideRep $ do
+            mval <- lookupGetParam "prettyjson"
+            defaultLayout $
+                case mval of
+                    Just "true" ->
+                        [whamlet|
+                            <div><pre>#{encodePrettyToLazyText doc}
+                        |]
+                    _ -> widget