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/#ShrIdent ProjectDevR GET DELETE POST
/s/#ShrIdent/p/#PrjIdent/tcr ClaimRequestsProjectR GET
-- /w GlobalWorkflowsR GET POST
-- /w/!new GlobalWorkflowNewR GET
-- /w/#WflIdent GlobalWorkflowR GET DELETE POST
@ -148,34 +150,35 @@
/s/#ShrIdent/m/#LocalMessageKeyHashid MessageR GET
/tdeps/#TicketDepKeyHashid TicketDepR GET
/s/#ShrIdent/p/#PrjIdent/t TicketsR GET POST
/s/#ShrIdent/p/#PrjIdent/t/!tree TicketTreeR 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/#Int/accept TicketAcceptR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/close TicketCloseR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/open TicketOpenR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/claim TicketClaimR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/unclaim TicketUnclaimR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/assign TicketAssignR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/unassign TicketUnassignR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/follow TicketFollowR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/unfollow TicketUnfollowR POST
/s/#ShrIdent/p/#PrjIdent/tcr ClaimRequestsProjectR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/cr ClaimRequestsTicketR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/cr/new ClaimRequestNewR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/d TicketDiscussionR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/!reply TicketTopReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#MessageKeyHashid TicketMessageR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#MessageKeyHashid/reply TicketReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps TicketDepsR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/!new TicketDepNewR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/#Int TicketDepOldR POST DELETE
/s/#ShrIdent/p/#PrjIdent/t/#Int/rdeps TicketReverseDepsR GET
/tdeps/#TicketDepKeyHashid TicketDepR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/participants TicketParticipantsR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/team TicketTeamR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/events TicketEventsR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid TicketR GET PUT DELETE POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/edit TicketEditR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/accept TicketAcceptR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/close TicketCloseR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/open TicketOpenR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/claim TicketClaimR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/unclaim TicketUnclaimR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/assign TicketAssignR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/unassign TicketUnassignR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/follow TicketFollowR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/unfollow TicketUnfollowR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/cr ClaimRequestsTicketR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/cr/new ClaimRequestNewR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/d TicketDiscussionR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/d/!reply TicketTopReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/d/#MessageKeyHashid TicketMessageR POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/d/#MessageKeyHashid/reply TicketReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/deps TicketDepsR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/deps/!new TicketDepNewR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/deps/#TicketKeyHashid TicketDepOldR POST DELETE
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/rdeps TicketReverseDepsR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/participants TicketParticipantsR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/team TicketTeamR GET
/s/#ShrIdent/p/#PrjIdent/t/#TicketKeyHashid/events TicketEventsR 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.
-
- 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.
-
@ -162,11 +162,13 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
(lmid, obiid, doc, remotesHttp) <- runDBExcept $ do
(pid, obid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
(did, meparent, mcollections) <- case mticket of
Just (shr, prj, num) -> do
Just (shr, prj, tkhid) -> do
mt <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
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)
(sid, ibidProject, fsidProject, t) <- fromMaybeE mt "Context: No such local ticket"
let did = ticketDiscuss t
@ -243,7 +245,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
-> ExceptT Text Handler
( Maybe (Either (ShrIdent, LocalMessageId) FedURI)
, [ShrIdent]
, Maybe (ShrIdent, PrjIdent, Int)
, Maybe (ShrIdent, PrjIdent, KeyHashid Ticket)
, [(Host, NonEmpty LocalURI)]
)
parseRecipsContextParent uContext muParent = do
@ -274,7 +276,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
then Left <$> parseComment luParent
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
route <- case decodeRouteLocal luContext of
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 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
lsrSet <- fromMaybeE (lookupSorted shr recips) "Note with local context: No required recipients"
(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
= FolloweeSharer ShrIdent
| FolloweeProject ShrIdent PrjIdent
| FolloweeTicket ShrIdent PrjIdent Int
| FolloweeTicket ShrIdent PrjIdent (KeyHashid Ticket)
| FolloweeRepo ShrIdent RpIdent
followC
@ -537,11 +539,13 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = run
MaybeT $ getValBy $ UniqueProject prj sid
project <- fromMaybeE mproject "Follow object: No such project in DB"
return (projectFollowers project, projectInbox project, False, projectOutbox project)
getFollowee (FolloweeTicket shr prj num) = do
getFollowee (FolloweeTicket shr prj tkhid) = do
mproject <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
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)
(ticket, project) <- fromMaybeE mproject "Follow object: No such ticket in DB"
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.ticketPublished ticket) "Ticket with 'published'"
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'"
when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved"
checkRecips hProject shrProject prjProject localRecips = do
@ -762,8 +766,18 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
num <-
((subtract 1) . projectNextTicket) <$>
updateGet jid [ProjectNextTicket +=. 1]
(obiidAccept, docAccept) <- insertAccept pidAuthor sid jid fsid luOffer num
insertTicket jid {-tids-} num obiidAccept
obiidAccept <- do
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
(pidsTeam, remotesTeam) <-
if localRecipProjectTeam project
@ -782,62 +796,51 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
insertToInbox ibid = do
ibiid <- insert $ InboxItem False
insert_ $ InboxItemLocal ibid obiid ibiid
insertAccept pidAuthor sid jid fsid luOffer num = do
now <- liftIO getCurrentTime
obid <- projectOutbox <$> getJust jid
insertToOutbox now obid
where
insertToOutbox now obid = do
summary <-
TextHtml . TL.toStrict . renderHtml <$>
withUrlRenderer
[hamlet|
<p>
<a href=@{SharerR shrUser}>
#{shr2text shrUser}
's ticket accepted by project #
<a href=@{ProjectR shrProject prjProject}>
./s/#{shr2text shrProject}/p/#{prj2text prjProject}
: #
<a href=@{TicketR shrProject prjProject num}>
#{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
|]
hLocal <- asksSite siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
let recips =
map encodeRouteHome
[ SharerR shrUser
, ProjectTeamR shrProject prjProject
, ProjectFollowersR shrProject prjProject
]
accept luAct = Doc hLocal Activity
{ activityId = luAct
, activityActor =
encodeRouteLocal $ ProjectR shrProject prjProject
, activitySummary = Just summary
, activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept
{ acceptObject = ObjURI hLocal luOffer
, acceptResult =
Just $ encodeRouteLocal $
TicketR shrProject prjProject num
}
insertAccept pidAuthor sid jid fsid luOffer obiid tid = do
tkhid <- encodeKeyHashid tid
summary <-
TextHtml . TL.toStrict . renderHtml <$>
withUrlRenderer
[hamlet|
<p>
<a href=@{SharerR shrUser}>
#{shr2text shrUser}
's ticket accepted by project #
<a href=@{ProjectR shrProject prjProject}>
./s/#{shr2text shrProject}/p/#{prj2text prjProject}
: #
<a href=@{TicketR shrProject prjProject tkhid}>
#{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
|]
hLocal <- asksSite siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
obikhid <- encodeKeyHashid obiid
let recips =
map encodeRouteHome
[ SharerR shrUser
, ProjectTeamR shrProject prjProject
, ProjectFollowersR shrProject prjProject
]
doc = Doc hLocal Activity
{ activityId =
Just $ encodeRouteLocal $
ProjectOutboxItemR shrProject prjProject obikhid
, activityActor =
encodeRouteLocal $ ProjectR shrProject prjProject
, activitySummary = Just summary
, activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept
{ acceptObject = ObjURI hLocal luOffer
, acceptResult =
Just $ encodeRouteLocal $
TicketR shrProject prjProject tkhid
}
obiid <- insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity =
persistJSONObjectFromDoc $ accept Nothing
, outboxItemPublished = now
}
encodeRouteLocal <- getEncodeRouteLocal
obikhid <- encodeKeyHashid obiid
let luAct = encodeRouteLocal $ ProjectOutboxItemR shrProject prjProject obikhid
doc = accept $ Just luAct
update
obiid
[OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (obiid, doc)
update
obiid
[OutboxItemActivity =. persistJSONObjectFromDoc doc]
return doc
insertTicket jid {-tidsDeps-} next obiidAccept = do
did <- insert Discussion
fsid <- insert FollowerSet
@ -864,6 +867,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
}
--insertMany_ $ map (TicketDependency tid) tidsDeps
-- insert_ $ Follow pidAuthor fsid False True
return tid
publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do
now <- liftIO getCurrentTime
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.
-
- 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.
-
@ -91,7 +91,7 @@ import Yesod.HttpSignature
import Database.Persist.JSON
import Network.FedURI
import Network.HTTP.Digest
import Web.ActivityPub hiding (Author (..))
import Web.ActivityPub hiding (Author (..), Ticket)
import Yesod.ActivityPub
import Yesod.MonadSite
import Yesod.FedURI
@ -130,7 +130,7 @@ verifyHostLocal h t = do
parseContext
:: (MonadSite m, SiteEnv m ~ App)
=> FedURI
-> ExceptT Text m (Either (ShrIdent, PrjIdent, Int) FedURI)
-> ExceptT Text m (Either (ShrIdent, PrjIdent, KeyHashid Ticket) FedURI)
parseContext uContext = do
let ObjURI hContext luContext = uContext
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 Network.FedURI
import Web.ActivityPub
import Web.ActivityPub hiding (Ticket)
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Data.List.NonEmpty.Local
import Vervis.FedURI
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
concatRecipients :: Audience u -> [ObjURI u]
@ -84,8 +86,8 @@ data LocalPersonCollection
= LocalPersonCollectionSharerFollowers ShrIdent
| LocalPersonCollectionProjectTeam ShrIdent PrjIdent
| LocalPersonCollectionProjectFollowers ShrIdent PrjIdent
| LocalPersonCollectionTicketTeam ShrIdent PrjIdent Int
| LocalPersonCollectionTicketFollowers ShrIdent PrjIdent Int
| LocalPersonCollectionTicketTeam ShrIdent PrjIdent (KeyHashid Ticket)
| LocalPersonCollectionTicketFollowers ShrIdent PrjIdent (KeyHashid Ticket)
| LocalPersonCollectionRepoTeam ShrIdent RpIdent
| LocalPersonCollectionRepoFollowers ShrIdent RpIdent
@ -131,7 +133,7 @@ data LocalProjectRecipientDirect
data LocalProjectRecipient
= LocalProjectDirect LocalProjectRecipientDirect
| LocalTicketRelated Int LocalTicketRecipientDirect
| LocalTicketRelated (KeyHashid Ticket) LocalTicketRecipientDirect
deriving (Eq, Ord)
data LocalRepoRecipientDirect
@ -220,7 +222,7 @@ data LocalProjectDirectSet = LocalProjectDirectSet
data LocalProjectRelatedSet = LocalProjectRelatedSet
{ localRecipProjectDirect :: LocalProjectDirectSet
, localRecipTicketRelated :: [(Int, LocalTicketDirectSet)]
, localRecipTicketRelated :: [(KeyHashid Ticket, LocalTicketDirectSet)]
}
deriving Eq

20
src/Vervis/Client.hs
View file

@ -1,6 +1,6 @@
{- 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.
-
@ -29,6 +29,7 @@ module Vervis.Client
)
where
import Control.Monad
import Control.Monad.Trans.Except
import Control.Monad.Trans.Reader
import Database.Persist
@ -45,7 +46,7 @@ import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Network.FedURI
import Web.ActivityPub hiding (Follow)
import Web.ActivityPub hiding (Follow, Ticket)
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
@ -190,7 +191,7 @@ followProject shrAuthor shrObject prjObject hide = do
followTicket
:: (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
encodeRouteHome <- getEncodeRouteHome
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.ticketPublished = Nothing
, AP.ticketUpdated = Nothing
, AP.ticketName = Nothing
-- , AP.ticketName = Nothing
, AP.ticketSummary = TextHtml title
, AP.ticketContent = TextHtml descHtml
, AP.ticketSource = TextPandocMarkdown desc
@ -332,7 +333,7 @@ undoFollowTicket
-> PersonId
-> ShrIdent
-> PrjIdent
-> Int
-> KeyHashid Ticket
-> m (Either Text (TextHtml, Audience URIMode, Undo URIMode))
undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee =
undoFollow shrAuthor pidAuthor getFsid "project" objRoute recipRoute
@ -346,9 +347,12 @@ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee =
jid <- do
mjid <- lift $ getKeyBy $ UniqueProject prjFollowee sid
fromMaybeE mjid "No such local project"
mt <- lift $ getValBy $ UniqueTicket jid numFollowee
ticketFollowers <$>
fromMaybeE mt "Unfollow target no such local ticket"
tid <- decodeKeyHashidE numFollowee "Invalid hashid for context"
mt <- lift $ get tid
t <- fromMaybeE mt "Unfollow target no such local ticket"
unless (ticketProject t == jid) $
throwE "Hashid doesn't match sharer/project"
return $ ticketFollowers t
undoFollowRepo
:: (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.
-
- 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.
-
@ -75,7 +75,7 @@ import Crypto.PublicVerifKey
import Database.Persist.JSON
import Network.FedURI
import Network.HTTP.Digest
import Web.ActivityPub hiding (Follow)
import Web.ActivityPub hiding (Follow, Ticket)
import Yesod.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
@ -112,7 +112,7 @@ prependError t a = do
Left e -> throwE $ t <> ": " <> e
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
route <- case decodeRouteLocal luContext of
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.
-
- 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.
-
@ -54,6 +54,7 @@ import Network.HTTP.Digest
import Web.ActivityPub
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Control.Monad.Trans.Except.Local
import Data.Tuple.Local
@ -102,11 +103,13 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
where
checkContextParent context mparent = runExceptT $ do
case context of
Left (shr, prj, num) -> do
Left (shr, prj, tkhid) -> do
mdid <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
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
did <- fromMaybeE mdid "Context: No such local ticket"
for_ mparent $ \ parent ->
@ -188,17 +191,17 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
else Just <$> parseParent uParent
case context of
Right _ -> return $ recip <> " not using; context isn't local"
Left (shr, prj, num) ->
Left (shr, prj, tkhid) ->
if shr /= shrRecip || prj /= prjRecip
then return $ recip <> " not using; context is a different project"
else do
msig <- checkForward shrRecip prjRecip
hLocal <- getsYesod $ appInstanceHost . appSettings
let colls =
findRelevantCollections hLocal num $
findRelevantCollections hLocal tkhid $
activityAudience $ actbActivity body
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
mmid <- insertToDiscussion luCreate luNote published ibid did meparent fsidTicket
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
return $ recip <> " inserted new ticket comment"
where
findRelevantCollections hLocal numCtx = nub . mapMaybe decide . concatRecipients
findRelevantCollections hLocal ctx = nub . mapMaybe decide . concatRecipients
where
decide u = do
let ObjURI h lu = u
@ -222,20 +225,24 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
ProjectFollowersR shr prj
| shr == shrRecip && prj == prjRecip
-> Just CreateNoteRecipProjectFollowers
TicketParticipantsR shr prj num
| shr == shrRecip && prj == prjRecip && num == numCtx
TicketParticipantsR shr prj tkhid
| shr == shrRecip && prj == prjRecip && tkhid == ctx
-> Just CreateNoteRecipTicketParticipants
TicketTeamR shr prj num
| shr == shrRecip && prj == prjRecip && num == numCtx
TicketTeamR shr prj tkhid
| shr == shrRecip && prj == prjRecip && tkhid == ctx
-> Just CreateNoteRecipTicketTeam
_ -> Nothing
recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
getContextAndParent num mparent = do
mt <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
Entity jid j <- getBy404 $ UniqueProject prjRecip sid
fmap (jid, projectInbox j, projectFollowers j, sid ,) <$>
getValBy (UniqueTicket jid num)
getContextAndParent tkhid mparent = do
mt <- do
sid <- lift $ getKeyBy404 $ UniqueSharer shrRecip
Entity jid j <- lift $ getBy404 $ UniqueProject prjRecip sid
tid <- decodeKeyHashidE tkhid "Context: Not a valid ticket khid"
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"
let did = ticketDiscuss t
meparent <- for mparent $ \ parent ->

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

@ -1,6 +1,6 @@
{- 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.
-
@ -383,10 +383,14 @@ projectFollowF shr prj =
| shr == shr' && prj == prj' = Just $ Just num
objRoute _ = Nothing
getRecip mnum = do
getRecip mtkhid = do
sid <- getKeyBy404 $ UniqueSharer shr
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)
followers (j, Nothing) = projectFollowers j

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

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

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

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

3
src/Vervis/Foundation.hs
View file

@ -80,7 +80,7 @@ import Control.Concurrent.ResultShare
import Crypto.PublicVerifKey
import Network.FedURI
import Web.ActivityAccess
import Web.ActivityPub hiding (TicketDependency)
import Web.ActivityPub hiding (Ticket, TicketDependency)
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
@ -138,6 +138,7 @@ type OutboxItemKeyHashid = KeyHashid OutboxItem
type SshKeyKeyHashid = KeyHashid SshKey
type MessageKeyHashid = KeyHashid Message
type LocalMessageKeyHashid = KeyHashid LocalMessage
type TicketKeyHashid = KeyHashid Ticket
type TicketDepKeyHashid = KeyHashid TicketDependency
-- 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.
-
- 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.
-
@ -123,7 +123,7 @@ fedUriField = Field
}
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
where
toTicket uTicket = runExceptT $ do
@ -133,10 +133,10 @@ ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
Nothing -> throwE ("Not a valid route" :: Text)
Just r -> return r
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"
fromTicket (h, shr, prj, num) =
ObjURI h $ encodeRouteLocal $ TicketR shr prj num
fromTicket (h, shr, prj, tkhid) =
ObjURI h $ encodeRouteLocal $ TicketR shr prj tkhid
projectField
:: (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
publishCommentForm
:: Form ((Host, ShrIdent, PrjIdent, Int), Maybe FedURI, Text)
:: Form ((Host, ShrIdent, PrjIdent, KeyHashid Ticket), Maybe FedURI, Text)
publishCommentForm html = do
enc <- getEncodeRouteLocal
defk <- encodeKeyHashid $ E.toSqlKey 1
flip renderDivs html $ (,,)
<$> areq (ticketField enc) "Ticket" (Just deft)
<$> areq (ticketField enc) "Ticket" (Just $ deft defk)
<*> aopt fedUriField "Replying to" (Just $ Just defp)
<*> areq textField "Message" (Just defmsg)
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"
defmsg = "Hi! I'm testing federation. Can you see my message? :)"
@ -346,7 +347,7 @@ postPublishR = do
, ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
, ticketPublished = Nothing
, ticketUpdated = Nothing
, ticketName = Nothing
-- , ticketName = Nothing
, ticketSummary = TextHtml title
, ticketContent = TextHtml descHtml
, ticketSource = TextPandocMarkdown desc
@ -447,13 +448,13 @@ postProjectFollowR shrObject prjObject = do
setFollowMessage shrAuthor eid
redirect $ ProjectR shrObject prjObject
postTicketFollowR :: ShrIdent -> PrjIdent -> Int -> Handler ()
postTicketFollowR shrObject prjObject numObject = do
postTicketFollowR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler ()
postTicketFollowR shrObject prjObject tkhidObject = do
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
setFollowMessage shrAuthor eid
redirect $ TicketR shrObject prjObject numObject
redirect $ TicketR shrObject prjObject tkhidObject
postRepoFollowR :: ShrIdent -> RpIdent -> Handler ()
postRepoFollowR shrObject rpObject = do
@ -494,15 +495,15 @@ postProjectUnfollowR shrFollowee prjFollowee = do
setUnfollowMessage shrAuthor eid
redirect $ ProjectR shrFollowee prjFollowee
postTicketUnfollowR :: ShrIdent -> PrjIdent -> Int -> Handler ()
postTicketUnfollowR shrFollowee prjFollowee numFollowee = do
postTicketUnfollowR :: ShrIdent -> PrjIdent -> KeyHashid Ticket -> Handler ()
postTicketUnfollowR shrFollowee prjFollowee tkhidFollowee = do
(shrAuthor, pidAuthor) <- getUser
eid <- runExceptT $ do
(summary, audience, undo) <-
ExceptT $ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee numFollowee
ExceptT $ undoFollowTicket shrAuthor pidAuthor shrFollowee prjFollowee tkhidFollowee
ExceptT $ undoC shrAuthor summary audience undo
setUnfollowMessage shrAuthor eid
redirect $ TicketR shrFollowee prjFollowee numFollowee
redirect $ TicketR shrFollowee prjFollowee tkhidFollowee
postRepoUnfollowR :: ShrIdent -> RpIdent -> Handler ()
postRepoUnfollowR shrFollowee rpFollowee = do
@ -666,7 +667,7 @@ postTicketsR shr prj = do
Entity _ p <- requireVerifiedAuth
runDB $ sharerIdent <$> getJust (personIdent p)
enum <- runExceptT $ do
etid <- runExceptT $ do
NewTicket title desc tparams eparams cparams <-
case result of
FormMissing -> throwE "Field(s) missing."
@ -701,17 +702,17 @@ postTicketsR shr prj = do
"Offer processed successfully but no ticket \
\created"
Just tal ->
Right . ticketNumber <$>
getJust (ticketAuthorLocalTicket tal)
case enum of
return $ Right $ ticketAuthorLocalTicket tal
case etid of
Left e -> do
setMessage $ toHtml e
defaultLayout $(widgetFile "ticket/new")
Right num -> do
Right tid -> do
tkhid <- encodeKeyHashid tid
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
case eobiidFollow of
Left e -> setMessage $ toHtml $ "Ticket created, but following it failed: " <> e
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.
-
- 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.
-
@ -128,17 +128,18 @@ getDiscussionMessage shr lmid = do
route2fed <- getEncodeRouteHome
uContext <- do
let did = messageRoot m
mt <- getValBy $ UniqueTicketDiscussion did
mt <- getBy $ UniqueTicketDiscussion did
mrd <- getValBy $ UniqueRemoteDiscussion did
case (mt, mrd) of
(Nothing, Nothing) -> fail $ "DiscussionId #" ++ show did ++ " has no context"
(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
s <- getJust $ projectSharer j
let shr = sharerIdent s
prj = projectIdent j
return $ route2fed $ TicketR shr prj $ ticketNumber t
tkhid <- encodeKeyHashid tid
return $ route2fed $ TicketR shr prj tkhid
(Nothing, Just rd) -> do
i <- getJust $ remoteDiscussionInstance 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.
-
- 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.
-
@ -40,6 +40,7 @@ import qualified Database.Esqueleto as E
import Web.ActivityPub
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Database.Persist.Local
import Yesod.Persist.Local
@ -150,9 +151,10 @@ getSharerFollowingR shr = do
E.on $ t E.^. TicketProject E.==. j E.^. ProjectId
E.where_ $ t E.^. TicketId `E.in_` E.valList tids
return
(s E.^. SharerIdent, j E.^. ProjectIdent, t E.^. TicketNumber)
(s E.^. SharerIdent, j E.^. ProjectIdent, t E.^. TicketId)
encodeHid <- getEncodeKeyHashid
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
getRepos fsids = do
rids <- selectKeysList [RepoFollowers <-. fsids] []

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

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

14
src/Vervis/Ticket.hs
View file

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

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

@ -24,9 +24,12 @@ where
import Control.Arrow ((&&&), (***))
import Data.HashMap.Lazy (HashMap)
import Data.Int
import Data.Maybe (mapMaybe)
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
import Database.Persist (Entity (..))
import Database.Persist.Sql (fromSqlKey)
import Text.Blaze.Html (preEscapedToHtml)
import Yesod.Core (MonadHandler, newIdent)
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 Data.Graph.DirectedAcyclic.View.Tree
import Yesod.Hashids
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
@ -47,7 +52,7 @@ import Vervis.Time (showDate)
import Vervis.Widget.Sharer
data TicketSummary = TicketSummary
{ tsNumber :: Int
{ tsId :: TicketId
, tsCreatedBy :: Either Sharer (Instance, RemoteObject, RemoteActor)
, tsCreatedAt :: UTCTime
, tsTitle :: Text
@ -56,8 +61,9 @@ data TicketSummary = TicketSummary
, tsComments :: Int
}
ticketDepW :: ShrIdent -> PrjIdent -> Ticket -> Widget
ticketDepW shr prj ticket = do
ticketDepW :: ShrIdent -> PrjIdent -> Entity Ticket -> Widget
ticketDepW shr prj (Entity tid ticket) = do
encodeTicketKey <- getEncodeKeyHashid
cNew <- newIdent
cTodo <- newIdent
cClosed <- newIdent
@ -67,9 +73,10 @@ ticketSummaryW
:: ShrIdent
-> PrjIdent
-> TicketSummary
-> Maybe (HashMap Int Int)
-> Maybe (HashMap Int64 Int64)
-> Widget
ticketSummaryW shr prj ts mcs = do
encodeTicketKey <- getEncodeKeyHashid
cNew <- newIdent
cTodo <- newIdent
cClosed <- newIdent
@ -92,7 +99,7 @@ ticketTreeVW
:: ShrIdent
-> PrjIdent
-> Text
-> DagViewTree TicketSummary (TicketSummary, HashMap Int Int)
-> DagViewTree TicketSummary (TicketSummary, HashMap Int64 Int64)
-> Widget
ticketTreeVW shr prj cDeps t = go t
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
-- 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
where
readInts (ct, pt) =
@ -120,11 +127,11 @@ getParentChoices = mapMaybe readInts . reqGetParams <$> getRequest
_ -> Nothing
ticketTreeDW
:: ShrIdent -> PrjIdent -> [TicketSummary] -> [(Int, Int)] -> Widget
:: ShrIdent -> PrjIdent -> [TicketSummary] -> [(Int64, Int64)] -> Widget
ticketTreeDW shr prj summaries deps = do
cDeps <- newIdent
choices <- getParentChoices
let nodes = map (tsNumber &&& id) summaries
let nodes = map (fromSqlKey . tsId &&& id) summaries
oneTree = ticketTreeVW shr prj cDeps
forest = map oneTree $ dagViewTree nodes deps choices
$(widgetFile "ticket/widget/tree")

23
src/Web/ActivityPub.hs
View file

@ -1,6 +1,6 @@
{- 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.
-
@ -66,6 +66,7 @@ module Web.ActivityPub
, Activity (..)
-- * Utilities
, emptyActivity
, hActivityPubActor
, provideAP
, provideAP'
@ -878,7 +879,7 @@ data Ticket u = Ticket
, ticketAttributedTo :: LocalURI
, ticketPublished :: Maybe UTCTime
, ticketUpdated :: Maybe UTCTime
, ticketName :: Maybe Text
-- , ticketName :: Maybe Text
, ticketSummary :: TextHtml
, ticketContent :: TextHtml
, ticketSource :: TextPandocMarkdown
@ -910,7 +911,7 @@ instance ActivityPub Ticket where
<*> pure attributedTo
<*> o .:? "published"
<*> o .:? "updated"
<*> o .:? "name"
-- <*> o .:? "name"
<*> (TextHtml . sanitizeBalance <$> o .: "summary")
<*> (TextHtml . sanitizeBalance <$> o .: "content")
<*> source .: "content"
@ -918,7 +919,7 @@ instance ActivityPub Ticket where
<*> o .: "isResolved"
toSeries authority
(Ticket local attributedTo published updated name summary content
(Ticket local attributedTo published updated {-name-} summary content
source assignedTo isResolved)
= maybe mempty (uncurry encodeTicketLocal) local
@ -926,7 +927,7 @@ instance ActivityPub Ticket where
<> "attributedTo" .= ObjURI authority attributedTo
<> "published" .=? published
<> "updated" .=? updated
<> "name" .=? name
-- <> "name" .=? name
<> "summary" .= summary
<> "content" .= content
<> "mediaType" .= ("text/html" :: Text)
@ -1250,6 +1251,18 @@ instance ActivityPub Activity where
encodeSpecific _ _ (RejectActivity a) = encodeReject 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 = "application/activity+json"

4
src/Yesod/Hashids.hs
View file

@ -1,6 +1,6 @@
{- 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.
-
@ -51,7 +51,7 @@ class Yesod site => YesodHashids site where
newtype KeyHashid record = KeyHashid
{ keyHashidText :: Text
}
deriving (Eq, Read, Show)
deriving (Eq, Ord, Read, Show)
instance PersistEntity record => PathPiece (KeyHashid record) where
fromPathPiece t = KeyHashid <$> fromPathPiece t

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

@ -1,6 +1,6 @@
$# 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.
$#
@ -18,15 +18,15 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th>#
<th>Title
<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>
<td>
<a href=@{SharerR shr}>#{shr2text shr}
/
<a href=@{ProjectR shr prj}>#{prj2text prj}
<td>
<a href=@{TicketR shr prj num}>#{num}
<a href=@{TicketR shr prj $ encodeHid tid}>###
<td>
<a href=@{TicketR shr prj num}>#{title}
<a href=@{TicketR shr prj $ encodeHid tid}>#{title}
<td>
#{showDate time}

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

@ -1,6 +1,6 @@
$# 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.
$#
@ -18,13 +18,13 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<th>Opened by
<th>#
<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>
<td>
#{showDate time}
<td>
^{sharerLinkW sharer}
<td>
<a href=@{TicketR shr prj num}>#{num}
<a href=@{TicketR shr prj $ encodeHid tid}>###
<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.
$#
$# 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.
$#
@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<form method=POST action=@{TicketAssignR shr prj num} enctype=#{enctype}>
<form method=POST action=@{TicketAssignR shr prj tkhid} enctype=#{enctype}>
^{widget}
<div class="submit">
<input type="submit">

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

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

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

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

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

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

4
templates/ticket/edit.hamlet
View file

@ -1,6 +1,6 @@
$# 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.
$#
@ -12,7 +12,7 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<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>
^{widget}
<div class="submit">

38
templates/ticket/one.hamlet
View file

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

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

@ -1,6 +1,6 @@
$# 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.
$#
@ -22,5 +22,5 @@ $case ticketStatus ticket
$of TSClosed
<span .#{cClosed}>
☒
<a href=@{TicketR shr prj $ ticketNumber ticket}>
<a href=@{TicketR shr prj $ encodeTicketKey tid}>
#{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>
<a href=@{TicketR shr prj $ tsNumber ts}>
#{tsNumber ts}
<a href=@{TicketR shr prj $ encodeTicketKey $ tsId ts}>
###
<span .ticket-date-column>
#{showDate $ tsCreatedAt ts}
@ -35,7 +35,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{sharerLinkFedW $ tsCreatedBy ts}
<span .ticket-title-column>
<a href=@{TicketR shr prj $ tsNumber ts}>
<a href=@{TicketR shr prj $ encodeTicketKey $ tsId ts}>
#{preEscapedToHtml $ tsTitle ts}
$forall wf <- tsLabels ts
$maybe wfcol <- workflowFieldColor wf
@ -52,11 +52,11 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
$maybe params <- mparams
<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
<a href=@?{(route, params)} title="Move subtree here">
☚
$nothing
<span .ticket-node-column>
<a id="node-#{tsNumber ts}">
<a id="node-#{keyHashidText $ encodeTicketKey $ tsId ts}">