Add a new-ticket form to /publish page, and handle in sharer outbox

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)
+projectField
-activityForm html = do
+    :: (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
+openTicketForm
-activityWidget shr widget enctype =
+    :: 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|
-        <p>
+        <h1>Publish a ticket comment
-          This is a federation test page. Provide a recepient actor URI and
+        <form method=POST action=@{SharerOutboxR shr} enctype=#{enctype1}>
-          message text, and a Create activity creating a new Note will be sent
+          ^{widget1}
-          to the destination server.
+          <input type=submit>
-        <form method=POST action=@{SharerOutboxR shr} enctype=#{enctype}>
+
-          ^{widget}
+        <h1>Open a new ticket
+        <form method=POST action=@{SharerOutboxR shr} enctype=#{enctype2}>
+          ^{widget2}
           <input type=submit>
     |]
 
@@ -362,8 +401,11 @@ getUserShrIdent = do
 getPublishR :: Handler Html
 getPublishR = do
     shr <- getUserShrIdent
-    ((_result, widget), enctype) <- runFormPost activityForm
+    ((_result1, widget1), enctype1) <-
-    defaultLayout $ activityWidget shr widget enctype
+        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
+    ((result1, widget1), enctype1) <-
-        ((hTicket, shrTicket, prj, num), muParent, msg) <-
+        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
+    openTicket ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do
-        Left err -> setMessage $ toHtml err
+        encodeRouteLocal <- getEncodeRouteLocal
-        Right lmid -> do
+        encodeRouteFed <- getEncodeRouteFed
-            lmkhid <- encodeKeyHashid lmid
+        local <- hostIsLocal h
-            renderUrl <- getUrlRender
+        descHtml <- ExceptT . pure $ renderPandocMarkdown desc
-            let u = renderUrl $ MessageR shrAuthor lmkhid
+        summary <-
-            setMessage $ toHtml $ "Message created! ID: " <> u
+            TextHtml . TL.toStrict . renderHtml <$>
-    defaultLayout $ activityWidget shrAuthor widget enctype
+                withUrlRenderer
+                    [hamlet|
+                        <p>
+                          <a href=@{SharerR shrAuthor}>
+                            #{shr2text shrAuthor}
+                          \ offered a ticket to project #
+                          $if local
+                            <a href=@{ProjectR shr prj}>
+                              ./s/#{shr2text shr}/p/#{prj2text prj}
+                          $else
+                            <a href=#{renderFedURI $ encodeRouteFed h $ ProjectR shr prj}>
+                              #{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