diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 810a2c1..d0dcf06 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -21,12 +21,14 @@ module Vervis.Client , followProject , followTicket , followRepo + , offerTicket ) where import Control.Monad.Trans.Except import Database.Persist import Data.Text (Text) +import Text.Blaze.Html (preEscapedToHtml) import Text.Blaze.Html.Renderer.Text import Text.Hamlet import Yesod.Core @@ -193,3 +195,50 @@ followRepo shrAuthor shrObject rpObject hide = do encodeRouteHome <- getEncodeRouteHome let uObject = encodeRouteHome $ RepoR shrObject rpObject follow shrAuthor uObject uObject hide + +offerTicket + :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent -> TextHtml -> TextPandocMarkdown -> ShrIdent -> PrjIdent -> m (Either Text (TextHtml, Audience URIMode, Offer URIMode)) +offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj = runExceptT $ do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + descHtml <- ExceptT . pure $ renderPandocMarkdown desc + summary <- + TextHtml . TL.toStrict . renderHtml <$> + withUrlRenderer + [hamlet| +
+
+ #{shr2text shrAuthor}
+ \ offered a ticket to project #
+
+ ./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
+ }
+ offer = Offer
+ { offerObject = ticket
+ , offerTarget = encodeRouteHome $ ProjectR shr prj
+ }
+ audience = Audience
+ { audienceTo = map encodeRouteHome $ recipsA ++ recipsC
+ , audienceBto = []
+ , audienceCc = []
+ , audienceBcc = []
+ , audienceGeneral = []
+ , audienceNonActors = map encodeRouteHome recipsC
+ }
+ return (summary, audience, offer)
diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs
index eaf7720..412e3ed 100644
--- a/src/Vervis/Handler/Client.hs
+++ b/src/Vervis/Handler/Client.hs
@@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- - Written in 2019 by fr33domlover
-
- #{shr2text shrAuthor}
- \ offered a ticket to project #
-
- ./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
- }
- 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."
- redirect $ TicketR shr prj num
-
getTicketTreeR :: ShrIdent -> PrjIdent -> Handler Html
getTicketTreeR shr prj = do
(summaries, deps) <- runDB $ do