From 0a4c2ad817ccd53b0c095407f0d8a1ab0a3dc29e Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sun, 23 Jun 2019 12:39:44 +0000 Subject: [PATCH] Add a new-ticket form to /publish page, and handle in sharer outbox --- src/Vervis/Handler/Inbox.hs | 158 ++++++++++++++++++++++++++++++------ 1 file changed, 132 insertions(+), 26 deletions(-) diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 7493b8b..ffe5b88 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -45,7 +45,8 @@ import Crypto.Error (CryptoFailable (..)) import Crypto.PubKey.Ed25519 (publicKey, signature, verify) import Data.Aeson import Data.Aeson.Encode.Pretty -import Data.Bifunctor (first, second) +import Data.Bifunctor +import Data.Bitraversable import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.List @@ -64,7 +65,9 @@ import Network.HTTP.Client (Manager, HttpException, requestFromURI) import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader) import Network.HTTP.Types.Header (hDate, hHost) import Network.HTTP.Types.Status -import Text.Blaze.Html (Html) +import Text.Blaze.Html (Html, preEscapedToHtml) +import Text.Blaze.Html.Renderer.Text +import Text.HTML.SanitizeXSS import Text.Shakespeare.I18N (RenderMessage) import UnliftIO.Exception (try) import Yesod.Auth (requireAuth) @@ -110,12 +113,13 @@ import Data.Time.Clock.Local import Database.Persist.Local import Yesod.Persist.Local +import Vervis.ActivityPub import Vervis.ActorKey import Vervis.API import Vervis.Federation import Vervis.Federation.Auth import Vervis.Foundation -import Vervis.Model +import Vervis.Model hiding (Ticket) import Vervis.Model.Ident import Vervis.Paginate import Vervis.RemoteActorStore @@ -329,8 +333,24 @@ ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField fromTicket (h, shr, prj, num) = l2f h $ encodeRouteLocal $ TicketR shr prj num -activityForm :: Form ((Text, ShrIdent, PrjIdent, Int), Maybe FedURI, Text) -activityForm html = do +projectField + :: (Route App -> LocalURI) -> Field Handler (Text, ShrIdent, PrjIdent) +projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField + where + toProject u = runExceptT $ do + let (h, lu) = f2l u + route <- + case decodeRouteLocal lu of + Nothing -> throwE ("Not a valid route" :: Text) + Just r -> return r + case route of + ProjectR shr prj -> return (h, shr, prj) + _ -> throwE "Not a project route" + fromProject (h, shr, prj) = l2f h $ encodeRouteLocal $ ProjectR shr prj + +publishCommentForm + :: Form ((Text, ShrIdent, PrjIdent, Int), Maybe FedURI, Text) +publishCommentForm html = do enc <- getEncodeRouteLocal flip renderDivs html $ (,,) <$> areq (ticketField enc) "Ticket" (Just deft) @@ -341,15 +361,34 @@ activityForm html = do defp = FedURI "forge.angeley.es" "/s/fr33/m/2f1a7" "" defmsg = "Hi! I'm testing federation. Can you see my message? :)" -activityWidget :: ShrIdent -> Widget -> Enctype -> Widget -activityWidget shr widget enctype = +openTicketForm + :: Form ((Text, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown) +openTicketForm html = do + enc <- getEncodeRouteLocal + flip renderDivs html $ (,,) + <$> areq (projectField enc) "Project" (Just defj) + <*> ( TextHtml . sanitizeBalance <$> + areq textField "Title" (Just deft) + ) + <*> ( TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$> + areq textareaField "Description" (Just defd) + ) + where + defj = ("forge.angeley.es", text2shr "fr33", text2prj "sandbox") + deft = "Time slows down when tasting coconut ice-cream" + defd = "Is that slow-motion effect intentional? :)" + +activityWidget :: ShrIdent -> Widget -> Enctype -> Widget -> Enctype -> Widget +activityWidget shr widget1 enctype1 widget2 enctype2 = [whamlet| -

- This is a federation test page. Provide a recepient actor URI and - message text, and a Create activity creating a new Note will be sent - to the destination server. -

- ^{widget} +

Publish a ticket comment + + ^{widget1} + + +

Open a new ticket + + ^{widget2} |] @@ -362,8 +401,11 @@ getUserShrIdent = do getPublishR :: Handler Html getPublishR = do shr <- getUserShrIdent - ((_result, widget), enctype) <- runFormPost activityForm - defaultLayout $ activityWidget shr widget enctype + ((_result1, widget1), enctype1) <- + runFormPost $ identifyForm "f1" publishCommentForm + ((_result2, widget2), enctype2) <- + runFormPost $ identifyForm "f2" openTicketForm + defaultLayout $ activityWidget shr widget1 enctype1 widget2 enctype2 getOutbox :: Route App -> AppDB OutboxId -> Handler TypedContent getOutbox here getObid = do @@ -456,13 +498,34 @@ postSharerOutboxR :: ShrIdent -> Handler Html postSharerOutboxR shrAuthor = do federation <- getsYesod $ appFederation . appSettings unless federation badMethod - ((result, widget), enctype) <- runFormPost activityForm - elmid <- runExceptT $ do - ((hTicket, shrTicket, prj, num), muParent, msg) <- + + ((result1, widget1), enctype1) <- + runFormPost $ identifyForm "f1" publishCommentForm + ((result2, widget2), enctype2) <- + runFormPost $ identifyForm "f2" openTicketForm + let result = Left <$> result1 <|> Right <$> result2 + + eid <- runExceptT $ do + input <- case result of FormMissing -> throwE "Field(s) missing" FormFailure _l -> throwE "Invalid input, see below" FormSuccess r -> return r + bitraverse publishComment openTicket input + case eid of + Left err -> setMessage $ toHtml err + Right id_ -> + case id_ of + Left lmid -> do + lmkhid <- encodeKeyHashid lmid + renderUrl <- getUrlRender + let u = renderUrl $ MessageR shrAuthor lmkhid + setMessage $ toHtml $ "Message created! ID: " <> u + Right _obiid -> + setMessage "Ticket offer published!" + defaultLayout $ activityWidget shrAuthor widget1 enctype1 widget2 enctype2 + where + publishComment ((hTicket, shrTicket, prj, num), muParent, msg) = do encodeRouteFed <- getEncodeRouteHome encodeRouteLocal <- getEncodeRouteLocal let msg' = T.filter (/= '\r') msg @@ -494,14 +557,57 @@ postSharerOutboxR shrAuthor = do , noteContent = contentHtml } ExceptT $ createNoteC hLocal note - case elmid of - Left err -> setMessage $ toHtml err - Right lmid -> do - lmkhid <- encodeKeyHashid lmid - renderUrl <- getUrlRender - let u = renderUrl $ MessageR shrAuthor lmkhid - setMessage $ toHtml $ "Message created! ID: " <> u - defaultLayout $ activityWidget shrAuthor widget enctype + openTicket ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteFed <- getEncodeRouteFed + local <- hostIsLocal h + descHtml <- ExceptT . pure $ renderPandocMarkdown desc + summary <- + TextHtml . TL.toStrict . renderHtml <$> + withUrlRenderer + [hamlet| +

+ + #{shr2text shrAuthor} + \ offered a ticket to project # + $if local + + ./s/#{shr2text shr}/p/#{prj2text prj} + $else + + #{h}/s/#{shr2text shr}/p/#{prj2text prj} + : #{preEscapedToHtml title}. + |] + let recipsA = [ProjectR shr prj] + recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj] + ticket = Ticket + { ticketLocal = Nothing + , ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor + , ticketPublished = Nothing + , ticketUpdated = Nothing + , ticketName = Nothing + , ticketSummary = TextHtml title + , ticketContent = TextHtml descHtml + , ticketSource = TextPandocMarkdown desc + , ticketAssignedTo = Nothing + , ticketIsResolved = False + , ticketDependsOn = [] + , ticketDependedBy = [] + } + offer = Offer + { offerObject = ticket + , offerTarget = encodeRouteFed h $ ProjectR shr prj + } + audience = Audience + { audienceTo = + map (encodeRouteFed h) $ recipsA ++ recipsC + , audienceBto = [] + , audienceCc = [] + , audienceBcc = [] + , audienceGeneral = [] + , audienceNonActors = map (encodeRouteFed h) recipsC + } + ExceptT $ offerTicketC shrAuthor summary audience offer getProjectOutboxR :: ShrIdent -> PrjIdent -> Handler TypedContent getProjectOutboxR shr prj = getOutbox here getObid