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

config/models

@@ -445,6 +445,7 @@ TicketUnderProject
 
 Patch
     ticket  TicketId
+    created UTCTime
     content Text
 
 TicketDependency

config/routes

@@ -201,4 +201,6 @@
 /s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/followers SharerPatchFollowersR   GET
 /s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/events    SharerPatchEventsR      GET
 
+/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/v/#PatchKeyHashid SharerPatchVersionR GET
+
 /s/#ShrIdent/p/#PrjIdent/w/+Texts            WikiPageR             GET

src/Vervis/Foundation.hs

@@ -70,7 +70,7 @@ import qualified Network.HTTP.Signature as S (Algorithm (..))
 import Crypto.PublicVerifKey
 import Network.FedURI
 import Web.ActivityAccess
-import Web.ActivityPub hiding (Ticket, TicketDependency)
+import Web.ActivityPub hiding (Ticket, TicketDependency, Patch)
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
@@ -131,6 +131,7 @@ type LocalMessageKeyHashid      = KeyHashid LocalMessage
 type LocalTicketKeyHashid       = KeyHashid LocalTicket
 type TicketAuthorLocalKeyHashid = KeyHashid TicketAuthorLocal
 type TicketDepKeyHashid         = KeyHashid TicketDependency
+type PatchKeyHashid             = KeyHashid Patch
 
 -- This is where we define all of the routes in our application. For a full
 -- explanation of the syntax, please see:

src/Vervis/Handler/Patch.hs

@@ -21,9 +21,12 @@ module Vervis.Handler.Patch
     , getSharerPatchReverseDepsR
     , getSharerPatchFollowersR
     , getSharerPatchEventsR
+
+    , getSharerPatchVersionR
     )
 where
 
+import Control.Monad
 import Data.Bitraversable
 import Data.Text (Text)
 import Data.Traversable
@@ -34,7 +37,7 @@ import Yesod.Persist.Core
 import qualified Database.Esqueleto as E
 
 import Network.FedURI
-import Web.ActivityPub hiding (Ticket (..))
+import Web.ActivityPub hiding (Ticket (..), Patch (..))
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
@@ -51,6 +54,7 @@ import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Model.Repo
 import Vervis.Model.Ticket
 import Vervis.Paginate
 import Vervis.Patch
@@ -208,3 +212,37 @@ getSharerPatchEventsR shr talkhid = do
     provideEmptyCollection
         CollectionTypeOrdered
         (SharerPatchEventsR shr talkhid)
+
+getSharerPatchVersionR
+    :: ShrIdent
+    -> KeyHashid TicketAuthorLocal
+    -> KeyHashid Patch
+    -> Handler TypedContent
+getSharerPatchVersionR shr talkhid ptkhid = do
+    (vcs, patch) <- runDB $ do
+        (_, _, Entity tid _, repo) <- getSharerPatch404 shr talkhid
+        (,) <$> case repo of
+                    Left (_, Entity _ trl) ->
+                        repoVcs <$> getJust (ticketRepoLocalRepo trl)
+                    Right _ ->
+                        error "TODO determine mediaType of patch of remote repo"
+            <*> do  ptid <- decodeKeyHashid404 ptkhid
+                    pt <- get404 ptid
+                    unless (patchTicket pt == tid) notFound
+                    return pt
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    let versionAP = AP.Patch
+            { AP.patchId           = encodeRouteLocal here
+            , AP.patchAttributedTo = encodeRouteHome $ SharerR shr
+            , AP.patchPublished    = patchCreated patch
+            , AP.patchContext      = encodeRouteLocal $ SharerPatchR shr talkhid
+            , AP.patchType         =
+                case vcs of
+                    VCSDarcs -> PatchTypeDarcs
+                    VCSGit -> error "TODO add PatchType for git patches"
+            , AP.patchContent      = patchContent patch
+            }
+    provideHtmlAndAP versionAP $ redirectToPrettyJSON here
+    where
+    here = SharerPatchVersionR shr talkhid ptkhid

src/Vervis/Migration.hs

@@ -1580,6 +1580,8 @@ changes hLocal ctx =
     , removeField "TicketContextLocal" "project"
       -- 249
     , addEntities model_2020_05_17
+      -- 250
+    , addFieldPrimRequired "Patch" defaultTime "created"
     ]
 
 migrateDB

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