mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-03-20 15:14:54 +09:00
326 lines
14 KiB
Haskell
326 lines
14 KiB
Haskell
{- 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
|