diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index f65d26e..a9e6985 100644 --- a/src/Vervis/Foundation.hs +++ b/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 diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 18fb3c2..f05a595 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/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 - { relationshipId = Just $ encodeRouteHome here - , relationshipSubject = + tdepAP = AP.TicketDependency + { ticketDepId = Just $ encodeRouteHome here + , ticketDepParent = encodeRouteHome $ ticketRoute sParent jParent tParent - , relationshipProperty = Left RelDependsOn - , relationshipObject = + , ticketDepChild = encodeRouteHome $ ticketRoute sChild jChild tChild - , relationshipAttributedTo = + , ticketDepAttributedTo = encodeRouteLocal $ SharerR $ sharerIdent sAuthor - , relationshipPublished = Just $ ticketDependencyCreated td - , relationshipUpdated = Just $ ticketDependencyCreated td - , relationshipSummary = TextHtml $ ticketDependencySummary td + , ticketDepPublished = Just $ ticketDependencyCreated td + , ticketDepUpdated = Just $ ticketDependencyCreated td + , ticketDepSummary = TextHtml $ ticketDependencySummary td } provideHtmlAndAP tdepAP $ redirectToPrettyJSON here diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index d7e78cd..74aa8fb 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -40,8 +40,7 @@ module Web.ActivityPub -- * Content objects , Note (..) - , RelationshipProperty (..) - , Relationship (..) + , TicketDependency (..) , 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" - unless (typ == ("Relationship" :: Text)) $ + typs <- o .: "type" + 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,18 +605,64 @@ 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 - <> "attributedTo" .= l2f host attributedTo + <> "attributedTo" .= l2f host attributedTo <> "published" .=? published <> "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 }