Add patch version route and GET handler, serving a specific patch file

src/Web/ActivityPub.hs

@@ -46,6 +46,8 @@ module Web.ActivityPub
     , TicketDependency (..)
     , TextHtml (..)
     , TextPandocMarkdown (..)
+    , PatchType (..)
+    , Patch (..)
     , TicketLocal (..)
     , Ticket (..)
     , Author (..)
@@ -823,6 +825,56 @@ newtype TextPandocMarkdown = TextPandocMarkdown
     }
     deriving (FromJSON, ToJSON)
 
+data PatchType = PatchTypeDarcs
+
+instance FromJSON PatchType where
+    parseJSON = withText "PatchType" parse
+        where
+        parse "application/x-darcs-patch" = pure PatchTypeDarcs
+        parse t = fail $ "Unknown patch mediaType: " ++ T.unpack t
+
+instance ToJSON PatchType where
+    toJSON = error "toJSON PatchType"
+    toEncoding = toEncoding . render
+        where
+        render PatchTypeDarcs = "application/x-darcs-patch" :: Text
+
+data Patch u = Patch
+    { patchId           :: LocalURI
+    , patchAttributedTo :: ObjURI u
+    , patchPublished    :: UTCTime
+    , patchContext      :: LocalURI
+    , patchType         :: PatchType
+    , patchContent      :: Text
+    }
+
+instance ActivityPub Patch where
+    jsonldContext _ = [as2Context, forgeContext]
+
+    parseObject o = do
+        typ <- o .: "type"
+        unless (typ == ("Patch" :: Text)) $
+            fail "type isn't Patch"
+
+        ObjURI a id_ <- o .: "id"
+
+        fmap (a,) $
+            Patch id_
+                <$> o .: "attributedTo"
+                <*> o .: "published"
+                <*> withAuthorityO a (o .: "context")
+                <*> o .: "mediaType"
+                <*> o .: "content"
+
+    toSeries a (Patch id_ attrib published context typ content)
+        =  "id"           .= ObjURI a id_
+        <> "type"         .= ("Patch" :: Text)
+        <> "attributedTo" .= attrib
+        <> "context"      .= ObjURI a context
+        <> "published"    .= published
+        <> "mediaType"    .= typ
+        <> "content"      .= content
+
 data TicketLocal = TicketLocal
     { ticketId           :: LocalURI
     , ticketReplies      :: LocalURI