Vocabulary for Project

src/Web/ActivityPub.hs

@@ -46,6 +46,7 @@ module Web.ActivityPub
     , CollectionPage (..)
     , Recipient (..)
     , Resource (..)
+    , Project (..)
 
       -- * Content objects
     , Note (..)
@@ -374,6 +375,7 @@ data ActorType
     | ActorTypeRepo
     | ActorTypeTicketTracker
     | ActorTypePatchTracker
+    | ActorTypeProject
     | ActorTypeOther Text
     deriving Eq
 
@@ -385,6 +387,7 @@ instance FromJSON ActorType where
             | t == "Repository"    = ActorTypeRepo
             | t == "TicketTracker" = ActorTypeTicketTracker
             | t == "PatchTracker"  = ActorTypePatchTracker
+            | t == "Project"       = ActorTypeProject
             | otherwise            = ActorTypeOther t
 
 instance ToJSON ActorType where
@@ -395,6 +398,7 @@ instance ToJSON ActorType where
             ActorTypeRepo          -> "Repository"
             ActorTypeTicketTracker -> "TicketTracker"
             ActorTypePatchTracker  -> "PatchTracker"
+            ActorTypeProject       -> "Project"
             ActorTypeOther t       -> t
 
 data Owner = OwnerInstance | OwnerActor LocalURI
@@ -810,6 +814,61 @@ instance ActivityPub Resource where
         =  "id"        .= ObjURI h luId
         <> "managedBy" .= ObjURI h luManager
 
+data Project u = Project
+    { projectActor      :: Actor u
+    , projectTracker    :: Maybe (ObjURI u)
+    , projectChildren   :: [ObjURI u]
+    , projectParents    :: [ObjURI u]
+    , projectComponents :: [ObjURI u]
+    }
+
+instance ActivityPub Project where
+    jsonldContext _ = [as2Context, secContext, forgeContext]
+    parseObject o = do
+        (h, a) <- parseObject o
+        unless (actorType (actorDetail a) == ActorTypeProject) $
+            fail "Actor type isn't Project"
+        fmap (h,) $
+            Project a
+                <$> o .:? "ticketsTrackedBy"
+                <*> (do c <- o .: "subprojects"
+                        typ <- c .: "type"
+                        unless (typ == ("Collection" :: Text)) $
+                            fail "subprojects.type isn't Collection"
+                        items <- c .: "items"
+                        mtotal <- c .:? "totalItems"
+                        for_ mtotal $ \ total ->
+                            unless (length items == total) $
+                                fail "Incorrect totalItems"
+                        return items
+                    )
+                <*> o .:? "context" .!= []
+                <*> (do c <- o .: "components"
+                        typ <- c .: "type"
+                        unless (typ == ("Collection" :: Text)) $
+                            fail "components.type isn't Collection"
+                        items <- c .: "items"
+                        mtotal <- c .:? "totalItems"
+                        for_ mtotal $ \ total ->
+                            unless (length items == total) $
+                                fail "Incorrect totalItems"
+                        return items
+                    )
+    toSeries h (Project actor tracker children parents components)
+        =  toSeries h actor
+        <> "ticketsTrackedBy" .=? tracker
+        <> "subprojects" `pair` pairs
+            (  "type"       .= ("Collection" :: Text)
+            <> "items"      .= children
+            <> "totalItems" .= length children
+            )
+        <> "context"          .= parents
+        <> "components" `pair` pairs
+            (  "type"       .= ("Collection" :: Text)
+            <> "items"      .= components
+            <> "totalItems" .= length components
+            )
+
 data Audience u = Audience
     { audienceTo        :: [ObjURI u]
     , audienceBto       :: [ObjURI u]