sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 17:24:53 +09:00
Code Issues Activity

Switch ticket routes to use the KeyHashid of LocalTicket instead of Ticket

Browse source
This commit is contained in:
fr33domlover 2020-02-06 00:52:15 +00:00
parent cd5180a1d5
commit 443ff6daa1
23 changed files with 382 additions and 337 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

48
config/routes
View file

@ -156,29 +156,29 @@
/s/#ShrIdent/p/#PrjIdent/t/!tree TicketTreeR GET /s/#ShrIdent/p/#PrjIdent/t/!tree TicketTreeR GET
/s/#ShrIdent/p/#PrjIdent/t/!new TicketNewR GET /s/#ShrIdent/p/#PrjIdent/t/!new TicketNewR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid TicketR GET PUT DELETE POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid TicketR GET PUT DELETE POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/edit TicketEditR GET /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/edit TicketEditR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/accept TicketAcceptR POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/accept TicketAcceptR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/close TicketCloseR POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/close TicketCloseR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/open TicketOpenR POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/open TicketOpenR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/claim TicketClaimR POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/claim TicketClaimR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/unclaim TicketUnclaimR POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/unclaim TicketUnclaimR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/assign TicketAssignR GET POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/assign TicketAssignR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/unassign TicketUnassignR POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/unassign TicketUnassignR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/follow TicketFollowR POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/follow TicketFollowR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/unfollow TicketUnfollowR POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/unfollow TicketUnfollowR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/cr ClaimRequestsTicketR GET POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/cr ClaimRequestsTicketR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/cr/new ClaimRequestNewR GET /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/cr/new ClaimRequestNewR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/d TicketDiscussionR GET POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/d TicketDiscussionR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/d/!reply TicketTopReplyR GET /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/d/!reply TicketTopReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/d/#MessageKeyHashid TicketMessageR POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/d/#MessageKeyHashid TicketMessageR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/d/#MessageKeyHashid/reply TicketReplyR GET /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/d/#MessageKeyHashid/reply TicketReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/deps TicketDepsR GET POST /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/deps TicketDepsR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/deps/!new TicketDepNewR GET /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/deps/!new TicketDepNewR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/deps/#TicketKeyHashid TicketDepOldR POST DELETE /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/deps/#LocalTicketKeyHashid TicketDepOldR POST DELETE
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/rdeps TicketReverseDepsR GET /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/rdeps TicketReverseDepsR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/participants TicketParticipantsR GET /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/participants TicketParticipantsR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/team TicketTeamR GET /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/team TicketTeamR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/events TicketEventsR GET /s/#ShrIdent/p/#PrjIdent/t/#LocalTicketKeyHashid/events TicketEventsR GET
/s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET /s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET

48
src/Vervis/API.hs
View file

@ -162,18 +162,14 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
(lmid, obiid, doc, remotesHttp) <- runDBExcept $ do (lmid, obiid, doc, remotesHttp) <- runDBExcept $ do
(pid, obid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor" (pid, obid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
(did, meparent, mcollections) <- case mticket of (did, meparent, mcollections) <- case mticket of
Just (shr, prj, tkhid) -> do Just (shr, prj, ltkhid) -> do
mt <- lift $ runMaybeT $ do mt <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid Entity jid j <- MaybeT $ getBy $ UniqueProject prj sid
tid <- decodeKeyHashidM tkhid ltid <- decodeKeyHashidM ltkhid
t <- MaybeT $ get tid lt <- MaybeT $ get ltid
t <- lift $ getJust $ localTicketTicket lt
guard $ ticketProject t == jid guard $ ticketProject t == jid
lt <- lift $ do
mlt <- getValBy $ UniqueLocalTicket tid
case mlt of
Nothing -> error "No LocalTicket"
Just lt -> return lt
return (sid, projectInbox j, projectFollowers j, t, lt) return (sid, projectInbox j, projectFollowers j, t, lt)
(sid, ibidProject, fsidProject, _t, lt) <- fromMaybeE mt "Context: No such local ticket" (sid, ibidProject, fsidProject, _t, lt) <- fromMaybeE mt "Context: No such local ticket"
let did = localTicketDiscuss lt let did = localTicketDiscuss lt
@ -250,7 +246,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
-> ExceptT Text Handler -> ExceptT Text Handler
( Maybe (Either (ShrIdent, LocalMessageId) FedURI) ( Maybe (Either (ShrIdent, LocalMessageId) FedURI)
, [ShrIdent] , [ShrIdent]
, Maybe (ShrIdent, PrjIdent, KeyHashid Ticket) , Maybe (ShrIdent, PrjIdent, KeyHashid LocalTicket)
, [(Host, NonEmpty LocalURI)] , [(Host, NonEmpty LocalURI)]
) )
parseRecipsContextParent uContext muParent = do parseRecipsContextParent uContext muParent = do
@ -281,7 +277,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
then Left <$> parseComment luParent then Left <$> parseComment luParent
else return $ Right uParent else return $ Right uParent
parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, KeyHashid Ticket) parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, KeyHashid LocalTicket)
parseContextTicket luContext = do parseContextTicket luContext = do
route <- case decodeRouteLocal luContext of route <- case decodeRouteLocal luContext of
Nothing -> throwE "Local context isn't a valid route" Nothing -> throwE "Local context isn't a valid route"
@ -294,7 +290,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
atMostSharer _ (shr, LocalSharerRelatedSet s [] []) = return $ if localRecipSharer s then Just shr else Nothing atMostSharer _ (shr, LocalSharerRelatedSet s [] []) = return $ if localRecipSharer s then Just shr else Nothing
atMostSharer e (_ , LocalSharerRelatedSet _ _ _ ) = throwE e atMostSharer e (_ , LocalSharerRelatedSet _ _ _ ) = throwE e
verifyTicketRecipients :: (ShrIdent, PrjIdent, KeyHashid Ticket) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent] verifyTicketRecipients :: (ShrIdent, PrjIdent, KeyHashid LocalTicket) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
verifyTicketRecipients (shr, prj, num) recips = do verifyTicketRecipients (shr, prj, num) recips = do
lsrSet <- fromMaybeE (lookupSorted shr recips) "Note with local context: No required recipients" lsrSet <- fromMaybeE (lookupSorted shr recips) "Note with local context: No required recipients"
(prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets" (prj', lprSet) <- verifySingleton (localRecipProjectRelated lsrSet) "Note project-related recipient sets"
@ -451,7 +447,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
data Followee data Followee
= FolloweeSharer ShrIdent = FolloweeSharer ShrIdent
| FolloweeProject ShrIdent PrjIdent | FolloweeProject ShrIdent PrjIdent
| FolloweeTicket ShrIdent PrjIdent (KeyHashid Ticket) | FolloweeTicket ShrIdent PrjIdent (KeyHashid LocalTicket)
| FolloweeRepo ShrIdent RpIdent | FolloweeRepo ShrIdent RpIdent
followC followC
@ -544,18 +540,14 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = run
MaybeT $ getValBy $ UniqueProject prj sid MaybeT $ getValBy $ UniqueProject prj sid
project <- fromMaybeE mproject "Follow object: No such project in DB" project <- fromMaybeE mproject "Follow object: No such project in DB"
return (projectFollowers project, projectInbox project, False, projectOutbox project) return (projectFollowers project, projectInbox project, False, projectOutbox project)
getFollowee (FolloweeTicket shr prj tkhid) = do getFollowee (FolloweeTicket shr prj ltkhid) = do
mproject <- lift $ runMaybeT $ do mproject <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
Entity jid project <- MaybeT $ getBy $ UniqueProject prj sid Entity jid project <- MaybeT $ getBy $ UniqueProject prj sid
tid <- decodeKeyHashidM tkhid ltid <- decodeKeyHashidM ltkhid
ticket <- MaybeT $ get tid lticket <- MaybeT $ get ltid
ticket <- lift $ getJust $ localTicketTicket lticket
guard $ ticketProject ticket == jid guard $ ticketProject ticket == jid
lticket <- lift $ do
mlt <- getValBy $ UniqueLocalTicket tid
case mlt of
Nothing -> error "No LocalTicket"
Just lt -> return lt
return (lticket, project) return (lticket, project)
(lticket, project) <- fromMaybeE mproject "Follow object: No such ticket in DB" (lticket, project) <- fromMaybeE mproject "Follow object: No such ticket in DB"
return (localTicketFollowers lticket, projectInbox project, False, projectOutbox project) return (localTicketFollowers lticket, projectInbox project, False, projectOutbox project)
@ -788,8 +780,8 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
persistJSONObjectFromDoc $ Doc hLocal emptyActivity persistJSONObjectFromDoc $ Doc hLocal emptyActivity
, outboxItemPublished = now , outboxItemPublished = now
} }
tid <- insertTicket jid {-tids-} {-num-} obiidAccept ltid <- insertTicket jid {-tids-} {-num-} obiidAccept
docAccept <- insertAccept pidAuthor sid jid fsid luOffer obiidAccept tid docAccept <- insertAccept pidAuthor sid jid fsid luOffer obiidAccept ltid
publishAccept pidAuthor sid jid fsid luOffer {-num-} obiidAccept docAccept publishAccept pidAuthor sid jid fsid luOffer {-num-} obiidAccept docAccept
(pidsTeam, remotesTeam) <- (pidsTeam, remotesTeam) <-
if localRecipProjectTeam project if localRecipProjectTeam project
@ -808,8 +800,8 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
insertToInbox ibid = do insertToInbox ibid = do
ibiid <- insert $ InboxItem False ibiid <- insert $ InboxItem False
insert_ $ InboxItemLocal ibid obiid ibiid insert_ $ InboxItemLocal ibid obiid ibiid
insertAccept pidAuthor sid jid fsid luOffer obiid tid = do insertAccept pidAuthor sid jid fsid luOffer obiid ltid = do
tkhid <- encodeKeyHashid tid ltkhid <- encodeKeyHashid ltid
summary <- summary <-
TextHtml . TL.toStrict . renderHtml <$> TextHtml . TL.toStrict . renderHtml <$>
withUrlRenderer withUrlRenderer
@ -821,7 +813,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
<a href=@{ProjectR shrProject prjProject}> <a href=@{ProjectR shrProject prjProject}>
./s/#{shr2text shrProject}/p/#{prj2text prjProject} ./s/#{shr2text shrProject}/p/#{prj2text prjProject}
: # : #
<a href=@{TicketR shrProject prjProject tkhid}> <a href=@{TicketR shrProject prjProject ltkhid}>
#{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}. #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
|] |]
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
@ -846,7 +838,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
{ acceptObject = ObjURI hLocal luOffer { acceptObject = ObjURI hLocal luOffer
, acceptResult = , acceptResult =
Just $ encodeRouteLocal $ Just $ encodeRouteLocal $
TicketR shrProject prjProject tkhid TicketR shrProject prjProject ltkhid
} }
} }
update update
@ -870,7 +862,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
, ticketCloser = Nothing , ticketCloser = Nothing
, ticketAccept = obiidAccept , ticketAccept = obiidAccept
} }
insert_ LocalTicket ltid <- insert LocalTicket
{ localTicketTicket = tid { localTicketTicket = tid
, localTicketDiscuss = did , localTicketDiscuss = did
, localTicketFollowers = fsid , localTicketFollowers = fsid
@ -882,7 +874,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
} }
--insertMany_ $ map (TicketDependency tid) tidsDeps --insertMany_ $ map (TicketDependency tid) tidsDeps
-- insert_ $ Follow pidAuthor fsid False True -- insert_ $ Follow pidAuthor fsid False True
return tid return ltid
publishAccept pidAuthor sid jid fsid luOffer {-num-} obiid doc = do publishAccept pidAuthor sid jid fsid luOffer {-num-} obiid doc = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let dont = Authority "dont-do.any-forwarding" Nothing let dont = Authority "dont-do.any-forwarding" Nothing

2
src/Vervis/ActivityPub.hs
View file

@ -130,7 +130,7 @@ verifyHostLocal h t = do
parseContext parseContext
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> FedURI => FedURI
-> ExceptT Text m (Either (ShrIdent, PrjIdent, KeyHashid Ticket) FedURI) -> ExceptT Text m (Either (ShrIdent, PrjIdent, KeyHashid LocalTicket) FedURI)
parseContext uContext = do parseContext uContext = do
let ObjURI hContext luContext = uContext let ObjURI hContext luContext = uContext
local <- hostIsLocal hContext local <- hostIsLocal hContext

8
src/Vervis/ActivityPub/Recipient.hs
View file

@ -86,8 +86,8 @@ data LocalPersonCollection
= LocalPersonCollectionSharerFollowers ShrIdent = LocalPersonCollectionSharerFollowers ShrIdent
| LocalPersonCollectionProjectTeam ShrIdent PrjIdent | LocalPersonCollectionProjectTeam ShrIdent PrjIdent
| LocalPersonCollectionProjectFollowers ShrIdent PrjIdent | LocalPersonCollectionProjectFollowers ShrIdent PrjIdent
| LocalPersonCollectionTicketTeam ShrIdent PrjIdent (KeyHashid Ticket) | LocalPersonCollectionTicketTeam ShrIdent PrjIdent (KeyHashid LocalTicket)
| LocalPersonCollectionTicketFollowers ShrIdent PrjIdent (KeyHashid Ticket) | LocalPersonCollectionTicketFollowers ShrIdent PrjIdent (KeyHashid LocalTicket)
| LocalPersonCollectionRepoTeam ShrIdent RpIdent | LocalPersonCollectionRepoTeam ShrIdent RpIdent
| LocalPersonCollectionRepoFollowers ShrIdent RpIdent | LocalPersonCollectionRepoFollowers ShrIdent RpIdent
@ -133,7 +133,7 @@ data LocalProjectRecipientDirect
data LocalProjectRecipient data LocalProjectRecipient
= LocalProjectDirect LocalProjectRecipientDirect = LocalProjectDirect LocalProjectRecipientDirect
| LocalTicketRelated (KeyHashid Ticket) LocalTicketRecipientDirect | LocalTicketRelated (KeyHashid LocalTicket) LocalTicketRecipientDirect
deriving (Eq, Ord) deriving (Eq, Ord)
data LocalRepoRecipientDirect data LocalRepoRecipientDirect
@ -222,7 +222,7 @@ data LocalProjectDirectSet = LocalProjectDirectSet
data LocalProjectRelatedSet = LocalProjectRelatedSet data LocalProjectRelatedSet = LocalProjectRelatedSet
{ localRecipProjectDirect :: LocalProjectDirectSet { localRecipProjectDirect :: LocalProjectDirectSet
, localRecipTicketRelated :: [(KeyHashid Ticket, LocalTicketDirectSet)] , localRecipTicketRelated :: [(KeyHashid LocalTicket, LocalTicketDirectSet)]
} }
deriving Eq deriving Eq

14
src/Vervis/Client.hs
View file

@ -191,7 +191,7 @@ followProject shrAuthor shrObject prjObject hide = do
followTicket followTicket
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
=> ShrIdent -> ShrIdent -> PrjIdent -> KeyHashid Ticket -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode) => ShrIdent -> ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode)
followTicket shrAuthor shrObject prjObject numObject hide = do followTicket shrAuthor shrObject prjObject numObject hide = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
let uObject = encodeRouteHome $ TicketR shrObject prjObject numObject let uObject = encodeRouteHome $ TicketR shrObject prjObject numObject
@ -333,7 +333,7 @@ undoFollowTicket
-> PersonId -> PersonId
-> ShrIdent -> ShrIdent
-> PrjIdent -> PrjIdent
-> KeyHashid Ticket -> KeyHashid LocalTicket
-> m (Either Text (TextHtml, Audience URIMode, Undo URIMode)) -> m (Either Text (TextHtml, Audience URIMode, Undo URIMode))
undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee = undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee =
undoFollow shrAuthor pidAuthor getFsid "project" objRoute recipRoute undoFollow shrAuthor pidAuthor getFsid "project" objRoute recipRoute
@ -347,14 +347,12 @@ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee =
jid <- do jid <- do
mjid <- lift $ getKeyBy $ UniqueProject prjFollowee sid mjid <- lift $ getKeyBy $ UniqueProject prjFollowee sid
fromMaybeE mjid "No such local project" fromMaybeE mjid "No such local project"
tid <- decodeKeyHashidE numFollowee "Invalid hashid for context" ltid <- decodeKeyHashidE numFollowee "Invalid hashid for context"
mt <- lift $ get tid mlt <- lift $ get ltid
t <- fromMaybeE mt "Unfollow target no such local ticket" lt <- fromMaybeE mlt "Unfollow target no such local ticket"
t <- lift $ getJust $ localTicketTicket lt
unless (ticketProject t == jid) $ unless (ticketProject t == jid) $
throwE "Hashid doesn't match sharer/project" throwE "Hashid doesn't match sharer/project"
lt <- do
mlt <- lift $ getValBy $ UniqueLocalTicket tid
fromMaybeE mlt "Unexpected, ticket doesn't have a LocalTicket!"
return $ localTicketFollowers lt return $ localTicketFollowers lt
undoFollowRepo undoFollowRepo

2
src/Vervis/Federation.hs
View file

@ -112,7 +112,7 @@ prependError t a = do
Left e -> throwE $ t <> ": " <> e Left e -> throwE $ t <> ": " <> e
Right x -> return x Right x -> return x
parseTicket :: Monad m => (ShrIdent, PrjIdent) -> LocalURI -> ExceptT Text m (KeyHashid Ticket) parseTicket :: Monad m => (ShrIdent, PrjIdent) -> LocalURI -> ExceptT Text m (KeyHashid LocalTicket)
parseTicket project luContext = do parseTicket project luContext = do
route <- case decodeRouteLocal luContext of route <- case decodeRouteLocal luContext of
Nothing -> throwE "Local context isn't a valid route" Nothing -> throwE "Local context isn't a valid route"

29
src/Vervis/Federation/Discussion.hs
View file

@ -103,18 +103,14 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
where where
checkContextParent context mparent = runExceptT $ do checkContextParent context mparent = runExceptT $ do
case context of case context of
Left (shr, prj, tkhid) -> do Left (shr, prj, ltkhid) -> do
mdid <- lift $ runMaybeT $ do mdid <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
jid <- MaybeT $ getKeyBy $ UniqueProject prj sid jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
tid <- decodeKeyHashidM tkhid ltid <- decodeKeyHashidM ltkhid
t <- MaybeT $ get tid lt <- MaybeT $ get ltid
t <- lift $ getJust $ localTicketTicket lt
guard $ ticketProject t == jid guard $ ticketProject t == jid
lt <- lift $ do
mlt <- getValBy $ UniqueLocalTicket tid
case mlt of
Nothing -> error "No LocalTicket"
Just lt -> return lt
return $ localTicketDiscuss lt return $ localTicketDiscuss lt
did <- fromMaybeE mdid "Context: No such local ticket" did <- fromMaybeE mdid "Context: No such local ticket"
for_ mparent $ \ parent -> for_ mparent $ \ parent ->
@ -196,17 +192,17 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
else Just <$> parseParent uParent else Just <$> parseParent uParent
case context of case context of
Right _ -> return $ recip <> " not using; context isn't local" Right _ -> return $ recip <> " not using; context isn't local"
Left (shr, prj, tkhid) -> Left (shr, prj, ltkhid) ->
if shr /= shrRecip || prj /= prjRecip if shr /= shrRecip || prj /= prjRecip
then return $ recip <> " not using; context is a different project" then return $ recip <> " not using; context is a different project"
else do else do
msig <- checkForward shrRecip prjRecip msig <- checkForward shrRecip prjRecip
hLocal <- getsYesod $ appInstanceHost . appSettings hLocal <- getsYesod $ appInstanceHost . appSettings
let colls = let colls =
findRelevantCollections hLocal tkhid $ findRelevantCollections hLocal ltkhid $
activityAudience $ actbActivity body activityAudience $ actbActivity body
mremotesHttp <- runDBExcept $ do mremotesHttp <- runDBExcept $ do
(sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent tkhid mparent (sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent ltkhid mparent
lift $ join <$> do lift $ join <$> do
mmid <- insertToDiscussion luCreate luNote published ibid did meparent fsidTicket mmid <- insertToDiscussion luCreate luNote published ibid did meparent fsidTicket
for mmid $ \ (ractid, mid) -> do for mmid $ \ (ractid, mid) -> do
@ -238,17 +234,16 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
-> Just CreateNoteRecipTicketTeam -> Just CreateNoteRecipTicketTeam
_ -> Nothing _ -> Nothing
recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip] recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
getContextAndParent tkhid mparent = do getContextAndParent ltkhid mparent = do
mt <- do mt <- do
sid <- lift $ getKeyBy404 $ UniqueSharer shrRecip sid <- lift $ getKeyBy404 $ UniqueSharer shrRecip
Entity jid j <- lift $ getBy404 $ UniqueProject prjRecip sid Entity jid j <- lift $ getBy404 $ UniqueProject prjRecip sid
tid <- decodeKeyHashidE tkhid "Context: Not a valid ticket khid" ltid <- decodeKeyHashidE ltkhid "Context: Not a valid ticket khid"
mt <- lift $ get tid mlt <- lift $ get ltid
for mt $ \ t -> do for mlt $ \ lt -> do
t <- lift $ getJust $ localTicketTicket lt
unless (ticketProject t == jid) $ unless (ticketProject t == jid) $
throwE "Context: Local ticket khid belongs to different project" throwE "Context: Local ticket khid belongs to different project"
mlt <- lift $ getValBy $ UniqueLocalTicket tid
lt <- fromMaybeE mlt "No LocalTicket"
return (jid, projectInbox j, projectFollowers j, sid ,t, lt) return (jid, projectInbox j, projectFollowers j, sid ,t, lt)
(jid, ibid, fsidProject, sid, _t, lt) <- fromMaybeE mt "Context: No such local ticket" (jid, ibid, fsidProject, sid, _t, lt) <- fromMaybeE mt "Context: No such local ticket"
let did = localTicketDiscuss lt let did = localTicketDiscuss lt

14
src/Vervis/Federation/Offer.hs
View file

@ -383,17 +383,15 @@ projectFollowF shr prj =
| shr == shr' && prj == prj' = Just $ Just num | shr == shr' && prj == prj' = Just $ Just num
objRoute _ = Nothing objRoute _ = Nothing
getRecip mtkhid = do getRecip mltkhid = do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
Entity jid j <- getBy404 $ UniqueProject prj sid Entity jid j <- getBy404 $ UniqueProject prj sid
mt <- for mtkhid $ \ tkhid -> do mt <- for mltkhid $ \ ltkhid -> do
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
t <- get404 tid lt <- get404 ltid
t <- getJust $ localTicketTicket lt
unless (ticketProject t == jid) notFound unless (ticketProject t == jid) notFound
mlt <- getValBy $ UniqueLocalTicket tid return lt
case mlt of
Nothing -> error "No LocalTicket"
Just lt -> return lt
return (j, mt) return (j, mt)
followers (j, Nothing) = projectFollowers j followers (j, Nothing) = projectFollowers j

12
src/Vervis/Federation/Ticket.hs
View file

@ -275,7 +275,7 @@ projectOfferTicketF
, ticketCloser = Nothing , ticketCloser = Nothing
, ticketAccept = obiidAccept , ticketAccept = obiidAccept
} }
insert_ LocalTicket ltid <- insert LocalTicket
{ localTicketTicket = tid { localTicketTicket = tid
, localTicketDiscuss = did , localTicketDiscuss = did
, localTicketFollowers = fsid , localTicketFollowers = fsid
@ -285,7 +285,7 @@ projectOfferTicketF
, ticketAuthorRemoteAuthor = raidAuthor , ticketAuthorRemoteAuthor = raidAuthor
, ticketAuthorRemoteOffer = ractid , ticketAuthorRemoteOffer = ractid
} }
docAccept <- insertAccept ra luOffer tid obiidAccept docAccept <- insertAccept ra luOffer ltid obiidAccept
-- insertMany_ $ map (TicketDependency tid) deps -- insertMany_ $ map (TicketDependency tid) deps
--insert_ $ RemoteFollow raidAuthor fsid False True --insert_ $ RemoteFollow raidAuthor fsid False True
return $ Just (ractid, obiidAccept, docAccept) return $ Just (ractid, obiidAccept, docAccept)
@ -315,9 +315,9 @@ projectOfferTicketF
delete ibiid delete ibiid
return remotes return remotes
insertAccept ra luOffer tid obiid = do insertAccept ra luOffer ltid obiid = do
let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI author let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI author
tkhid <- encodeKeyHashid tid ltkhid <- encodeKeyHashid ltid
summary <- summary <-
TextHtml . TL.toStrict . renderHtml <$> TextHtml . TL.toStrict . renderHtml <$>
withUrlRenderer withUrlRenderer
@ -332,7 +332,7 @@ projectOfferTicketF
<a href=@{ProjectR shrRecip prjRecip}> <a href=@{ProjectR shrRecip prjRecip}>
./s/#{shr2text shrRecip}/p/#{prj2text prjRecip} ./s/#{shr2text shrRecip}/p/#{prj2text prjRecip}
\: # \: #
<a href=@{TicketR shrRecip prjRecip tkhid}> <a href=@{TicketR shrRecip prjRecip ltkhid}>
#{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}. #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
|] |]
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
@ -360,7 +360,7 @@ projectOfferTicketF
luOffer luOffer
, acceptResult = , acceptResult =
Just $ encodeRouteLocal $ Just $ encodeRouteLocal $
TicketR shrRecip prjRecip tkhid TicketR shrRecip prjRecip ltkhid
} }
} }
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]

2
src/Vervis/Foundation.hs
View file

@ -138,7 +138,7 @@ type OutboxItemKeyHashid = KeyHashid OutboxItem
type SshKeyKeyHashid = KeyHashid SshKey type SshKeyKeyHashid = KeyHashid SshKey
type MessageKeyHashid = KeyHashid Message type MessageKeyHashid = KeyHashid Message
type LocalMessageKeyHashid = KeyHashid LocalMessage type LocalMessageKeyHashid = KeyHashid LocalMessage
type TicketKeyHashid = KeyHashid Ticket type LocalTicketKeyHashid = KeyHashid LocalTicket
type TicketDepKeyHashid = KeyHashid TicketDependency type TicketDepKeyHashid = KeyHashid TicketDependency
-- This is where we define all of the routes in our application. For a full -- This is where we define all of the routes in our application. For a full

29
src/Vervis/Handler/Client.hs
View file

@ -123,7 +123,7 @@ fedUriField = Field
} }
ticketField ticketField
:: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent, KeyHashid Ticket) :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent, KeyHashid LocalTicket)
ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
where where
toTicket uTicket = runExceptT $ do toTicket uTicket = runExceptT $ do
@ -154,7 +154,7 @@ projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField
fromProject (h, shr, prj) = ObjURI h $ encodeRouteLocal $ ProjectR shr prj fromProject (h, shr, prj) = ObjURI h $ encodeRouteLocal $ ProjectR shr prj
publishCommentForm publishCommentForm
:: Form ((Host, ShrIdent, PrjIdent, KeyHashid Ticket), Maybe FedURI, Text) :: Form ((Host, ShrIdent, PrjIdent, KeyHashid LocalTicket), Maybe FedURI, Text)
publishCommentForm html = do publishCommentForm html = do
enc <- getEncodeRouteLocal enc <- getEncodeRouteLocal
defk <- encodeKeyHashid $ E.toSqlKey 1 defk <- encodeKeyHashid $ E.toSqlKey 1
@ -448,7 +448,7 @@ postProjectFollowR shrObject prjObject = do
setFollowMessage shrAuthor eid setFollowMessage shrAuthor eid
redirect $ ProjectR shrObject prjObject redirect $ ProjectR shrObject prjObject
postTicketFollowR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler () postTicketFollowR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler ()
postTicketFollowR shrObject prjObject tkhidObject = do postTicketFollowR shrObject prjObject tkhidObject = do
shrAuthor <- getUserShrIdent shrAuthor <- getUserShrIdent
(summary, audience, follow) <- followTicket shrAuthor shrObject prjObject tkhidObject False (summary, audience, follow) <- followTicket shrAuthor shrObject prjObject tkhidObject False
@ -495,7 +495,7 @@ postProjectUnfollowR shrFollowee prjFollowee = do
setUnfollowMessage shrAuthor eid setUnfollowMessage shrAuthor eid
redirect $ ProjectR shrFollowee prjFollowee redirect $ ProjectR shrFollowee prjFollowee
postTicketUnfollowR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler () postTicketUnfollowR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler ()
postTicketUnfollowR shrFollowee prjFollowee tkhidFollowee = do postTicketUnfollowR shrFollowee prjFollowee tkhidFollowee = do
(shrAuthor, pidAuthor) <- getUser (shrAuthor, pidAuthor) <- getUser
eid <- runExceptT $ do eid <- runExceptT $ do
@ -667,7 +667,7 @@ postTicketsR shr prj = do
Entity _ p <- requireVerifiedAuth Entity _ p <- requireVerifiedAuth
runDB $ sharerIdent <$> getJust (personIdent p) runDB $ sharerIdent <$> getJust (personIdent p)
etid <- runExceptT $ do eltid <- runExceptT $ do
NewTicket title desc tparams eparams cparams <- NewTicket title desc tparams eparams cparams <-
case result of case result of
FormMissing -> throwE "Field(s) missing." FormMissing -> throwE "Field(s) missing."
@ -701,18 +701,23 @@ postTicketsR shr prj = do
Left Left
"Offer processed successfully but no ticket \ "Offer processed successfully but no ticket \
\created" \created"
Just tal -> Just tal -> do
return $ Right $ ticketAuthorLocalTicket tal let tid = ticketAuthorLocalTicket tal
case etid of mltid <- getKeyBy $ UniqueLocalTicket tid
return $
case mltid of
Nothing -> Left "Weird, no LocalTicket created"
Just ltid -> Right ltid
case eltid of
Left e -> do Left e -> do
setMessage $ toHtml e setMessage $ toHtml e
defaultLayout $(widgetFile "ticket/new") defaultLayout $(widgetFile "ticket/new")
Right tid -> do Right ltid -> do
tkhid <- encodeKeyHashid tid ltkhid <- encodeKeyHashid ltid
eobiidFollow <- runExceptT $ do eobiidFollow <- runExceptT $ do
(summary, audience, follow) <- followTicket shrAuthor shr prj tkhid False (summary, audience, follow) <- followTicket shrAuthor shr prj ltkhid False
ExceptT $ followC shrAuthor summary audience follow ExceptT $ followC shrAuthor summary audience follow
case eobiidFollow of case eobiidFollow of
Left e -> setMessage $ toHtml $ "Ticket created, but following it failed: " <> e Left e -> setMessage $ toHtml $ "Ticket created, but following it failed: " <> e
Right _ -> setMessage "Ticket created." Right _ -> setMessage "Ticket created."
redirect $ TicketR shr prj tkhid redirect $ TicketR shr prj ltkhid

8
src/Vervis/Handler/Discussion.hs
View file

@ -128,20 +128,20 @@ getDiscussionMessage shr lmid = do
route2fed <- getEncodeRouteHome route2fed <- getEncodeRouteHome
uContext <- do uContext <- do
let did = messageRoot m let did = messageRoot m
mlt <- getValBy $ UniqueLocalTicketDiscussion did mlt <- getBy $ UniqueLocalTicketDiscussion did
mrd <- getValBy $ UniqueRemoteDiscussion did mrd <- getValBy $ UniqueRemoteDiscussion did
case (mlt, mrd) of case (mlt, mrd) of
(Nothing, Nothing) -> fail $ "DiscussionId #" ++ show did ++ " has no context" (Nothing, Nothing) -> fail $ "DiscussionId #" ++ show did ++ " has no context"
(Just _, Just _) -> fail $ "DiscussionId #" ++ show did ++ " has both ticket and remote contexts" (Just _, Just _) -> fail $ "DiscussionId #" ++ show did ++ " has both ticket and remote contexts"
(Just lt, Nothing) -> do (Just (Entity ltid lt), Nothing) -> do
let tid = localTicketTicket lt let tid = localTicketTicket lt
t <- getJust tid t <- getJust tid
j <- getJust $ ticketProject t j <- getJust $ ticketProject t
s <- getJust $ projectSharer j s <- getJust $ projectSharer j
let shr = sharerIdent s let shr = sharerIdent s
prj = projectIdent j prj = projectIdent j
tkhid <- encodeKeyHashid tid ltkhid <- encodeKeyHashid ltid
return $ route2fed $ TicketR shr prj tkhid return $ route2fed $ TicketR shr prj ltkhid
(Nothing, Just rd) -> do (Nothing, Just rd) -> do
i <- getJust $ remoteDiscussionInstance rd i <- getJust $ remoteDiscussionInstance rd
return $ ObjURI (instanceHost i) (remoteDiscussionIdent rd) return $ ObjURI (instanceHost i) (remoteDiscussionIdent rd)

10
src/Vervis/Handler/Sharer.hs
View file

@ -145,14 +145,14 @@ getSharerFollowingR shr = do
return (s E.^. SharerIdent, j E.^. ProjectIdent) return (s E.^. SharerIdent, j E.^. ProjectIdent)
return $ map (\ (E.Value shr, E.Value prj) -> ProjectR shr prj) pairs return $ map (\ (E.Value shr, E.Value prj) -> ProjectR shr prj) pairs
getTickets fsids = do getTickets fsids = do
lts <- selectList [LocalTicketFollowers <-. fsids] [] ltids <- selectKeysList [LocalTicketFollowers <-. fsids] []
let tids = map (localTicketTicket . entityVal) lts triples <- E.select $ E.from $ \ (lt `E.InnerJoin` t `E.InnerJoin` j `E.InnerJoin` s) -> do
triples <- E.select $ E.from $ \ (t `E.InnerJoin` j `E.InnerJoin` s) -> do
E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId E.on $ j E.^. ProjectSharer E.==. s E.^. SharerId
E.on $ t E.^. TicketProject E.==. j E.^. ProjectId E.on $ t E.^. TicketProject E.==. j E.^. ProjectId
E.where_ $ t E.^. TicketId `E.in_` E.valList tids E.on $ lt E.^. LocalTicketTicket E.==. t E.^. TicketId
E.where_ $ lt E.^. LocalTicketId `E.in_` E.valList ltids
return return
(s E.^. SharerIdent, j E.^. ProjectIdent, t E.^. TicketId) (s E.^. SharerIdent, j E.^. ProjectIdent, lt E.^. LocalTicketId)
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
return $ return $
map (\ (E.Value shr, E.Value prj, E.Value tid) -> TicketR shr prj $ encodeHid tid) map (\ (E.Value shr, E.Value prj, E.Value tid) -> TicketR shr prj $ encodeHid tid)

430
src/Vervis/Handler/Ticket.hs
View file

@ -161,7 +161,9 @@ getTicketsR shr prj = selectRep $ do
Entity sid _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid Entity jid _ <- getBy404 $ UniqueProject prj sid
let countAllTickets = count [TicketProject ==. jid] let countAllTickets = count [TicketProject ==. jid]
selectTickets off lim = selectList [TicketProject ==. jid] [Desc TicketId, OffsetBy off, LimitTo lim] selectTickets off lim = do
tids <- selectKeysList [TicketProject ==. jid] [Desc TicketId, OffsetBy off, LimitTo lim]
selectKeysList [LocalTicketTicket <-. tids] [Desc LocalTicketTicket]
getPageAndNavCount countAllTickets selectTickets getPageAndNavCount countAllTickets selectTickets
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
@ -203,8 +205,7 @@ getTicketsR shr prj = selectRep $ do
else Nothing else Nothing
, collectionPageStartIndex = Nothing , collectionPageStartIndex = Nothing
, collectionPageItems = , collectionPageItems =
map (encodeRouteHome . ticketUrl . entityKey) map (encodeRouteHome . ticketUrl) tickets
tickets
} }
where where
here = TicketsR shr prj here = TicketsR shr prj
@ -228,8 +229,8 @@ getTicketNewR shr prj = do
((_result, widget), enctype) <- runFormPost $ newTicketForm wid ((_result, widget), enctype) <- runFormPost $ newTicketForm wid
defaultLayout $(widgetFile "ticket/new") defaultLayout $(widgetFile "ticket/new")
getTicketR :: ShrIdent -> PrjIdent -> TicketKeyHashid -> Handler TypedContent getTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketR shar proj khid = do getTicketR shar proj ltkhid = do
mpid <- maybeAuthId mpid <- maybeAuthId
( wshr, wfl, ( wshr, wfl,
author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams, author, massignee, mcloser, ticket, lticket, tparams, eparams, cparams,
@ -249,14 +250,11 @@ getTicketR shar proj khid = do
, projectWorkflow project , projectWorkflow project
, workflowIdent w , workflowIdent w
) )
tid <- decodeKeyHashid404 khid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == jid) notFound unless (ticketProject ticket == jid) notFound
lticket <- do
mlt <- getValBy $ UniqueLocalTicket tid
case mlt of
Nothing -> error "No LocalTicket"
Just lt -> return lt
author <- author <-
requireEitherAlt requireEitherAlt
(do mtal <- getValBy $ UniqueTicketAuthorLocal tid (do mtal <- getValBy $ UniqueTicketAuthorLocal tid
@ -292,14 +290,16 @@ getTicketR shar proj khid = do
tparams <- getTicketTextParams tid wid tparams <- getTicketTextParams tid wid
eparams <- getTicketEnumParams tid wid eparams <- getTicketEnumParams tid wid
cparams <- getTicketClasses tid wid cparams <- getTicketClasses tid wid
deps <- E.select $ E.from $ \ (dep `E.InnerJoin` t) -> do deps <- E.select $ E.from $ \ (dep `E.InnerJoin` t `E.InnerJoin` lt) -> do
E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
E.on $ dep E.^. TicketDependencyChild E.==. t E.^. TicketId E.on $ dep E.^. TicketDependencyChild E.==. t E.^. TicketId
E.where_ $ dep E.^. TicketDependencyParent E.==. E.val tid E.where_ $ dep E.^. TicketDependencyParent E.==. E.val tid
return t return (lt E.^. LocalTicketId, t)
rdeps <- E.select $ E.from $ \ (dep `E.InnerJoin` t) -> do rdeps <- E.select $ E.from $ \ (dep `E.InnerJoin` t `E.InnerJoin` lt) -> do
E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
E.on $ dep E.^. TicketDependencyParent E.==. t E.^. TicketId E.on $ dep E.^. TicketDependencyParent E.==. t E.^. TicketId
E.where_ $ dep E.^. TicketDependencyChild E.==. E.val tid E.where_ $ dep E.^. TicketDependencyChild E.==. E.val tid
return t return (lt E.^. LocalTicketId, t)
return return
( wshr, wfl ( wshr, wfl
, author, massignee, mcloser, ticket, lticket , author, massignee, mcloser, ticket, lticket
@ -312,8 +312,8 @@ getTicketR shar proj khid = do
discuss = discuss =
discussionW discussionW
(return $ localTicketDiscuss lticket) (return $ localTicketDiscuss lticket)
(TicketTopReplyR shar proj khid) (TicketTopReplyR shar proj ltkhid)
(TicketReplyR shar proj khid . encodeHid) (TicketReplyR shar proj ltkhid . encodeHid)
cRelevant <- newIdent cRelevant <- newIdent
cIrrelevant <- newIdent cIrrelevant <- newIdent
let relevant filt = let relevant filt =
@ -334,21 +334,21 @@ getTicketR shar proj khid = do
( hLocal ( hLocal
, AP.TicketLocal , AP.TicketLocal
{ AP.ticketId = { AP.ticketId =
encodeRouteLocal $ TicketR shar proj khid encodeRouteLocal $ TicketR shar proj ltkhid
, AP.ticketContext = , AP.ticketContext =
encodeRouteLocal $ ProjectR shar proj encodeRouteLocal $ ProjectR shar proj
, AP.ticketReplies = , AP.ticketReplies =
encodeRouteLocal $ TicketDiscussionR shar proj khid encodeRouteLocal $ TicketDiscussionR shar proj ltkhid
, AP.ticketParticipants = , AP.ticketParticipants =
encodeRouteLocal $ TicketParticipantsR shar proj khid encodeRouteLocal $ TicketParticipantsR shar proj ltkhid
, AP.ticketTeam = , AP.ticketTeam =
encodeRouteLocal $ TicketTeamR shar proj khid encodeRouteLocal $ TicketTeamR shar proj ltkhid
, AP.ticketEvents = , AP.ticketEvents =
encodeRouteLocal $ TicketEventsR shar proj khid encodeRouteLocal $ TicketEventsR shar proj ltkhid
, AP.ticketDeps = , AP.ticketDeps =
encodeRouteLocal $ TicketDepsR shar proj khid encodeRouteLocal $ TicketDepsR shar proj ltkhid
, AP.ticketReverseDeps = , AP.ticketReverseDeps =
encodeRouteLocal $ TicketReverseDepsR shar proj khid encodeRouteLocal $ TicketReverseDepsR shar proj ltkhid
} }
) )
@ -371,18 +371,20 @@ getTicketR shar proj khid = do
provideHtmlAndAP' host ticketAP $ provideHtmlAndAP' host ticketAP $
let followButton = let followButton =
followW followW
(TicketFollowR shar proj khid) (TicketFollowR shar proj ltkhid)
(TicketUnfollowR shar proj khid) (TicketUnfollowR shar proj ltkhid)
(return $ localTicketFollowers lticket) (return $ localTicketFollowers lticket)
in $(widgetFile "ticket/one") in $(widgetFile "ticket/one")
putTicketR :: ShrIdent -> PrjIdent -> TicketKeyHashid -> Handler Html putTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
putTicketR shr prj tkhid = do putTicketR shr prj ltkhid = do
(tid, ticket, wid) <- runDB $ do (tid, ticket, wid) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shr Entity sid _sharer <- getBy404 $ UniqueSharer shr
Entity pid project <- getBy404 $ UniqueProject prj sid Entity pid project <- getBy404 $ UniqueProject prj sid
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == pid) notFound unless (ticketProject ticket == pid) notFound
return (tid, ticket, projectWorkflow project) return (tid, ticket, projectWorkflow project)
((result, widget), enctype) <- ((result, widget), enctype) <-
@ -393,7 +395,7 @@ putTicketR shr prj tkhid = do
case renderPandocMarkdown $ ticketSource ticket' of case renderPandocMarkdown $ ticketSource ticket' of
Left err -> do Left err -> do
setMessage $ toHtml err setMessage $ toHtml err
redirect $ TicketEditR shr prj tkhid redirect $ TicketEditR shr prj ltkhid
Right t -> return t Right t -> return t
let ticket'' = ticket' { ticketDescription = newDescHtml } let ticket'' = ticket' { ticketDescription = newDescHtml }
runDB $ do runDB $ do
@ -432,7 +434,7 @@ putTicketR shr prj tkhid = do
} }
insertMany_ $ map mkcparam cins insertMany_ $ map mkcparam cins
setMessage "Ticket updated." setMessage "Ticket updated."
redirect $ TicketR shr prj tkhid redirect $ TicketR shr prj ltkhid
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing." setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/edit") defaultLayout $(widgetFile "ticket/edit")
@ -440,41 +442,46 @@ putTicketR shr prj tkhid = do
setMessage "Ticket update failed, see errors below." setMessage "Ticket update failed, see errors below."
defaultLayout $(widgetFile "ticket/edit") defaultLayout $(widgetFile "ticket/edit")
deleteTicketR :: ShrIdent -> PrjIdent -> TicketKeyHashid -> Handler Html deleteTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
deleteTicketR _shr _prj _tkhid = deleteTicketR _shr _prj _ltkhid =
--TODO: I can easily implement this, but should it even be possible to --TODO: I can easily implement this, but should it even be possible to
--delete tickets? --delete tickets?
error "Not implemented" error "Not implemented"
postTicketR :: ShrIdent -> PrjIdent -> TicketKeyHashid -> Handler Html postTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketR shr prj tkhid = do postTicketR shr prj ltkhid = do
mmethod <- lookupPostParam "_method" mmethod <- lookupPostParam "_method"
case mmethod of case mmethod of
Just "PUT" -> putTicketR shr prj tkhid Just "PUT" -> putTicketR shr prj ltkhid
Just "DELETE" -> deleteTicketR shr prj tkhid Just "DELETE" -> deleteTicketR shr prj ltkhid
_ -> notFound _ -> notFound
getTicketEditR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html getTicketEditR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTicketEditR shr prj tkhid = do getTicketEditR shr prj ltkhid = do
(tid, ticket, wid) <- runDB $ do (tid, ticket, wid) <- runDB $ do
Entity sid _sharer <- getBy404 $ UniqueSharer shr Entity sid _sharer <- getBy404 $ UniqueSharer shr
Entity pid project <- getBy404 $ UniqueProject prj sid Entity pid project <- getBy404 $ UniqueProject prj sid
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == pid) notFound unless (ticketProject ticket == pid) notFound
return (tid, ticket, projectWorkflow project) return (tid, ticket, projectWorkflow project)
((_result, widget), enctype) <- ((_result, widget), enctype) <-
runFormPost $ editTicketContentForm tid ticket wid runFormPost $ editTicketContentForm tid ticket wid
defaultLayout $(widgetFile "ticket/edit") defaultLayout $(widgetFile "ticket/edit")
postTicketAcceptR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html postTicketAcceptR
postTicketAcceptR shr prj tkhid = do :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketAcceptR shr prj ltkhid = do
succ <- runDB $ do succ <- runDB $ do
Entity tid ticket <- do Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s Entity p _ <- getBy404 $ UniqueProject prj s
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == p) notFound unless (ticketProject ticket == p) notFound
return $ Entity tid ticket return $ Entity tid ticket
case ticketStatus ticket of case ticketStatus ticket of
@ -486,18 +493,21 @@ postTicketAcceptR shr prj tkhid = do
if succ if succ
then "Ticket accepted." then "Ticket accepted."
else "Ticket is already accepted." else "Ticket is already accepted."
redirect $ TicketR shr prj tkhid redirect $ TicketR shr prj ltkhid
postTicketCloseR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html postTicketCloseR
postTicketCloseR shr prj tkhid = do :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketCloseR shr prj ltkhid = do
pid <- requireAuthId pid <- requireAuthId
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
succ <- runDB $ do succ <- runDB $ do
Entity tid ticket <- do Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s Entity p _ <- getBy404 $ UniqueProject prj s
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == p) notFound unless (ticketProject ticket == p) notFound
return $ Entity tid ticket return $ Entity tid ticket
case ticketStatus ticket of case ticketStatus ticket of
@ -514,18 +524,21 @@ postTicketCloseR shr prj tkhid = do
if succ if succ
then "Ticket closed." then "Ticket closed."
else "Ticket is already closed." else "Ticket is already closed."
redirect $ TicketR shr prj tkhid redirect $ TicketR shr prj ltkhid
postTicketOpenR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html postTicketOpenR
postTicketOpenR shr prj tkhid = do :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketOpenR shr prj ltkhid = do
pid <- requireAuthId pid <- requireAuthId
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
succ <- runDB $ do succ <- runDB $ do
Entity tid ticket <- do Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s Entity p _ <- getBy404 $ UniqueProject prj s
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == p) notFound unless (ticketProject ticket == p) notFound
return $ Entity tid ticket return $ Entity tid ticket
case ticketStatus ticket of case ticketStatus ticket of
@ -540,17 +553,20 @@ postTicketOpenR shr prj tkhid = do
if succ if succ
then "Ticket reopened" then "Ticket reopened"
else "Ticket is already open." else "Ticket is already open."
redirect $ TicketR shr prj tkhid redirect $ TicketR shr prj ltkhid
postTicketClaimR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html postTicketClaimR
postTicketClaimR shr prj tkhid = do :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketClaimR shr prj ltkhid = do
pid <- requireAuthId pid <- requireAuthId
mmsg <- runDB $ do mmsg <- runDB $ do
Entity tid ticket <- do Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s Entity p _ <- getBy404 $ UniqueProject prj s
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == p) notFound unless (ticketProject ticket == p) notFound
return $ Entity tid ticket return $ Entity tid ticket
case (ticketStatus ticket, ticketAssignee ticket) of case (ticketStatus ticket, ticketAssignee ticket) of
@ -567,17 +583,20 @@ postTicketClaimR shr prj tkhid = do
update tid [TicketAssignee =. Just pid] update tid [TicketAssignee =. Just pid]
return Nothing return Nothing
setMessage $ fromMaybe "The ticket is now assigned to you." mmsg setMessage $ fromMaybe "The ticket is now assigned to you." mmsg
redirect $ TicketR shr prj tkhid redirect $ TicketR shr prj ltkhid
postTicketUnclaimR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html postTicketUnclaimR
postTicketUnclaimR shr prj tkhid = do :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketUnclaimR shr prj ltkhid = do
pid <- requireAuthId pid <- requireAuthId
mmsg <- runDB $ do mmsg <- runDB $ do
Entity tid ticket <- do Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s Entity p _ <- getBy404 $ UniqueProject prj s
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == p) notFound unless (ticketProject ticket == p) notFound
return $ Entity tid ticket return $ Entity tid ticket
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
@ -597,21 +616,24 @@ postTicketUnclaimR shr prj tkhid = do
update tid [TicketAssignee =. Nothing] update tid [TicketAssignee =. Nothing]
return Nothing return Nothing
setMessage $ fromMaybe "The ticket is now unassigned." mmsg setMessage $ fromMaybe "The ticket is now unassigned." mmsg
redirect $ TicketR shr prj tkhid redirect $ TicketR shr prj ltkhid
getTicketAssignR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html getTicketAssignR
getTicketAssignR shr prj tkhid = do :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTicketAssignR shr prj ltkhid = do
vpid <- requireAuthId vpid <- requireAuthId
(jid, Entity tid ticket) <- runDB $ do (jid, Entity tid ticket) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject prj s Entity j _ <- getBy404 $ UniqueProject prj s
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == j) notFound unless (ticketProject ticket == j) notFound
return (j, Entity tid ticket) return (j, Entity tid ticket)
let msg t = do let msg t = do
setMessage t setMessage t
redirect $ TicketR shr prj tkhid redirect $ TicketR shr prj ltkhid
case (ticketStatus ticket, ticketAssignee ticket) of case (ticketStatus ticket, ticketAssignee ticket) of
(TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it." (TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it."
(TSClosed, _) -> msg "The ticket is closed. Can’t assign it." (TSClosed, _) -> msg "The ticket is closed. Can’t assign it."
@ -621,19 +643,22 @@ getTicketAssignR shr prj tkhid = do
runFormPost $ assignTicketForm vpid jid runFormPost $ assignTicketForm vpid jid
defaultLayout $(widgetFile "ticket/assign") defaultLayout $(widgetFile "ticket/assign")
postTicketAssignR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html postTicketAssignR
postTicketAssignR shr prj tkhid = do :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketAssignR shr prj ltkhid = do
vpid <- requireAuthId vpid <- requireAuthId
(jid, Entity tid ticket) <- runDB $ do (jid, Entity tid ticket) <- runDB $ do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject prj s Entity j _ <- getBy404 $ UniqueProject prj s
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == j) notFound unless (ticketProject ticket == j) notFound
return (j, Entity tid ticket) return (j, Entity tid ticket)
let msg t = do let msg t = do
setMessage t setMessage t
redirect $ TicketR shr prj tkhid redirect $ TicketR shr prj ltkhid
case (ticketStatus ticket, ticketAssignee ticket) of case (ticketStatus ticket, ticketAssignee ticket) of
(TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it." (TSNew, _) -> msg "The ticket isn’t accepted yet. Can’t assign it."
(TSClosed, _) -> msg "The ticket is closed. Can’t assign it." (TSClosed, _) -> msg "The ticket is closed. Can’t assign it."
@ -657,15 +682,18 @@ postTicketAssignR shr prj tkhid = do
setMessage "Ticket assignment failed, see errors below." setMessage "Ticket assignment failed, see errors below."
defaultLayout $(widgetFile "ticket/assign") defaultLayout $(widgetFile "ticket/assign")
postTicketUnassignR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html postTicketUnassignR
postTicketUnassignR shr prj tkhid = do :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketUnassignR shr prj ltkhid = do
pid <- requireAuthId pid <- requireAuthId
mmsg <- runDB $ do mmsg <- runDB $ do
Entity tid ticket <- do Entity tid ticket <- do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity p _ <- getBy404 $ UniqueProject prj s Entity p _ <- getBy404 $ UniqueProject prj s
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == p) notFound unless (ticketProject ticket == p) notFound
return $ Entity tid ticket return $ Entity tid ticket
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
@ -685,7 +713,7 @@ postTicketUnassignR shr prj tkhid = do
update tid [TicketAssignee =. Nothing] update tid [TicketAssignee =. Nothing]
return Nothing return Nothing
setMessage $ fromMaybe "The ticket is now unassigned." mmsg setMessage $ fromMaybe "The ticket is now unassigned." mmsg
redirect $ TicketR shr prj tkhid redirect $ TicketR shr prj ltkhid
-- | The logged-in user gets a list of the ticket claim requests they have -- | The logged-in user gets a list of the ticket claim requests they have
-- opened, in any project. -- opened, in any project.
@ -693,16 +721,17 @@ getClaimRequestsPersonR :: Handler Html
getClaimRequestsPersonR = do getClaimRequestsPersonR = do
pid <- requireAuthId pid <- requireAuthId
rqs <- runDB $ E.select $ E.from $ rqs <- runDB $ E.select $ E.from $
\ (tcr `E.InnerJoin` ticket `E.InnerJoin` project `E.InnerJoin` sharer) -> do \ (tcr `E.InnerJoin` ticket `E.InnerJoin` lticket `E.InnerJoin` project `E.InnerJoin` sharer) -> do
E.on $ project E.^. ProjectSharer E.==. sharer E.^. SharerId E.on $ project E.^. ProjectSharer E.==. sharer E.^. SharerId
E.on $ ticket E.^. TicketProject E.==. project E.^. ProjectId E.on $ ticket E.^. TicketProject E.==. project E.^. ProjectId
E.on $ ticket E.^. TicketId E.==. lticket E.^. LocalTicketTicket
E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId
E.where_ $ tcr E.^. TicketClaimRequestPerson E.==. E.val pid E.where_ $ tcr E.^. TicketClaimRequestPerson E.==. E.val pid
E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated] E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
return return
( sharer E.^. SharerIdent ( sharer E.^. SharerIdent
, project E.^. ProjectIdent , project E.^. ProjectIdent
, ticket E.^. TicketId , lticket E.^. LocalTicketId
, ticket E.^. TicketTitle , ticket E.^. TicketTitle
, tcr E.^. TicketClaimRequestCreated , tcr E.^. TicketClaimRequestCreated
) )
@ -718,17 +747,19 @@ getClaimRequestsProjectR shr prj = do
E.select $ E.from $ E.select $ E.from $
\ ( tcr `E.InnerJoin` \ ( tcr `E.InnerJoin`
ticket `E.InnerJoin` ticket `E.InnerJoin`
lticket `E.InnerJoin`
person `E.InnerJoin` person `E.InnerJoin`
sharer sharer
) -> do ) -> do
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
E.on $ ticket E.^. TicketId E.==. lticket E.^. LocalTicketTicket
E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId E.on $ tcr E.^. TicketClaimRequestTicket E.==. ticket E.^. TicketId
E.where_ $ ticket E.^. TicketProject E.==. E.val jid E.where_ $ ticket E.^. TicketProject E.==. E.val jid
E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated] E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
return return
( sharer ( sharer
, ticket E.^. TicketId , lticket E.^. LocalTicketId
, ticket E.^. TicketTitle , ticket E.^. TicketTitle
, tcr E.^. TicketClaimRequestCreated , tcr E.^. TicketClaimRequestCreated
) )
@ -737,13 +768,15 @@ getClaimRequestsProjectR shr prj = do
-- | Get a list of ticket claim requests for a given ticket. -- | Get a list of ticket claim requests for a given ticket.
getClaimRequestsTicketR getClaimRequestsTicketR
:: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getClaimRequestsTicketR shr prj tkhid = do getClaimRequestsTicketR shr prj ltkhid = do
rqs <- runDB $ do rqs <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid Entity jid _ <- getBy404 $ UniqueProject prj sid
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == jid) notFound unless (ticketProject ticket == jid) notFound
E.select $ E.from $ \ (tcr `E.InnerJoin` person `E.InnerJoin` sharer) -> do E.select $ E.from $ \ (tcr `E.InnerJoin` person `E.InnerJoin` sharer) -> do
E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId E.on $ person E.^. PersonIdent E.==. sharer E.^. SharerId
@ -753,14 +786,15 @@ getClaimRequestsTicketR shr prj tkhid = do
return (sharer, tcr) return (sharer, tcr)
defaultLayout $(widgetFile "ticket/claim-request/list") defaultLayout $(widgetFile "ticket/claim-request/list")
getClaimRequestNewR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html getClaimRequestNewR
getClaimRequestNewR shr prj tkhid = do :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getClaimRequestNewR shr prj ltkhid = do
((_result, widget), etype) <- runFormPost claimRequestForm ((_result, widget), etype) <- runFormPost claimRequestForm
defaultLayout $(widgetFile "ticket/claim-request/new") defaultLayout $(widgetFile "ticket/claim-request/new")
postClaimRequestsTicketR postClaimRequestsTicketR
:: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postClaimRequestsTicketR shr prj tkhid = do postClaimRequestsTicketR shr prj ltkhid = do
((result, widget), etype) <- runFormPost claimRequestForm ((result, widget), etype) <- runFormPost claimRequestForm
case result of case result of
FormSuccess msg -> do FormSuccess msg -> do
@ -770,8 +804,10 @@ postClaimRequestsTicketR shr prj tkhid = do
tid <- do tid <- do
Entity s _ <- getBy404 $ UniqueSharer shr Entity s _ <- getBy404 $ UniqueSharer shr
Entity j _ <- getBy404 $ UniqueProject prj s Entity j _ <- getBy404 $ UniqueProject prj s
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == j) notFound unless (ticketProject ticket == j) notFound
return tid return tid
let cr = TicketClaimRequest let cr = TicketClaimRequest
@ -782,7 +818,7 @@ postClaimRequestsTicketR shr prj tkhid = do
} }
insert_ cr insert_ cr
setMessage "Ticket claim request opened." setMessage "Ticket claim request opened."
redirect $ TicketR shr prj tkhid redirect $ TicketR shr prj ltkhid
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing." setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/claim-request/new") defaultLayout $(widgetFile "ticket/claim-request/new")
@ -791,44 +827,41 @@ postClaimRequestsTicketR shr prj tkhid = do
defaultLayout $(widgetFile "ticket/claim-request/new") defaultLayout $(widgetFile "ticket/claim-request/new")
selectDiscussionId selectDiscussionId
:: ShrIdent -> PrjIdent -> KeyHashid Ticket -> AppDB DiscussionId :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> AppDB DiscussionId
selectDiscussionId shar proj tkhid = do selectDiscussionId shr prj ltkhid = do
Entity sid _sharer <- getBy404 $ UniqueSharer shar Entity sid _sharer <- getBy404 $ UniqueSharer shr
Entity pid _project <- getBy404 $ UniqueProject proj sid Entity pid _project <- getBy404 $ UniqueProject prj sid
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == pid) notFound unless (ticketProject ticket == pid) notFound
lticket <- do
mlt <- getValBy $ UniqueLocalTicket tid
case mlt of
Nothing -> error "No LocalTicket"
Just lt -> return lt
return $ localTicketDiscuss lticket return $ localTicketDiscuss lticket
getTicketDiscussionR getTicketDiscussionR
:: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTicketDiscussionR shar proj tkhid = do getTicketDiscussionR shar proj ltkhid = do
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
getDiscussion getDiscussion
(TicketReplyR shar proj tkhid . encodeHid) (TicketReplyR shar proj ltkhid . encodeHid)
(TicketTopReplyR shar proj tkhid) (TicketTopReplyR shar proj ltkhid)
(selectDiscussionId shar proj tkhid) (selectDiscussionId shar proj ltkhid)
postTicketDiscussionR postTicketDiscussionR
:: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketDiscussionR shr prj tkhid = do postTicketDiscussionR shr prj ltkhid = do
hLocal <- getsYesod $ appInstanceHost . appSettings hLocal <- getsYesod $ appInstanceHost . appSettings
postTopReply postTopReply
hLocal hLocal
[ProjectR shr prj] [ProjectR shr prj]
[ ProjectFollowersR shr prj [ ProjectFollowersR shr prj
, TicketParticipantsR shr prj tkhid , TicketParticipantsR shr prj ltkhid
, TicketTeamR shr prj tkhid , TicketTeamR shr prj ltkhid
] ]
(TicketR shr prj tkhid) (TicketR shr prj ltkhid)
(ProjectR shr prj) (ProjectR shr prj)
(TicketDiscussionR shr prj tkhid) (TicketDiscussionR shr prj ltkhid)
(const $ TicketR shr prj tkhid) (const $ TicketR shr prj ltkhid)
getMessageR :: ShrIdent -> KeyHashid LocalMessage -> Handler TypedContent getMessageR :: ShrIdent -> KeyHashid LocalMessage -> Handler TypedContent
getMessageR shr hid = do getMessageR shr hid = do
@ -838,10 +871,10 @@ getMessageR shr hid = do
postTicketMessageR postTicketMessageR
:: ShrIdent :: ShrIdent
-> PrjIdent -> PrjIdent
-> KeyHashid Ticket -> KeyHashid LocalTicket
-> KeyHashid Message -> KeyHashid Message
-> Handler Html -> Handler Html
postTicketMessageR shr prj tkhid mkhid = do postTicketMessageR shr prj ltkhid mkhid = do
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
mid <- decodeKeyHashid404 mkhid mid <- decodeKeyHashid404 mkhid
hLocal <- getsYesod $ appInstanceHost . appSettings hLocal <- getsYesod $ appInstanceHost . appSettings
@ -849,33 +882,36 @@ postTicketMessageR shr prj tkhid mkhid = do
hLocal hLocal
[ProjectR shr prj] [ProjectR shr prj]
[ ProjectFollowersR shr prj [ ProjectFollowersR shr prj
, TicketParticipantsR shr prj tkhid , TicketParticipantsR shr prj ltkhid
, TicketTeamR shr prj tkhid , TicketTeamR shr prj ltkhid
] ]
(TicketR shr prj tkhid) (TicketR shr prj ltkhid)
(ProjectR shr prj) (ProjectR shr prj)
(TicketReplyR shr prj tkhid . encodeHid) (TicketReplyR shr prj ltkhid . encodeHid)
(TicketMessageR shr prj tkhid . encodeHid) (TicketMessageR shr prj ltkhid . encodeHid)
(const $ TicketR shr prj tkhid) (const $ TicketR shr prj ltkhid)
(selectDiscussionId shr prj tkhid) (selectDiscussionId shr prj ltkhid)
mid mid
getTicketTopReplyR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html getTicketTopReplyR
getTicketTopReplyR shar proj tkhid = :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTopReply $ TicketDiscussionR shar proj tkhid getTicketTopReplyR shr prj ltkhid =
getTopReply $ TicketDiscussionR shr prj ltkhid
getTicketReplyR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> KeyHashid Message -> Handler Html getTicketReplyR
getTicketReplyR shar proj tkhid hid = do :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid Message -> Handler Html
getTicketReplyR shr prj ltkhid mkhid = do
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
mid <- decodeKeyHashid404 hid mid <- decodeKeyHashid404 mkhid
getReply getReply
(TicketReplyR shar proj tkhid . encodeHid) (TicketReplyR shr prj ltkhid . encodeHid)
(TicketMessageR shar proj tkhid . encodeHid) (TicketMessageR shr prj ltkhid . encodeHid)
(selectDiscussionId shar proj tkhid) (selectDiscussionId shr prj ltkhid)
mid mid
getTicketDeps :: Bool -> ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler TypedContent getTicketDeps
getTicketDeps forward shr prj tkhid = do :: Bool -> ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketDeps forward shr prj ltkhid = do
(deps, rows) <- unzip <$> runDB getDepsFromDB (deps, rows) <- unzip <$> runDB getDepsFromDB
depsAP <- makeDepsCollection deps depsAP <- makeDepsCollection deps
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
@ -888,12 +924,15 @@ getTicketDeps forward shr prj tkhid = do
if forward then TicketDependencyChild else TicketDependencyParent if forward then TicketDependencyChild else TicketDependencyParent
Entity sid _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid Entity jid _ <- getBy404 $ UniqueProject prj sid
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == jid) notFound unless (ticketProject ticket == jid) notFound
fmap (map toRow) $ E.select $ E.from $ fmap (map toRow) $ E.select $ E.from $
\ ( td \ ( td
`E.InnerJoin` t `E.InnerJoin` t
`E.InnerJoin` lt
`E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s) `E.LeftOuterJoin` (tal `E.InnerJoin` p `E.InnerJoin` s)
`E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i) `E.LeftOuterJoin` (tar `E.InnerJoin` ra `E.InnerJoin` ro `E.InnerJoin` i)
) -> do ) -> do
@ -904,12 +943,13 @@ getTicketDeps forward shr prj tkhid = do
E.on $ p E.?. PersonIdent E.==. s E.?. SharerId E.on $ p E.?. PersonIdent E.==. s E.?. SharerId
E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId E.on $ tal E.?. TicketAuthorLocalAuthor E.==. p E.?. PersonId
E.on $ E.just (t E.^. TicketId) E.==. tal E.?. TicketAuthorLocalTicket E.on $ E.just (t E.^. TicketId) E.==. tal E.?. TicketAuthorLocalTicket
E.on $ t E.^. TicketId E.==. lt E.^. LocalTicketTicket
E.on $ td E.^. to' E.==. t E.^. TicketId E.on $ td E.^. to' E.==. t E.^. TicketId
E.where_ $ td E.^. from' E.==. E.val tid E.where_ $ td E.^. from' E.==. E.val tid
E.orderBy [E.asc $ t E.^. TicketId] E.orderBy [E.asc $ t E.^. TicketId]
return return
( td E.^. TicketDependencyId ( td E.^. TicketDependencyId
, t E.^. TicketId , lt E.^. LocalTicketId
, s , s
, i , i
, ro , ro
@ -918,9 +958,9 @@ getTicketDeps forward shr prj tkhid = do
, t E.^. TicketStatus , t E.^. TicketStatus
) )
where where
toRow (E.Value dep, E.Value tid, ms, mi, mro, mra, E.Value title, E.Value status) = toRow (E.Value dep, E.Value ltid, ms, mi, mro, mra, E.Value title, E.Value status) =
( dep ( dep
, ( tid , ( ltid
, case (ms, mi, mro, mra) of , case (ms, mi, mro, mra) of
(Just s, Nothing, Nothing, Nothing) -> (Just s, Nothing, Nothing, Nothing) ->
Left $ entityVal s Left $ entityVal s
@ -937,7 +977,7 @@ getTicketDeps forward shr prj tkhid = do
encodeKeyHashid <- getEncodeKeyHashid encodeKeyHashid <- getEncodeKeyHashid
let here = let here =
let route = if forward then TicketDepsR else TicketReverseDepsR let route = if forward then TicketDepsR else TicketReverseDepsR
in route shr prj tkhid in route shr prj ltkhid
return Collection return Collection
{ collectionId = encodeRouteLocal here { collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered , collectionType = CollectionTypeUnordered
@ -950,16 +990,19 @@ getTicketDeps forward shr prj tkhid = do
} }
getTicketDepsR getTicketDepsR
:: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler TypedContent :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketDepsR = getTicketDeps True getTicketDepsR = getTicketDeps True
postTicketDepsR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html postTicketDepsR
postTicketDepsR shr prj tkhid = do :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postTicketDepsR shr prj ltkhid = do
(jid, tid) <- runDB $ do (jid, tid) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid Entity jid _ <- getBy404 $ UniqueProject prj sid
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == jid) notFound unless (ticketProject ticket == jid) notFound
return (jid, tid) return (jid, tid)
((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid ((result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
@ -978,7 +1021,7 @@ postTicketDepsR shr prj tkhid = do
insert_ td insert_ td
trrFix td ticketDepGraph trrFix td ticketDepGraph
setMessage "Ticket dependency added." setMessage "Ticket dependency added."
redirect $ TicketR shr prj tkhid redirect $ TicketR shr prj ltkhid
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing." setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/dep/new") defaultLayout $(widgetFile "ticket/dep/new")
@ -986,37 +1029,46 @@ postTicketDepsR shr prj tkhid = do
setMessage "Submission failed, see errors below." setMessage "Submission failed, see errors below."
defaultLayout $(widgetFile "ticket/dep/new") defaultLayout $(widgetFile "ticket/dep/new")
getTicketDepNewR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html getTicketDepNewR
getTicketDepNewR shr prj tkhid = do :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
getTicketDepNewR shr prj ltkhid = do
(jid, tid) <- runDB $ do (jid, tid) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid Entity jid _ <- getBy404 $ UniqueProject prj sid
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
ticket <- get404 tid lticket <- get404 ltid
let tid = localTicketTicket lticket
ticket <- getJust tid
unless (ticketProject ticket == jid) notFound unless (ticketProject ticket == jid) notFound
return (jid, tid) return (jid, tid)
((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid ((_result, widget), enctype) <- runFormPost $ ticketDepForm jid tid
defaultLayout $(widgetFile "ticket/dep/new") defaultLayout $(widgetFile "ticket/dep/new")
postTicketDepOldR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> KeyHashid Ticket -> Handler Html postTicketDepOldR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html
postTicketDepOldR shr prj pnum cnum = do postTicketDepOldR shr prj pnum cnum = do
mmethod <- lookupPostParam "_method" mmethod <- lookupPostParam "_method"
case mmethod of case mmethod of
Just "DELETE" -> deleteTicketDepOldR shr prj pnum cnum Just "DELETE" -> deleteTicketDepOldR shr prj pnum cnum
_ -> notFound _ -> notFound
deleteTicketDepOldR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> KeyHashid Ticket -> Handler Html deleteTicketDepOldR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> KeyHashid LocalTicket -> Handler Html
deleteTicketDepOldR shr prj pnum cnum = do deleteTicketDepOldR shr prj pnum cnum = do
runDB $ do runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid Entity jid _ <- getBy404 $ UniqueProject prj sid
ptid <- decodeKeyHashid404 pnum pltid <- decodeKeyHashid404 pnum
pt <- get404 ptid plt <- get404 pltid
let ptid = localTicketTicket plt
pt <- getJust ptid
unless (ticketProject pt == jid) notFound unless (ticketProject pt == jid) notFound
ctid <- decodeKeyHashid404 cnum cltid <- decodeKeyHashid404 cnum
ct <- get404 ctid clt <- get404 cltid
let ctid = localTicketTicket clt
ct <- getJust ctid
unless (ticketProject ct == jid) notFound unless (ticketProject ct == jid) notFound
Entity tdid _ <- getBy404 $ UniqueTicketDependency ptid ctid Entity tdid _ <- getBy404 $ UniqueTicketDependency ptid ctid
@ -1025,15 +1077,15 @@ deleteTicketDepOldR shr prj pnum cnum = do
redirect $ TicketDepsR shr prj pnum redirect $ TicketDepsR shr prj pnum
getTicketReverseDepsR getTicketReverseDepsR
:: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler TypedContent :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketReverseDepsR = getTicketDeps False getTicketReverseDepsR = getTicketDeps False
getTicketDepR :: KeyHashid TicketDependency -> Handler TypedContent getTicketDepR :: KeyHashid TicketDependency -> Handler TypedContent
getTicketDepR tdkhid = do getTicketDepR tdkhid = do
tdid <- decodeKeyHashid404 tdkhid tdid <- decodeKeyHashid404 tdkhid
( td, ( td,
(sParent, jParent, tParent), (sParent, jParent, ltParent),
(sChild, jChild, tChild), (sChild, jChild, ltChild),
(sAuthor, pAuthor) (sAuthor, pAuthor)
) <- runDB $ do ) <- runDB $ do
tdep <- get404 tdid tdep <- get404 tdid
@ -1045,15 +1097,15 @@ getTicketDepR tdkhid = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
let ticketRoute s j t = let ticketRoute s j lt =
TicketR (sharerIdent s) (projectIdent j) (encodeHid t) TicketR (sharerIdent s) (projectIdent j) (encodeHid lt)
here = TicketDepR tdkhid here = TicketDepR tdkhid
tdepAP = AP.TicketDependency tdepAP = AP.TicketDependency
{ ticketDepId = Just $ encodeRouteHome here { ticketDepId = Just $ encodeRouteHome here
, ticketDepParent = , ticketDepParent =
encodeRouteHome $ ticketRoute sParent jParent tParent encodeRouteHome $ ticketRoute sParent jParent ltParent
, ticketDepChild = , ticketDepChild =
encodeRouteHome $ ticketRoute sChild jChild tChild encodeRouteHome $ ticketRoute sChild jChild ltChild
, ticketDepAttributedTo = , ticketDepAttributedTo =
encodeRouteLocal $ SharerR $ sharerIdent sAuthor encodeRouteLocal $ SharerR $ sharerIdent sAuthor
, ticketDepPublished = Just $ ticketDependencyCreated td , ticketDepPublished = Just $ ticketDependencyCreated td
@ -1065,40 +1117,44 @@ getTicketDepR tdkhid = do
where where
getTicket tid = do getTicket tid = do
t <- getJust tid t <- getJust tid
ltid <- do
mltid <- getKeyBy $ UniqueLocalTicket tid
case mltid of
Nothing -> error "No LocalTicket"
Just ltid -> return ltid
j <- getJust $ ticketProject t j <- getJust $ ticketProject t
s <- getJust $ projectSharer j s <- getJust $ projectSharer j
return (s, j, tid) return (s, j, ltid)
getAuthor pid = do getAuthor pid = do
p <- getJust pid p <- getJust pid
s <- getJust $ personIdent p s <- getJust $ personIdent p
return (s, p) return (s, p)
getTicketParticipantsR getTicketParticipantsR
:: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler TypedContent :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketParticipantsR shr prj tkhid = getFollowersCollection here getFsid getTicketParticipantsR shr prj ltkhid = getFollowersCollection here getFsid
where where
here = TicketParticipantsR shr prj tkhid here = TicketParticipantsR shr prj ltkhid
getFsid = do getFsid = do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
jid <- getKeyBy404 $ UniqueProject prj sid jid <- getKeyBy404 $ UniqueProject prj sid
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
t <- get404 tid lt <- get404 ltid
let tid = localTicketTicket lt
t <- getJust tid
unless (ticketProject t == jid) notFound unless (ticketProject t == jid) notFound
lt <- do
mlt <- getValBy $ UniqueLocalTicket tid
case mlt of
Nothing -> error "No LocalTicket"
Just lt -> return lt
return $ localTicketFollowers lt return $ localTicketFollowers lt
getTicketTeamR getTicketTeamR
:: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler TypedContent :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketTeamR shr prj tkhid = do getTicketTeamR shr prj ltkhid = do
memberShrs <- runDB $ do memberShrs <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
jid <- getKeyBy404 $ UniqueProject prj sid jid <- getKeyBy404 $ UniqueProject prj sid
tid <- decodeKeyHashid404 tkhid ltid <- decodeKeyHashid404 ltkhid
t <- get404 tid lt <- get404 ltid
let tid = localTicketTicket lt
t <- getJust tid
unless (ticketProject t == jid) notFound unless (ticketProject t == jid) notFound
id_ <- id_ <-
requireEitherAlt requireEitherAlt
@ -1118,7 +1174,7 @@ getTicketTeamR shr prj tkhid = do
map (sharerIdent . entityVal) <$> map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] [] selectList [SharerId <-. sids] []
let here = TicketTeamR shr prj tkhid let here = TicketTeamR shr prj ltkhid
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
@ -1134,5 +1190,5 @@ getTicketTeamR shr prj tkhid = do
provideHtmlAndAP team $ redirectToPrettyJSON here provideHtmlAndAP team $ redirectToPrettyJSON here
getTicketEventsR getTicketEventsR
:: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler TypedContent :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler TypedContent
getTicketEventsR _shr _prj _tkhid = error "TODO not implemented" getTicketEventsR _shr _prj _ltkhid = error "TODO not implemented"

5
src/Vervis/Ticket.hs
View file

@ -81,6 +81,7 @@ getTicketSummaries mfilt morder offlim jid = do
limit $ fromIntegral lim limit $ fromIntegral lim
return return
( t ^. TicketId ( t ^. TicketId
, lt ^. LocalTicketId
, s , s
, i , i
, ro , ro
@ -91,13 +92,13 @@ getTicketSummaries mfilt morder offlim jid = do
, count $ m ?. MessageId , count $ m ?. MessageId
) )
for tickets $ for tickets $
\ (Value tid, ms, mi, mro, mra, Value c, Value t, Value d, Value r) -> do \ (Value tid, Value ltid, ms, mi, mro, mra, Value c, Value t, Value d, Value r) -> do
labels <- select $ from $ \ (tpc `InnerJoin` wf) -> do labels <- select $ from $ \ (tpc `InnerJoin` wf) -> do
on $ tpc ^. TicketParamClassField ==. wf ^. WorkflowFieldId on $ tpc ^. TicketParamClassField ==. wf ^. WorkflowFieldId
where_ $ tpc ^. TicketParamClassTicket ==. val tid where_ $ tpc ^. TicketParamClassTicket ==. val tid
return wf return wf
return TicketSummary return TicketSummary
{ tsId = tid { tsId = ltid
, tsCreatedBy = , tsCreatedBy =
case (ms, mi, mro, mra) of case (ms, mi, mro, mra) of
(Just s, Nothing, Nothing, Nothing) -> (Just s, Nothing, Nothing, Nothing) ->

6
src/Vervis/Widget/Ticket.hs
View file

@ -52,7 +52,7 @@ import Vervis.Time (showDate)
import Vervis.Widget.Sharer import Vervis.Widget.Sharer
data TicketSummary = TicketSummary data TicketSummary = TicketSummary
{ tsId :: TicketId { tsId :: LocalTicketId
, tsCreatedBy :: Either Sharer (Instance, RemoteObject, RemoteActor) , tsCreatedBy :: Either Sharer (Instance, RemoteObject, RemoteActor)
, tsCreatedAt :: UTCTime , tsCreatedAt :: UTCTime
, tsTitle :: Text , tsTitle :: Text
@ -61,8 +61,8 @@ data TicketSummary = TicketSummary
, tsComments :: Int , tsComments :: Int
} }
ticketDepW :: ShrIdent -> PrjIdent -> Entity Ticket -> Widget ticketDepW :: ShrIdent -> PrjIdent -> LocalTicketId -> Ticket -> Widget
ticketDepW shr prj (Entity tid ticket) = do ticketDepW shr prj ltid ticket = do
encodeTicketKey <- getEncodeKeyHashid encodeTicketKey <- getEncodeKeyHashid
cNew <- newIdent cNew <- newIdent
cTodo <- newIdent cTodo <- newIdent

2
templates/ticket/assign.hamlet
View file

@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{TicketAssignR shr prj tkhid} enctype=#{enctype}> <form method=POST action=@{TicketAssignR shr prj ltkhid} enctype=#{enctype}>
^{widget} ^{widget}
<div class="submit"> <div class="submit">
<input type="submit"> <input type="submit">

2
templates/ticket/claim-request/new.hamlet
View file

@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{ClaimRequestsTicketR shr prj tkhid} enctype=#{etype}> <form method=POST action=@{ClaimRequestsTicketR shr prj ltkhid} enctype=#{etype}>
^{widget} ^{widget}
<div class="submit"> <div class="submit">
<input type="submit"> <input type="submit">

4
templates/ticket/dep/list.hamlet
View file

@ -32,9 +32,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
#{show status} #{show status}
$if forward $if forward
<td> <td>
^{buttonW DELETE "Remove" (TicketDepOldR shr prj tkhid $ encodeHid tid)} ^{buttonW DELETE "Remove" (TicketDepOldR shr prj ltkhid $ encodeHid tid)}
$if forward $if forward
<p> <p>
<a href=@{TicketDepNewR shr prj tkhid}> <a href=@{TicketDepNewR shr prj ltkhid}>
Add new… Add new…

2
templates/ticket/dep/new.hamlet
View file

@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{TicketDepsR shr prj tkhid} enctype=#{enctype}> <form method=POST action=@{TicketDepsR shr prj ltkhid} enctype=#{enctype}>
^{widget} ^{widget}
<div class="submit"> <div class="submit">
<input type="submit"> <input type="submit">

2
templates/ticket/edit.hamlet
View file

@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{TicketR shr prj tkhid} enctype=#{enctype}> <form method=POST action=@{TicketR shr prj ltkhid} enctype=#{enctype}>
<input type=hidden name=_method value=PUT> <input type=hidden name=_method value=PUT>
^{widget} ^{widget}
<div class="submit"> <div class="submit">

38
templates/ticket/one.hamlet
View file

@ -20,19 +20,19 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div> <div>
<span> <span>
<a href=@{TicketParticipantsR shar proj khid}> <a href=@{TicketParticipantsR shar proj ltkhid}>
[🐤 Followers] [🐤 Followers]
<span> <span>
<a href=@{TicketDepsR shar proj khid}> <a href=@{TicketDepsR shar proj ltkhid}>
[⤴ Dependencies] [⤴ Dependencies]
<span> <span>
<a href=@{TicketReverseDepsR shar proj khid}> <a href=@{TicketReverseDepsR shar proj ltkhid}>
[⤷ Dependants] [⤷ Dependants]
<span> <span>
<a href=@{ClaimRequestsTicketR shar proj khid}> <a href=@{ClaimRequestsTicketR shar proj ltkhid}>
[✋ Claim requests] [✋ Claim requests]
<span> <span>
<a href=@{TicketEditR shar proj khid}> <a href=@{TicketEditR shar proj ltkhid}>
[✏ Edit] [✏ Edit]
^{followButton} ^{followButton}
@ -44,9 +44,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
$if null rdeps $if null rdeps
<li>(none) <li>(none)
$else $else
$forall et <- rdeps $forall (E.Value ltid, Entity _ t) <- rdeps
<li> <li>
^{ticketDepW shar proj et} ^{ticketDepW shar proj ltid t}
<p> <p>
Depends on: Depends on:
@ -55,9 +55,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
$if null deps $if null deps
<li>(none) <li>(none)
$else $else
$forall et <- deps $forall (E.Value ltid, Entity _ t) <- deps
<li> <li>
^{ticketDepW shar proj et} ^{ticketDepW shar proj ltid t}
<div>^{desc} <div>^{desc}
@ -67,23 +67,23 @@ $if ticketStatus ticket /= TSClosed
$if me $if me
Assigned to you. Assigned to you.
^{buttonW POST "Unclaim this ticket" (TicketUnclaimR shar proj khid)} ^{buttonW POST "Unclaim this ticket" (TicketUnclaimR shar proj ltkhid)}
$else $else
Assigned to ^{sharerLinkW assignee}. Assigned to ^{sharerLinkW assignee}.
^{buttonW POST "Unassign this ticket" (TicketUnassignR shar proj khid)} ^{buttonW POST "Unassign this ticket" (TicketUnassignR shar proj ltkhid)}
$nothing $nothing
Not assigned. Not assigned.
<a href=@{ClaimRequestNewR shar proj khid}>Ask to have it assigned to you <a href=@{ClaimRequestNewR shar proj ltkhid}>Ask to have it assigned to you
or or
^{buttonW POST "Claim this ticket" (TicketClaimR shar proj khid)} ^{buttonW POST "Claim this ticket" (TicketClaimR shar proj ltkhid)}
or or
<a href=@{TicketAssignR shar proj khid}>Assign to someone else <a href=@{TicketAssignR shar proj ltkhid}>Assign to someone else
. .
<p> <p>
@ -92,18 +92,18 @@ $if ticketStatus ticket /= TSClosed
$of TSNew $of TSNew
Open, new. Open, new.
^{buttonW POST "Accept this ticket" (TicketAcceptR shar proj khid)} ^{buttonW POST "Accept this ticket" (TicketAcceptR shar proj ltkhid)}
^{buttonW POST "Close this ticket" (TicketCloseR shar proj khid)} ^{buttonW POST "Close this ticket" (TicketCloseR shar proj ltkhid)}
$of TSTodo $of TSTodo
Open, to do. Open, to do.
^{buttonW POST "Close this ticket" (TicketCloseR shar proj khid)} ^{buttonW POST "Close this ticket" (TicketCloseR shar proj ltkhid)}
$of TSClosed $of TSClosed
Closed on #{showDate $ ticketClosed ticket} Closed on #{showDate $ ticketClosed ticket}
$maybe closer <- mcloser $maybe closer <- mcloser
by ^{sharerLinkW closer}. by ^{sharerLinkW closer}.
^{buttonW POST "Reopen this ticket" (TicketOpenR shar proj khid)} ^{buttonW POST "Reopen this ticket" (TicketOpenR shar proj ltkhid)}
<h3>Custom fields <h3>Custom fields
@ -145,7 +145,7 @@ $if ticketStatus ticket /= TSClosed
No No
<p> <p>
^{buttonW DELETE "Delete this ticket" (TicketR shar proj khid)} ^{buttonW DELETE "Delete this ticket" (TicketR shar proj ltkhid)}
<h3>Discussion <h3>Discussion

2
templates/ticket/widget/dep.hamlet
View file

@ -22,5 +22,5 @@ $case ticketStatus ticket
$of TSClosed $of TSClosed
<span .#{cClosed}> <span .#{cClosed}>
☒ ☒
<a href=@{TicketR shr prj $ encodeTicketKey tid}> <a href=@{TicketR shr prj $ encodeTicketKey ltid}>
#{ticketTitle ticket} #{ticketTitle ticket}