Move AP Ticket local URI fields into a dedicated TicketLocal type

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.ticketLocal        = Just
+                ( hLocal
+                , AP.TicketLocal
                     { AP.ticketId =
-                Just $ encodeRouteLocal $ TicketR shar proj num
+                        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")
 

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
+    { ticketLocal        :: Maybe (Text, TicketLocal)
-    , ticketAttributedTo :: FedURI
+    , 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")
+                <$> parseTicketLocal o
-                <*> o .: "attributedTo"
+                <*> 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
+        (Ticket local attributedTo published updated name summary content
-                source replies assignedTo isResolved participants team
+                source assignedTo isResolved dependsOn dependedBy)
-                dependsOn dependedBy events)
+
-            =  "type"         .=  ("Ticket" :: Text)
+            =   maybe mempty (uncurry encodeTicketLocal) local
-            <> "id"           .=? (l2f host <$> id_)
+            <> "type"         .=  ("Ticket" :: Text)
-            <> "attributedTo" .=  attributedTo
+            <> "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