forge/Vervis
1
0
Fork 0
Code Pull requests Activity

UI: New ticket/MR creation form + deck/loom navigation links

Browse source
This commit is contained in:
fr33domlover 2022-10-17 15:08:00 +00:00
parent d8c65930ca
commit 118b787416
33 changed files with 408 additions and 322 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

86
src/Vervis/Client.hs
View file

@ -24,7 +24,7 @@ module Vervis.Client
--, followProject
--, followTicket
--, followRepo
--, offerTicket
, offerIssue
--, resolve
--, undoFollowSharer
--, undoFollowProject
@ -299,55 +299,65 @@ followRepo shrAuthor shrObject rpObject hide = do
let uObject = encodeRouteHome $ RepoR shrObject rpObject
follow shrAuthor uObject uObject hide
-}
-}
offerIssue
:: KeyHashid Person -> Text -> PandocMarkdown -> FedURI
-> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Ticket URIMode)
offerIssue senderHash title desc uTracker = do
tracker <- do
tracker <- checkTracker uTracker
case tracker of
TrackerDeck deckID -> Left <$> encodeKeyHashid deckID
TrackerLoom _ -> throwE "Local patch tracker doesn't take issues"
TrackerRemote (ObjURI hTracker luTracker) -> Right <$> do
instanceID <- lift $ runDB $ either entityKey id <$> insertBy' (Instance hTracker)
result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hTracker luTracker
case result of
Left Nothing -> throwE "Tracker @id mismatch"
Left (Just err) -> throwE $ T.pack $ displayException err
Right Nothing -> throwE "Tracker isn't an actor"
Right (Just actor) -> return (entityVal actor, uTracker)
offerTicket
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
=> ShrIdent -> TextHtml -> TextPandocMarkdown -> ShrIdent -> PrjIdent -> m (Either Text (TextHtml, Audience URIMode, AP.Ticket URIMode, FedURI))
offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runExceptT $ do
error "Temporarily disabled"
{-
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
summary <-
TextHtml . TL.toStrict . renderHtml <$>
withUrlRenderer
[hamlet|
<p>
<a href=@{SharerR shrAuthor}>
#{shr2text shrAuthor}
\ offered a ticket to project #
<a href=@{ProjectR shr prj}>
./s/#{shr2text shr}/p/#{prj2text prj}
: #{preEscapedToHtml title}.
|]
let recipsA = [ProjectR shr prj]
recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj]
encodeRouteLocal <- getEncodeRouteLocal
hLocal <- asksSite siteInstanceHost
let audAuthor =
AudLocal [] [LocalStagePersonFollowers senderHash]
audTracker =
case tracker of
Left deckHash ->
AudLocal
[LocalActorDeck deckHash]
[LocalStageDeckFollowers deckHash]
Right (remoteActor, ObjURI hTracker luTracker) ->
AudRemote hTracker
[luTracker]
(maybeToList $ remoteActorFollowers remoteActor)
audience = [audAuthor, audTracker]
ticket = AP.Ticket
{ AP.ticketLocal = Nothing
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
, AP.ticketAttributedTo = encodeRouteLocal $ PersonR senderHash
, AP.ticketPublished = Nothing
, AP.ticketUpdated = Nothing
, AP.ticketContext = Nothing
-- , AP.ticketName = Nothing
, AP.ticketSummary = TextHtml title
, AP.ticketContent = TextHtml descHtml
, AP.ticketSource = TextPandocMarkdown desc
, AP.ticketSummary = encodeEntities title
, AP.ticketContent = descHtml
, AP.ticketSource = desc
, AP.ticketAssignedTo = Nothing
, AP.ticketResolved = Nothing
, AP.ticketAttachment = Nothing
}
target = encodeRouteHome $ ProjectR shr prj
audience = Audience
{ audienceTo = map encodeRouteHome $ recipsA ++ recipsC
, audienceBto = []
, audienceCc = []
, audienceBcc = []
, audienceGeneral = []
, audienceNonActors = map encodeRouteHome recipsC
}
return (summary, audience, ticket, target)
return (Nothing, audience, ticket)
{-
{-
resolve
:: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
=> ShrIdent

87
src/Vervis/Form/Ticket.hs
View file

@ -14,12 +14,16 @@
-}
module Vervis.Form.Ticket
( --NewTicket (..)
--, newTicketForm
( fedUriField
, NewTicket (..)
, NewCloth (..)
, newTicketForm
, newClothForm
--, editTicketContentForm
--, assignTicketForm
--, claimRequestForm
ticketFilterForm
, ticketFilterForm
--, ticketDepForm
)
where
@ -32,13 +36,19 @@ import Data.Maybe
import Data.Text (Text)
import Data.Time.Calendar (Day (..))
import Data.Time.Clock (getCurrentTime, UTCTime (..))
import Data.Traversable
import Database.Persist
import Text.HTML.SanitizeXSS
import Yesod.Core
import Yesod.Form
import Yesod.Persist.Core (runDB)
import qualified Data.Text as T
import Development.PatchMediaType
import Network.FedURI
import Web.Text
import Vervis.FedURI
import Vervis.Foundation (App, Form, Handler)
import Vervis.Model
import Vervis.Model.Ticket
@ -46,18 +56,36 @@ import Vervis.Model.Workflow
import Vervis.Ticket
import Vervis.TicketFilter (TicketFilter (..))
fedUriField
:: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI
fedUriField = Field
{ fieldParse = parseHelper $ \ t ->
case parseObjURI t of
Left e -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t
Right u -> Right u
, fieldView = \theId name attrs val isReq ->
[whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderObjURI val}>|]
, fieldEnctype = UrlEncoded
}
--TODO use custom fields to ensure uniqueness or other constraints?
{-
data NewTicket = NewTicket
{ ntTitle :: Text
, ntDesc :: Text
, ntTParams :: [(WorkflowFieldId, Text)]
, ntEParams :: [(WorkflowFieldId, WorkflowEnumCtorId)]
, ntCParams :: [WorkflowFieldId]
, ntOffer :: Bool
, ntDesc :: PandocMarkdown
--, ntTParams :: [(WorkflowFieldId, Text)]
--, ntEParams :: [(WorkflowFieldId, WorkflowEnumCtorId)]
--, ntCParams :: [WorkflowFieldId]
}
data NewCloth = NewCloth
{ ncTitle :: Text
, ncDesc :: PandocMarkdown
, ncTarget :: Maybe Text
, ncOrigin :: Maybe (FedURI, Maybe Text)
, ncPatch :: Maybe (PatchMediaType, FileInfo)
}
{-
fieldSettings :: Text -> Bool -> FieldSettings App
fieldSettings name req =
fieldSettingsLabel $
@ -103,9 +131,11 @@ cfield (Entity fid f) =
in if workflowFieldRequired f
then mkval <$> areq checkBoxField sets Nothing
else mkval . fromMaybe False <$> aopt checkBoxField sets Nothing
-}
newTicketForm :: WorkflowId -> Form NewTicket
newTicketForm wid html = do
{-
(tfs, efs, cfs) <- lift $ runDB $ do
tfs <- selectList
[ WorkflowFieldWorkflow ==. wid
@ -128,16 +158,37 @@ newTicketForm wid html = do
]
[]
return (tfs, efs, cfs)
-}
flip renderDivs html $ NewTicket
<$> (sanitizeBalance <$> areq textField "Title*" Nothing)
<*> ( maybe "" (T.filter (/= '\r') . unTextarea) <$>
aopt textareaField "Description (Markdown)" Nothing
<$> (areq textField "Title*" Nothing)
<*> ( pandocMarkdownFromText . T.filter (/= '\r') . unTextarea <$>
areq textareaField "Description (Markdown)*" Nothing
)
<*> (catMaybes <$> traverse tfield tfs)
<*> (fmap catMaybes $ sequenceA $ mapMaybe efield efs)
<*> (catMaybes <$> traverse cfield cfs)
<*> areq checkBoxField "Offer" Nothing
-}
-- <*> (catMaybes <$> traverse tfield tfs)
-- <*> (fmap catMaybes $ sequenceA $ mapMaybe efield efs)
-- <*> (catMaybes <$> traverse cfield cfs)
newClothForm :: Form NewCloth
newClothForm = renderDivs $ mk
<$> (areq textField "Title*" Nothing)
<*> ( pandocMarkdownFromText . T.filter (/= '\r') . unTextarea <$>
areq textareaField "Description (Markdown)*" Nothing
)
<*> aopt textField "Target branch" Nothing
<*> aopt fedUriField "Origin repo" Nothing
<*> aopt textField "Origin branch" Nothing
<*> aopt (selectFieldList typeList) "Patch type" Nothing
<*> aopt fileField "Patch file" Nothing
where
typeList :: [(Text, PatchMediaType)]
typeList =
[ ("Darcs", PatchMediaTypeDarcs)
, ("Git" , PatchMediaTypeGit)
]
mk title desc targetBranch originRepo originBranch typ file =
NewCloth
title desc targetBranch
((,originBranch) <$> originRepo) ((,) <$> typ <*> file)
{-
editTicketContentAForm :: Ticket -> AForm Handler Ticket

16
src/Vervis/Form/Project.hs → src/Vervis/Form/Tracker.hs
View file

@ -13,9 +13,9 @@
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
module Vervis.Form.Project
( NewProject (..)
, newProjectForm
module Vervis.Form.Tracker
( NewDeck (..)
, newDeckForm
, NewLoom (..)
, newLoomForm
--, NewProjectCollab (..)
@ -41,13 +41,13 @@ import Yesod.Hashids
import Vervis.Foundation
import Vervis.Model
data NewProject = NewProject
{ npName :: Text
, npDesc :: Text
data NewDeck = NewDeck
{ ndName :: Text
, ndDesc :: Text
}
newProjectForm :: Form NewProject
newProjectForm = renderDivs $ NewProject
newDeckForm :: Form NewDeck
newDeckForm = renderDivs $ NewDeck
<$> areq textField "Name*" Nothing
<*> areq textField "Description" Nothing

2
src/Vervis/Foundation.hs
View file

@ -908,6 +908,7 @@ instance YesodBreadcrumbs App where
TicketDepsR d t -> ("Dependencies", Just $ TicketR d t)
TicketReverseDepsR d t -> ("Dependants", Just $ TicketR d t)
TicketNewR d -> ("New Ticket", Just $ DeckR d)
TicketFollowR _ _ -> ("", Nothing)
TicketUnfollowR _ _ -> ("", Nothing)
TicketReplyR d t -> ("Reply", Just $ TicketR d t)
@ -940,6 +941,7 @@ instance YesodBreadcrumbs App where
BundleR l c b -> ("Bundle " <> keyHashidText b, Just $ ClothR l c)
PatchR l c b p -> ("Patch " <> keyHashidText p, Just $ BundleR l c b)
ClothNewR l -> ("New Merge Request", Just $ LoomR l)
ClothApplyR _ _ -> ("", Nothing)
ClothFollowR _ _ -> ("", Nothing)
ClothUnfollowR _ _ -> ("", Nothing)

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

@ -79,6 +79,7 @@ import Vervis.API
import Vervis.Client
import Vervis.Data.Actor
import Vervis.FedURI
import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
@ -898,93 +899,6 @@ postRepoUnfollowR shrFollowee rpFollowee = do
setUnfollowMessage shrAuthor eid
redirect $ RepoR shrFollowee rpFollowee
postProjectTicketsR :: ShrIdent -> PrjIdent -> Handler Html
postProjectTicketsR shr prj = do
wid <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr
j <- getValBy404 $ UniqueProject prj sid
return $ projectWorkflow j
((result, widget), enctype) <- runFormPost $ newTicketForm wid
(eperson, sharer) <- do
ep@(Entity _ p) <- requireVerifiedAuth
s <- runDB $ getJust $ personIdent p
return (ep, s)
let shrAuthor = sharerIdent sharer
eid <- runExceptT $ do
NewTicket title desc tparams eparams cparams offer <-
case result of
FormMissing -> throwE "Field(s) missing."
FormFailure _l ->
throwE "Ticket submission failed, see errors below."
FormSuccess nt -> return nt
unless (null tparams && null eparams && null cparams) $
throwE "Custom param support currently disabled"
{-
let mktparam (fid, v) = TicketParamText
{ ticketParamTextTicket = tid
, ticketParamTextField = fid
, ticketParamTextValue = v
}
insertMany_ $ map mktparam $ ntTParams nt
let mkeparam (fid, v) = TicketParamEnum
{ ticketParamEnumTicket = tid
, ticketParamEnumField = fid
, ticketParamEnumValue = v
}
insertMany_ $ map mkeparam $ ntEParams nt
-}
if offer
then Right <$> do
(summary, audience, ticket, target) <-
ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj
obiid <- offerTicketC eperson sharer (Just summary) audience ticket target
ExceptT $ runDB $ do
mtal <- getValBy $ UniqueTicketAuthorLocalOpen obiid
return $
case mtal of
Nothing ->
Left
"Offer processed successfully but no ticket \
\created"
Just tal -> Right $ ticketAuthorLocalTicket tal
else Left <$> do
(summary, audience, Create obj mtarget) <- do
encodeRouteHome <- getEncodeRouteHome
let project = encodeRouteHome $ ProjectR shr prj
ExceptT $ createTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) project project
let ticket =
case obj of
CreateTicket _ t -> t
_ -> error "Create object isn't a ticket"
obiid <- createTicketC eperson sharer (Just summary) audience ticket mtarget
ExceptT $ runDB $ do
mtalid <- getKeyBy $ UniqueTicketAuthorLocalOpen obiid
return $
case mtalid of
Nothing ->
Left
"Create processed successfully but no ticket \
\created"
Just v -> Right v
case eid of
Left e -> do
setMessage $ toHtml e
defaultLayout $(widgetFile "ticket/new")
Right (Left talid) -> do
talkhid <- encodeKeyHashid talid
redirect $ SharerTicketR shr talkhid
Right (Right ltid) -> do
ltkhid <- encodeKeyHashid ltid
eobiidFollow <- runExceptT $ do
(summary, audience, follow) <- followTicket shrAuthor shr prj ltkhid False
followC shrAuthor (Just summary) audience follow
case eobiidFollow of
Left e -> setMessage $ toHtml $ "Ticket created, but following it failed: " <> e
Right _ -> setMessage "Ticket created."
redirect $ ProjectTicketR shr prj ltkhid
postProjectTicketCloseR
:: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
postProjectTicketCloseR shr prj ltkhid = do
@ -1016,18 +930,6 @@ postProjectTicketOpenR shr prj ltkhid = do
redirect $ ProjectTicketR shr prj ltkhid
-}
fedUriField
:: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI
fedUriField = Field
{ fieldParse = parseHelper $ \ t ->
case parseObjURI t of
Left e -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t
Right u -> Right u
, fieldView = \theId name attrs val isReq ->
[whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderObjURI val}>|]
, fieldEnctype = UrlEncoded
}
capField
:: Field Handler
( FedURI

81
src/Vervis/Handler/Cloth.hs
View file

@ -26,6 +26,9 @@ module Vervis.Handler.Cloth
, getClothDepR
, getClothNewR
, postClothNewR
, postClothApplyR
, postClothFollowR
, postClothUnfollowR
@ -66,6 +69,7 @@ module Vervis.Handler.Cloth
)
where
import Control.Exception.Base
import Control.Monad
import Control.Monad.Trans.Except
import Data.Bifunctor
@ -83,10 +87,13 @@ import Network.HTTP.Types.Method
import Text.Blaze.Html (Html, preEscapedToHtml)
import Yesod.Auth
import Yesod.Core
import Yesod.Form
import Yesod.Persist.Core
import qualified Data.List.NonEmpty as NE
import qualified Data.List.Ordered as LO
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Database.Esqueleto as E
import Data.MediaType
@ -97,6 +104,7 @@ import Web.Text
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Yesod.RenderSource
import qualified Web.ActivityPub as AP
@ -104,6 +112,7 @@ import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
import Data.Paginate.Local
import Database.Persist.Local
import Yesod.Form.Local
import Yesod.Persist.Local
import Vervis.ActivityPub
@ -112,6 +121,7 @@ import Vervis.Cloth
import Vervis.Data.Actor
import Vervis.Persist.Discussion
import Vervis.FedURI
import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
@ -129,6 +139,7 @@ import Vervis.Web.Repo
import Vervis.Widget
import Vervis.Widget.Discussion
import Vervis.Widget.Person
import Vervis.Widget.Tracker
import qualified Vervis.Client as C
@ -284,10 +295,11 @@ getClothR loomHash clothHash = do
where
getClothHtml = do
mpid <- maybeAuthId
(ticket, targetRepo, author, tparams, eparams, cparams, resolved, moriginRepo, mbundle) <- handlerToWidget $ runDB $ do
(Entity _ loom, Entity _ cloth, Entity ticketID ticket, author, maybeResolve, proposal) <-
(eloom, actor, ticket, targetRepo, author, tparams, eparams, cparams, resolved, moriginRepo, mbundle) <- handlerToWidget $ runDB $ do
(eloom@(Entity _ loom), Entity _ cloth, Entity ticketID ticket, author, maybeResolve, proposal) <-
getCloth404 loomHash clothHash
(ticket,,,,,,,,)
actor <- getJust $ loomActor loom
(eloom,actor,ticket,,,,,,,,)
<$> getLocalRepo' (loomRepo loom) (ticketLoomBranch cloth)
<*> bitraverse
(\ (Entity _ (TicketAuthorLocal _ personID _)) -> do
@ -626,6 +638,69 @@ getClothDepR _ _ _ = do
tdc
-}
getClothNewR :: KeyHashid Loom -> Handler Html
getClothNewR loomHash = do
loomID <- decodeKeyHashid404 loomHash
_ <- runDB $ get404 loomID
((_result, widget), enctype) <- runFormPost newClothForm
defaultLayout $(widgetFile "cloth/new")
postClothNewR :: KeyHashid Loom -> Handler Html
postClothNewR loomHash = do
loomID <- decodeKeyHashid404 loomHash
person@(Entity pid p) <- requireAuth
(loom, senderActor) <- runDB $ do
loom <- get404 loomID
a <- getJust $ personActor p
return (loom, a)
NewCloth title desc targetBranch origin patch <-
runFormPostRedirect (ClothNewR loomHash) newClothForm
encodeRouteHome <- getEncodeRouteHome
errorOrTicket <- runExceptT $ do
let uLoom = encodeRouteHome $ LoomR loomHash
senderHash <- encodeKeyHashid pid
(maybeSummary, audience, ticket) <- do
uTargetRepo <-
encodeRouteHome . RepoR <$> encodeKeyHashid (loomRepo loom)
case (origin, patch) of
(Nothing, Nothing) -> throwE "Neither origin no patch provided"
(Just _, Just _) -> throwE "Both origin and patch provided"
(Just (uRepo, mb), Nothing) ->
C.offerMerge
senderHash title desc uLoom uTargetRepo targetBranch
uRepo mb
(Nothing, Just (typ, fi)) -> do
diff <-
withExceptT (T.pack . displayException) $ ExceptT $
TE.decodeUtf8' <$> fileSourceByteString fi
C.offerPatches
senderHash title desc uLoom uTargetRepo targetBranch
typ (diff :| [])
(localRecips, remoteRecips, fwdHosts, action) <-
lift $ C.makeServerInput Nothing maybeSummary audience $
AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) uLoom
offerID <-
offerTicketC
person senderActor Nothing localRecips remoteRecips fwdHosts action
ticket uLoom
runDBExcept $ do
mtal <- lift $ getValBy $ UniqueTicketAuthorLocalOpen offerID
tal <- fromMaybeE mtal "Offer processed bu no ticket created"
return $ ticketAuthorLocalTicket tal
case errorOrTicket of
Left e -> do
setMessage $ toHtml e
redirect $ ClothNewR loomHash
Right ticketID -> do
clothID <- do
maybeClothID <- runDB $ getKeyBy $ UniqueTicketLoom ticketID
case maybeClothID of
Nothing -> error "No TicketLoom for the new Ticket"
Just c -> return c
clothHash <- encodeKeyHashid clothID
setMessage "MR created"
redirect $ ClothR loomHash clothHash
postClothApplyR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler ()
postClothApplyR loomHash clothHash = do
ep@(Entity personID person) <- requireAuth

21
src/Vervis/Handler/Deck.hs
View file

@ -103,8 +103,8 @@ import Vervis.Federation.Collab
import Vervis.Federation.Discussion
import Vervis.Federation.Ticket
import Vervis.FedURI
import Vervis.Form.Project
import Vervis.Form.Ticket
import Vervis.Form.Tracker
import Vervis.Foundation
import Vervis.Model
import Vervis.Paginate
@ -115,6 +115,7 @@ import Vervis.TicketFilter
import Vervis.Web.Actor
import Vervis.Widget.Person
import Vervis.Widget.Ticket
import Vervis.Widget.Tracker
import qualified Vervis.Client as C
@ -226,16 +227,20 @@ getDeckFollowersR = getActorFollowersCollection DeckFollowersR deckActor
getDeckTicketsR :: KeyHashid Deck -> Handler TypedContent
getDeckTicketsR deckHash = selectRep $ do
provideRep $ do
((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
let tf = def
{-
((filtResult, filtWidget), filtEnctype) <- runFormPost ticketFilterForm
let tf =
case filtResult of
FormSuccess filt -> filt
FormMissing -> def
FormFailure l ->
error $ "Ticket filter form failed: " ++ show l
-}
deckID <- decodeKeyHashid404 deckHash
(total, pages, mpage) <- runDB $ do
_ <- get404 deckID
(deck, actor, (total, pages, mpage)) <- runDB $ do
deck <- get404 deckID
actor <- getJust $ deckActor deck
let countAllTickets = count [TicketDeckDeck ==. deckID]
selectTickets off lim =
getTicketSummaries
@ -243,7 +248,7 @@ getDeckTicketsR deckHash = selectRep $ do
(Just $ \ t -> [E.desc $ t E.^. TicketId])
(Just (off, lim))
deckID
getPageAndNavCount countAllTickets selectTickets
(deck,actor,) <$> getPageAndNavCount countAllTickets selectTickets
case mpage of
Nothing -> redirectFirstPage here
Just (rows, navModel) ->
@ -319,12 +324,12 @@ getDeckMessageR _ _ = notFound
getDeckNewR :: Handler Html
getDeckNewR = do
((_result, widget), enctype) <- runFormPost newProjectForm
defaultLayout $(widgetFile "project/new")
((_result, widget), enctype) <- runFormPost newDeckForm
defaultLayout $(widgetFile "deck/new")
postDeckNewR :: Handler Html
postDeckNewR = do
NewProject name desc <- runFormPostRedirect DeckNewR newProjectForm
NewDeck name desc <- runFormPostRedirect DeckNewR newDeckForm
personEntity@(Entity personID person) <- requireAuth
personHash <- encodeKeyHashid personID

15
src/Vervis/Handler/Loom.hs
View file

@ -80,8 +80,8 @@ import Vervis.Federation.Collab
import Vervis.Federation.Discussion
import Vervis.Federation.Ticket
import Vervis.FedURI
import Vervis.Form.Project
import Vervis.Form.Ticket
import Vervis.Form.Tracker
import Vervis.Foundation
import Vervis.Model
import Vervis.Paginate
@ -91,6 +91,7 @@ import Vervis.Ticket
import Vervis.TicketFilter
import Vervis.Web.Actor
import Vervis.Widget.Ticket
import Vervis.Widget.Tracker
import qualified Vervis.Client as C
@ -180,16 +181,20 @@ getLoomFollowersR = getActorFollowersCollection LoomFollowersR loomActor
getLoomClothsR :: KeyHashid Loom -> Handler TypedContent
getLoomClothsR loomHash = selectRep $ do
provideRep $ do
((filtResult, filtWidget), filtEnctype) <- runFormGet ticketFilterForm
let tf = def
{-
((filtResult, filtWidget), filtEnctype) <- runFormPost ticketFilterForm
let tf =
case filtResult of
FormSuccess filt -> filt
FormMissing -> def
FormFailure l ->
error $ "Ticket filter form failed: " ++ show l
-}
loomID <- decodeKeyHashid404 loomHash
(total, pages, mpage) <- runDB $ do
_ <- get404 loomID
(loom, actor, (total, pages, mpage)) <- runDB $ do
loom <- get404 loomID
actor <- getJust $ loomActor loom
let countAllTickets = count [TicketLoomLoom ==. loomID]
selectTickets off lim =
getClothSummaries
@ -197,7 +202,7 @@ getLoomClothsR loomHash = selectRep $ do
(Just $ \ t -> [E.desc $ t E.^. TicketId])
(Just (off, lim))
loomID
getPageAndNavCount countAllTickets selectTickets
(loom,actor,) <$> getPageAndNavCount countAllTickets selectTickets
case mpage of
Nothing -> redirectFirstPage here
Just (rows, navModel) ->

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

@ -24,6 +24,9 @@ module Vervis.Handler.Ticket
, getTicketDepR
, getTicketNewR
, postTicketNewR
, postTicketFollowR
, postTicketUnfollowR
@ -41,8 +44,6 @@ module Vervis.Handler.Ticket
{-
, getProjectTicketsR
, getProjectTicketTreeR
, getProjectTicketNewR
, putProjectTicketR
, deleteProjectTicketR
, postProjectTicketR
, getProjectTicketEditR
@ -98,7 +99,7 @@ import Network.HTTP.Types (StdMethod (DELETE, POST))
import Text.Blaze.Html (Html, toHtml)
import Text.Blaze.Html.Renderer.Text
import Text.HTML.SanitizeXSS
import Yesod.Auth (requireAuthId, maybeAuthId)
import Yesod.Auth
import Yesod.Core hiding (logWarn)
import Yesod.Core.Handler
import Yesod.Core.Widget
@ -128,17 +129,19 @@ import Yesod.RenderSource
import qualified Web.ActivityPub as AP
import Control.Monad.Trans.Except.Local
import Data.Either.Local
import Data.Maybe.Local (partitionMaybePairs)
import Data.Paginate.Local
import Database.Persist.Local
import Yesod.Form.Local
import Yesod.Persist.Local
import Vervis.ActivityPub
import Vervis.API
import Vervis.Data.Actor
import Vervis.Persist.Discussion
import Vervis.FedURI
import Vervis.Form.Ticket
import Vervis.Foundation
--import Vervis.GraphProxy (ticketDepGraph)
import Vervis.Model
@ -147,6 +150,7 @@ import Vervis.Model.Ticket
import Vervis.Model.Workflow
import Vervis.Paginate
import Vervis.Persist.Actor
import Vervis.Persist.Discussion
import Vervis.Recipient
import Vervis.Settings
import Vervis.Style
@ -157,6 +161,9 @@ import Vervis.Web.Actor
import Vervis.Web.Discussion
import Vervis.Widget.Discussion
import Vervis.Widget.Person
import Vervis.Widget.Tracker
import qualified Vervis.Client as C
selectDiscussionID deckHash taskHash = do
(_, _, Entity _ ticket, _, _) <- getTicket404 deckHash taskHash
@ -251,10 +258,11 @@ getTicketR deckHash ticketHash = do
where
getTicketHtml = do
mpid <- maybeAuthId
(ticket, author, tparams, eparams, cparams, resolved) <- handlerToWidget $ runDB $ do
(_deck, _ticketdeck, Entity ticketID ticket, author, maybeResolve) <-
(edeck, actor, ticket, author, tparams, eparams, cparams, resolved) <- handlerToWidget $ runDB $ do
(deck, _ticketdeck, Entity ticketID ticket, author, maybeResolve) <-
getTicket404 deckHash ticketHash
(ticket,,,,,)
actor <- getJust $ deckActor $ entityVal deck
(deck,actor,ticket,,,,,)
<$> bitraverse
(\ (Entity _ (TicketAuthorLocal _ personID _)) -> do
p <- getJust personID
@ -421,6 +429,54 @@ getTicketDepR _ _ _ = do
tdc
-}
getTicketNewR :: KeyHashid Deck -> Handler Html
getTicketNewR deckHash = do
deckID <- decodeKeyHashid404 deckHash
wid <- runDB $ deckWorkflow <$> get404 deckID
((_result, widget), enctype) <- runFormPost $ newTicketForm wid
defaultLayout $(widgetFile "ticket/new")
postTicketNewR :: KeyHashid Deck -> Handler Html
postTicketNewR deckHash = do
deckID <- decodeKeyHashid404 deckHash
person@(Entity pid p) <- requireAuth
(wid, actor) <- runDB $ do
wid <- deckWorkflow <$> get404 deckID
a <- getJust $ personActor p
return (wid, a)
NewTicket title desc <-
runFormPostRedirect (TicketNewR deckHash) $ newTicketForm wid
errorOrTicket <- runExceptT $ do
encodeRouteHome <- getEncodeRouteHome
let uDeck = encodeRouteHome $ DeckR deckHash
senderHash <- encodeKeyHashid pid
(maybeSummary, audience, ticket) <-
C.offerIssue senderHash title desc uDeck
(localRecips, remoteRecips, fwdHosts, action) <-
lift $ C.makeServerInput Nothing maybeSummary audience $
AP.OfferActivity $ AP.Offer (AP.OfferTicket ticket) uDeck
offerID <-
offerTicketC
person actor Nothing localRecips remoteRecips fwdHosts action
ticket uDeck
runDBExcept $ do
mtal <- lift $ getValBy $ UniqueTicketAuthorLocalOpen offerID
tal <- fromMaybeE mtal "Offer processed bu no ticket created"
return $ ticketAuthorLocalTicket tal
case errorOrTicket of
Left e -> do
setMessage $ toHtml e
redirect $ TicketNewR deckHash
Right ticketID -> do
taskID <- do
maybeTaskID <- runDB $ getKeyBy $ UniqueTicketDeck ticketID
case maybeTaskID of
Nothing -> error "No TicketDeck for the new Ticket"
Just t -> return t
taskHash <- encodeKeyHashid taskID
setMessage "Ticket created"
redirect $ TicketR deckHash taskHash
postTicketFollowR :: KeyHashid Deck -> KeyHashid TicketDeck -> Handler ()
postTicketFollowR _ = error "Temporarily disabled"
@ -500,75 +556,6 @@ postTicketReplyOnR deckHash taskHash msgHash = do
{-
getProjectTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
getProjectTicketNewR shr prj = do
wid <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr
Entity _ j <- getBy404 $ UniqueProject prj sid
return $ projectWorkflow j
((_result, widget), enctype) <- runFormPost $ newTicketForm wid
defaultLayout $(widgetFile "ticket/new")
putProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
putProjectTicketR shr prj ltkhid = do
(tid, ticket, wid) <- runDB $ do
(_es, Entity _ project, Entity tid ticket, _elt, _etcl, _etpl, _author, _) <- getProjectTicket404 shr prj ltkhid
return (tid, ticket, projectWorkflow project)
((result, widget), enctype) <-
runFormPost $ editTicketContentForm tid ticket wid
case result of
FormSuccess (ticket', tparams, eparams, cparams) -> do
newDescHtml <-
case renderPandocMarkdown $ ticketSource ticket' of
Left err -> do
setMessage $ toHtml err
redirect $ ProjectTicketEditR shr prj ltkhid
Right t -> return t
let ticket'' = ticket' { ticketDescription = newDescHtml }
runDB $ do
replace tid ticket''
let (tdel, tins, tupd) = partitionMaybePairs tparams
deleteWhere [TicketParamTextId <-. tdel]
let mktparam (fid, v) = TicketParamText
{ ticketParamTextTicket = tid
, ticketParamTextField = fid
, ticketParamTextValue = v
}
insertMany_ $ map mktparam tins
traverse_
(\ (aid, (_fid, v)) ->
update aid [TicketParamTextValue =. v]
)
tupd
let (edel, eins, eupd) = partitionMaybePairs eparams
deleteWhere [TicketParamEnumId <-. edel]
let mkeparam (fid, v) = TicketParamEnum
{ ticketParamEnumTicket = tid
, ticketParamEnumField = fid
, ticketParamEnumValue = v
}
insertMany_ $ map mkeparam eins
traverse_
(\ (aid, (_fid, v)) ->
update aid [TicketParamEnumValue =. v]
)
eupd
let (cdel, cins, _ckeep) = partitionMaybePairs cparams
deleteWhere [TicketParamClassId <-. cdel]
let mkcparam fid = TicketParamClass
{ ticketParamClassTicket = tid
, ticketParamClassField = fid
}
insertMany_ $ map mkcparam cins
setMessage "Ticket updated."
redirect $ ProjectTicketR shr prj ltkhid
FormMissing -> do
setMessage "Field(s) missing."
defaultLayout $(widgetFile "ticket/edit")
FormFailure _l -> do
setMessage "Ticket update failed, see errors below."
defaultLayout $(widgetFile "ticket/edit")
deleteProjectTicketR :: ShrIdent -> PrjIdent -> KeyHashid LocalTicket -> Handler Html
deleteProjectTicketR _shr _prj _ltkhid =
--TODO: I can easily implement this, but should it even be possible to

29
src/Vervis/Widget/Project.hs
View file

@ -1,29 +0,0 @@
{- This file is part of Vervis.
-
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
module Vervis.Widget.Project
( projectNavW
)
where
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Settings
import Vervis.Widget.Workflow
projectNavW :: Project -> Workflow -> Sharer -> ShrIdent -> PrjIdent -> Widget
projectNavW project workflow wsharer shar proj =
$(widgetFile "project/widget/nav")

40
src/Vervis/Widget/Tracker.hs Normal file
View file

@ -0,0 +1,40 @@
{- This file is part of Vervis.
-
- Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
- The author(s) have dedicated all copyright and related and neighboring
- rights to this software to the public domain worldwide. This software is
- distributed without any warranty.
-
- You should have received a copy of the CC0 Public Domain Dedication along
- with this software. If not, see
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
module Vervis.Widget.Tracker
( deckNavW
, loomNavW
)
where
import Database.Persist.Types
import Yesod.Hashids
import Vervis.Foundation
import Vervis.Model
import Vervis.Settings
deckNavW :: Entity Deck -> Actor -> Widget
deckNavW (Entity deckID deck) actor = do
deckHash <- encodeKeyHashid deckID
hashRepo <- getEncodeKeyHashid
$(widgetFile "deck/widget/nav")
loomNavW :: Entity Loom -> Actor -> Widget
loomNavW (Entity loomID loom) actor = do
loomHash <- encodeKeyHashid loomID
hashRepo <- getEncodeKeyHashid
$(widgetFile "loom/widget/nav")

14
templates/cloth/list.hamlet
View file

@ -12,16 +12,18 @@ $# 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/>.
$# <p>
$# <a href=@{ProjectTicketNewR shr prj}>Create new…
^{loomNavW (Entity loomID loom) actor}
<p>
<a href=@{ClothNewR loomHash}>Create new…
$# <p>
$# <a href=@{ProjectTicketTreeR shr prj}>View as tree…
<form method=GET action=@{LoomClothsR loomHash} enctype=#{filtEnctype}>
^{filtWidget}
<div class="submit">
<input type="submit" value="Filter">
$# <form method=GET action=@{LoomClothsR loomHash} enctype=#{filtEnctype}>
$# ^{filtWidget}
$# <div class="submit">
$# <input type="submit" value="Filter">
^{pageNav}

2
templates/cloth/one.hamlet
View file

@ -13,6 +13,8 @@ $# 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/>.
^{loomNavW eloom actor}
<h2>#{ticketTitle ticket}
<div>

0
templates/project/claim-request/list.hamlet → templates/deck/claim-request/list.hamlet
View file

0
templates/project/collab/list.hamlet → templates/deck/collab/list.hamlet
View file

0
templates/project/collab/new.hamlet → templates/deck/collab/new.hamlet
View file

0
templates/project/collab/one.hamlet → templates/deck/collab/one.hamlet
View file

0
templates/project/edit.hamlet → templates/deck/edit.hamlet
View file

0
templates/project/list.hamlet → templates/deck/list.hamlet
View file

0
templates/project/new.hamlet → templates/deck/new.hamlet
View file

0
templates/project/one.hamlet → templates/deck/one.hamlet
View file

0
templates/project/role/graph.hamlet → templates/deck/role/graph.hamlet
View file

0
templates/project/role/new.hamlet → templates/deck/role/new.hamlet
View file

0
templates/project/role/one.hamlet → templates/deck/role/one.hamlet
View file

0
templates/project/role/op/list.hamlet → templates/deck/role/op/list.hamlet
View file

0
templates/project/role/op/new.hamlet → templates/deck/role/op/new.hamlet
View file

29
templates/project/widget/nav.hamlet → templates/deck/widget/nav.hamlet
View file

@ -1,6 +1,6 @@
$# This file is part of Vervis.
$#
$# Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
$# Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@ -15,36 +15,29 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div>
<span>
[[ 🏗
<a href=@{ProjectR shar proj}>
#{prj2text proj}
<a href=@{DeckR deckHash}>
=#{keyHashidText deckHash} #{actorName actor}
]] ::
<span>
<a href=@{ProjectInboxR shar proj}>
<a href=@{DeckInboxR deckHash}>
[📥 Inbox]
<span>
<a href=@{ProjectOutboxR shar proj}>
<a href=@{DeckOutboxR deckHash}>
[📤 Outbox]
<span>
<a href=@{ProjectFollowersR shar proj}>
<a href=@{DeckFollowersR deckHash}>
[🐤 Followers]
<span>
<a href=@{ProjectDevsR shar proj}>
[🤝 Collaborators]
[🤝 Collaborators]
<span>
<a href=@{ProjectTicketsR shar proj}>
<a href=@{DeckTicketsR deckHash}>
[🐛 Tickets]
<span>
<a href=@{ClaimRequestsProjectR shar proj}>
[✋ Ticket claim requests]
<span>
[🔁 Ticket workflow:
^{workflowLinkW wsharer workflow}]
<span>
$maybe _wiki <- projectWiki project
<a href=@{WikiPageR shar proj []}>
$maybe repoID <- deckWiki deck
<a href=@{RepoR $ hashRepo repoID}>
[📖 Wiki]
$nothing
[No wiki]
<span>
<a href=@{ProjectEditR shar proj}>
<a href=@{DeckEditR deckHash}>
[✏ Edit]

39
templates/loom/widget/nav.hamlet Normal file
View file

@ -0,0 +1,39 @@
$# This file is part of Vervis.
$#
$# Written in 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
$# The author(s) have dedicated all copyright and related and neighboring
$# rights to this software to the public domain worldwide. This software is
$# distributed without any warranty.
$#
$# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div>
<span>
[[ 🏗
<a href=@{LoomR loomHash}>
+#{keyHashidText loomHash} #{actorName actor}
]] ::
<span>
<a href=@{LoomInboxR loomHash}>
[📥 Inbox]
<span>
<a href=@{LoomOutboxR loomHash}>
[📤 Outbox]
<span>
<a href=@{LoomFollowersR loomHash}>
[🐤 Followers]
<span>
[🤝 Collaborators]
<span>
<a href=@{LoomClothsR loomHash}>
[🧩 Merge Requests]
<span>
<a href=@{RepoR $ hashRepo $ loomRepo loom}>
[🗃 Repository]
<span>
[✏ Edit]

14
templates/ticket/list.hamlet
View file

@ -12,16 +12,18 @@ $# 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/>.
$# <p>
$# <a href=@{ProjectTicketNewR shr prj}>Create new…
^{deckNavW (Entity deckID deck) actor}
<p>
<a href=@{TicketNewR deckHash}>Create new…
$# <p>
$# <a href=@{ProjectTicketTreeR shr prj}>View as tree…
<form method=GET action=@{DeckTicketsR deckHash} enctype=#{filtEnctype}>
^{filtWidget}
<div class="submit">
<input type="submit" value="Filter">
$# <form method=GET action=@{DeckTicketsR deckHash} enctype=#{filtEnctype}>
$# ^{filtWidget}
$# <div class="submit">
$# <input type="submit" value="Filter">
^{pageNav}

4
templates/ticket/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, 2022 by fr33domlover <fr33domlover@riseup.net>.
$#
$# ♡ Copying is an act of love. Please copy, reuse and share.
$#
@ -14,7 +14,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
Enter the details and click "Submit" to create a new ticket.
<form method=POST action=@{ProjectTicketsR shr prj} enctype=#{enctype}>
<form method=POST action=@{TicketNewR deckHash} enctype=#{enctype}>
^{widget}
<div class="submit">
<input type="submit">

2
templates/ticket/one.hamlet
View file

@ -13,6 +13,8 @@ $# 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/>.
^{deckNavW edeck actor}
<h2>#{ticketTitle ticket}
<div>

6
th/routes
View file

@ -224,10 +224,9 @@
/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/deps TicketDepsR GET
/decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/rdeps TicketReverseDepsR GET
-- /decks/#DeckKeyHashid/new-ticket TicketNewR GET POST
/decks/#DeckKeyHashid/new-ticket TicketNewR GET POST
-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/edit TicketEditR GET POST
-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/delete TicketDeleteR POST
-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/accept TicketAcceptR POST
-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/close TicketCloseR POST
-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/open TicketOpenR POST
-- /decks/#DeckKeyHashid/tickets/#TicketDeckKeyHashid/claim TicketClaimR POST
@ -277,10 +276,9 @@
/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/bundles/#BundleKeyHashid BundleR GET
/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/bundles/#BundleKeyHashid/patches/#PatchKeyHashid PatchR GET
-- /looms/#LoomKeyHashid/new-cloth ClothNewR GET POST
/looms/#LoomKeyHashid/new-cloth ClothNewR GET POST
-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/edit ClothEditR GET POST
-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/delete ClothDeleteR POST
-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/accept ClothAcceptR POST
-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/close ClothCloseR POST
-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/open ClothOpenR POST
-- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/claim ClothClaimR POST

4
vervis.cabal
View file

@ -166,10 +166,10 @@ library
Vervis.Form.Discussion
--Vervis.Form.Group
Vervis.Form.Key
Vervis.Form.Project
Vervis.Form.Repo
--Vervis.Form.Role
Vervis.Form.Ticket
Vervis.Form.Tracker
-- Vervis.Form.Workflow
Vervis.Formatting
Vervis.Foundation
@ -239,10 +239,10 @@ library
Vervis.Widget
Vervis.Widget.Discussion
Vervis.Widget.Person
--Vervis.Widget.Project
Vervis.Widget.Repo
--Vervis.Widget.Role
Vervis.Widget.Ticket
Vervis.Widget.Tracker
-- Vervis.Widget.Workflow
-- Vervis.Wiki
Vervis.WorkItem