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 . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -22,6 +22,7 @@ module Vervis.Handler.Client , postRepoFollowR , getNotificationsR , postNotificationsR + , postTicketsR ) where @@ -68,6 +69,7 @@ import Vervis.ActivityPub import Vervis.API import Vervis.Client import Vervis.FedURI +import Vervis.Form.Ticket import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident @@ -526,3 +528,65 @@ postNotificationsR shr = do case requireEither mx my of Left b -> liftIO $ throwIO $ userError $ if b then t else f Right exy -> return exy + +postTicketsR :: ShrIdent -> PrjIdent -> Handler Html +postTicketsR shr prj = do + wid <- runDB $ do + sid <- getKeyBy404 $ UniqueSharer shr + j <- getValBy404 $ UniqueProject prj sid + return $ projectWorkflow j + ((result, widget), enctype) <- runFormPost $ newTicketForm wid + + shrAuthor <- do + Entity _ p <- requireVerifiedAuth + runDB $ sharerIdent <$> getJust (personIdent p) + + enum <- runExceptT $ do + NewTicket title desc tparams eparams <- + 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) $ + 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 + -} + (summary, audience, offer) <- + ExceptT $ offerTicket shrAuthor (TextHtml title) (TextPandocMarkdown desc) shr prj + 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 + eobiidFollow <- runExceptT $ do + (summary, audience, follow) <- followTicket shrAuthor shr prj num 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 diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index f2cffb7..7bc4364 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -15,7 +15,6 @@ module Vervis.Handler.Ticket ( getTicketsR - , postTicketsR , getTicketTreeR , getTicketNewR , getTicketR @@ -144,100 +143,6 @@ getTicketsR shr prj = do jid defaultLayout $(widgetFile "ticket/list") -postTicketsR :: ShrIdent -> PrjIdent -> Handler Html -postTicketsR shr prj = do - wid <- runDB $ do - sid <- getKeyBy404 $ UniqueSharer shr - j <- getValBy404 $ UniqueProject prj sid - return $ projectWorkflow j - ((result, widget), enctype) <- runFormPost $ newTicketForm wid - enum <- runExceptT $ do - NewTicket title desc tparams eparams <- - 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) $ - 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 - -} - 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| -

- - #{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