forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Remove ticket numbers from UI and from URLs, use KeyHashid instead

Browse source
This commit is contained in:
fr33domlover 2020-02-03 14:53:12 +00:00
parent fc0f694289
commit 1cb3812ef5
30 changed files with 584 additions and 466 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

55
config/routes
View file

@ -129,6 +129,8 @@
/s/#ShrIdent/p/#PrjIdent/d/!new ProjectDevNewR GET /s/#ShrIdent/p/#PrjIdent/d/!new ProjectDevNewR GET
/s/#ShrIdent/p/#PrjIdent/d/#ShrIdent ProjectDevR GET DELETE POST /s/#ShrIdent/p/#PrjIdent/d/#ShrIdent ProjectDevR GET DELETE POST
/s/#ShrIdent/p/#PrjIdent/tcr ClaimRequestsProjectR GET
-- /w GlobalWorkflowsR GET POST -- /w GlobalWorkflowsR GET POST
-- /w/!new GlobalWorkflowNewR GET -- /w/!new GlobalWorkflowNewR GET
-- /w/#WflIdent GlobalWorkflowR GET DELETE POST -- /w/#WflIdent GlobalWorkflowR GET DELETE POST
@ -148,34 +150,35 @@
/s/#ShrIdent/m/#LocalMessageKeyHashid MessageR GET /s/#ShrIdent/m/#LocalMessageKeyHashid MessageR GET
/tdeps/#TicketDepKeyHashid TicketDepR GET
/s/#ShrIdent/p/#PrjIdent/t TicketsR GET POST /s/#ShrIdent/p/#PrjIdent/t TicketsR GET POST
/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/#Int TicketR GET PUT DELETE POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/edit TicketEditR GET /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid TicketR GET PUT DELETE POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/accept TicketAcceptR POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/edit TicketEditR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/close TicketCloseR POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/accept TicketAcceptR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/open TicketOpenR POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/close TicketCloseR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/claim TicketClaimR POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/open TicketOpenR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/unclaim TicketUnclaimR POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/claim TicketClaimR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/assign TicketAssignR GET POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/unclaim TicketUnclaimR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/unassign TicketUnassignR POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/assign TicketAssignR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/follow TicketFollowR POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/unassign TicketUnassignR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/unfollow TicketUnfollowR POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/follow TicketFollowR POST
/s/#ShrIdent/p/#PrjIdent/tcr ClaimRequestsProjectR GET /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/unfollow TicketUnfollowR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/cr ClaimRequestsTicketR GET POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/cr ClaimRequestsTicketR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/cr/new ClaimRequestNewR GET /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/cr/new ClaimRequestNewR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/d TicketDiscussionR GET POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/d TicketDiscussionR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/!reply TicketTopReplyR GET /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/d/!reply TicketTopReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#MessageKeyHashid TicketMessageR POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/d/#MessageKeyHashid TicketMessageR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#MessageKeyHashid/reply TicketReplyR GET /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/d/#MessageKeyHashid/reply TicketReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps TicketDepsR GET POST /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/deps TicketDepsR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/!new TicketDepNewR GET /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/deps/!new TicketDepNewR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/#Int TicketDepOldR POST DELETE /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/deps/#TicketKeyHashid TicketDepOldR POST DELETE
/s/#ShrIdent/p/#PrjIdent/t/#Int/rdeps TicketReverseDepsR GET /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/rdeps TicketReverseDepsR GET
/tdeps/#TicketDepKeyHashid TicketDepR GET /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/participants TicketParticipantsR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/participants TicketParticipantsR GET /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/team TicketTeamR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/team TicketTeamR GET /s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/events TicketEventsR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/events TicketEventsR GET
/s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET /s/#ShrIdent/p/#PrjIdent/w/+Texts WikiPageR GET

136
src/Vervis/API.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -162,11 +162,13 @@ 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, num) -> do Just (shr, prj, tkhid) -> 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
t <- MaybeT $ getValBy $ UniqueTicket jid num tid <- decodeKeyHashidM tkhid
t <- MaybeT $ get tid
guard $ ticketProject t == jid
return (sid, projectInbox j, projectFollowers j, t) return (sid, projectInbox j, projectFollowers j, t)
(sid, ibidProject, fsidProject, t) <- fromMaybeE mt "Context: No such local ticket" (sid, ibidProject, fsidProject, t) <- fromMaybeE mt "Context: No such local ticket"
let did = ticketDiscuss t let did = ticketDiscuss t
@ -243,7 +245,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, Int) , Maybe (ShrIdent, PrjIdent, KeyHashid Ticket)
, [(Host, NonEmpty LocalURI)] , [(Host, NonEmpty LocalURI)]
) )
parseRecipsContextParent uContext muParent = do parseRecipsContextParent uContext muParent = do
@ -274,7 +276,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, Int) parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, KeyHashid Ticket)
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"
@ -287,7 +289,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, Int) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent] verifyTicketRecipients :: (ShrIdent, PrjIdent, KeyHashid Ticket) -> 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"
@ -444,7 +446,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 Int | FolloweeTicket ShrIdent PrjIdent (KeyHashid Ticket)
| FolloweeRepo ShrIdent RpIdent | FolloweeRepo ShrIdent RpIdent
followC followC
@ -537,11 +539,13 @@ 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 num) = do getFollowee (FolloweeTicket shr prj tkhid) = 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
ticket <- MaybeT $ getValBy $ UniqueTicket jid num tid <- decodeKeyHashidM tkhid
ticket <- MaybeT $ get tid
guard $ ticketProject ticket == jid
return (ticket, project) return (ticket, project)
(ticket, project) <- fromMaybeE mproject "Follow object: No such ticket in DB" (ticket, project) <- fromMaybeE mproject "Follow object: No such ticket in DB"
return (ticketFollowers ticket, projectInbox project, False, projectOutbox project) return (ticketFollowers ticket, projectInbox project, False, projectOutbox project)
@ -670,7 +674,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'" verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'" verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'" verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'"
verifyNothingE (AP.ticketName ticket) "Ticket with 'name'" -- verifyNothingE (AP.ticketName ticket) "Ticket with 'name'"
verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'" verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved" when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved"
checkRecips hProject shrProject prjProject localRecips = do checkRecips hProject shrProject prjProject localRecips = do
@ -762,8 +766,18 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
num <- num <-
((subtract 1) . projectNextTicket) <$> ((subtract 1) . projectNextTicket) <$>
updateGet jid [ProjectNextTicket +=. 1] updateGet jid [ProjectNextTicket +=. 1]
(obiidAccept, docAccept) <- insertAccept pidAuthor sid jid fsid luOffer num obiidAccept <- do
insertTicket jid {-tids-} num obiidAccept obidProject <- projectOutbox <$> getJust jid
now <- liftIO getCurrentTime
hLocal <- asksSite siteInstanceHost
insert OutboxItem
{ outboxItemOutbox = obidProject
, outboxItemActivity =
persistJSONObjectFromDoc $ Doc hLocal emptyActivity
, outboxItemPublished = now
}
tid <- insertTicket jid {-tids-} num obiidAccept
docAccept <- insertAccept pidAuthor sid jid fsid luOffer obiidAccept tid
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
@ -782,62 +796,51 @@ 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 num = do insertAccept pidAuthor sid jid fsid luOffer obiid tid = do
now <- liftIO getCurrentTime tkhid <- encodeKeyHashid tid
obid <- projectOutbox <$> getJust jid summary <-
insertToOutbox now obid TextHtml . TL.toStrict . renderHtml <$>
where withUrlRenderer
insertToOutbox now obid = do [hamlet|
summary <- <p>
TextHtml . TL.toStrict . renderHtml <$> <a href=@{SharerR shrUser}>
withUrlRenderer #{shr2text shrUser}
[hamlet| 's ticket accepted by project #
<p> <a href=@{ProjectR shrProject prjProject}>
<a href=@{SharerR shrUser}> ./s/#{shr2text shrProject}/p/#{prj2text prjProject}
#{shr2text shrUser} : #
's ticket accepted by project # <a href=@{TicketR shrProject prjProject tkhid}>
<a href=@{ProjectR shrProject prjProject}> #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
./s/#{shr2text shrProject}/p/#{prj2text prjProject} |]
: # hLocal <- asksSite siteInstanceHost
<a href=@{TicketR shrProject prjProject num}> encodeRouteLocal <- getEncodeRouteLocal
#{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}. encodeRouteHome <- getEncodeRouteHome
|] obikhid <- encodeKeyHashid obiid
hLocal <- asksSite siteInstanceHost let recips =
encodeRouteLocal <- getEncodeRouteLocal map encodeRouteHome
encodeRouteHome <- getEncodeRouteHome [ SharerR shrUser
let recips = , ProjectTeamR shrProject prjProject
map encodeRouteHome , ProjectFollowersR shrProject prjProject
[ SharerR shrUser ]
, ProjectTeamR shrProject prjProject doc = Doc hLocal Activity
, ProjectFollowersR shrProject prjProject { activityId =
] Just $ encodeRouteLocal $
accept luAct = Doc hLocal Activity ProjectOutboxItemR shrProject prjProject obikhid
{ activityId = luAct , activityActor =
, activityActor = encodeRouteLocal $ ProjectR shrProject prjProject
encodeRouteLocal $ ProjectR shrProject prjProject , activitySummary = Just summary
, activitySummary = Just summary , activityAudience = Audience recips [] [] [] [] []
, activityAudience = Audience recips [] [] [] [] [] , activitySpecific = AcceptActivity Accept
, activitySpecific = AcceptActivity Accept { acceptObject = ObjURI hLocal luOffer
{ acceptObject = ObjURI hLocal luOffer , acceptResult =
, acceptResult = Just $ encodeRouteLocal $
Just $ encodeRouteLocal $ TicketR shrProject prjProject tkhid
TicketR shrProject prjProject num
}
} }
obiid <- insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity =
persistJSONObjectFromDoc $ accept Nothing
, outboxItemPublished = now
} }
encodeRouteLocal <- getEncodeRouteLocal update
obikhid <- encodeKeyHashid obiid obiid
let luAct = encodeRouteLocal $ ProjectOutboxItemR shrProject prjProject obikhid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
doc = accept $ Just luAct return doc
update
obiid
[OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (obiid, doc)
insertTicket jid {-tidsDeps-} next obiidAccept = do insertTicket jid {-tidsDeps-} next obiidAccept = do
did <- insert Discussion did <- insert Discussion
fsid <- insert FollowerSet fsid <- insert FollowerSet
@ -864,6 +867,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
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

6
src/Vervis/ActivityPub.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -91,7 +91,7 @@ import Yesod.HttpSignature
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Network.HTTP.Digest import Network.HTTP.Digest
import Web.ActivityPub hiding (Author (..)) import Web.ActivityPub hiding (Author (..), Ticket)
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.MonadSite import Yesod.MonadSite
import Yesod.FedURI import Yesod.FedURI
@ -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, Int) FedURI) -> ExceptT Text m (Either (ShrIdent, PrjIdent, KeyHashid Ticket) FedURI)
parseContext uContext = do parseContext uContext = do
let ObjURI hContext luContext = uContext let ObjURI hContext luContext = uContext
local <- hostIsLocal hContext local <- hostIsLocal hContext

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

@ -46,15 +46,17 @@ import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T import qualified Data.Text as T
import Network.FedURI import Network.FedURI
import Web.ActivityPub import Web.ActivityPub hiding (Ticket)
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite import Yesod.MonadSite
import Data.List.NonEmpty.Local import Data.List.NonEmpty.Local
import Vervis.FedURI import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
concatRecipients :: Audience u -> [ObjURI u] concatRecipients :: Audience u -> [ObjURI u]
@ -84,8 +86,8 @@ data LocalPersonCollection
= LocalPersonCollectionSharerFollowers ShrIdent = LocalPersonCollectionSharerFollowers ShrIdent
| LocalPersonCollectionProjectTeam ShrIdent PrjIdent | LocalPersonCollectionProjectTeam ShrIdent PrjIdent
| LocalPersonCollectionProjectFollowers ShrIdent PrjIdent | LocalPersonCollectionProjectFollowers ShrIdent PrjIdent
| LocalPersonCollectionTicketTeam ShrIdent PrjIdent Int | LocalPersonCollectionTicketTeam ShrIdent PrjIdent (KeyHashid Ticket)
| LocalPersonCollectionTicketFollowers ShrIdent PrjIdent Int | LocalPersonCollectionTicketFollowers ShrIdent PrjIdent (KeyHashid Ticket)
| LocalPersonCollectionRepoTeam ShrIdent RpIdent | LocalPersonCollectionRepoTeam ShrIdent RpIdent
| LocalPersonCollectionRepoFollowers ShrIdent RpIdent | LocalPersonCollectionRepoFollowers ShrIdent RpIdent
@ -131,7 +133,7 @@ data LocalProjectRecipientDirect
data LocalProjectRecipient data LocalProjectRecipient
= LocalProjectDirect LocalProjectRecipientDirect = LocalProjectDirect LocalProjectRecipientDirect
| LocalTicketRelated Int LocalTicketRecipientDirect | LocalTicketRelated (KeyHashid Ticket) LocalTicketRecipientDirect
deriving (Eq, Ord) deriving (Eq, Ord)
data LocalRepoRecipientDirect data LocalRepoRecipientDirect
@ -220,7 +222,7 @@ data LocalProjectDirectSet = LocalProjectDirectSet
data LocalProjectRelatedSet = LocalProjectRelatedSet data LocalProjectRelatedSet = LocalProjectRelatedSet
{ localRecipProjectDirect :: LocalProjectDirectSet { localRecipProjectDirect :: LocalProjectDirectSet
, localRecipTicketRelated :: [(Int, LocalTicketDirectSet)] , localRecipTicketRelated :: [(KeyHashid Ticket, LocalTicketDirectSet)]
} }
deriving Eq deriving Eq

20
src/Vervis/Client.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -29,6 +29,7 @@ module Vervis.Client
) )
where where
import Control.Monad
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader import Control.Monad.Trans.Reader
import Database.Persist import Database.Persist
@ -45,7 +46,7 @@ import qualified Data.Text as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import Network.FedURI import Network.FedURI
import Web.ActivityPub hiding (Follow) import Web.ActivityPub hiding (Follow, Ticket)
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
@ -190,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 -> Int -> Bool -> m (TextHtml, Audience URIMode, AP.Follow URIMode) => ShrIdent -> ShrIdent -> PrjIdent -> KeyHashid Ticket -> 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
@ -231,7 +232,7 @@ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runEx
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor , AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
, AP.ticketPublished = Nothing , AP.ticketPublished = Nothing
, AP.ticketUpdated = Nothing , AP.ticketUpdated = Nothing
, AP.ticketName = Nothing -- , AP.ticketName = Nothing
, AP.ticketSummary = TextHtml title , AP.ticketSummary = TextHtml title
, AP.ticketContent = TextHtml descHtml , AP.ticketContent = TextHtml descHtml
, AP.ticketSource = TextPandocMarkdown desc , AP.ticketSource = TextPandocMarkdown desc
@ -332,7 +333,7 @@ undoFollowTicket
-> PersonId -> PersonId
-> ShrIdent -> ShrIdent
-> PrjIdent -> PrjIdent
-> Int -> KeyHashid Ticket
-> 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
@ -346,9 +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"
mt <- lift $ getValBy $ UniqueTicket jid numFollowee tid <- decodeKeyHashidE numFollowee "Invalid hashid for context"
ticketFollowers <$> mt <- lift $ get tid
fromMaybeE mt "Unfollow target no such local ticket" t <- fromMaybeE mt "Unfollow target no such local ticket"
unless (ticketProject t == jid) $
throwE "Hashid doesn't match sharer/project"
return $ ticketFollowers t
undoFollowRepo undoFollowRepo
:: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)

6
src/Vervis/Federation.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -75,7 +75,7 @@ import Crypto.PublicVerifKey
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Network.HTTP.Digest import Network.HTTP.Digest
import Web.ActivityPub hiding (Follow) import Web.ActivityPub hiding (Follow, Ticket)
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.Auth.Unverified import Yesod.Auth.Unverified
import Yesod.FedURI import Yesod.FedURI
@ -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 Int parseTicket :: Monad m => (ShrIdent, PrjIdent) -> LocalURI -> ExceptT Text m (KeyHashid Ticket)
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"

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

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -54,6 +54,7 @@ import Network.HTTP.Digest
import Web.ActivityPub import Web.ActivityPub
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids
import Control.Monad.Trans.Except.Local import Control.Monad.Trans.Except.Local
import Data.Tuple.Local import Data.Tuple.Local
@ -102,11 +103,13 @@ 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, num) -> do Left (shr, prj, tkhid) -> 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
t <- MaybeT $ getValBy $ UniqueTicket jid num tid <- decodeKeyHashidM tkhid
t <- MaybeT $ get tid
guard $ ticketProject t == jid
return $ ticketDiscuss t return $ ticketDiscuss t
did <- fromMaybeE mdid "Context: No such local ticket" did <- fromMaybeE mdid "Context: No such local ticket"
for_ mparent $ \ parent -> for_ mparent $ \ parent ->
@ -188,17 +191,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, num) -> Left (shr, prj, tkhid) ->
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 num $ findRelevantCollections hLocal tkhid $
activityAudience $ actbActivity body activityAudience $ actbActivity body
mremotesHttp <- runDBExcept $ do mremotesHttp <- runDBExcept $ do
(sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent num mparent (sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent tkhid 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
@ -212,7 +215,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
return $ recip <> " inserted new ticket comment" return $ recip <> " inserted new ticket comment"
where where
findRelevantCollections hLocal numCtx = nub . mapMaybe decide . concatRecipients findRelevantCollections hLocal ctx = nub . mapMaybe decide . concatRecipients
where where
decide u = do decide u = do
let ObjURI h lu = u let ObjURI h lu = u
@ -222,20 +225,24 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
ProjectFollowersR shr prj ProjectFollowersR shr prj
| shr == shrRecip && prj == prjRecip | shr == shrRecip && prj == prjRecip
-> Just CreateNoteRecipProjectFollowers -> Just CreateNoteRecipProjectFollowers
TicketParticipantsR shr prj num TicketParticipantsR shr prj tkhid
| shr == shrRecip && prj == prjRecip && num == numCtx | shr == shrRecip && prj == prjRecip && tkhid == ctx
-> Just CreateNoteRecipTicketParticipants -> Just CreateNoteRecipTicketParticipants
TicketTeamR shr prj num TicketTeamR shr prj tkhid
| shr == shrRecip && prj == prjRecip && num == numCtx | shr == shrRecip && prj == prjRecip && tkhid == ctx
-> 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 num mparent = do getContextAndParent tkhid mparent = do
mt <- lift $ do mt <- do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- lift $ getKeyBy404 $ UniqueSharer shrRecip
Entity jid j <- getBy404 $ UniqueProject prjRecip sid Entity jid j <- lift $ getBy404 $ UniqueProject prjRecip sid
fmap (jid, projectInbox j, projectFollowers j, sid ,) <$> tid <- decodeKeyHashidE tkhid "Context: Not a valid ticket khid"
getValBy (UniqueTicket jid num) mt <- lift $ get tid
for mt $ \ t -> do
unless (ticketProject t == jid) $
throwE "Context: Local ticket khid belongs to different project"
return (jid, projectInbox j, projectFollowers j, sid ,t)
(jid, ibid, fsidProject, sid, t) <- fromMaybeE mt "Context: No such local ticket" (jid, ibid, fsidProject, sid, t) <- fromMaybeE mt "Context: No such local ticket"
let did = ticketDiscuss t let did = ticketDiscuss t
meparent <- for mparent $ \ parent -> meparent <- for mparent $ \ parent ->

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

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -383,10 +383,14 @@ projectFollowF shr prj =
| shr == shr' && prj == prj' = Just $ Just num | shr == shr' && prj == prj' = Just $ Just num
objRoute _ = Nothing objRoute _ = Nothing
getRecip mnum = do getRecip mtkhid = 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 mnum $ \ num -> getValBy404 $ UniqueTicket jid num mt <- for mtkhid $ \ tkhid -> do
tid <- decodeKeyHashid404 tkhid
t <- get404 tid
unless (ticketProject t == jid) notFound
return t
return (j, mt) return (j, mt)
followers (j, Nothing) = projectFollowers j followers (j, Nothing) = projectFollowers j

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

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -81,7 +81,7 @@ checkOffer ticket hProject shrProject prjProject = do
verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'" verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'" verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'" verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'"
verifyNothingE (AP.ticketName ticket) "Ticket with 'name'" -- verifyNothingE (AP.ticketName ticket) "Ticket with 'name'"
verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'" verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'"
when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved" when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved"
@ -176,17 +176,17 @@ projectOfferTicketF
mticket <- do mticket <- do
ra <- getJust $ remoteAuthorId author ra <- getJust $ remoteAuthorId author
insertTicket ra luOffer jid ibid {-tids-} insertTicket ra luOffer jid ibid {-tids-}
for mticket $ \ (ractid, num, obiidAccept, docAccept) -> do for mticket $ \ (ractid, obiidAccept, docAccept) -> do
msr <- for msig $ \ sig -> do msr <- for msig $ \ sig -> do
remoteRecips <- deliverLocal ractid colls sid fsid remoteRecips <- deliverLocal ractid colls sid fsid
(sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
return (num, msr, obiidAccept, docAccept) return (msr, obiidAccept, docAccept)
lift $ for_ mremotesHttp $ \ (num, msr, obiidAccept, docAccept) -> do lift $ for_ mremotesHttp $ \ (msr, obiidAccept, docAccept) -> do
let handler e = logError $ "Project Accept sender: delivery failed! " <> T.pack (displayException e) let handler e = logError $ "Project Accept sender: delivery failed! " <> T.pack (displayException e)
for msr $ \ (sig, remotesHttp) -> do for msr $ \ (sig, remotesHttp) -> do
forkHandler handler $ forkHandler handler $
deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
forkHandler handler $ publishAccept luOffer num obiidAccept docAccept forkHandler handler $ publishAccept luOffer obiidAccept docAccept
return $ recip <> " inserted new ticket" return $ recip <> " inserted new ticket"
where where
recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip] recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
@ -245,7 +245,20 @@ projectOfferTicketF
updateGet jid [ProjectNextTicket +=. 1] updateGet jid [ProjectNextTicket +=. 1]
did <- insert Discussion did <- insert Discussion
fsid <- insert FollowerSet fsid <- insert FollowerSet
(obiidAccept, docAccept) <- insertAccept ra luOffer next
obiidAccept <- do
obidProject <- do
sid <- fromJust <$> getKeyBy (UniqueSharer shrRecip)
j <- fromJust <$> getValBy (UniqueProject prjRecip sid)
return $ projectOutbox j
hLocal <- asksSite siteInstanceHost
now <- liftIO getCurrentTime
insert OutboxItem
{ outboxItemOutbox = obidProject
, outboxItemActivity = persistJSONObjectFromDoc $ Doc hLocal emptyActivity
, outboxItemPublished = now
}
tid <- insert Ticket tid <- insert Ticket
{ ticketProject = jid { ticketProject = jid
, ticketNumber = next , ticketNumber = next
@ -267,9 +280,10 @@ projectOfferTicketF
, ticketAuthorRemoteAuthor = raidAuthor , ticketAuthorRemoteAuthor = raidAuthor
, ticketAuthorRemoteOffer = ractid , ticketAuthorRemoteOffer = ractid
} }
docAccept <- insertAccept ra luOffer tid 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, next, obiidAccept, docAccept) return $ Just (ractid, obiidAccept, docAccept)
deliverLocal deliverLocal
:: RemoteActivityId :: RemoteActivityId
@ -296,71 +310,58 @@ projectOfferTicketF
delete ibiid delete ibiid
return remotes return remotes
insertAccept ra luOffer num = do insertAccept ra luOffer tid obiid = do
now <- liftIO getCurrentTime let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI author
(sid, project) <- do tkhid <- encodeKeyHashid tid
sid <- fromJust <$> getKeyBy (UniqueSharer shrRecip) summary <-
j <- fromJust <$> getValBy (UniqueProject prjRecip sid) TextHtml . TL.toStrict . renderHtml <$>
return (sid, j) withUrlRenderer
insertToOutbox now $ projectOutbox project [hamlet|
where <p>
insertToOutbox now obid = do <a href="#{renderObjURI uAuthor}">
let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI author $maybe name <- remoteActorName ra
summary <- #{name}
TextHtml . TL.toStrict . renderHtml <$> $nothing
withUrlRenderer #{renderAuthority hAuthor}#{localUriPath luAuthor}
[hamlet| \'s ticket accepted by project #
<p> <a href=@{ProjectR shrRecip prjRecip}>
<a href="#{renderObjURI uAuthor}"> ./s/#{shr2text shrRecip}/p/#{prj2text prjRecip}
$maybe name <- remoteActorName ra \: #
#{name} <a href=@{TicketR shrRecip prjRecip tkhid}>
$nothing #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
#{renderAuthority hAuthor}#{localUriPath luAuthor} |]
\'s ticket accepted by project # hLocal <- asksSite siteInstanceHost
<a href=@{ProjectR shrRecip prjRecip}> encodeRouteLocal <- getEncodeRouteLocal
./s/#{shr2text shrRecip}/p/#{prj2text prjRecip} encodeRouteHome <- getEncodeRouteHome
\: # obikhid <- encodeKeyHashid obiid
<a href=@{TicketR shrRecip prjRecip num}> let recips =
#{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}. remoteAuthorURI author :
|] map encodeRouteHome
hLocal <- asksSite siteInstanceHost [ ProjectTeamR shrRecip prjRecip
encodeRouteLocal <- getEncodeRouteLocal , ProjectFollowersR shrRecip prjRecip
encodeRouteHome <- getEncodeRouteHome ]
let recips = doc = Doc hLocal Activity
remoteAuthorURI author : { activityId =
map encodeRouteHome Just $ encodeRouteLocal $
[ ProjectTeamR shrRecip prjRecip ProjectOutboxItemR shrRecip prjRecip obikhid
, ProjectFollowersR shrRecip prjRecip , activityActor =
] encodeRouteLocal $ ProjectR shrRecip prjRecip
accept luAct = Doc hLocal Activity , activitySummary = Just summary
{ activityId = luAct , activityAudience = Audience recips [] [] [] [] []
, activityActor = , activitySpecific = AcceptActivity Accept
encodeRouteLocal $ ProjectR shrRecip prjRecip { acceptObject =
, activitySummary = Just summary ObjURI
, activityAudience = Audience recips [] [] [] [] [] (objUriAuthority $ remoteAuthorURI author)
, activitySpecific = AcceptActivity Accept luOffer
{ acceptObject = , acceptResult =
ObjURI Just $ encodeRouteLocal $
(objUriAuthority $ remoteAuthorURI author) TicketR shrRecip prjRecip tkhid
luOffer
, acceptResult =
Just $ encodeRouteLocal $
TicketR shrRecip prjRecip num
}
} }
obiid <- insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity = persistJSONObjectFromDoc $ accept Nothing
, outboxItemPublished = now
} }
encodeRouteLocal <- getEncodeRouteLocal update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
obikhid <- encodeKeyHashid obiid return doc
let luAct = encodeRouteLocal $ ProjectOutboxItemR shrRecip prjRecip obikhid
doc = accept $ Just luAct
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (obiid, doc)
publishAccept luOffer num obiid doc = do publishAccept luOffer 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
remotesHttp <- runDB $ do remotesHttp <- runDB $ do

4
src/Vervis/Field/Ticket.hs
View file

@ -70,5 +70,5 @@ selectTicketDep jid tid =
checkDep tid $ checkDep tid $
checkNotSelf tid $ checkNotSelf tid $
selectField $ selectField $
optionsPersistKey [TicketProject P.==. jid, TicketId P.!=. tid] [P.Asc TicketNumber] $ optionsPersistKey [TicketProject P.==. jid, TicketId P.!=. tid] [P.Asc TicketId] $
\ t -> sformat (int % " :: " % stext) (ticketNumber t) (ticketTitle t) \ t -> sformat ("### :: " % stext) (ticketTitle t)

3
src/Vervis/Foundation.hs
View file

@ -80,7 +80,7 @@ import Control.Concurrent.ResultShare
import Crypto.PublicVerifKey import Crypto.PublicVerifKey
import Network.FedURI import Network.FedURI
import Web.ActivityAccess import Web.ActivityAccess
import Web.ActivityPub hiding (TicketDependency) import Web.ActivityPub hiding (Ticket, TicketDependency)
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
@ -138,6 +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 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

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

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- 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. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -123,7 +123,7 @@ fedUriField = Field
} }
ticketField ticketField
:: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent, Int) :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent, KeyHashid Ticket)
ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
where where
toTicket uTicket = runExceptT $ do toTicket uTicket = runExceptT $ do
@ -133,10 +133,10 @@ ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
Nothing -> throwE ("Not a valid route" :: Text) Nothing -> throwE ("Not a valid route" :: Text)
Just r -> return r Just r -> return r
case route of case route of
TicketR shr prj num -> return (hTicket, shr, prj, num) TicketR shr prj tkhid -> return (hTicket, shr, prj, tkhid)
_ -> throwE "Not a ticket route" _ -> throwE "Not a ticket route"
fromTicket (h, shr, prj, num) = fromTicket (h, shr, prj, tkhid) =
ObjURI h $ encodeRouteLocal $ TicketR shr prj num ObjURI h $ encodeRouteLocal $ TicketR shr prj tkhid
projectField projectField
:: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent) :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent)
@ -154,15 +154,16 @@ 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, Int), Maybe FedURI, Text) :: Form ((Host, ShrIdent, PrjIdent, KeyHashid Ticket), Maybe FedURI, Text)
publishCommentForm html = do publishCommentForm html = do
enc <- getEncodeRouteLocal enc <- getEncodeRouteLocal
defk <- encodeKeyHashid $ E.toSqlKey 1
flip renderDivs html $ (,,) flip renderDivs html $ (,,)
<$> areq (ticketField enc) "Ticket" (Just deft) <$> areq (ticketField enc) "Ticket" (Just $ deft defk)
<*> aopt fedUriField "Replying to" (Just $ Just defp) <*> aopt fedUriField "Replying to" (Just $ Just defp)
<*> areq textField "Message" (Just defmsg) <*> areq textField "Message" (Just defmsg)
where where
deft = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox", 1) deft k = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox", k)
defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7" defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7"
defmsg = "Hi! I'm testing federation. Can you see my message? :)" defmsg = "Hi! I'm testing federation. Can you see my message? :)"
@ -346,7 +347,7 @@ postPublishR = do
, ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor , ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
, ticketPublished = Nothing , ticketPublished = Nothing
, ticketUpdated = Nothing , ticketUpdated = Nothing
, ticketName = Nothing -- , ticketName = Nothing
, ticketSummary = TextHtml title , ticketSummary = TextHtml title
, ticketContent = TextHtml descHtml , ticketContent = TextHtml descHtml
, ticketSource = TextPandocMarkdown desc , ticketSource = TextPandocMarkdown desc
@ -447,13 +448,13 @@ postProjectFollowR shrObject prjObject = do
setFollowMessage shrAuthor eid setFollowMessage shrAuthor eid
redirect $ ProjectR shrObject prjObject redirect $ ProjectR shrObject prjObject
postTicketFollowR :: ShrIdent -> PrjIdent -> Int -> Handler () postTicketFollowR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler ()
postTicketFollowR shrObject prjObject numObject = do postTicketFollowR shrObject prjObject tkhidObject = do
shrAuthor <- getUserShrIdent shrAuthor <- getUserShrIdent
(summary, audience, follow) <- followTicket shrAuthor shrObject prjObject numObject False (summary, audience, follow) <- followTicket shrAuthor shrObject prjObject tkhidObject False
eid <- followC shrAuthor summary audience follow eid <- followC shrAuthor summary audience follow
setFollowMessage shrAuthor eid setFollowMessage shrAuthor eid
redirect $ TicketR shrObject prjObject numObject redirect $ TicketR shrObject prjObject tkhidObject
postRepoFollowR :: ShrIdent -> RpIdent -> Handler () postRepoFollowR :: ShrIdent -> RpIdent -> Handler ()
postRepoFollowR shrObject rpObject = do postRepoFollowR shrObject rpObject = do
@ -494,15 +495,15 @@ postProjectUnfollowR shrFollowee prjFollowee = do
setUnfollowMessage shrAuthor eid setUnfollowMessage shrAuthor eid
redirect $ ProjectR shrFollowee prjFollowee redirect $ ProjectR shrFollowee prjFollowee
postTicketUnfollowR :: ShrIdent -> PrjIdent -> Int -> Handler () postTicketUnfollowR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler ()
postTicketUnfollowR shrFollowee prjFollowee numFollowee = do postTicketUnfollowR shrFollowee prjFollowee tkhidFollowee = do
(shrAuthor, pidAuthor) <- getUser (shrAuthor, pidAuthor) <- getUser
eid <- runExceptT $ do eid <- runExceptT $ do
(summary, audience, undo) <- (summary, audience, undo) <-
ExceptT $ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee ExceptT $ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee tkhidFollowee
ExceptT $ undoC shrAuthor summary audience undo ExceptT $ undoC shrAuthor summary audience undo
setUnfollowMessage shrAuthor eid setUnfollowMessage shrAuthor eid
redirect $ TicketR shrFollowee prjFollowee numFollowee redirect $ TicketR shrFollowee prjFollowee tkhidFollowee
postRepoUnfollowR :: ShrIdent -> RpIdent -> Handler () postRepoUnfollowR :: ShrIdent -> RpIdent -> Handler ()
postRepoUnfollowR shrFollowee rpFollowee = do postRepoUnfollowR shrFollowee rpFollowee = do
@ -666,7 +667,7 @@ postTicketsR shr prj = do
Entity _ p <- requireVerifiedAuth Entity _ p <- requireVerifiedAuth
runDB $ sharerIdent <$> getJust (personIdent p) runDB $ sharerIdent <$> getJust (personIdent p)
enum <- runExceptT $ do etid <- 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,17 +702,17 @@ postTicketsR shr prj = do
"Offer processed successfully but no ticket \ "Offer processed successfully but no ticket \
\created" \created"
Just tal -> Just tal ->
Right . ticketNumber <$> return $ Right $ ticketAuthorLocalTicket tal
getJust (ticketAuthorLocalTicket tal) case etid of
case enum of
Left e -> do Left e -> do
setMessage $ toHtml e setMessage $ toHtml e
defaultLayout $(widgetFile "ticket/new") defaultLayout $(widgetFile "ticket/new")
Right num -> do Right tid -> do
tkhid <- encodeKeyHashid tid
eobiidFollow <- runExceptT $ do eobiidFollow <- runExceptT $ do
(summary, audience, follow) <- followTicket shrAuthor shr prj num False (summary, audience, follow) <- followTicket shrAuthor shr prj tkhid 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 num redirect $ TicketR shr prj tkhid

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

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -128,17 +128,18 @@ getDiscussionMessage shr lmid = do
route2fed <- getEncodeRouteHome route2fed <- getEncodeRouteHome
uContext <- do uContext <- do
let did = messageRoot m let did = messageRoot m
mt <- getValBy $ UniqueTicketDiscussion did mt <- getBy $ UniqueTicketDiscussion did
mrd <- getValBy $ UniqueRemoteDiscussion did mrd <- getValBy $ UniqueRemoteDiscussion did
case (mt, mrd) of case (mt, 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 t, Nothing) -> do (Just (Entity tid t), Nothing) -> do
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
return $ route2fed $ TicketR shr prj $ ticketNumber t tkhid <- encodeKeyHashid tid
return $ route2fed $ TicketR shr prj tkhid
(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)

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

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2016, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -40,6 +40,7 @@ import qualified Database.Esqueleto as E
import Web.ActivityPub import Web.ActivityPub
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI import Yesod.FedURI
import Yesod.Hashids
import Database.Persist.Local import Database.Persist.Local
import Yesod.Persist.Local import Yesod.Persist.Local
@ -150,9 +151,10 @@ getSharerFollowingR shr = do
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.where_ $ t E.^. TicketId `E.in_` E.valList tids
return return
(s E.^. SharerIdent, j E.^. ProjectIdent, t E.^. TicketNumber) (s E.^. SharerIdent, j E.^. ProjectIdent, t E.^. TicketId)
encodeHid <- getEncodeKeyHashid
return $ return $
map (\ (E.Value shr, E.Value prj, E.Value num) -> TicketR shr prj num) map (\ (E.Value shr, E.Value prj, E.Value tid) -> TicketR shr prj $ encodeHid tid)
triples triples
getRepos fsids = do getRepos fsids = do
rids <- selectKeysList [RepoFollowers <-. fsids] [] rids <- selectKeysList [RepoFollowers <-. fsids] []

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

@ -57,7 +57,7 @@ where
import Control.Applicative (liftA2) import Control.Applicative (liftA2)
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger (logWarn) import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Data.Aeson (encode) import Data.Aeson (encode)
import Data.Bifunctor import Data.Bifunctor
@ -77,7 +77,7 @@ import Text.Blaze.Html (Html, toHtml, preEscapedToHtml)
import Text.Blaze.Html.Renderer.Text import Text.Blaze.Html.Renderer.Text
import Text.HTML.SanitizeXSS import Text.HTML.SanitizeXSS
import Yesod.Auth (requireAuthId, maybeAuthId) import Yesod.Auth (requireAuthId, maybeAuthId)
import Yesod.Core import Yesod.Core hiding (logWarn)
import Yesod.Core.Handler import Yesod.Core.Handler
import Yesod.Form.Functions (runFormGet, runFormPost) import Yesod.Form.Functions (runFormGet, runFormPost)
import Yesod.Form.Types (FormResult (..)) import Yesod.Form.Types (FormResult (..))
@ -147,7 +147,7 @@ getTicketsR shr prj = selectRep $ do
selectTickets off lim = selectTickets off lim =
getTicketSummaries getTicketSummaries
(filterTickets tf) (filterTickets tf)
(Just $ \ t -> [E.asc $ t E.^. TicketNumber]) (Just $ \ t -> [E.asc $ t E.^. TicketId])
(Just (off, lim)) (Just (off, lim))
jid jid
getPageAndNavCount countAllTickets selectTickets getPageAndNavCount countAllTickets selectTickets
@ -161,7 +161,7 @@ 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 TicketNumber, OffsetBy off, LimitTo lim] selectTickets off lim = selectList [TicketProject ==. jid] [Desc TicketId, OffsetBy off, LimitTo lim]
getPageAndNavCount countAllTickets selectTickets getPageAndNavCount countAllTickets selectTickets
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
@ -169,6 +169,8 @@ getTicketsR shr prj = selectRep $ do
encodeRoutePageLocal <- getEncodeRoutePageLocal encodeRoutePageLocal <- getEncodeRoutePageLocal
let pageUrl = encodeRoutePageLocal here let pageUrl = encodeRoutePageLocal here
host <- asksSite siteInstanceHost host <- asksSite siteInstanceHost
encodeTicketKey <- getEncodeKeyHashid
let ticketUrl = TicketR shr prj . encodeTicketKey
return $ return $
case mpage of case mpage of
@ -201,12 +203,11 @@ getTicketsR shr prj = selectRep $ do
else Nothing else Nothing
, collectionPageStartIndex = Nothing , collectionPageStartIndex = Nothing
, collectionPageItems = , collectionPageItems =
map (encodeRouteHome . ticketUrl . entityVal) map (encodeRouteHome . ticketUrl . entityKey)
tickets tickets
} }
where where
here = TicketsR shr prj here = TicketsR shr prj
ticketUrl = TicketR shr prj . ticketNumber
encodeStrict = BL.toStrict . encode encodeStrict = BL.toStrict . encode
getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
@ -214,9 +215,8 @@ getTicketTreeR shr prj = do
(summaries, deps) <- runDB $ do (summaries, deps) <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr Entity sid _ <- getBy404 $ UniqueSharer shr
Entity jid _ <- getBy404 $ UniqueProject prj sid Entity jid _ <- getBy404 $ UniqueProject prj sid
liftA2 (,) (,) <$> getTicketSummaries Nothing Nothing Nothing jid
(getTicketSummaries Nothing Nothing Nothing jid) <*> getTicketDepEdges jid
(getTicketDepEdges jid)
defaultLayout $ ticketTreeDW shr prj summaries deps defaultLayout $ ticketTreeDW shr prj summaries deps
getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
@ -228,8 +228,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 -> Int -> Handler TypedContent getTicketR :: ShrIdent -> PrjIdent -> TicketKeyHashid -> Handler TypedContent
getTicketR shar proj num = do getTicketR shar proj khid = do
mpid <- maybeAuthId mpid <- maybeAuthId
( wshr, wfl, ( wshr, wfl,
author, massignee, mcloser, ticket, tparams, eparams, cparams, author, massignee, mcloser, ticket, tparams, eparams, cparams,
@ -249,7 +249,9 @@ getTicketR shar proj num = do
, projectWorkflow project , projectWorkflow project
, workflowIdent w , workflowIdent w
) )
Entity tid ticket <- getBy404 $ UniqueTicket jid num tid <- decodeKeyHashid404 khid
ticket <- get404 tid
unless (ticketProject ticket == jid) notFound
author <- author <-
requireEitherAlt requireEitherAlt
(do mtal <- getValBy $ UniqueTicketAuthorLocal tid (do mtal <- getValBy $ UniqueTicketAuthorLocal tid
@ -304,8 +306,8 @@ getTicketR shar proj num = do
discuss = discuss =
discussionW discussionW
(return $ ticketDiscuss ticket) (return $ ticketDiscuss ticket)
(TicketTopReplyR shar proj num) (TicketTopReplyR shar proj khid)
(TicketReplyR shar proj num . encodeHid) (TicketReplyR shar proj khid . encodeHid)
cRelevant <- newIdent cRelevant <- newIdent
cIrrelevant <- newIdent cIrrelevant <- newIdent
let relevant filt = let relevant filt =
@ -326,21 +328,21 @@ getTicketR shar proj num = do
( hLocal ( hLocal
, AP.TicketLocal , AP.TicketLocal
{ AP.ticketId = { AP.ticketId =
encodeRouteLocal $ TicketR shar proj num encodeRouteLocal $ TicketR shar proj khid
, AP.ticketContext = , AP.ticketContext =
encodeRouteLocal $ ProjectR shar proj encodeRouteLocal $ ProjectR shar proj
, AP.ticketReplies = , AP.ticketReplies =
encodeRouteLocal $ TicketDiscussionR shar proj num encodeRouteLocal $ TicketDiscussionR shar proj khid
, AP.ticketParticipants = , AP.ticketParticipants =
encodeRouteLocal $ TicketParticipantsR shar proj num encodeRouteLocal $ TicketParticipantsR shar proj khid
, AP.ticketTeam = , AP.ticketTeam =
encodeRouteLocal $ TicketTeamR shar proj num encodeRouteLocal $ TicketTeamR shar proj khid
, AP.ticketEvents = , AP.ticketEvents =
encodeRouteLocal $ TicketEventsR shar proj num encodeRouteLocal $ TicketEventsR shar proj khid
, AP.ticketDeps = , AP.ticketDeps =
encodeRouteLocal $ TicketDepsR shar proj num encodeRouteLocal $ TicketDepsR shar proj khid
, AP.ticketReverseDeps = , AP.ticketReverseDeps =
encodeRouteLocal $ TicketReverseDepsR shar proj num encodeRouteLocal $ TicketReverseDepsR shar proj khid
} }
) )
@ -352,7 +354,7 @@ getTicketR shar proj num = do
remoteObjectIdent object remoteObjectIdent object
, AP.ticketPublished = Just $ ticketCreated ticket , AP.ticketPublished = Just $ ticketCreated ticket
, AP.ticketUpdated = Nothing , AP.ticketUpdated = Nothing
, AP.ticketName = Just $ "#" <> T.pack (show num) -- , AP.ticketName = Just $ "#" <> T.pack (show num)
, AP.ticketSummary = TextHtml $ ticketTitle ticket , AP.ticketSummary = TextHtml $ ticketTitle ticket
, AP.ticketContent = TextHtml $ ticketDescription ticket , AP.ticketContent = TextHtml $ ticketDescription ticket
, AP.ticketSource = TextPandocMarkdown $ ticketSource ticket , AP.ticketSource = TextPandocMarkdown $ ticketSource ticket
@ -363,17 +365,19 @@ getTicketR shar proj num = do
provideHtmlAndAP' host ticketAP $ provideHtmlAndAP' host ticketAP $
let followButton = let followButton =
followW followW
(TicketFollowR shar proj num) (TicketFollowR shar proj khid)
(TicketUnfollowR shar proj num) (TicketUnfollowR shar proj khid)
(return $ ticketFollowers ticket) (return $ ticketFollowers ticket)
in $(widgetFile "ticket/one") in $(widgetFile "ticket/one")
putTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html putTicketR :: ShrIdent -> PrjIdent -> TicketKeyHashid -> Handler Html
putTicketR shar proj num = do putTicketR shr prj tkhid = do
(tid, ticket, wid) <- runDB $ do (tid, ticket, wid) <- runDB $ 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
Entity tid ticket <- getBy404 $ UniqueTicket pid num tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
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
@ -383,7 +387,7 @@ putTicketR shar proj num = 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 shar proj num redirect $ TicketEditR shr prj tkhid
Right t -> return t Right t -> return t
let ticket'' = ticket' { ticketDescription = newDescHtml } let ticket'' = ticket' { ticketDescription = newDescHtml }
runDB $ do runDB $ do
@ -422,7 +426,7 @@ putTicketR shar proj num = do
} }
insertMany_ $ map mkcparam cins insertMany_ $ map mkcparam cins
setMessage "Ticket updated." setMessage "Ticket updated."
redirect $ TicketR shar proj num redirect $ TicketR shr prj tkhid
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing." setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/edit") defaultLayout $(widgetFile "ticket/edit")
@ -430,38 +434,43 @@ putTicketR shar proj num = 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 -> Int -> Handler Html deleteTicketR :: ShrIdent -> PrjIdent -> TicketKeyHashid -> Handler Html
deleteTicketR shar proj num = deleteTicketR _shr _prj _tkhid =
--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 -> Int -> Handler Html postTicketR :: ShrIdent -> PrjIdent -> TicketKeyHashid -> Handler Html
postTicketR shar proj num = do postTicketR shr prj tkhid = do
mmethod <- lookupPostParam "_method" mmethod <- lookupPostParam "_method"
case mmethod of case mmethod of
Just "PUT" -> putTicketR shar proj num Just "PUT" -> putTicketR shr prj tkhid
Just "DELETE" -> deleteTicketR shar proj num Just "DELETE" -> deleteTicketR shr prj tkhid
_ -> notFound _ -> notFound
getTicketEditR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketEditR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
getTicketEditR shar proj num = do getTicketEditR shr prj tkhid = do
(tid, ticket, wid) <- runDB $ do (tid, ticket, wid) <- runDB $ 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
Entity tid ticket <- getBy404 $ UniqueTicket pid num tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
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 -> Int -> Handler Html postTicketAcceptR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
postTicketAcceptR shr prj num = do postTicketAcceptR shr prj tkhid = 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
getBy404 $ UniqueTicket p num tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
unless (ticketProject ticket == p) notFound
return $ Entity tid ticket
case ticketStatus ticket of case ticketStatus ticket of
TSNew -> do TSNew -> do
update tid [TicketStatus =. TSTodo] update tid [TicketStatus =. TSTodo]
@ -471,17 +480,20 @@ postTicketAcceptR shr prj num = 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 num redirect $ TicketR shr prj tkhid
postTicketCloseR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketCloseR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
postTicketCloseR shr prj num = do postTicketCloseR shr prj tkhid = 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
getBy404 $ UniqueTicket p num tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
unless (ticketProject ticket == p) notFound
return $ Entity tid ticket
case ticketStatus ticket of case ticketStatus ticket of
TSClosed -> return False TSClosed -> return False
_ -> do _ -> do
@ -496,17 +508,20 @@ postTicketCloseR shr prj num = 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 num redirect $ TicketR shr prj tkhid
postTicketOpenR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketOpenR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
postTicketOpenR shr prj num = do postTicketOpenR shr prj tkhid = 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
getBy404 $ UniqueTicket p num tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
unless (ticketProject ticket == p) notFound
return $ Entity tid ticket
case ticketStatus ticket of case ticketStatus ticket of
TSClosed -> do TSClosed -> do
update tid update tid
@ -519,16 +534,19 @@ postTicketOpenR shr prj num = 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 num redirect $ TicketR shr prj tkhid
postTicketClaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketClaimR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
postTicketClaimR shr prj num = do postTicketClaimR shr prj tkhid = 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
getBy404 $ UniqueTicket p num tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
unless (ticketProject ticket == p) notFound
return $ Entity tid ticket
case (ticketStatus ticket, ticketAssignee ticket) of case (ticketStatus ticket, ticketAssignee ticket) of
(TSNew, _) -> (TSNew, _) ->
return $ return $
@ -543,46 +561,51 @@ postTicketClaimR shr prj num = 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 num redirect $ TicketR shr prj tkhid
postTicketUnclaimR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketUnclaimR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
postTicketUnclaimR shr prj num = do postTicketUnclaimR shr prj tkhid = 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
getBy404 $ UniqueTicket p num tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
unless (ticketProject ticket == p) notFound
return $ Entity tid ticket
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
(Nothing, _) -> (Nothing, _) ->
return $ Just "The ticket is already unassigned." return $ Just "The ticket is already unassigned."
(Just False, _) -> (Just False, _) ->
return $ Just "The ticket is assigned to someone else." return $ Just "The ticket is assigned to someone else."
(Just True, TSNew) -> do (Just True, TSNew) -> do
$logWarn "Found a new claimed ticket, this is invalid" logWarn "Found a new claimed ticket, this is invalid"
return $ return $
Just "The ticket isn’t accepted yet. Can’t unclaim it." Just "The ticket isn’t accepted yet. Can’t unclaim it."
(Just True, TSClosed) -> do (Just True, TSClosed) -> do
$logWarn "Found a closed claimed ticket, this is invalid" logWarn "Found a closed claimed ticket, this is invalid"
return $ return $
Just "The ticket is closed. Can’t unclaim closed tickets." Just "The ticket is closed. Can’t unclaim closed tickets."
(Just True, TSTodo) -> do (Just True, TSTodo) -> 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 num redirect $ TicketR shr prj tkhid
getTicketAssignR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketAssignR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
getTicketAssignR shr prj num = do getTicketAssignR shr prj tkhid = 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
et <- getBy404 $ UniqueTicket j num tid <- decodeKeyHashid404 tkhid
return (j, et) ticket <- get404 tid
unless (ticketProject ticket == j) notFound
return (j, Entity tid ticket)
let msg t = do let msg t = do
setMessage t setMessage t
redirect $ TicketR shr prj num redirect $ TicketR shr prj tkhid
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."
@ -592,17 +615,19 @@ getTicketAssignR shr prj num = do
runFormPost $ assignTicketForm vpid jid runFormPost $ assignTicketForm vpid jid
defaultLayout $(widgetFile "ticket/assign") defaultLayout $(widgetFile "ticket/assign")
postTicketAssignR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketAssignR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
postTicketAssignR shr prj num = do postTicketAssignR shr prj tkhid = 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
et <- getBy404 $ UniqueTicket j num tid <- decodeKeyHashid404 tkhid
return (j, et) ticket <- get404 tid
unless (ticketProject ticket == j) notFound
return (j, Entity tid ticket)
let msg t = do let msg t = do
setMessage t setMessage t
redirect $ TicketR shr prj num redirect $ TicketR shr prj tkhid
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."
@ -626,32 +651,35 @@ postTicketAssignR shr prj num = 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 -> Int -> Handler Html postTicketUnassignR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
postTicketUnassignR shr prj num = do postTicketUnassignR shr prj tkhid = 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
getBy404 $ UniqueTicket p num tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
unless (ticketProject ticket == p) notFound
return $ Entity tid ticket
case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of case ((== pid) <$> ticketAssignee ticket, ticketStatus ticket) of
(Nothing, _) -> (Nothing, _) ->
return $ Just "The ticket is already unassigned." return $ Just "The ticket is already unassigned."
(Just True, _) -> (Just True, _) ->
return $ Just "The ticket is assigned to you, unclaim instead." return $ Just "The ticket is assigned to you, unclaim instead."
(Just False, TSNew) -> do (Just False, TSNew) -> do
$logWarn "Found a new claimed ticket, this is invalid" logWarn "Found a new claimed ticket, this is invalid"
return $ return $
Just "The ticket isn’t accepted yet. Can’t unclaim it." Just "The ticket isn’t accepted yet. Can’t unclaim it."
(Just False, TSClosed) -> do (Just False, TSClosed) -> do
$logWarn "Found a closed claimed ticket, this is invalid" logWarn "Found a closed claimed ticket, this is invalid"
return $ return $
Just "The ticket is closed. Can’t unclaim closed tickets." Just "The ticket is closed. Can’t unclaim closed tickets."
(Just False, TSTodo) -> do (Just False, TSTodo) -> 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 num redirect $ TicketR shr prj tkhid
-- | 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.
@ -668,10 +696,11 @@ getClaimRequestsPersonR = do
return return
( sharer E.^. SharerIdent ( sharer E.^. SharerIdent
, project E.^. ProjectIdent , project E.^. ProjectIdent
, ticket E.^. TicketNumber , ticket E.^. TicketId
, ticket E.^. TicketTitle , ticket E.^. TicketTitle
, tcr E.^. TicketClaimRequestCreated , tcr E.^. TicketClaimRequestCreated
) )
encodeHid <- getEncodeKeyHashid
defaultLayout $(widgetFile "person/claim-requests") defaultLayout $(widgetFile "person/claim-requests")
-- | Get a list of ticket claim requests for a given project. -- | Get a list of ticket claim requests for a given project.
@ -693,19 +722,23 @@ getClaimRequestsProjectR shr prj = do
E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated] E.orderBy [E.desc $ tcr E.^. TicketClaimRequestCreated]
return return
( sharer ( sharer
, ticket E.^. TicketNumber , ticket E.^. TicketId
, ticket E.^. TicketTitle , ticket E.^. TicketTitle
, tcr E.^. TicketClaimRequestCreated , tcr E.^. TicketClaimRequestCreated
) )
encodeHid <- getEncodeKeyHashid
defaultLayout $(widgetFile "project/claim-request/list") defaultLayout $(widgetFile "project/claim-request/list")
-- | Get a list of ticket claim requests for a given ticket. -- | Get a list of ticket claim requests for a given ticket.
getClaimRequestsTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html getClaimRequestsTicketR
getClaimRequestsTicketR shr prj num = do :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
getClaimRequestsTicketR shr prj tkhid = 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
Entity tid _ <- getBy404 $ UniqueTicket jid num tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
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
E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId E.on $ tcr E.^. TicketClaimRequestPerson E.==. person E.^. PersonId
@ -714,13 +747,14 @@ getClaimRequestsTicketR shr prj num = do
return (sharer, tcr) return (sharer, tcr)
defaultLayout $(widgetFile "ticket/claim-request/list") defaultLayout $(widgetFile "ticket/claim-request/list")
getClaimRequestNewR :: ShrIdent -> PrjIdent -> Int -> Handler Html getClaimRequestNewR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
getClaimRequestNewR shr prj num = do getClaimRequestNewR shr prj tkhid = do
((_result, widget), etype) <- runFormPost claimRequestForm ((_result, widget), etype) <- runFormPost claimRequestForm
defaultLayout $(widgetFile "ticket/claim-request/new") defaultLayout $(widgetFile "ticket/claim-request/new")
postClaimRequestsTicketR :: ShrIdent -> PrjIdent -> Int -> Handler Html postClaimRequestsTicketR
postClaimRequestsTicketR shr prj num = do :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
postClaimRequestsTicketR shr prj tkhid = do
((result, widget), etype) <- runFormPost claimRequestForm ((result, widget), etype) <- runFormPost claimRequestForm
case result of case result of
FormSuccess msg -> do FormSuccess msg -> do
@ -730,8 +764,10 @@ postClaimRequestsTicketR shr prj num = 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
Entity t _ <- getBy404 $ UniqueTicket j num tid <- decodeKeyHashid404 tkhid
return t ticket <- get404 tid
unless (ticketProject ticket == j) notFound
return tid
let cr = TicketClaimRequest let cr = TicketClaimRequest
{ ticketClaimRequestPerson = pid { ticketClaimRequestPerson = pid
, ticketClaimRequestTicket = tid , ticketClaimRequestTicket = tid
@ -740,7 +776,7 @@ postClaimRequestsTicketR shr prj num = do
} }
insert_ cr insert_ cr
setMessage "Ticket claim request opened." setMessage "Ticket claim request opened."
redirect $ TicketR shr prj num redirect $ TicketR shr prj tkhid
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing." setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/claim-request/new") defaultLayout $(widgetFile "ticket/claim-request/new")
@ -748,43 +784,53 @@ postClaimRequestsTicketR shr prj num = do
setMessage "Submission failed, see errors below." setMessage "Submission failed, see errors below."
defaultLayout $(widgetFile "ticket/claim-request/new") defaultLayout $(widgetFile "ticket/claim-request/new")
selectDiscussionId :: ShrIdent -> PrjIdent -> Int -> AppDB DiscussionId selectDiscussionId
selectDiscussionId shar proj tnum = do :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> AppDB DiscussionId
selectDiscussionId shar proj tkhid = do
Entity sid _sharer <- getBy404 $ UniqueSharer shar Entity sid _sharer <- getBy404 $ UniqueSharer shar
Entity pid _project <- getBy404 $ UniqueProject proj sid Entity pid _project <- getBy404 $ UniqueProject proj sid
Entity _tid ticket <- getBy404 $ UniqueTicket pid tnum tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
unless (ticketProject ticket == pid) notFound
return $ ticketDiscuss ticket return $ ticketDiscuss ticket
getTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketDiscussionR
getTicketDiscussionR shar proj num = do :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
getTicketDiscussionR shar proj tkhid = do
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
getDiscussion getDiscussion
(TicketReplyR shar proj num . encodeHid) (TicketReplyR shar proj tkhid . encodeHid)
(TicketTopReplyR shar proj num) (TicketTopReplyR shar proj tkhid)
(selectDiscussionId shar proj num) (selectDiscussionId shar proj tkhid)
postTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketDiscussionR
postTicketDiscussionR shr prj num = do :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
postTicketDiscussionR shr prj tkhid = 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 num , TicketParticipantsR shr prj tkhid
, TicketTeamR shr prj num , TicketTeamR shr prj tkhid
] ]
(TicketR shr prj num) (TicketR shr prj tkhid)
(ProjectR shr prj) (ProjectR shr prj)
(TicketDiscussionR shr prj num) (TicketDiscussionR shr prj tkhid)
(const $ TicketR shr prj num) (const $ TicketR shr prj tkhid)
getMessageR :: ShrIdent -> KeyHashid LocalMessage -> Handler TypedContent getMessageR :: ShrIdent -> KeyHashid LocalMessage -> Handler TypedContent
getMessageR shr hid = do getMessageR shr hid = do
lmid <- decodeKeyHashid404 hid lmid <- decodeKeyHashid404 hid
getDiscussionMessage shr lmid getDiscussionMessage shr lmid
postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> KeyHashid Message -> Handler Html postTicketMessageR
postTicketMessageR shr prj num mkhid = do :: ShrIdent
-> PrjIdent
-> KeyHashid Ticket
-> KeyHashid Message
-> Handler Html
postTicketMessageR shr prj tkhid mkhid = do
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
mid <- decodeKeyHashid404 mkhid mid <- decodeKeyHashid404 mkhid
hLocal <- getsYesod $ appInstanceHost . appSettings hLocal <- getsYesod $ appInstanceHost . appSettings
@ -792,35 +838,36 @@ postTicketMessageR shr prj num mkhid = do
hLocal hLocal
[ProjectR shr prj] [ProjectR shr prj]
[ ProjectFollowersR shr prj [ ProjectFollowersR shr prj
, TicketParticipantsR shr prj num , TicketParticipantsR shr prj tkhid
, TicketTeamR shr prj num , TicketTeamR shr prj tkhid
] ]
(TicketR shr prj num) (TicketR shr prj tkhid)
(ProjectR shr prj) (ProjectR shr prj)
(TicketReplyR shr prj num . encodeHid) (TicketReplyR shr prj tkhid . encodeHid)
(TicketMessageR shr prj num . encodeHid) (TicketMessageR shr prj tkhid . encodeHid)
(const $ TicketR shr prj num) (const $ TicketR shr prj tkhid)
(selectDiscussionId shr prj num) (selectDiscussionId shr prj tkhid)
mid mid
getTicketTopReplyR :: ShrIdent -> PrjIdent -> Int -> Handler Html getTicketTopReplyR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
getTicketTopReplyR shar proj num = getTicketTopReplyR shar proj tkhid =
getTopReply $ TicketDiscussionR shar proj num getTopReply $ TicketDiscussionR shar proj tkhid
getTicketReplyR :: ShrIdent -> PrjIdent -> Int -> KeyHashid Message -> Handler Html getTicketReplyR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> KeyHashid Message -> Handler Html
getTicketReplyR shar proj tnum hid = do getTicketReplyR shar proj tkhid hid = do
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
mid <- decodeKeyHashid404 hid mid <- decodeKeyHashid404 hid
getReply getReply
(TicketReplyR shar proj tnum . encodeHid) (TicketReplyR shar proj tkhid . encodeHid)
(TicketMessageR shar proj tnum . encodeHid) (TicketMessageR shar proj tkhid . encodeHid)
(selectDiscussionId shar proj tnum) (selectDiscussionId shar proj tkhid)
mid mid
getTicketDeps :: Bool -> ShrIdent -> PrjIdent -> Int -> Handler TypedContent getTicketDeps :: Bool -> ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler TypedContent
getTicketDeps forward shr prj num = do getTicketDeps forward shr prj tkhid = do
(deps, rows) <- unzip <$> runDB getDepsFromDB (deps, rows) <- unzip <$> runDB getDepsFromDB
depsAP <- makeDepsCollection deps depsAP <- makeDepsCollection deps
encodeHid <- getEncodeKeyHashid
provideHtmlAndAP depsAP $(widgetFile "ticket/dep/list") provideHtmlAndAP depsAP $(widgetFile "ticket/dep/list")
where where
getDepsFromDB = do getDepsFromDB = do
@ -830,7 +877,9 @@ getTicketDeps forward shr prj num = 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
Entity tid _ <- getBy404 $ UniqueTicket jid num tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
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
@ -849,7 +898,7 @@ getTicketDeps forward shr prj num = do
E.orderBy [E.asc $ t E.^. TicketNumber] E.orderBy [E.asc $ t E.^. TicketNumber]
return return
( td E.^. TicketDependencyId ( td E.^. TicketDependencyId
, t E.^. TicketNumber , t E.^. TicketId
, s , s
, i , i
, ro , ro
@ -858,9 +907,9 @@ getTicketDeps forward shr prj num = do
, t E.^. TicketStatus , t E.^. TicketStatus
) )
where where
toRow (E.Value dep, E.Value number, ms, mi, mro, mra, E.Value title, E.Value status) = toRow (E.Value dep, E.Value tid, ms, mi, mro, mra, E.Value title, E.Value status) =
( dep ( dep
, ( number , ( tid
, 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
@ -877,7 +926,7 @@ getTicketDeps forward shr prj num = 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 num in route shr prj tkhid
return Collection return Collection
{ collectionId = encodeRouteLocal here { collectionId = encodeRouteLocal here
, collectionType = CollectionTypeUnordered , collectionType = CollectionTypeUnordered
@ -889,15 +938,18 @@ getTicketDeps forward shr prj num = do
map (encodeRouteHome . TicketDepR . encodeKeyHashid) tdids map (encodeRouteHome . TicketDepR . encodeKeyHashid) tdids
} }
getTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent getTicketDepsR
:: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler TypedContent
getTicketDepsR = getTicketDeps True getTicketDepsR = getTicketDeps True
postTicketDepsR :: ShrIdent -> PrjIdent -> Int -> Handler Html postTicketDepsR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
postTicketDepsR shr prj num = do postTicketDepsR shr prj tkhid = 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
Entity tid _ <- getBy404 $ UniqueTicket jid num tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
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
case result of case result of
@ -915,7 +967,7 @@ postTicketDepsR shr prj num = do
insert_ td insert_ td
trrFix td ticketDepGraph trrFix td ticketDepGraph
setMessage "Ticket dependency added." setMessage "Ticket dependency added."
redirect $ TicketR shr prj num redirect $ TicketR shr prj tkhid
FormMissing -> do FormMissing -> do
setMessage "Field(s) missing." setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/dep/new") defaultLayout $(widgetFile "ticket/dep/new")
@ -923,25 +975,30 @@ postTicketDepsR shr prj num = 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 -> Int -> Handler Html getTicketDepNewR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler Html
getTicketDepNewR shr prj num = do getTicketDepNewR shr prj tkhid = 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
Entity tid _ <- getBy404 $ UniqueTicket jid num tid <- decodeKeyHashid404 tkhid
ticket <- get404 tid
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 -> Int -> Int -> Handler Html postTicketDepOldR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> KeyHashid Ticket -> Handler Html
postTicketDepOldR shr prj pnum cnum = do postTicketDepOldR shr prj pnum cnum = error "Disabled for now"
{-
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 -> Int -> Int -> Handler Html deleteTicketDepOldR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> KeyHashid Ticket -> Handler Html
deleteTicketDepOldR shr prj pnum cnum = do deleteTicketDepOldR shr prj pnum cnum = error "Disabled for now"
{-
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
@ -951,8 +1008,10 @@ deleteTicketDepOldR shr prj pnum cnum = do
delete tdid delete tdid
setMessage "Ticket dependency removed." setMessage "Ticket dependency removed."
redirect $ TicketDepsR shr prj pnum redirect $ TicketDepsR shr prj pnum
-}
getTicketReverseDepsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent getTicketReverseDepsR
:: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler TypedContent
getTicketReverseDepsR = getTicketDeps False getTicketReverseDepsR = getTicketDeps False
getTicketDepR :: KeyHashid TicketDependency -> Handler TypedContent getTicketDepR :: KeyHashid TicketDependency -> Handler TypedContent
@ -971,8 +1030,9 @@ getTicketDepR tdkhid = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
encodeHid <- getEncodeKeyHashid
let ticketRoute s j t = let ticketRoute s j t =
TicketR (sharerIdent s) (projectIdent j) (ticketNumber t) TicketR (sharerIdent s) (projectIdent j) (encodeHid t)
here = TicketDepR tdkhid here = TicketDepR tdkhid
tdepAP = AP.TicketDependency tdepAP = AP.TicketDependency
{ ticketDepId = Just $ encodeRouteHome here { ticketDepId = Just $ encodeRouteHome here
@ -993,28 +1053,34 @@ getTicketDepR tdkhid = do
t <- getJust tid t <- getJust tid
j <- getJust $ ticketProject t j <- getJust $ ticketProject t
s <- getJust $ projectSharer j s <- getJust $ projectSharer j
return (s, j, t) return (s, j, tid)
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 :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent getTicketParticipantsR
getTicketParticipantsR shr prj num = getFollowersCollection here getFsid :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler TypedContent
getTicketParticipantsR shr prj tkhid = getFollowersCollection here getFsid
where where
here = TicketParticipantsR shr prj num here = TicketParticipantsR shr prj tkhid
getFsid = do getFsid = do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
jid <- getKeyBy404 $ UniqueProject prj sid jid <- getKeyBy404 $ UniqueProject prj sid
t <- getValBy404 $ UniqueTicket jid num tid <- decodeKeyHashid404 tkhid
t <- get404 tid
unless (ticketProject t == jid) notFound
return $ ticketFollowers t return $ ticketFollowers t
getTicketTeamR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent getTicketTeamR
getTicketTeamR shr prj num = do :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler TypedContent
getTicketTeamR shr prj tkhid = 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 <- getKeyBy404 $ UniqueTicket _jid num tid <- decodeKeyHashid404 tkhid
t <- get404 tid
unless (ticketProject t == jid) notFound
id_ <- id_ <-
requireEitherAlt requireEitherAlt
(getKeyBy $ UniquePersonIdent sid) (getKeyBy $ UniquePersonIdent sid)
@ -1033,7 +1099,7 @@ getTicketTeamR shr prj num = do
map (sharerIdent . entityVal) <$> map (sharerIdent . entityVal) <$>
selectList [SharerId <-. sids] [] selectList [SharerId <-. sids] []
let here = TicketTeamR shr prj num let here = TicketTeamR shr prj tkhid
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
@ -1046,7 +1112,8 @@ getTicketTeamR shr prj num = do
, collectionLast = Nothing , collectionLast = Nothing
, collectionItems = map (encodeRouteHome . SharerR) memberShrs , collectionItems = map (encodeRouteHome . SharerR) memberShrs
} }
provideHtmlAndAP team $ redirect (here, [("prettyjson", "true")]) provideHtmlAndAP team $ redirectToPrettyJSON here
getTicketEventsR :: ShrIdent -> PrjIdent -> Int -> Handler TypedContent getTicketEventsR
getTicketEventsR shr prj num = error "TODO not implemented" :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler TypedContent
getTicketEventsR _shr _prj _tkhid = error "TODO not implemented"

7
src/Vervis/Migration.hs
View file

@ -753,7 +753,7 @@ changes hLocal ctx =
, ticketPublished = , ticketPublished =
Just $ ticket20190612Created ticket Just $ ticket20190612Created ticket
, ticketUpdated = Nothing , ticketUpdated = Nothing
, ticketName = Just $ "#" <> T.pack (show num) -- , ticketName = Just $ "#" <> T.pack (show num)
, ticketSummary = , ticketSummary =
TextHtml $ TL.toStrict $ renderHtml $ toHtml $ TextHtml $ TL.toStrict $ renderHtml $ toHtml $
ticket20190612Title ticket ticket20190612Title ticket
@ -907,6 +907,7 @@ changes hLocal ctx =
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
renderUrl <- askUrlRenderParams renderUrl <- askUrlRenderParams
encodeHid <- getEncodeKeyHashid
offerR <- do offerR <- do
let obiidOffer = ticketAuthorLocal20190624Offer tal let obiidOffer = ticketAuthorLocal20190624Offer tal
obikhid <- obikhid <-
@ -928,7 +929,7 @@ changes hLocal ctx =
<a href=@{ProjectR shrProject prj}> <a href=@{ProjectR shrProject prj}>
./s/#{shr2text shrProject}/p/#{prj2text prj} ./s/#{shr2text shrProject}/p/#{prj2text prj}
: # : #
<a href=@{TicketR shrProject prj num}> <a href=@{TicketR shrProject prj $ encodeHid $ toSqlKey $ fromSqlKey tid}>
#{preEscapedToHtml $ ticket20190624Title ticket}. #{preEscapedToHtml $ ticket20190624Title ticket}.
|] |]
doc mluAct = Doc hLocal Activity doc mluAct = Doc hLocal Activity
@ -942,7 +943,7 @@ changes hLocal ctx =
{ acceptObject = encodeRouteHome offerR { acceptObject = encodeRouteHome offerR
, acceptResult = , acceptResult =
Just $ encodeRouteLocal $ Just $ encodeRouteLocal $
TicketR shrProject prj num TicketR shrProject prj $ encodeHid $ toSqlKey $ fromSqlKey tid
} }
} }
obiidNew <- insert OutboxItem20190624 obiidNew <- insert OutboxItem20190624

14
src/Vervis/Ticket.hs
View file

@ -32,6 +32,7 @@ where
import Control.Arrow ((***)) import Control.Arrow ((***))
import Data.Foldable (for_) import Data.Foldable (for_)
import Data.Int
import Data.Text (Text) import Data.Text (Text)
import Data.Traversable import Data.Traversable
import Database.Esqueleto import Database.Esqueleto
@ -78,7 +79,6 @@ getTicketSummaries mfilt morder offlim jid = do
limit $ fromIntegral lim limit $ fromIntegral lim
return return
( t ^. TicketId ( t ^. TicketId
, t ^. TicketNumber
, s , s
, i , i
, ro , ro
@ -89,13 +89,13 @@ getTicketSummaries mfilt morder offlim jid = do
, count $ m ?. MessageId , count $ m ?. MessageId
) )
for tickets $ for tickets $
\ (Value tid, Value n, ms, mi, mro, mra, Value c, Value t, Value d, Value r) -> do \ (Value tid, 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
{ tsNumber = n { tsId = tid
, tsCreatedBy = , tsCreatedBy =
case (ms, mi, mro, mra) of case (ms, mi, mro, mra) of
(Just s, Nothing, Nothing, Nothing) -> (Just s, Nothing, Nothing, Nothing) ->
@ -113,17 +113,17 @@ getTicketSummaries mfilt morder offlim jid = do
-- | Get the child-parent ticket number pairs of all the ticket dependencies -- | Get the child-parent ticket number pairs of all the ticket dependencies
-- in the given project, in ascending order by child, and then ascending order -- in the given project, in ascending order by child, and then ascending order
-- by parent. -- by parent.
getTicketDepEdges :: ProjectId -> AppDB [(Int, Int)] getTicketDepEdges :: ProjectId -> AppDB [(Int64, Int64)]
getTicketDepEdges jid = getTicketDepEdges jid =
fmap (map $ unValue *** unValue) $ fmap (map $ fromSqlKey . unValue *** fromSqlKey . unValue) $
select $ from $ \ (t1 `InnerJoin` td `InnerJoin` t2) -> do select $ from $ \ (t1 `InnerJoin` td `InnerJoin` t2) -> do
on $ t2 ^. TicketId ==. td ^. TicketDependencyParent on $ t2 ^. TicketId ==. td ^. TicketDependencyParent
on $ t1 ^. TicketId ==. td ^. TicketDependencyChild on $ t1 ^. TicketId ==. td ^. TicketDependencyChild
where_ $ where_ $
t1 ^. TicketProject ==. val jid &&. t1 ^. TicketProject ==. val jid &&.
t2 ^. TicketProject ==. val jid t2 ^. TicketProject ==. val jid
orderBy [asc $ t1 ^. TicketNumber, asc $ t2 ^. TicketNumber] orderBy [asc $ t1 ^. TicketId, asc $ t2 ^. TicketId]
return (t1 ^. TicketNumber, t2 ^. TicketNumber) return (t1 ^. TicketId, t2 ^. TicketId)
data WorkflowFieldFilter = WorkflowFieldFilter data WorkflowFieldFilter = WorkflowFieldFilter
{ wffNew :: Bool { wffNew :: Bool

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

@ -24,9 +24,12 @@ where
import Control.Arrow ((&&&), (***)) import Control.Arrow ((&&&), (***))
import Data.HashMap.Lazy (HashMap) import Data.HashMap.Lazy (HashMap)
import Data.Int
import Data.Maybe (mapMaybe) import Data.Maybe (mapMaybe)
import Data.Text (Text) import Data.Text (Text)
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import Database.Persist (Entity (..))
import Database.Persist.Sql (fromSqlKey)
import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html (preEscapedToHtml)
import Yesod.Core (MonadHandler, newIdent) import Yesod.Core (MonadHandler, newIdent)
import Yesod.Core.Handler (getCurrentRoute, getRequest, YesodRequest (..)) import Yesod.Core.Handler (getCurrentRoute, getRequest, YesodRequest (..))
@ -37,6 +40,8 @@ import qualified Data.Text as T (null, pack, unpack)
import qualified Data.Text.Read as TR (decimal) import qualified Data.Text.Read as TR (decimal)
import Data.Graph.DirectedAcyclic.View.Tree import Data.Graph.DirectedAcyclic.View.Tree
import Yesod.Hashids
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
@ -47,7 +52,7 @@ import Vervis.Time (showDate)
import Vervis.Widget.Sharer import Vervis.Widget.Sharer
data TicketSummary = TicketSummary data TicketSummary = TicketSummary
{ tsNumber :: Int { tsId :: TicketId
, tsCreatedBy :: Either Sharer (Instance, RemoteObject, RemoteActor) , tsCreatedBy :: Either Sharer (Instance, RemoteObject, RemoteActor)
, tsCreatedAt :: UTCTime , tsCreatedAt :: UTCTime
, tsTitle :: Text , tsTitle :: Text
@ -56,8 +61,9 @@ data TicketSummary = TicketSummary
, tsComments :: Int , tsComments :: Int
} }
ticketDepW :: ShrIdent -> PrjIdent -> Ticket -> Widget ticketDepW :: ShrIdent -> PrjIdent -> Entity Ticket -> Widget
ticketDepW shr prj ticket = do ticketDepW shr prj (Entity tid ticket) = do
encodeTicketKey <- getEncodeKeyHashid
cNew <- newIdent cNew <- newIdent
cTodo <- newIdent cTodo <- newIdent
cClosed <- newIdent cClosed <- newIdent
@ -67,9 +73,10 @@ ticketSummaryW
:: ShrIdent :: ShrIdent
-> PrjIdent -> PrjIdent
-> TicketSummary -> TicketSummary
-> Maybe (HashMap Int Int) -> Maybe (HashMap Int64 Int64)
-> Widget -> Widget
ticketSummaryW shr prj ts mcs = do ticketSummaryW shr prj ts mcs = do
encodeTicketKey <- getEncodeKeyHashid
cNew <- newIdent cNew <- newIdent
cTodo <- newIdent cTodo <- newIdent
cClosed <- newIdent cClosed <- newIdent
@ -92,7 +99,7 @@ ticketTreeVW
:: ShrIdent :: ShrIdent
-> PrjIdent -> PrjIdent
-> Text -> Text
-> DagViewTree TicketSummary (TicketSummary, HashMap Int Int) -> DagViewTree TicketSummary (TicketSummary, HashMap Int64 Int64)
-> Widget -> Widget
ticketTreeVW shr prj cDeps t = go t ticketTreeVW shr prj cDeps t = go t
where where
@ -108,7 +115,7 @@ ticketTreeVW shr prj cDeps t = go t
-- | In the request's GET parameters, find ones of the form @N=M@ where N and M -- | In the request's GET parameters, find ones of the form @N=M@ where N and M
-- are integers. Return a list of pairs corresponding to those parameters. -- are integers. Return a list of pairs corresponding to those parameters.
getParentChoices :: MonadHandler m => m [(Int, Int)] getParentChoices :: MonadHandler m => m [(Int64, Int64)]
getParentChoices = mapMaybe readInts . reqGetParams <$> getRequest getParentChoices = mapMaybe readInts . reqGetParams <$> getRequest
where where
readInts (ct, pt) = readInts (ct, pt) =
@ -120,11 +127,11 @@ getParentChoices = mapMaybe readInts . reqGetParams <$> getRequest
_ -> Nothing _ -> Nothing
ticketTreeDW ticketTreeDW
:: ShrIdent -> PrjIdent -> [TicketSummary] -> [(Int, Int)] -> Widget :: ShrIdent -> PrjIdent -> [TicketSummary] -> [(Int64, Int64)] -> Widget
ticketTreeDW shr prj summaries deps = do ticketTreeDW shr prj summaries deps = do
cDeps <- newIdent cDeps <- newIdent
choices <- getParentChoices choices <- getParentChoices
let nodes = map (tsNumber &&& id) summaries let nodes = map (fromSqlKey . tsId &&& id) summaries
oneTree = ticketTreeVW shr prj cDeps oneTree = ticketTreeVW shr prj cDeps
forest = map oneTree $ dagViewTree nodes deps choices forest = map oneTree $ dagViewTree nodes deps choices
$(widgetFile "ticket/widget/tree") $(widgetFile "ticket/widget/tree")

23
src/Web/ActivityPub.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -66,6 +66,7 @@ module Web.ActivityPub
, Activity (..) , Activity (..)
-- * Utilities -- * Utilities
, emptyActivity
, hActivityPubActor , hActivityPubActor
, provideAP , provideAP
, provideAP' , provideAP'
@ -878,7 +879,7 @@ data Ticket u = Ticket
, ticketAttributedTo :: LocalURI , ticketAttributedTo :: LocalURI
, ticketPublished :: Maybe UTCTime , ticketPublished :: Maybe UTCTime
, ticketUpdated :: Maybe UTCTime , ticketUpdated :: Maybe UTCTime
, ticketName :: Maybe Text -- , ticketName :: Maybe Text
, ticketSummary :: TextHtml , ticketSummary :: TextHtml
, ticketContent :: TextHtml , ticketContent :: TextHtml
, ticketSource :: TextPandocMarkdown , ticketSource :: TextPandocMarkdown
@ -910,7 +911,7 @@ instance ActivityPub Ticket where
<*> pure attributedTo <*> pure attributedTo
<*> o .:? "published" <*> o .:? "published"
<*> o .:? "updated" <*> o .:? "updated"
<*> o .:? "name" -- <*> o .:? "name"
<*> (TextHtml . sanitizeBalance <$> o .: "summary") <*> (TextHtml . sanitizeBalance <$> o .: "summary")
<*> (TextHtml . sanitizeBalance <$> o .: "content") <*> (TextHtml . sanitizeBalance <$> o .: "content")
<*> source .: "content" <*> source .: "content"
@ -918,7 +919,7 @@ instance ActivityPub Ticket where
<*> o .: "isResolved" <*> o .: "isResolved"
toSeries authority toSeries authority
(Ticket local attributedTo published updated name summary content (Ticket local attributedTo published updated {-name-} summary content
source assignedTo isResolved) source assignedTo isResolved)
= maybe mempty (uncurry encodeTicketLocal) local = maybe mempty (uncurry encodeTicketLocal) local
@ -926,7 +927,7 @@ instance ActivityPub Ticket where
<> "attributedTo" .= ObjURI authority attributedTo <> "attributedTo" .= ObjURI authority attributedTo
<> "published" .=? published <> "published" .=? published
<> "updated" .=? updated <> "updated" .=? updated
<> "name" .=? name -- <> "name" .=? name
<> "summary" .= summary <> "summary" .= summary
<> "content" .= content <> "content" .= content
<> "mediaType" .= ("text/html" :: Text) <> "mediaType" .= ("text/html" :: Text)
@ -1250,6 +1251,18 @@ instance ActivityPub Activity where
encodeSpecific _ _ (RejectActivity a) = encodeReject a encodeSpecific _ _ (RejectActivity a) = encodeReject a
encodeSpecific h _ (UndoActivity a) = encodeUndo h a encodeSpecific h _ (UndoActivity a) = encodeUndo h a
emptyActivity :: Activity u
emptyActivity = Activity
{ activityId = Nothing
, activityActor = topLocalURI
, activitySummary = Nothing
, activityAudience = emptyAudience
, activitySpecific =
RejectActivity $ Reject $ ObjURI (Authority "" Nothing) topLocalURI
}
where
emptyAudience = Audience [] [] [] [] [] []
typeActivityStreams2 :: ContentType typeActivityStreams2 :: ContentType
typeActivityStreams2 = "application/activity+json" typeActivityStreams2 = "application/activity+json"

4
src/Yesod/Hashids.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -51,7 +51,7 @@ class Yesod site => YesodHashids site where
newtype KeyHashid record = KeyHashid newtype KeyHashid record = KeyHashid
{ keyHashidText :: Text { keyHashidText :: Text
} }
deriving (Eq, Read, Show) deriving (Eq, Ord, Read, Show)
instance PersistEntity record => PathPiece (KeyHashid record) where instance PersistEntity record => PathPiece (KeyHashid record) where
fromPathPiece t = KeyHashid <$> fromPathPiece t fromPathPiece t = KeyHashid <$> fromPathPiece t

8
templates/person/claim-requests.hamlet
View file

@ -1,6 +1,6 @@
$# This file is part of Vervis. $# This file is part of Vervis.
$# $#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>. $# Written in 2016, 2020 by fr33domlover <fr33domlover@riseup.net>.
$# $#
$# ♡ Copying is an act of love. Please copy, reuse and share. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -18,15 +18,15 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th># <th>#
<th>Title <th>Title
<th>Created on <th>Created on
$forall (E.Value shr, E.Value prj, E.Value num, E.Value title, E.Value time) <- rqs $forall (E.Value shr, E.Value prj, E.Value tid, E.Value title, E.Value time) <- rqs
<tr> <tr>
<td> <td>
<a href=@{SharerR shr}>#{shr2text shr} <a href=@{SharerR shr}>#{shr2text shr}
/ /
<a href=@{ProjectR shr prj}>#{prj2text prj} <a href=@{ProjectR shr prj}>#{prj2text prj}
<td> <td>
<a href=@{TicketR shr prj num}>#{num} <a href=@{TicketR shr prj $ encodeHid tid}>###
<td> <td>
<a href=@{TicketR shr prj num}>#{title} <a href=@{TicketR shr prj $ encodeHid tid}>#{title}
<td> <td>
#{showDate time} #{showDate time}

8
templates/project/claim-request/list.hamlet
View file

@ -1,6 +1,6 @@
$# This file is part of Vervis. $# This file is part of Vervis.
$# $#
$# Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>. $# Written in 2016, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
$# $#
$# ♡ Copying is an act of love. Please copy, reuse and share. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -18,13 +18,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th>Opened by <th>Opened by
<th># <th>#
<th>Title <th>Title
$forall (Entity _ sharer, E.Value num, E.Value title, E.Value time) <- rqs $forall (Entity _ sharer, E.Value tid, E.Value title, E.Value time) <- rqs
<tr> <tr>
<td> <td>
#{showDate time} #{showDate time}
<td> <td>
^{sharerLinkW sharer} ^{sharerLinkW sharer}
<td> <td>
<a href=@{TicketR shr prj num}>#{num} <a href=@{TicketR shr prj $ encodeHid tid}>###
<td> <td>
<a href=@{TicketR shr prj num}>#{title} <a href=@{TicketR shr prj $ encodeHid tid}>#{title}

4
templates/ticket/assign.hamlet
View file

@ -1,6 +1,6 @@
$# This file is part of Vervis. $# This file is part of Vervis.
$# $#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>. $# Written in 2016, 2020 by fr33domlover <fr33domlover@riseup.net>.
$# $#
$# ♡ Copying is an act of love. Please copy, reuse and share. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -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 num} enctype=#{enctype}> <form method=POST action=@{TicketAssignR shr prj tkhid} enctype=#{enctype}>
^{widget} ^{widget}
<div class="submit"> <div class="submit">
<input type="submit"> <input type="submit">

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

@ -1,6 +1,6 @@
$# This file is part of Vervis. $# This file is part of Vervis.
$# $#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>. $# Written in 2016, 2020 by fr33domlover <fr33domlover@riseup.net>.
$# $#
$# ♡ Copying is an act of love. Please copy, reuse and share. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -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 num} enctype=#{etype}> <form method=POST action=@{ClaimRequestsTicketR shr prj tkhid} enctype=#{etype}>
^{widget} ^{widget}
<div class="submit"> <div class="submit">
<input type="submit"> <input type="submit">

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

@ -1,6 +1,6 @@
$# This file is part of Vervis. $# 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. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -20,21 +20,21 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th>Status <th>Status
$if forward $if forward
<th>Remove dependency <th>Remove dependency
$forall (number, author, title, status) <- rows $forall (tid, author, title, status) <- rows
<tr> <tr>
<td> <td>
<a href=@{TicketR shr prj number}>#{number} <a href=@{TicketR shr prj $ encodeHid tid}>###
<td> <td>
^{sharerLinkFedW author} ^{sharerLinkFedW author}
<td> <td>
<a href=@{TicketR shr prj number}>#{title} <a href=@{TicketR shr prj $ encodeHid tid}>#{title}
<td> <td>
#{show status} #{show status}
$if forward $if forward
<td> <td>
^{buttonW DELETE "Remove" (TicketDepOldR shr prj num number)} ^{buttonW DELETE "Remove" (TicketDepOldR shr prj tkhid $ encodeHid tid)}
$if forward $if forward
<p> <p>
<a href=@{TicketDepNewR shr prj num}> <a href=@{TicketDepNewR shr prj tkhid}>
Add new… Add new…

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

@ -1,6 +1,6 @@
$# This file is part of Vervis. $# This file is part of Vervis.
$# $#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>. $# Written in 2016, 2020 by fr33domlover <fr33domlover@riseup.net>.
$# $#
$# ♡ Copying is an act of love. Please copy, reuse and share. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -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 num} enctype=#{enctype}> <form method=POST action=@{TicketDepsR shr prj tkhid} enctype=#{enctype}>
^{widget} ^{widget}
<div class="submit"> <div class="submit">
<input type="submit"> <input type="submit">

4
templates/ticket/edit.hamlet
View file

@ -1,6 +1,6 @@
$# This file is part of Vervis. $# This file is part of Vervis.
$# $#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>. $# Written in 2016, 2020 by fr33domlover <fr33domlover@riseup.net>.
$# $#
$# ♡ Copying is an act of love. Please copy, reuse and share. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -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 shar proj num} enctype=#{enctype}> <form method=POST action=@{TicketR shr prj tkhid} 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 num}> <a href=@{TicketParticipantsR shar proj khid}>
[🐤 Followers] [🐤 Followers]
<span> <span>
<a href=@{TicketDepsR shar proj num}> <a href=@{TicketDepsR shar proj khid}>
[⤴ Dependencies] [⤴ Dependencies]
<span> <span>
<a href=@{TicketReverseDepsR shar proj num}> <a href=@{TicketReverseDepsR shar proj khid}>
[⤷ Dependants] [⤷ Dependants]
<span> <span>
<a href=@{ClaimRequestsTicketR shar proj num}> <a href=@{ClaimRequestsTicketR shar proj khid}>
[✋ Claim requests] [✋ Claim requests]
<span> <span>
<a href=@{TicketEditR shar proj num}> <a href=@{TicketEditR shar proj khid}>
[✏ 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 Entity _ t <- rdeps $forall et <- rdeps
<li> <li>
^{ticketDepW shar proj t} ^{ticketDepW shar proj et}
<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 Entity _ t <- deps $forall et <- deps
<li> <li>
^{ticketDepW shar proj t} ^{ticketDepW shar proj et}
<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 num)} ^{buttonW POST "Unclaim this ticket" (TicketUnclaimR shar proj khid)}
$else $else
Assigned to ^{sharerLinkW assignee}. Assigned to ^{sharerLinkW assignee}.
^{buttonW POST "Unassign this ticket" (TicketUnassignR shar proj num)} ^{buttonW POST "Unassign this ticket" (TicketUnassignR shar proj khid)}
$nothing $nothing
Not assigned. Not assigned.
<a href=@{ClaimRequestNewR shar proj num}>Ask to have it assigned to you <a href=@{ClaimRequestNewR shar proj khid}>Ask to have it assigned to you
or or
^{buttonW POST "Claim this ticket" (TicketClaimR shar proj num)} ^{buttonW POST "Claim this ticket" (TicketClaimR shar proj khid)}
or or
<a href=@{TicketAssignR shar proj num}>Assign to someone else <a href=@{TicketAssignR shar proj khid}>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 num)} ^{buttonW POST "Accept this ticket" (TicketAcceptR shar proj khid)}
^{buttonW POST "Close this ticket" (TicketCloseR shar proj num)} ^{buttonW POST "Close this ticket" (TicketCloseR shar proj khid)}
$of TSTodo $of TSTodo
Open, to do. Open, to do.
^{buttonW POST "Close this ticket" (TicketCloseR shar proj num)} ^{buttonW POST "Close this ticket" (TicketCloseR shar proj khid)}
$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 num)} ^{buttonW POST "Reopen this ticket" (TicketOpenR shar proj khid)}
<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 num)} ^{buttonW DELETE "Delete this ticket" (TicketR shar proj khid)}
<h3>Discussion <h3>Discussion

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

@ -1,6 +1,6 @@
$# This file is part of Vervis. $# This file is part of Vervis.
$# $#
$# Written in 2016 by fr33domlover <fr33domlover@riseup.net>. $# Written in 2016, 2020 by fr33domlover <fr33domlover@riseup.net>.
$# $#
$# ♡ Copying is an act of love. Please copy, reuse and share. $# ♡ Copying is an act of love. Please copy, reuse and share.
$# $#
@ -22,5 +22,5 @@ $case ticketStatus ticket
$of TSClosed $of TSClosed
<span .#{cClosed}> <span .#{cClosed}>
☒ ☒
<a href=@{TicketR shr prj $ ticketNumber ticket}> <a href=@{TicketR shr prj $ encodeTicketKey tid}>
#{ticketTitle ticket} #{ticketTitle ticket}

10
templates/ticket/widget/summary.hamlet
View file

@ -25,8 +25,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
☒ ☒
<span .ticket-number-column> <span .ticket-number-column>
<a href=@{TicketR shr prj $ tsNumber ts}> <a href=@{TicketR shr prj $ encodeTicketKey $ tsId ts}>
#{tsNumber ts} ###
<span .ticket-date-column> <span .ticket-date-column>
#{showDate $ tsCreatedAt ts} #{showDate $ tsCreatedAt ts}
@ -35,7 +35,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{sharerLinkFedW $ tsCreatedBy ts} ^{sharerLinkFedW $ tsCreatedBy ts}
<span .ticket-title-column> <span .ticket-title-column>
<a href=@{TicketR shr prj $ tsNumber ts}> <a href=@{TicketR shr prj $ encodeTicketKey $ tsId ts}>
#{preEscapedToHtml $ tsTitle ts} #{preEscapedToHtml $ tsTitle ts}
$forall wf <- tsLabels ts $forall wf <- tsLabels ts
$maybe wfcol <- workflowFieldColor wf $maybe wfcol <- workflowFieldColor wf
@ -52,11 +52,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
$maybe params <- mparams $maybe params <- mparams
<span .ticket-node-column> <span .ticket-node-column>
<a href="#node-#{tsNumber ts}" title="Jump to subtree"> <a href="#node-#{keyHashidText $ encodeTicketKey $ tsId ts}" title="Jump to subtree">
☝ ☝
$maybe route <- mroute $maybe route <- mroute
<a href=@?{(route, params)} title="Move subtree here"> <a href=@?{(route, params)} title="Move subtree here">
☚ ☚
$nothing $nothing
<span .ticket-node-column> <span .ticket-node-column>
<a id="node-#{tsNumber ts}"> <a id="node-#{keyHashidText $ encodeTicketKey $ tsId ts}">