From 708f62629457c2548c4d419e46c8fb1bd676b411 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 3 Jun 2019 21:52:34 +0000 Subject: [PATCH] Provide ActivityPub representation of tickets in getTicketR --- config/routes | 1 + src/Vervis/Foundation.hs | 4 ++ src/Vervis/Handler/Ticket.hs | 47 ++++++++++++++-- src/Web/ActivityPub.hs | 102 ++++++++++++++++++++++++++++++++++- src/Yesod/ActivityPub.hs | 21 ++++++++ 5 files changed, 171 insertions(+), 4 deletions(-) diff --git a/config/routes b/config/routes index 2c5dca1..8d79137 100644 --- a/config/routes +++ b/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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 8ec8b52..09c2015 100644 --- a/src/Vervis/Foundation.hs +++ b/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) diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index c174553..dcf08af 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/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" diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 51d7fc2..19742d6 100644 --- a/src/Web/ActivityPub.hs +++ b/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 } diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs index ae081b6..bee49ee 100644 --- a/src/Yesod/ActivityPub.hs +++ b/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| + 
#{encodePrettyToLazyText doc}
+                        |]
+                    _ -> widget