Add GET routes and handlers for sharer-hosted patches

config/models

@@ -443,6 +443,10 @@ TicketUnderProject
     UniqueTicketUnderProjectProject project
     UniqueTicketUnderProjectAuthor  author
 
+Patch
+    ticket  TicketId
+    content Text
+
 TicketDependency
     parent  TicketId
     child   TicketId

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

migrations/2020_05_17_patch.model

@@ -0,0 +1,3 @@
+Patch
+    ticket  TicketId
+    content Text

src/Data/Patch/Local.hs

@@ -0,0 +1,66 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | 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]
+    }

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

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

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

src/Vervis/Darcs.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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

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 $

src/Vervis/Git.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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 :: [Edit] -> Commit SHA1 -> P.Patch
-patch edits c = 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

src/Vervis/Handler/Patch.hs

@@ -0,0 +1,326 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2020 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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

src/Vervis/Handler/Repo/Darcs.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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

src/Vervis/Handler/Repo/Git.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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

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 =

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

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")

src/Vervis/Patch.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2018 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -13,54 +13,163 @@
  - <http://creativecommons.org/publicdomain/zero/1.0/>.
  -}
 
--- | 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 (..)
+    ( getSharerPatch
-    , Edit (..)
+    , getSharerPatch404
-    , Author (..)
+    , getRepoPatch
-    , Patch (..)
+    , getRepoPatch404
     )
 where
 
-import Data.Int (Int64)
+import Control.Monad
-import Data.List.NonEmpty (NonEmpty)
+import Control.Monad.Trans.Class
-import Data.Text (Text)
+import Control.Monad.Trans.Maybe
-import Data.Time.Clock (UTCTime)
+import Data.Maybe
-import Data.Word (Word32)
+import Data.Traversable
-import Data.Vector (Vector)
+import Database.Persist
-import Text.Email.Validate (EmailAddress)
+import Yesod.Core
 
-data Hunk = Hunk
+import Yesod.Hashids
-    { hunkAddFirst   :: [Text]
-    , hunkRemoveAdd  :: [(NonEmpty Text, NonEmpty Text)]
-    , hunkRemoveLast :: [Text]
-    }
 
-data Edit
+import Data.Either.Local
-    = AddTextFile FilePath Word32 [Text]
+import Database.Persist.Local
-    | 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
+import Vervis.Foundation
-    { authorName  :: Text
+import Vervis.Model
-    , authorEmail :: EmailAddress
+import Vervis.Model.Ident
-    }
 
-data Patch = Patch
+getSharerPatch
-    { patchWritten     :: (Author, UTCTime)
+    :: ShrIdent
-    , patchCommitted   :: Maybe (Author, UTCTime)
+    -> TicketAuthorLocalId
-    , patchTitle       :: Text
+    -> AppDB
-    , patchDescription :: Text
+        ( Maybe
-    , patchDiff        :: [Edit]
+            ( 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

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

src/Vervis/Widget/Repo.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2020 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ 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
 

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

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