From 02c42029d2406dcc76ccce6679e1a387b300a1ee Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sun, 24 May 2020 09:17:49 +0000 Subject: [PATCH] Add GET routes and handlers for sharer-hosted patches --- config/models | 4 + config/routes | 9 + migrations/2020_05_17_patch.model | 3 + src/Data/Patch/Local.hs | 66 ++++++ src/Vervis/API.hs | 2 +- src/Vervis/ActivityPub.hs | 6 +- src/Vervis/Application.hs | 1 + src/Vervis/Darcs.hs | 10 +- src/Vervis/Federation/Ticket.hs | 2 +- src/Vervis/Git.hs | 12 +- src/Vervis/Handler/Patch.hs | 326 ++++++++++++++++++++++++++++++ src/Vervis/Handler/Repo/Darcs.hs | 4 +- src/Vervis/Handler/Repo/Git.hs | 4 +- src/Vervis/Handler/Ticket.hs | 18 +- src/Vervis/Migration.hs | 2 + src/Vervis/Migration/Model.hs | 4 + src/Vervis/Patch.hs | 197 ++++++++++++++---- src/Vervis/Ticket.hs | 6 + src/Vervis/Widget/Repo.hs | 5 +- src/Web/ActivityPub.hs | 6 +- vervis.cabal | 4 +- 21 files changed, 618 insertions(+), 73 deletions(-) create mode 100644 migrations/2020_05_17_patch.model create mode 100644 src/Data/Patch/Local.hs create mode 100644 src/Vervis/Handler/Patch.hs diff --git a/config/models b/config/models index 8264a10..39230f1 100644 --- a/config/models +++ b/config/models @@ -443,6 +443,10 @@ TicketUnderProject UniqueTicketUnderProjectProject project UniqueTicketUnderProjectAuthor author +Patch + ticket TicketId + content Text + TicketDependency parent TicketId child TicketId diff --git a/config/routes b/config/routes index 069af2a..d876618 100644 --- a/config/routes +++ b/config/routes @@ -192,4 +192,13 @@ /s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/team SharerTicketTeamR GET /s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/events SharerTicketEventsR GET +/s/#ShrIdent/pt SharerPatchesR GET + +/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid SharerPatchR GET +/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/d SharerPatchDiscussionR GET +/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/deps SharerPatchDepsR GET +/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/rdeps SharerPatchReverseDepsR GET +/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/followers SharerPatchFollowersR GET +/s/#ShrIdent/pt/#TicketAuthorLocalKeyHashid/events SharerPatchEventsR GET + /s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET diff --git a/migrations/2020_05_17_patch.model b/migrations/2020_05_17_patch.model new file mode 100644 index 0000000..aa7a432 --- /dev/null +++ b/migrations/2020_05_17_patch.model @@ -0,0 +1,3 @@ +Patch + ticket TicketId + content Text diff --git a/src/Data/Patch/Local.hs b/src/Data/Patch/Local.hs new file mode 100644 index 0000000..4c1c69e --- /dev/null +++ b/src/Data/Patch/Local.hs @@ -0,0 +1,66 @@ +{- This file is part of Vervis. + - + - Written in 2018 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +-- | Representation of a commit in a repo for viewing. +-- +-- Each version control system has its own specific details of how repository +-- changes are represented and encoded and stored internally. This module is +-- merely a model for displaying a commit to a human viewer. +module Data.Patch.Local + ( Hunk (..) + , Edit (..) + , Author (..) + , Patch (..) + ) +where + +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import Data.Time.Clock (UTCTime) +import Data.Word (Word32) +import Data.Vector (Vector) +import Text.Email.Validate (EmailAddress) + +data Hunk = Hunk + { hunkAddFirst :: [Text] + , hunkRemoveAdd :: [(NonEmpty Text, NonEmpty Text)] + , hunkRemoveLast :: [Text] + } + +data Edit + = AddTextFile FilePath Word32 [Text] + | AddBinaryFile FilePath Word32 Int64 + | RemoveTextFile FilePath Word32 [Text] + | RemoveBinaryFile FilePath Word32 Int64 + | MoveFile FilePath Word32 FilePath Word32 + | ChmodFile FilePath Word32 Word32 + | EditTextFile FilePath (Vector Text) (NonEmpty (Bool, Int, Hunk)) Word32 Word32 + | EditBinaryFile FilePath Int64 Word32 Int64 Word32 + | TextToBinary FilePath [Text] Word32 Int64 Word32 + | BinaryToText FilePath Int64 Word32 [Text] Word32 + +data Author = Author + { authorName :: Text + , authorEmail :: EmailAddress + } + +data Patch = Patch + { patchWritten :: (Author, UTCTime) + , patchCommitted :: Maybe (Author, UTCTime) + , patchTitle :: Text + , patchDescription :: Text + , patchDiff :: [Edit] + } diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 9a501a1..6cd4bf1 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -655,7 +655,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT { ticketId = encodeRouteLocal $ SharerTicketR shrUser talkhid , ticketReplies = encodeRouteLocal $ SharerTicketDiscussionR shrUser talkhid , ticketParticipants = encodeRouteLocal $ SharerTicketFollowersR shrUser talkhid - , ticketTeam = encodeRouteLocal $ SharerTicketTeamR shrUser talkhid + , ticketTeam = Just $ encodeRouteLocal $ SharerTicketTeamR shrUser talkhid , ticketEvents = encodeRouteLocal $ SharerTicketEventsR shrUser talkhid , ticketDeps = encodeRouteLocal $ SharerTicketDepsR shrUser talkhid , ticketReverseDeps = encodeRouteLocal $ SharerTicketReverseDepsR shrUser talkhid diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index e890b59..2c8165e 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -109,15 +109,17 @@ import qualified Web.ActivityPub as AP import Control.Monad.Trans.Except.Local import Data.Either.Local import Data.List.NonEmpty.Local +import Data.Patch.Local hiding (Patch) import Data.Tuple.Local import Database.Persist.Local +import qualified Data.Patch.Local as P + import Vervis.ActivityPub.Recipient import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident -import Vervis.Patch import Vervis.RemoteActorStore import Vervis.Settings import Vervis.Time @@ -718,7 +720,7 @@ serveCommit :: ShrIdent -> RpIdent -> Text - -> Patch + -> P.Patch -> [Text] -> Handler TypedContent serveCommit shr rp ref patch parents = do diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index fbdf979..bdfdb87 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -108,6 +108,7 @@ import Vervis.Handler.Group import Vervis.Handler.Home import Vervis.Handler.Inbox import Vervis.Handler.Key +import Vervis.Handler.Patch import Vervis.Handler.Person import Vervis.Handler.Project import Vervis.Handler.Repo diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index e3b17ca..6922dfa 100644 --- a/src/Vervis/Darcs.hs +++ b/src/Vervis/Darcs.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019 by fr33domlover . + - Written in 2016, 2018, 2019, 2020 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -73,15 +73,17 @@ import Data.Either.Local (maybeRight) import Data.EventTime.Local import Data.List.Local import Data.List.NonEmpty.Local +import Data.Patch.Local hiding (Patch) import Data.Text.UTF8.Local (decodeStrict) import Data.Time.Clock.Local () +import qualified Data.Patch.Local as DP + import Vervis.Changes import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Repo -import Vervis.Patch import Vervis.Path import Vervis.Readme import Vervis.Settings @@ -309,7 +311,7 @@ joinHunks = -- the expected format. If not, an exception is thrown. -- * The hash may or may not be found in the repo. If there's no patch in the -- repo with the given hash, 'Nothing' is returned. -readPatch :: FilePath -> Text -> IO (Maybe Patch) +readPatch :: FilePath -> Text -> IO (Maybe DP.Patch) readPatch path hash = handle $ runExceptT $ do let pih = PatchInfoHash $ fst $ B16.decode $ encodeUtf8 hash li <- ExceptT $ readLatestInventory path latestInventoryAllP @@ -319,7 +321,7 @@ readPatch path hash = handle $ runExceptT $ do ExceptT $ readCompressedPatch path pch (P.patch <* A.endOfInput) (an, ae) <- ExceptT . pure $ A.parseOnly (author <* A.endOfInput) $ piAuthor pi - return Patch + return DP.Patch { patchWritten = ( Author { authorName = an diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 3e6e654..9793a05 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -645,7 +645,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do remoteRecipsC = catMaybes [ remoteActorFollowers ra , Just $ AP.ticketParticipants tlocal - , Just $ AP.ticketTeam tlocal + , AP.ticketTeam tlocal ] localRecips = map encodeRouteHome $ diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index 6dffb97..fdd6e5a 100644 --- a/src/Vervis/Git.hs +++ b/src/Vervis/Git.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019 by fr33domlover . + - Written in 2016, 2018, 2019, 2020 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -76,13 +76,15 @@ import Data.DList.Local import Data.EventTime.Local import Data.Git.Local import Data.List.Local +import Data.Patch.Local hiding (Patch) + +import qualified Data.Patch.Local as P import Vervis.Changes import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Repo -import Vervis.Patch import Vervis.Path import Vervis.Readme import Vervis.Settings @@ -204,8 +206,8 @@ listRefs :: FilePath -> IO (Set Text, Set Text) listRefs path = G.withRepo (fromString path) $ \ git -> (,) <$> listBranches git <*> listTags git -patch :: [Edit] -> Commit SHA1 -> Patch -patch edits c = Patch +patch :: [Edit] -> Commit SHA1 -> P.Patch +patch edits c = P.Patch { patchWritten = makeAuthor $ commitAuthor c , patchCommitted = if commitAuthor c == commitCommitter c @@ -299,7 +301,7 @@ accumEdits (OldAndNew old new) es = (BinaryContent from, BinaryContent to) -> EditBinaryFile (ep2fp $ bsFilename new) (BL.length from) (unModePerm $ bsMode old) (BL.length to) (unModePerm $ bsMode new) : es else error "getDiffWith gave OldAndNew with different file paths" -readPatch :: FilePath -> Text -> IO (Patch, [Text]) +readPatch :: FilePath -> Text -> IO (P.Patch, [Text]) readPatch path hash = G.withRepo (fromString path) $ \ git -> do let ref = fromHex $ encodeUtf8 hash c <- G.getCommit git ref diff --git a/src/Vervis/Handler/Patch.hs b/src/Vervis/Handler/Patch.hs new file mode 100644 index 0000000..1b7d1db --- /dev/null +++ b/src/Vervis/Handler/Patch.hs @@ -0,0 +1,326 @@ +{- This file is part of Vervis. + - + - Written in 2020 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Handler.Patch + ( getSharerPatchesR + , getSharerPatchR + , getSharerPatchDiscussionR + , getSharerPatchDepsR + , getSharerPatchReverseDepsR + , getSharerPatchFollowersR + , getSharerPatchEventsR + ) +where + +import Data.Bitraversable +import Data.Text (Text) +import Data.Traversable +import Database.Persist +import Yesod.Core +import Yesod.Persist.Core + +import qualified Database.Esqueleto as E + +import Network.FedURI +import Web.ActivityPub hiding (Ticket (..)) +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.Hashids + +import qualified Web.ActivityPub as AP + +import Data.Paginate.Local +import Yesod.Persist.Local + +import Vervis.API +import Vervis.FedURI +import Vervis.Foundation +import Vervis.Model +import Vervis.Model.Ident +import Vervis.Model.Ticket +import Vervis.Paginate +import Vervis.Patch + +getSharerPatchesR :: ShrIdent -> Handler TypedContent +getSharerPatchesR shr = do + (total, pages, mpage) <- runDB $ do + sid <- getKeyBy404 $ UniqueSharer shr + pid <- getKeyBy404 $ UniquePersonIdent sid + getPageAndNavCount (countPatches pid) (selectPatches pid) + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + encodeRoutePageLocal <- getEncodeRoutePageLocal + let pageUrl = encodeRoutePageLocal here + encodeTicketKey <- getEncodeKeyHashid + let patchUrl = SharerPatchR shr . encodeTicketKey + + case mpage of + Nothing -> provide $ Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeOrdered + , collectionTotalItems = Just total + , collectionCurrent = Nothing + , collectionFirst = Just $ pageUrl 1 + , collectionLast = Just $ pageUrl pages + , collectionItems = [] :: [Text] + } + Just (patches, navModel) -> + let current = nmCurrent navModel + in provide $ CollectionPage + { collectionPageId = pageUrl current + , collectionPageType = CollectionPageTypeOrdered + , collectionPageTotalItems = Nothing + , collectionPageCurrent = Just $ pageUrl current + , collectionPageFirst = Just $ pageUrl 1 + , collectionPageLast = Just $ pageUrl pages + , collectionPagePartOf = encodeRouteLocal here + , collectionPagePrev = + if current > 1 + then Just $ pageUrl $ current - 1 + else Nothing + , collectionPageNext = + if current < pages + then Just $ pageUrl $ current + 1 + else Nothing + , collectionPageStartIndex = Nothing + , collectionPageItems = + map (encodeRouteHome . patchUrl . E.unValue) patches + } + where + here = SharerPatchesR shr + provide :: ActivityPub a => a URIMode -> Handler TypedContent + provide a = provideHtmlAndAP a $ redirectToPrettyJSON here + countPatches pid = fmap toOne $ + E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup) -> do + E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor + E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId + E.where_ $ + tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. + E.isNothing (tup E.?. TicketUnderProjectId) E.&&. + E.exists + (E.from $ \ pt -> + E.where_ $ lt E.^. LocalTicketTicket E.==. pt E.^. PatchTicket + ) + return $ E.count $ tal E.^. TicketAuthorLocalId + where + toOne [x] = E.unValue x + toOne [] = error "toOne = 0" + toOne _ = error "toOne > 1" + selectPatches pid off lim = + E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup) -> do + E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor + E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId + E.where_ $ + tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. + E.isNothing (tup E.?. TicketUnderProjectId) E.&&. + E.exists + (E.from $ \ pt -> + E.where_ $ lt E.^. LocalTicketTicket E.==. pt E.^. PatchTicket + ) + E.orderBy [E.desc $ tal E.^. TicketAuthorLocalId] + E.offset $ fromIntegral off + E.limit $ fromIntegral lim + return $ tal E.^. TicketAuthorLocalId + +getSharerPatchR + :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerPatchR shr talkhid = do + (ticket, repo, massignee) <- runDB $ do + (_, _, Entity _ t, tp) <- getSharerPatch404 shr talkhid + (,,) t + <$> bitraverse + (\ (_, Entity _ trl) -> do + r <- getJust $ ticketRepoLocalRepo trl + s <- getJust $ repoSharer r + return (s, r) + ) + (\ (Entity _ tpr, _) -> do + roid <- + case ticketProjectRemoteProject tpr of + Nothing -> + remoteActorIdent <$> + getJust (ticketProjectRemoteTracker tpr) + Just roid -> return roid + ro <- getJust roid + i <- getJust $ remoteObjectInstance ro + return (i, ro) + ) + tp + <*> (for (ticketAssignee t) $ \ pidAssignee -> do + p <- getJust pidAssignee + getJust $ personIdent p + ) + hLocal <- getsYesod siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let patchAP = AP.Ticket + { AP.ticketLocal = Just + ( hLocal + , AP.TicketLocal + { AP.ticketId = + encodeRouteLocal $ SharerPatchR shr talkhid + , AP.ticketReplies = + encodeRouteLocal $ SharerPatchDiscussionR shr talkhid + , AP.ticketParticipants = + encodeRouteLocal $ SharerPatchFollowersR shr talkhid + , AP.ticketTeam = Nothing + , AP.ticketEvents = + encodeRouteLocal $ SharerPatchEventsR shr talkhid + , AP.ticketDeps = + encodeRouteLocal $ SharerPatchDepsR shr talkhid + , AP.ticketReverseDeps = + encodeRouteLocal $ SharerPatchReverseDepsR shr talkhid + } + ) + , AP.ticketAttributedTo = encodeRouteLocal $ SharerR shr + , AP.ticketPublished = Just $ ticketCreated ticket + , AP.ticketUpdated = Nothing + , AP.ticketContext = + Just $ + case repo of + Left (s, r) -> + encodeRouteHome $ + RepoR (sharerIdent s) (repoIdent r) + Right (i, ro) -> + ObjURI (instanceHost i) (remoteObjectIdent ro) + , AP.ticketSummary = TextHtml $ ticketTitle ticket + , AP.ticketContent = TextHtml $ ticketDescription ticket + , AP.ticketSource = TextPandocMarkdown $ ticketSource ticket + , AP.ticketAssignedTo = + encodeRouteHome . SharerR . sharerIdent <$> massignee + , AP.ticketIsResolved = ticketStatus ticket == TSClosed + } + provideHtmlAndAP patchAP $ redirectToPrettyJSON here + where + here = SharerPatchR shr talkhid + +getSharerPatchDiscussionR + :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerPatchDiscussionR shr talkhid = do + (locals, remotes) <- runDB $ do + (_, Entity _ lt, _, _) <- getSharerPatch404 shr talkhid + let did = localTicketDiscuss lt + (,) <$> selectLocals did <*> selectRemotes did + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + encodeHid <- getEncodeKeyHashid + let localUri' = localUri encodeRouteHome encodeHid + replies = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just $ length locals + length remotes + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = + map localUri' locals ++ map remoteUri remotes + } + provideHtmlAndAP replies $ redirectToPrettyJSON here + where + here = SharerPatchDiscussionR shr talkhid + selectLocals did = + E.select $ E.from $ + \ (m `E.InnerJoin` lm `E.InnerJoin` p `E.InnerJoin` s) -> do + E.on $ p E.^. PersonIdent E.==. s E.^. SharerId + E.on $ lm E.^. LocalMessageAuthor E.==. p E.^. PersonId + E.on $ m E.^. MessageId E.==. lm E.^. LocalMessageRest + E.where_ $ + m E.^. MessageRoot E.==. E.val did E.&&. + E.isNothing (m E.^. MessageParent) E.&&. + E.isNothing (lm E.^. LocalMessageUnlinkedParent) + return (s E.^. SharerIdent, lm E.^. LocalMessageId) + selectRemotes did = + E.select $ E.from $ + \ (m `E.InnerJoin` rm `E.InnerJoin` ro `E.InnerJoin` i) -> do + E.on $ ro E.^. RemoteObjectInstance E.==. i E.^. InstanceId + E.on $ rm E.^. RemoteMessageIdent E.==. ro E.^. RemoteObjectId + E.on $ m E.^. MessageId E.==. rm E.^. RemoteMessageRest + E.where_ $ + m E.^. MessageRoot E.==. E.val did E.&&. + E.isNothing (m E.^. MessageParent) E.&&. + E.isNothing (rm E.^. RemoteMessageLostParent) + return (i E.^. InstanceHost, ro E.^. RemoteObjectIdent) + localUri encR encH (E.Value shrAuthor, E.Value lmid) = + encR $ MessageR shrAuthor (encH lmid) + remoteUri (E.Value h, E.Value lu) = ObjURI h lu + +getSharerPatchDeps + :: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerPatchDeps forward shr talkhid = do + tdids <- runDB $ do + (_, _, Entity tid _, _) <- getSharerPatch404 shr talkhid + let (from, to) = + if forward + then (TicketDependencyParent, TicketDependencyChild) + else (TicketDependencyChild, TicketDependencyParent) + E.select $ E.from $ \ (td `E.InnerJoin` t) -> do + E.on $ td E.^. to E.==. t E.^. TicketId + E.where_ $ td E.^. from E.==. E.val tid + return $ td E.^. TicketDependencyId + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + encodeHid <- getEncodeKeyHashid + let deps = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeUnordered + , collectionTotalItems = Just $ length tdids + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = + map (encodeRouteHome . TicketDepR . encodeHid . E.unValue) + tdids + } + provideHtmlAndAP deps $ redirectToPrettyJSON here + where + here = + let route = + if forward then SharerPatchDepsR else SharerTicketReverseDepsR + in route shr talkhid + +getSharerPatchDepsR + :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerPatchDepsR = getSharerPatchDeps True + +getSharerPatchReverseDepsR + :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerPatchReverseDepsR = getSharerPatchDeps False + +getSharerPatchFollowersR + :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerPatchFollowersR shr talkhid = getFollowersCollection here getFsid + where + here = SharerPatchFollowersR shr talkhid + getFsid = do + (_, Entity _ lt, _, _) <- getSharerPatch404 shr talkhid + return $ localTicketFollowers lt + +getSharerPatchEventsR + :: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent +getSharerPatchEventsR shr talkhid = do + _ <- runDB $ getSharerPatch404 shr talkhid + encodeRouteLocal <- getEncodeRouteLocal + let team = Collection + { collectionId = encodeRouteLocal here + , collectionType = CollectionTypeOrdered + , collectionTotalItems = Just 0 + , collectionCurrent = Nothing + , collectionFirst = Nothing + , collectionLast = Nothing + , collectionItems = [] :: [Text] + } + provideHtmlAndAP team $ redirectToPrettyJSON here + where + here = SharerPatchEventsR shr talkhid diff --git a/src/Vervis/Handler/Repo/Darcs.hs b/src/Vervis/Handler/Repo/Darcs.hs index e3ca775..03a423f 100644 --- a/src/Vervis/Handler/Repo/Darcs.hs +++ b/src/Vervis/Handler/Repo/Darcs.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019 by fr33domlover . + - Written in 2016, 2018, 2019, 2020 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -55,6 +55,7 @@ import Yesod.RenderSource import Data.ByteString.Char8.Local (takeLine) import Data.Paginate.Local +import Data.Patch.Local import Text.FilePath.Local (breakExt) import Vervis.ActivityPub @@ -67,7 +68,6 @@ import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Repo import Vervis.Paginate -import Vervis.Patch import Vervis.Readme import Vervis.Settings import Vervis.SourceTree diff --git a/src/Vervis/Handler/Repo/Git.hs b/src/Vervis/Handler/Repo/Git.hs index cd7a926..d0069bf 100644 --- a/src/Vervis/Handler/Repo/Git.hs +++ b/src/Vervis/Handler/Repo/Git.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019 by fr33domlover . + - Written in 2016, 2018, 2019, 2020 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -69,6 +69,7 @@ import qualified Web.ActivityPub as AP import Data.ByteString.Char8.Local (takeLine) import Data.Git.Local import Data.Paginate.Local +import Data.Patch.Local import Text.FilePath.Local (breakExt) import Vervis.ActivityPub @@ -81,7 +82,6 @@ import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Repo import Vervis.Paginate -import Vervis.Patch import Vervis.Readme import Vervis.Settings import Vervis.SourceTree diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index d50f8fc..beed48c 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -389,7 +389,7 @@ getProjectTicketR shar proj ltkhid = do , AP.ticketParticipants = encodeRouteLocal $ ProjectTicketParticipantsR shar proj ltkhid , AP.ticketTeam = - encodeRouteLocal $ ProjectTicketTeamR shar proj ltkhid + Just $ encodeRouteLocal $ ProjectTicketTeamR shar proj ltkhid , AP.ticketEvents = encodeRouteLocal $ ProjectTicketEventsR shar proj ltkhid , AP.ticketDeps = @@ -1178,22 +1178,28 @@ getSharerTicketsR shr = do provide :: ActivityPub a => a URIMode -> Handler TypedContent provide a = provideHtmlAndAP a $ redirectToPrettyJSON here countTickets pid = fmap toOne $ - E.select $ E.from $ \ (tal `E.LeftOuterJoin` tup) -> do + E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup `E.LeftOuterJoin` pt) -> do + E.on $ E.just (lt E.^. LocalTicketTicket) E.==. pt E.?. PatchTicket E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor + E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId E.where_ $ tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. - E.isNothing (tup E.?. TicketUnderProjectId) + E.isNothing (tup E.?. TicketUnderProjectId) E.&&. + E.isNothing (pt E.?. PatchId) return $ E.count $ tal E.^. TicketAuthorLocalId where toOne [x] = E.unValue x toOne [] = error "toOne = 0" toOne _ = error "toOne > 1" selectTickets pid off lim = - E.select $ E.from $ \ (tal `E.LeftOuterJoin` tup) -> do + E.select $ E.from $ \ (tal `E.InnerJoin` lt `E.LeftOuterJoin` tup `E.LeftOuterJoin` pt) -> do + E.on $ E.just (lt E.^. LocalTicketTicket) E.==. pt E.?. PatchTicket E.on $ E.just (tal E.^. TicketAuthorLocalId) E.==. tup E.?. TicketUnderProjectAuthor + E.on $ tal E.^. TicketAuthorLocalTicket E.==. lt E.^. LocalTicketId E.where_ $ tal E.^. TicketAuthorLocalAuthor E.==. E.val pid E.&&. - E.isNothing (tup E.?. TicketUnderProjectId) + E.isNothing (tup E.?. TicketUnderProjectId) E.&&. + E.isNothing (pt E.?. PatchId) E.orderBy [E.desc $ tal E.^. TicketAuthorLocalId] E.offset $ fromIntegral off E.limit $ fromIntegral lim @@ -1241,7 +1247,7 @@ getSharerTicketR shr talkhid = do , AP.ticketParticipants = encodeRouteLocal $ SharerTicketFollowersR shr talkhid , AP.ticketTeam = - encodeRouteLocal $ SharerTicketTeamR shr talkhid + Just $ encodeRouteLocal $ SharerTicketTeamR shr talkhid , AP.ticketEvents = encodeRouteLocal $ SharerTicketEventsR shr talkhid , AP.ticketDeps = diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 08d8c66..2ce32c1 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -1578,6 +1578,8 @@ changes hLocal ctx = insertMany_ $ map makeTPL tcls -- 248 , removeField "TicketContextLocal" "project" + -- 249 + , addEntities model_2020_05_17 ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 9bce159..5887e54 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -197,6 +197,7 @@ module Vervis.Migration.Model , TicketContextLocal247 , TicketContextLocal247Generic (..) , TicketProjectLocal247Generic (..) + , model_2020_05_17 ) where @@ -391,3 +392,6 @@ model_2020_05_16 = $(schema "2020_05_16_tcl") makeEntitiesMigration "247" $(modelFile "migrations/2020_05_16_tcl_mig.model") + +model_2020_05_17 :: [Entity SqlBackend] +model_2020_05_17 = $(schema "2020_05_17_patch") diff --git a/src/Vervis/Patch.hs b/src/Vervis/Patch.hs index ad05533..5cc8bd5 100644 --- a/src/Vervis/Patch.hs +++ b/src/Vervis/Patch.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2018 by fr33domlover . + - Written in 2020 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -13,54 +13,163 @@ - . -} --- | Representation of a commit in a repo for viewing. --- --- Each version control system has its own specific details of how repository --- changes are represented and encoded and stored internally. This module is --- merely a model for displaying a commit to a human viewer. module Vervis.Patch - ( Hunk (..) - , Edit (..) - , Author (..) - , Patch (..) + ( getSharerPatch + , getSharerPatch404 + , getRepoPatch + , getRepoPatch404 ) where -import Data.Int (Int64) -import Data.List.NonEmpty (NonEmpty) -import Data.Text (Text) -import Data.Time.Clock (UTCTime) -import Data.Word (Word32) -import Data.Vector (Vector) -import Text.Email.Validate (EmailAddress) +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Data.Maybe +import Data.Traversable +import Database.Persist +import Yesod.Core -data Hunk = Hunk - { hunkAddFirst :: [Text] - , hunkRemoveAdd :: [(NonEmpty Text, NonEmpty Text)] - , hunkRemoveLast :: [Text] - } +import Yesod.Hashids -data Edit - = AddTextFile FilePath Word32 [Text] - | AddBinaryFile FilePath Word32 Int64 - | RemoveTextFile FilePath Word32 [Text] - | RemoveBinaryFile FilePath Word32 Int64 - | MoveFile FilePath Word32 FilePath Word32 - | ChmodFile FilePath Word32 Word32 - | EditTextFile FilePath (Vector Text) (NonEmpty (Bool, Int, Hunk)) Word32 Word32 - | EditBinaryFile FilePath Int64 Word32 Int64 Word32 - | TextToBinary FilePath [Text] Word32 Int64 Word32 - | BinaryToText FilePath Int64 Word32 [Text] Word32 +import Data.Either.Local +import Database.Persist.Local -data Author = Author - { authorName :: Text - , authorEmail :: EmailAddress - } +import Vervis.Foundation +import Vervis.Model +import Vervis.Model.Ident -data Patch = Patch - { patchWritten :: (Author, UTCTime) - , patchCommitted :: Maybe (Author, UTCTime) - , patchTitle :: Text - , patchDescription :: Text - , patchDiff :: [Edit] - } +getSharerPatch + :: ShrIdent + -> TicketAuthorLocalId + -> AppDB + ( Maybe + ( Entity TicketAuthorLocal + , Entity LocalTicket + , Entity Ticket + , Either + ( Entity TicketContextLocal + , Entity TicketRepoLocal + ) + ( Entity TicketProjectRemote + , Maybe (Entity TicketProjectRemoteAccept) + ) + ) + ) +getSharerPatch shr talid = runMaybeT $ do + pid <- do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + MaybeT $ getKeyBy $ UniquePersonIdent sid + tal <- MaybeT $ get talid + guard $ ticketAuthorLocalAuthor tal == pid + let ltid = ticketAuthorLocalTicket tal + lt <- lift $ getJust ltid + let tid = localTicketTicket lt + t <- lift $ getJust tid + npatches <- lift $ count [PatchTicket ==. tid] + guard $ npatches >= 1 + repo <- + requireEitherAlt + (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid + for mtcl $ \ etcl@(Entity tclid tcl) -> do + etrl <- MaybeT $ getBy $ UniqueTicketRepoLocal tclid + mtup1 <- lift $ getBy $ UniqueTicketUnderProjectProject tclid + mtup2 <- lift $ getBy $ UniqueTicketUnderProjectAuthor talid + unless (isJust mtup1 == isJust mtup2) $ + error "TUP points to unrelated TAL and TCL!" + guard $ not $ isJust mtup1 + return (etcl, etrl) + ) + (do mtpr <- lift $ getBy $ UniqueTicketProjectRemote talid + lift $ for mtpr $ \ etpr@(Entity tprid _) -> + (etpr,) <$> getBy (UniqueTicketProjectRemoteAccept tprid) + ) + "MR doesn't have context" + "MR has both local and remote context" + return (Entity talid tal, Entity ltid lt, Entity tid t, repo) + +getSharerPatch404 + :: ShrIdent + -> KeyHashid TicketAuthorLocal + -> AppDB + ( Entity TicketAuthorLocal + , Entity LocalTicket + , Entity Ticket + , Either + ( Entity TicketContextLocal + , Entity TicketRepoLocal + ) + ( Entity TicketProjectRemote + , Maybe (Entity TicketProjectRemoteAccept) + ) + ) +getSharerPatch404 shr talkhid = do + talid <- decodeKeyHashid404 talkhid + mpatch <- getSharerPatch shr talid + case mpatch of + Nothing -> notFound + Just patch -> return patch + +getRepoPatch + :: ShrIdent + -> RpIdent + -> LocalTicketId + -> AppDB + ( Maybe + ( Entity Sharer + , Entity Repo + , Entity Ticket + , Entity LocalTicket + , Entity TicketContextLocal + , Entity TicketRepoLocal + , Either + (Entity TicketAuthorLocal, Entity TicketUnderProject) + (Entity TicketAuthorRemote) + ) + ) +getRepoPatch shr rp ltid = runMaybeT $ do + es@(Entity sid _) <- MaybeT $ getBy $ UniqueSharer shr + er@(Entity rid _) <- MaybeT $ getBy $ UniqueRepo rp sid + lt <- MaybeT $ get ltid + let tid = localTicketTicket lt + t <- MaybeT $ get tid + etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid + etrl@(Entity _ trl) <- MaybeT $ getBy $ UniqueTicketRepoLocal tclid + guard $ ticketRepoLocalRepo trl == rid + npatches <- lift $ count [PatchTicket ==. tid] + guard $ npatches >= 1 + author <- + requireEitherAlt + (do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid + for mtal $ \ tal@(Entity talid _) -> do + tupid1 <- MaybeT $ getKeyBy $ UniqueTicketUnderProjectProject tclid + tup@(Entity tupid2 _) <- MaybeT $ getBy $ UniqueTicketUnderProjectAuthor talid + unless (tupid1 == tupid2) $ + error "TAL and TPL used by different TUPs!" + return (tal, tup) + ) + (lift $ getBy $ UniqueTicketAuthorRemote tclid) + "MR doesn't have author" + "MR has both local and remote author" + return (es, er, Entity tid t, Entity ltid lt, etcl, etrl, author) + +getRepoPatch404 + :: ShrIdent + -> RpIdent + -> KeyHashid LocalTicket + -> AppDB + ( Entity Sharer + , Entity Repo + , Entity Ticket + , Entity LocalTicket + , Entity TicketContextLocal + , Entity TicketRepoLocal + , Either + (Entity TicketAuthorLocal, Entity TicketUnderProject) + (Entity TicketAuthorRemote) + ) +getRepoPatch404 shr rp ltkhid = do + ltid <- decodeKeyHashid404 ltkhid + mpatch <- getRepoPatch shr rp ltid + case mpatch of + Nothing -> notFound + Just patch -> return patch diff --git a/src/Vervis/Ticket.hs b/src/Vervis/Ticket.hs index 1e196c9..f29194e 100644 --- a/src/Vervis/Ticket.hs +++ b/src/Vervis/Ticket.hs @@ -46,6 +46,8 @@ import Data.Traversable import Database.Esqueleto import Yesod.Core (notFound) +import qualified Database.Persist as P + import Yesod.Hashids import Data.Either.Local @@ -457,6 +459,8 @@ getSharerTicket shr talid = runMaybeT $ do lt <- lift $ getJust ltid let tid = localTicketTicket lt t <- lift $ getJust tid + npatches <- lift $ P.count [PatchTicket P.==. tid] + guard $ npatches <= 0 project <- requireEitherAlt (do mtcl <- lift $ getBy $ UniqueTicketContextLocal tid @@ -525,6 +529,8 @@ getProjectTicket shr prj ltid = runMaybeT $ do etcl@(Entity tclid _) <- MaybeT $ getBy $ UniqueTicketContextLocal tid etpl@(Entity _ tpl) <- MaybeT $ getBy $ UniqueTicketProjectLocal tclid guard $ ticketProjectLocalProject tpl == jid + npatches <- lift $ P.count [PatchTicket P.==. tid] + guard $ npatches <= 0 author <- requireEitherAlt (do mtal <- lift $ getBy $ UniqueTicketAuthorLocal ltid diff --git a/src/Vervis/Widget/Repo.hs b/src/Vervis/Widget/Repo.hs index f67cf7f..375c61d 100644 --- a/src/Vervis/Widget/Repo.hs +++ b/src/Vervis/Widget/Repo.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2020 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -31,10 +31,11 @@ import qualified Data.List.NonEmpty as N import qualified Data.Text as T (take) import qualified Data.Vector as V +import Data.Patch.Local (Hunk (..)) + import Vervis.Changes import Vervis.Foundation import Vervis.Model.Ident -import Vervis.Patch (Hunk (..)) import Vervis.Settings (widgetFile, appDiffContextLines) import Vervis.Style diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 53dcad7..3371d0a 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -827,7 +827,7 @@ data TicketLocal = TicketLocal { ticketId :: LocalURI , ticketReplies :: LocalURI , ticketParticipants :: LocalURI - , ticketTeam :: LocalURI + , ticketTeam :: Maybe LocalURI , ticketEvents :: LocalURI , ticketDeps :: LocalURI , ticketReverseDeps :: LocalURI @@ -851,7 +851,7 @@ parseTicketLocal o = do <$> pure id_ <*> withAuthorityO a (o .: "replies") <*> withAuthorityO a (o .: "participants") - <*> withAuthorityO a (o .: "team") + <*> withAuthorityMaybeO a (o .:? "team") <*> withAuthorityO a (o .: "history") <*> withAuthorityO a (o .: "dependencies") <*> withAuthorityO a (o .: "dependants") @@ -867,7 +867,7 @@ encodeTicketLocal = "id" .= ObjURI a id_ <> "replies" .= ObjURI a replies <> "participants" .= ObjURI a participants - <> "team" .= ObjURI a team + <> "team" .=? (ObjURI a <$> team) <> "history" .= ObjURI a events <> "dependencies" .= ObjURI a deps <> "dependants" .= ObjURI a rdeps diff --git a/vervis.cabal b/vervis.cabal index 9251673..e794afc 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -73,6 +73,7 @@ library Data.Maybe.Local Data.MediaType Data.Paginate.Local + Data.Patch.Local Data.Text.UTF8.Local Data.Text.Lazy.UTF8.Local Data.Time.Clock.Local @@ -163,6 +164,7 @@ library Vervis.Handler.Home Vervis.Handler.Inbox Vervis.Handler.Key + Vervis.Handler.Patch Vervis.Handler.Person Vervis.Handler.Project Vervis.Handler.Repo @@ -189,8 +191,8 @@ library Vervis.Model.Workflow Vervis.Paginate Vervis.Palette - Vervis.Path Vervis.Patch + Vervis.Path Vervis.Query Vervis.Readme Vervis.RemoteActorStore