From c63479470ed59bb3206f2d9cd8310bd8e9626c38 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 25 May 2020 09:40:48 +0000 Subject: [PATCH] Add patch version route and GET handler, serving a specific patch file --- config/models | 1 + config/routes | 2 ++ src/Vervis/Foundation.hs | 3 ++- src/Vervis/Handler/Patch.hs | 40 +++++++++++++++++++++++++++- src/Vervis/Migration.hs | 2 ++ src/Web/ActivityPub.hs | 52 +++++++++++++++++++++++++++++++++++++ 6 files changed, 98 insertions(+), 2 deletions(-) diff --git a/config/models b/config/models index 39230f1..b96c7f2 100644 --- a/config/models +++ b/config/models @@ -445,6 +445,7 @@ TicketUnderProject Patch ticket TicketId + created UTCTime content Text TicketDependency diff --git a/config/routes b/config/routes index d876618..91e3332 100644 --- a/config/routes +++ b/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 diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 29aff9c..9925952 100644 --- a/src/Vervis/Foundation.hs +++ b/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: diff --git a/src/Vervis/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs index 29124b9..d66f991 100644 --- a/src/Vervis/Handler/Patch.hs +++ b/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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 2ce32c1..f82b2a0 100644 --- a/src/Vervis/Migration.hs +++ b/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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index a602b8c..5911faa 100644 --- a/src/Web/ActivityPub.hs +++ b/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