Represent a ticket dep using a dedicated TicketDependency AP type

src/Vervis/Foundation.hs

@@ -80,7 +80,7 @@ import Control.Concurrent.ResultShare
 import Crypto.PublicVerifKey
 import Network.FedURI
 import Web.ActivityAccess
-import Web.ActivityPub
+import Web.ActivityPub hiding (TicketDependency)
 import Yesod.ActivityPub
 import Yesod.Hashids
 import Yesod.MonadSite

src/Vervis/Handler/Ticket.hs

@@ -91,7 +91,7 @@ import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)
 
 import Data.Aeson.Encode.Pretty.ToEncoding
 import Network.FedURI
-import Web.ActivityPub hiding (Ticket (..))
+import Web.ActivityPub hiding (Ticket (..), TicketDependency)
 import Yesod.ActivityPub
 import Yesod.Auth.Unverified
 import Yesod.FedURI
@@ -960,18 +960,17 @@ getTicketDepR tdkhid = do
     let ticketRoute s j t =
             TicketR (sharerIdent s) (projectIdent j) (ticketNumber t)
         here = TicketDepR tdkhid
-        tdepAP = Relationship
+        tdepAP = AP.TicketDependency
-            { relationshipId           = Just $ encodeRouteHome here
+            { ticketDepId           = Just $ encodeRouteHome here
-            , relationshipSubject      =
+            , ticketDepParent       =
                 encodeRouteHome $ ticketRoute sParent jParent tParent
-            , relationshipProperty     = Left RelDependsOn
+            , ticketDepChild        =
-            , relationshipObject       =
                 encodeRouteHome $ ticketRoute sChild jChild tChild
-            , relationshipAttributedTo =
+            , ticketDepAttributedTo =
                 encodeRouteLocal $ SharerR $ sharerIdent sAuthor
-            , relationshipPublished    = Just $ ticketDependencyCreated td
+            , ticketDepPublished    = Just $ ticketDependencyCreated td
-            , relationshipUpdated      = Just $ ticketDependencyCreated td
+            , ticketDepUpdated      = Just $ ticketDependencyCreated td
-            , relationshipSummary      = TextHtml $ ticketDependencySummary td
+            , ticketDepSummary      = TextHtml $ ticketDependencySummary td
             }
 
     provideHtmlAndAP tdepAP $ redirectToPrettyJSON here

src/Web/ActivityPub.hs

@@ -40,8 +40,7 @@ module Web.ActivityPub
 
       -- * Content objects
     , Note (..)
-    , RelationshipProperty (..)
+    , TicketDependency (..)
-    , Relationship (..)
     , TextHtml (..)
     , TextPandocMarkdown (..)
     , TicketLocal (..)
@@ -95,6 +94,7 @@ import Data.Bifunctor
 import Data.Bitraversable (bitraverse)
 import Data.ByteString (ByteString)
 import Data.Foldable (for_)
+import Data.List
 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
 import Data.Proxy
 import Data.PEM
@@ -556,7 +556,7 @@ instance ActivityPub Note where
         <> "content"      .=  content
         <> "mediaType"    .=  ("text/html" :: Text)
 
-data RelationshipProperty = RelDependsOn
+data RelationshipProperty = RelDependsOn deriving Eq
 
 instance FromJSON RelationshipProperty where
     parseJSON = withText "RelationshipProperty" parse
@@ -573,6 +573,7 @@ instance ToJSON RelationshipProperty where
 
 data Relationship = Relationship
     { relationshipId           :: Maybe FedURI
+    , relationshipExtraTypes   :: [Text]
     , relationshipSubject      :: FedURI
     , relationshipProperty     :: Either RelationshipProperty Text
     , relationshipObject       :: FedURI
@@ -585,8 +586,8 @@ data Relationship = Relationship
 instance ActivityPub Relationship where
     jsonldContext _ = [as2Context, forgeContext]
     parseObject o = do
-        typ <- o .: "type"
+        typs <- o .: "type"
-        unless (typ == ("Relationship" :: Text)) $
+        unless (("Relationship" :: Text) `elem` typs) $
             fail "type isn't Relationship"
 
         (h, attributedTo) <- f2l <$> o .: "attributedTo"
@@ -594,6 +595,7 @@ instance ActivityPub Relationship where
         fmap (h,) $
             Relationship
                 <$> o .:? "id"
+                <*> pure (delete "Relationship" typs)
                 <*> o .: "subject"
                 <*> o .:+ "relationship"
                 <*> o .: "object"
@@ -603,10 +605,10 @@ instance ActivityPub Relationship where
                 <*> (TextHtml . sanitizeBalance <$> o .: "summary")
 
     toSeries host
-        (Relationship id_ subject property object attributedTo published
+        (Relationship id_ typs subject property object attributedTo published
                       updated summary)
             =  "id"           .=? id_
-            <> "type"         .=  ("Relationship" :: Text)
+            <> "type"         .=  ("Relationship" : typs)
             <> "subject"      .=  subject
             <> "relationship" .=+ property
             <> "object"       .=  object
@@ -615,6 +617,52 @@ instance ActivityPub Relationship where
             <> "updated"      .=? updated
             <> "summary"      .=  summary
 
+data TicketDependency = TicketDependency
+    { ticketDepId           :: Maybe FedURI
+    , ticketDepParent       :: FedURI
+    , ticketDepChild        :: FedURI
+    , ticketDepAttributedTo :: LocalURI
+    , ticketDepPublished    :: Maybe UTCTime
+    , ticketDepUpdated      :: Maybe UTCTime
+    , ticketDepSummary      :: TextHtml
+    }
+
+instance ActivityPub TicketDependency where
+    jsonldContext _ = [as2Context, forgeContext]
+    parseObject o = do
+        (h, rel) <- parseObject o
+        unless ("TicketDependency" `elem` relationshipExtraTypes rel) $
+            fail "type isn't TicketDependency"
+
+        unless (relationshipProperty rel == Left RelDependsOn) $
+            fail "relationship isn't dependsOn"
+
+        return (h, rel2td rel)
+        where
+        rel2td rel = TicketDependency
+            { ticketDepId           = relationshipId rel
+            , ticketDepParent       = relationshipSubject rel
+            , ticketDepChild        = relationshipObject rel
+            , ticketDepAttributedTo = relationshipAttributedTo rel
+            , ticketDepPublished    = relationshipPublished rel
+            , ticketDepUpdated      = relationshipUpdated rel
+            , ticketDepSummary      = relationshipSummary rel
+            }
+
+    toSeries h = toSeries h . td2rel
+        where
+        td2rel td = Relationship
+            { relationshipId           = ticketDepId td
+            , relationshipExtraTypes   = ["TicketDependency"]
+            , relationshipSubject      = ticketDepParent td
+            , relationshipProperty     = Left RelDependsOn
+            , relationshipObject       = ticketDepChild td
+            , relationshipAttributedTo = ticketDepAttributedTo td
+            , relationshipPublished    = ticketDepPublished td
+            , relationshipUpdated      = ticketDepUpdated td
+            , relationshipSummary      = ticketDepSummary td
+            }
+
 newtype TextHtml = TextHtml
     { unTextHtml :: Text
     }