diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index eb319c9..7a3e675 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -282,37 +282,45 @@ getTicketR shar proj num = do TSNew -> wffNew filt TSTodo -> wffTodo filt TSClosed -> wffClosed filt + hLocal <- getsYesod siteInstanceHost encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome let siblingUri = encodeRouteHome . TicketR shar proj . ticketNumber . entityVal ticketAP = AP.Ticket - { AP.ticketId = - Just $ encodeRouteLocal $ TicketR shar proj num + { AP.ticketLocal = Just + ( hLocal + , AP.TicketLocal + { AP.ticketId = + encodeRouteLocal $ TicketR shar proj num + , AP.ticketContext = + encodeRouteLocal $ ProjectR shar proj + , AP.ticketReplies = + encodeRouteLocal $ TicketDiscussionR shar proj num + , AP.ticketParticipants = + encodeRouteLocal $ TicketParticipantsR shar proj num + , AP.ticketTeam = + encodeRouteLocal $ TicketTeamR shar proj num + , AP.ticketEvents = + encodeRouteLocal $ TicketEventsR shar proj num + } + ) + , AP.ticketAttributedTo = - encodeRouteHome $ SharerR $ sharerIdent author + encodeRouteLocal $ 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 = - Just $ encodeRouteLocal $ TicketDiscussionR shar proj num , AP.ticketAssignedTo = encodeRouteHome . SharerR . sharerIdent . fst <$> massignee , AP.ticketIsResolved = ticketStatus ticket == TSClosed - , AP.ticketParticipants = - Just $ encodeRouteLocal $ TicketParticipantsR shar proj num - , AP.ticketTeam = - Just $ encodeRouteLocal $ TicketTeamR shar proj num , AP.ticketDependsOn = map siblingUri deps , AP.ticketDependedBy = map siblingUri rdeps - , AP.ticketEvents = - Just $ encodeRouteLocal $ TicketEventsR shar proj num } provideHtmlAndAP ticketAP $(widgetFile "ticket/one") diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 9996641..c95de5c 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -41,6 +41,7 @@ module Web.ActivityPub , Note (..) , TextHtml (..) , TextPandocMarkdown (..) + , TicketLocal (..) , Ticket (..) -- * Activity @@ -115,7 +116,7 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as M (lookup) +import qualified Data.HashMap.Strict as M import qualified Data.Text as T (pack, unpack) import qualified Data.Vector as V import qualified Network.HTTP.Signature as S @@ -615,24 +616,63 @@ newtype TextPandocMarkdown = TextPandocMarkdown } deriving (FromJSON, ToJSON) +data TicketLocal = TicketLocal + { ticketId :: LocalURI + , ticketContext :: LocalURI + , ticketReplies :: LocalURI + , ticketParticipants :: LocalURI + , ticketTeam :: LocalURI + , ticketEvents :: LocalURI + } + +parseTicketLocal :: Object -> Parser (Maybe (Text, TicketLocal)) +parseTicketLocal o = do + mid <- fmap f2l <$> o .:? "id" + case mid of + Nothing -> do + verifyNothing "context" + verifyNothing "replies" + verifyNothing $ frg <> "participants" + verifyNothing $ frg <> "team" + verifyNothing $ frg <> "events" + return Nothing + Just (h, id_) -> + fmap (Just . (h,)) $ + TicketLocal + <$> pure id_ + <*> withHost h (f2l <$> o .: "context") + <*> withHost h (f2l <$> o .: "replies") + <*> withHost h (f2l <$> o .: (frg <> "participants")) + <*> withHost h (f2l <$> o .: (frg <> "team")) + <*> withHost h (f2l <$> o .: (frg <> "events")) + where + verifyNothing t = + if t `M.member` o + then fail $ T.unpack t ++ " field found, expected none" + else return () + +encodeTicketLocal :: Text -> TicketLocal -> Series +encodeTicketLocal h (TicketLocal id_ context replies participants team events) + = "id" .= l2f h id_ + <> "context" .= l2f h context + <> "replies" .= l2f h replies + <> (frg <> "participants") .= l2f h participants + <> (frg <> "team") .= l2f h team + <> (frg <> "events") .= l2f h events + data Ticket = Ticket - { ticketId :: Maybe LocalURI - , ticketAttributedTo :: FedURI + { ticketLocal :: Maybe (Text, TicketLocal) + , ticketAttributedTo :: LocalURI , ticketPublished :: Maybe UTCTime , ticketUpdated :: Maybe UTCTime - , ticketContext :: LocalURI , ticketName :: Maybe Text , ticketSummary :: TextHtml , ticketContent :: TextHtml , ticketSource :: TextPandocMarkdown - , ticketReplies :: Maybe LocalURI , ticketAssignedTo :: Maybe FedURI , ticketIsResolved :: Bool - , ticketParticipants :: Maybe LocalURI - , ticketTeam :: Maybe LocalURI , ticketDependsOn :: [FedURI] , ticketDependedBy :: [FedURI] - , ticketEvents :: Maybe LocalURI } instance ActivityPub Ticket where @@ -651,38 +691,32 @@ instance ActivityPub Ticket where unless (sourceType == ("text/markdown; variant=Pandoc" :: Text)) $ fail "source mediaType isn't Pandoc Markdown" - (h, context) <- f2l <$> o .: "context" + (h, attributedTo) <- f2l <$> o .: "attributedTo" fmap (h,) $ Ticket - <$> withHostMaybe h (fmap f2l <$> o .:? "id") - <*> o .: "attributedTo" + <$> parseTicketLocal o + <*> pure attributedTo <*> o .:? "published" <*> o .:? "updated" - <*> pure context <*> o .:? "name" <*> (TextHtml . sanitizeBalance <$> o .: "summary") <*> (TextHtml . sanitizeBalance <$> o .: "content") <*> source .: "content" - <*> withHostMaybe h (fmap f2l <$> o .:? "replies") <*> o .:? (frg <> "assignedTo") <*> o .: (frg <> "isResolved") - <*> withHostMaybe h (fmap f2l <$> o .:? (frg <> "participants")) - <*> withHostMaybe h (fmap f2l <$> o .:? (frg <> "team")) <*> o .:? (frg <> "dependsOn") .!= [] <*> o .:? (frg <> "dependedBy") .!= [] - <*> withHostMaybe h (fmap 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 + (Ticket local attributedTo published updated name summary content + source assignedTo isResolved dependsOn dependedBy) + + = maybe mempty (uncurry encodeTicketLocal) local + <> "type" .= ("Ticket" :: Text) + <> "attributedTo" .= l2f host attributedTo <> "published" .=? published <> "updated" .=? updated - <> "context" .= l2f host context <> "name" .=? name <> "summary" .= summary <> "content" .= content @@ -691,14 +725,10 @@ instance ActivityPub Ticket where [ "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