Bring back postTicketsR, now implemented using offerTicketC
This commit is contained in:
parent
55fdb5437c
commit
4be444f5ab
3 changed files with 102 additions and 63 deletions
|
@ -110,7 +110,7 @@ newTicketForm wid html = do
|
||||||
[]
|
[]
|
||||||
return (tfs, efs)
|
return (tfs, efs)
|
||||||
flip renderDivs html $ NewTicket
|
flip renderDivs html $ NewTicket
|
||||||
<$> areq textField "Title*" Nothing
|
<$> (sanitizeBalance <$> areq textField "Title*" Nothing)
|
||||||
<*> ( maybe "" (T.filter (/= '\r') . unTextarea) <$>
|
<*> ( maybe "" (T.filter (/= '\r') . unTextarea) <$>
|
||||||
aopt textareaField "Description (Markdown)" Nothing
|
aopt textareaField "Description (Markdown)" Nothing
|
||||||
)
|
)
|
||||||
|
|
|
@ -55,8 +55,10 @@ module Vervis.Handler.Ticket
|
||||||
where
|
where
|
||||||
|
|
||||||
import Control.Applicative (liftA2)
|
import Control.Applicative (liftA2)
|
||||||
|
import Control.Monad
|
||||||
import Control.Monad.IO.Class (liftIO)
|
import Control.Monad.IO.Class (liftIO)
|
||||||
import Control.Monad.Logger (logWarn)
|
import Control.Monad.Logger (logWarn)
|
||||||
|
import Control.Monad.Trans.Except
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Data.Bool (bool)
|
import Data.Bool (bool)
|
||||||
import Data.Default.Class (def)
|
import Data.Default.Class (def)
|
||||||
|
@ -70,7 +72,7 @@ import Data.Time.Format (formatTime, defaultTimeLocale)
|
||||||
import Data.Traversable (for)
|
import Data.Traversable (for)
|
||||||
import Database.Persist
|
import Database.Persist
|
||||||
import Network.HTTP.Types (StdMethod (DELETE, POST))
|
import Network.HTTP.Types (StdMethod (DELETE, POST))
|
||||||
import Text.Blaze.Html (Html, toHtml)
|
import Text.Blaze.Html (Html, toHtml, preEscapedToHtml)
|
||||||
import Text.Blaze.Html.Renderer.Text
|
import Text.Blaze.Html.Renderer.Text
|
||||||
import Text.HTML.SanitizeXSS
|
import Text.HTML.SanitizeXSS
|
||||||
import Yesod.Auth (requireAuthId, maybeAuthId)
|
import Yesod.Auth (requireAuthId, maybeAuthId)
|
||||||
|
@ -90,6 +92,7 @@ import Data.Aeson.Encode.Pretty.ToEncoding
|
||||||
import Network.FedURI
|
import Network.FedURI
|
||||||
import Web.ActivityPub hiding (Ticket (..))
|
import Web.ActivityPub hiding (Ticket (..))
|
||||||
import Yesod.ActivityPub
|
import Yesod.ActivityPub
|
||||||
|
import Yesod.Auth.Unverified
|
||||||
import Yesod.FedURI
|
import Yesod.FedURI
|
||||||
import Yesod.Hashids
|
import Yesod.Hashids
|
||||||
|
|
||||||
|
@ -141,43 +144,22 @@ getTicketsR shr prj = do
|
||||||
defaultLayout $(widgetFile "ticket/list")
|
defaultLayout $(widgetFile "ticket/list")
|
||||||
|
|
||||||
postTicketsR :: ShrIdent -> PrjIdent -> Handler Html
|
postTicketsR :: ShrIdent -> PrjIdent -> Handler Html
|
||||||
postTicketsR shar proj = do
|
postTicketsR shr prj = do
|
||||||
Entity pid project <- runDB $ do
|
wid <- runDB $ do
|
||||||
Entity sid _sharer <- getBy404 $ UniqueSharer shar
|
sid <- getKeyBy404 $ UniqueSharer shr
|
||||||
getBy404 $ UniqueProject proj sid
|
j <- getValBy404 $ UniqueProject prj sid
|
||||||
((result, widget), enctype) <-
|
return $ projectWorkflow j
|
||||||
runFormPost $ newTicketForm $ projectWorkflow project
|
((result, widget), enctype) <- runFormPost $ newTicketForm wid
|
||||||
|
enum <- runExceptT $ do
|
||||||
|
NewTicket title desc tparams eparams <-
|
||||||
case result of
|
case result of
|
||||||
FormSuccess nt -> do
|
FormMissing -> throwE "Field(s) missing."
|
||||||
author <- requireAuthId
|
FormFailure _l ->
|
||||||
now <- liftIO getCurrentTime
|
throwE "Ticket submission failed, see errors below."
|
||||||
let source = ntDesc nt
|
FormSuccess nt -> return nt
|
||||||
descHtml <-
|
unless (null tparams && null eparams) $
|
||||||
case renderPandocMarkdown source of
|
throwE "Custom param support currently disabled"
|
||||||
Left err -> do
|
{-
|
||||||
setMessage $ toHtml err
|
|
||||||
redirect $ TicketNewR shar proj
|
|
||||||
Right t -> return t
|
|
||||||
tnum <- runDB $ do
|
|
||||||
update pid [ProjectNextTicket +=. 1]
|
|
||||||
did <- insert Discussion
|
|
||||||
fsid <- insert FollowerSet
|
|
||||||
let ticket = Ticket
|
|
||||||
{ ticketProject = pid
|
|
||||||
, ticketNumber = projectNextTicket project
|
|
||||||
, ticketCreated = now
|
|
||||||
, ticketTitle = sanitizeBalance $ ntTitle nt
|
|
||||||
, ticketSource = source
|
|
||||||
, ticketDescription = descHtml
|
|
||||||
, ticketAssignee = Nothing
|
|
||||||
, ticketStatus = TSNew
|
|
||||||
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0
|
|
||||||
, ticketCloser = Nothing
|
|
||||||
, ticketDiscuss = did
|
|
||||||
, ticketFollowers = fsid
|
|
||||||
}
|
|
||||||
tid <- insert ticket
|
|
||||||
insert_ $ TicketAuthorLocal tid author $ error "TODO offer"
|
|
||||||
let mktparam (fid, v) = TicketParamText
|
let mktparam (fid, v) = TicketParamText
|
||||||
{ ticketParamTextTicket = tid
|
{ ticketParamTextTicket = tid
|
||||||
, ticketParamTextField = fid
|
, ticketParamTextField = fid
|
||||||
|
@ -190,15 +172,72 @@ postTicketsR shar proj = do
|
||||||
, ticketParamEnumValue = v
|
, ticketParamEnumValue = v
|
||||||
}
|
}
|
||||||
insertMany_ $ map mkeparam $ ntEParams nt
|
insertMany_ $ map mkeparam $ ntEParams nt
|
||||||
return $ ticketNumber ticket
|
-}
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
descHtml <- ExceptT . pure $ renderPandocMarkdown desc
|
||||||
|
shrAuthor <- do
|
||||||
|
Entity _ p <- requireVerifiedAuth
|
||||||
|
lift $ runDB $ sharerIdent <$> getJust (personIdent p)
|
||||||
|
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]
|
||||||
|
ticket = AP.Ticket
|
||||||
|
{ AP.ticketLocal = Nothing
|
||||||
|
, AP.ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor
|
||||||
|
, AP.ticketPublished = Nothing
|
||||||
|
, AP.ticketUpdated = Nothing
|
||||||
|
, AP.ticketName = Nothing
|
||||||
|
, AP.ticketSummary = TextHtml title
|
||||||
|
, AP.ticketContent = TextHtml descHtml
|
||||||
|
, AP.ticketSource = TextPandocMarkdown desc
|
||||||
|
, AP.ticketAssignedTo = Nothing
|
||||||
|
, AP.ticketIsResolved = False
|
||||||
|
, AP.ticketDependsOn = []
|
||||||
|
, AP.ticketDependedBy = []
|
||||||
|
}
|
||||||
|
offer = Offer
|
||||||
|
{ offerObject = ticket
|
||||||
|
, offerTarget = encodeRouteHome $ ProjectR shr prj
|
||||||
|
}
|
||||||
|
audience = Audience
|
||||||
|
{ audienceTo = map encodeRouteHome $ recipsA ++ recipsC
|
||||||
|
, audienceBto = []
|
||||||
|
, audienceCc = []
|
||||||
|
, audienceBcc = []
|
||||||
|
, audienceGeneral = []
|
||||||
|
, audienceNonActors = map encodeRouteHome recipsC
|
||||||
|
}
|
||||||
|
obiid <- ExceptT $ offerTicketC shrAuthor summary audience offer
|
||||||
|
ExceptT $ runDB $ do
|
||||||
|
mtal <- getValBy $ UniqueTicketAuthorLocalOffer obiid
|
||||||
|
case mtal of
|
||||||
|
Nothing ->
|
||||||
|
return $
|
||||||
|
Left
|
||||||
|
"Offer processed successfully but no ticket \
|
||||||
|
\created"
|
||||||
|
Just tal ->
|
||||||
|
Right . ticketNumber <$>
|
||||||
|
getJust (ticketAuthorLocalTicket tal)
|
||||||
|
case enum of
|
||||||
|
Left e -> do
|
||||||
|
setMessage $ toHtml e
|
||||||
|
defaultLayout $(widgetFile "ticket/new")
|
||||||
|
Right num -> do
|
||||||
setMessage "Ticket created."
|
setMessage "Ticket created."
|
||||||
redirect $ TicketR shar proj tnum
|
redirect $ TicketR shr prj num
|
||||||
FormMissing -> do
|
|
||||||
setMessage "Field(s) missing."
|
|
||||||
defaultLayout $(widgetFile "ticket/new")
|
|
||||||
FormFailure _l -> do
|
|
||||||
setMessage "Ticket creation failed, see errors below."
|
|
||||||
defaultLayout $(widgetFile "ticket/new")
|
|
||||||
|
|
||||||
getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
|
getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
|
||||||
getTicketTreeR shr prj = do
|
getTicketTreeR shr prj = do
|
||||||
|
@ -211,10 +250,10 @@ getTicketTreeR shr prj = do
|
||||||
defaultLayout $ ticketTreeDW shr prj summaries deps
|
defaultLayout $ ticketTreeDW shr prj summaries deps
|
||||||
|
|
||||||
getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
|
getTicketNewR :: ShrIdent -> PrjIdent -> Handler Html
|
||||||
getTicketNewR shar proj = do
|
getTicketNewR shr prj = do
|
||||||
wid <- runDB $ do
|
wid <- runDB $ do
|
||||||
Entity sid _ <- getBy404 $ UniqueSharer shar
|
Entity sid _ <- getBy404 $ UniqueSharer shr
|
||||||
Entity _ j <- getBy404 $ UniqueProject proj sid
|
Entity _ j <- getBy404 $ UniqueProject prj sid
|
||||||
return $ projectWorkflow j
|
return $ projectWorkflow j
|
||||||
((_result, widget), enctype) <- runFormPost $ newTicketForm wid
|
((_result, widget), enctype) <- runFormPost $ newTicketForm wid
|
||||||
defaultLayout $(widgetFile "ticket/new")
|
defaultLayout $(widgetFile "ticket/new")
|
||||||
|
|
|
@ -14,6 +14,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
|
|
||||||
Enter the details and click "Submit" to create a new ticket.
|
Enter the details and click "Submit" to create a new ticket.
|
||||||
|
|
||||||
<form method=POST action=@{TicketsR shar proj} enctype=#{enctype}>
|
<form method=POST action=@{TicketsR shr prj} enctype=#{enctype}>
|
||||||
^{widget}
|
^{widget}
|
||||||
<input type=submit>
|
<input type=submit>
|
||||||
|
|
Loading…
Reference in a new issue