Implement sharer ticket JSON view, including discussion, followers, deps etc.
This commit is contained in:
fr33domlover
parent
00e0f7c14f
commit
0de98a9cdd
2 changed files with 247 additions and 3 deletions
|
|
@ -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.
|
||||
--
|
||||
|
|
@ -184,5 +184,11 @@
|
|||
/s/#ShrIdent/t SharerTicketsR GET
|
||||
|
||||
/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid SharerTicketR GET
|
||||
/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/d SharerTicketDiscussionR GET
|
||||
/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/deps SharerTicketDepsR GET
|
||||
/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/rdeps SharerTicketReverseDepsR GET
|
||||
/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/followers SharerTicketFollowersR GET
|
||||
/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/team SharerTicketTeamR GET
|
||||
/s/#ShrIdent/t/#TicketAuthorLocalKeyHashid/events SharerTicketEventsR GET
|
||||
|
||||
/s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET
|
||||
|
|
|
|||
|
|
@ -54,6 +54,12 @@ module Vervis.Handler.Ticket
|
|||
|
||||
, getSharerTicketsR
|
||||
, getSharerTicketR
|
||||
, getSharerTicketDiscussionR
|
||||
, getSharerTicketDepsR
|
||||
, getSharerTicketReverseDepsR
|
||||
, getSharerTicketFollowersR
|
||||
, getSharerTicketTeamR
|
||||
, getSharerTicketEventsR
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -64,10 +70,11 @@ import Control.Monad.Logger.CallStack
|
|||
import Control.Monad.Trans.Except
|
||||
import Data.Aeson (encode)
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.Bool (bool)
|
||||
import Data.Default.Class (def)
|
||||
import Data.Foldable (traverse_)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Maybe
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Calendar (Day (..))
|
||||
|
|
@ -1225,6 +1232,43 @@ getTicketEventsR
|
|||
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
|
||||
getTicketEventsR _shr _prj _ltkhid = error "TODO not implemented"
|
||||
|
||||
getSharerTicket
|
||||
:: ShrIdent
|
||||
-> KeyHashid TicketAuthorLocal
|
||||
-> AppDB
|
||||
( Entity TicketAuthorLocal
|
||||
, Entity LocalTicket
|
||||
, Entity Ticket
|
||||
, Either (Entity TicketProjectLocal) ()
|
||||
)
|
||||
getSharerTicket shr talkhid = do
|
||||
pid <- do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
getKeyBy404 $ UniquePersonIdent sid
|
||||
talid <- decodeKeyHashid404 talkhid
|
||||
tal <- get404 talid
|
||||
unless (ticketAuthorLocalAuthor tal == pid) notFound
|
||||
let ltid = ticketAuthorLocalTicket tal
|
||||
lt <- getJust ltid
|
||||
let tid = localTicketTicket lt
|
||||
t <- getJust tid
|
||||
project <-
|
||||
requireEitherAlt
|
||||
(do mtpl <- getBy $ UniqueTicketProjectLocal tid
|
||||
for mtpl $ \ etpl@(Entity tplid tpl) -> do
|
||||
mtup1 <- getBy $ UniqueTicketUnderProjectProject tplid
|
||||
mtup2 <- getBy $ UniqueTicketUnderProjectAuthor talid
|
||||
unless (isJust mtup1 == isJust mtup2) $
|
||||
error "TUP points to unrelated TAL and TPL!"
|
||||
unless (isNothing mtup1) notFound
|
||||
return etpl
|
||||
)
|
||||
(return Nothing
|
||||
)
|
||||
"Ticket doesn't have project"
|
||||
"Ticket has both local and remote project"
|
||||
return (Entity talid tal, Entity ltid lt, Entity tid t, project)
|
||||
|
||||
getSharerTicketsR :: ShrIdent -> Handler TypedContent
|
||||
getSharerTicketsR shr = do
|
||||
(total, pages, mpage) <- runDB $ do
|
||||
|
|
@ -1298,4 +1342,198 @@ getSharerTicketsR shr = do
|
|||
|
||||
getSharerTicketR
|
||||
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketR shr talkhid = error "Not implemented yet"
|
||||
getSharerTicketR shr talkhid = do
|
||||
(ticket, project, massignee) <- runDB $ do
|
||||
(_, _, Entity _ t, tp) <- getSharerTicket shr talkhid
|
||||
(,,) t
|
||||
<$> bitraverse
|
||||
(\ (Entity _ tpl) -> do
|
||||
j <- getJust $ ticketProjectLocalProject tpl
|
||||
s <- getJust $ projectSharer j
|
||||
return (s, j)
|
||||
)
|
||||
return
|
||||
tp
|
||||
<*> (for (ticketAssignee t) $ \ pidAssignee -> do
|
||||
p <- getJust pidAssignee
|
||||
getJust $ personIdent p
|
||||
)
|
||||
hLocal <- getsYesod siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let ticketAP = AP.Ticket
|
||||
{ AP.ticketLocal = Just
|
||||
( hLocal
|
||||
, AP.TicketLocal
|
||||
{ AP.ticketId =
|
||||
encodeRouteLocal $ SharerTicketR shr talkhid
|
||||
, AP.ticketContext =
|
||||
encodeRouteLocal $
|
||||
case project of
|
||||
Left (s, j) ->
|
||||
ProjectR (sharerIdent s) (projectIdent j)
|
||||
Right () -> error "No TPR yet!"
|
||||
, AP.ticketReplies =
|
||||
encodeRouteLocal $ SharerTicketDiscussionR shr talkhid
|
||||
, AP.ticketParticipants =
|
||||
encodeRouteLocal $ SharerTicketFollowersR shr talkhid
|
||||
, AP.ticketTeam =
|
||||
encodeRouteLocal $ SharerTicketTeamR shr talkhid
|
||||
, AP.ticketEvents =
|
||||
encodeRouteLocal $ SharerTicketEventsR shr talkhid
|
||||
, AP.ticketDeps =
|
||||
encodeRouteLocal $ SharerTicketDepsR shr talkhid
|
||||
, AP.ticketReverseDeps =
|
||||
encodeRouteLocal $ SharerTicketReverseDepsR shr talkhid
|
||||
}
|
||||
)
|
||||
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shr
|
||||
, AP.ticketPublished = Just $ ticketCreated ticket
|
||||
, AP.ticketUpdated = Nothing
|
||||
, 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 ticketAP $ redirectToPrettyJSON here
|
||||
where
|
||||
here = SharerTicketR shr talkhid
|
||||
|
||||
getSharerTicketDiscussionR
|
||||
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketDiscussionR shr talkhid = do
|
||||
(locals, remotes) <- runDB $ do
|
||||
(_, Entity _ lt, _, _) <- getSharerTicket 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 = SharerTicketDiscussionR 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
|
||||
|
||||
getSharerTicketDeps
|
||||
:: Bool -> ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketDeps forward shr talkhid = do
|
||||
tdids <- runDB $ do
|
||||
(_, _, Entity tid _, _) <- getSharerTicket 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 SharerTicketDepsR else SharerTicketReverseDepsR
|
||||
in route shr talkhid
|
||||
|
||||
getSharerTicketDepsR
|
||||
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketDepsR = getSharerTicketDeps True
|
||||
|
||||
getSharerTicketReverseDepsR
|
||||
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketReverseDepsR = getSharerTicketDeps False
|
||||
|
||||
getSharerTicketFollowersR
|
||||
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketFollowersR shr talkhid = getFollowersCollection here getFsid
|
||||
where
|
||||
here = SharerTicketFollowersR shr talkhid
|
||||
getFsid = do
|
||||
(_, Entity _ lt, _, _) <- getSharerTicket shr talkhid
|
||||
return $ localTicketFollowers lt
|
||||
|
||||
getSharerTicketTeamR
|
||||
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketTeamR shr talkhid = do
|
||||
_ <- runDB $ getSharerTicket shr talkhid
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let team = Collection
|
||||
{ collectionId = encodeRouteLocal here
|
||||
, collectionType = CollectionTypeUnordered
|
||||
, collectionTotalItems = Just 0
|
||||
, collectionCurrent = Nothing
|
||||
, collectionFirst = Nothing
|
||||
, collectionLast = Nothing
|
||||
, collectionItems = [] :: [Text]
|
||||
}
|
||||
provideHtmlAndAP team $ redirectToPrettyJSON here
|
||||
where
|
||||
here = SharerTicketTeamR shr talkhid
|
||||
|
||||
getSharerTicketEventsR
|
||||
:: ShrIdent -> KeyHashid TicketAuthorLocal -> Handler TypedContent
|
||||
getSharerTicketEventsR shr talkhid = do
|
||||
_ <- runDB $ getSharerTicket 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 = SharerTicketEventsR shr talkhid
|
||||
|
|
|
|||
Loading…
Reference in a new issue