mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 18:44:51 +09:00
Add a new-ticket form to /publish page, and handle in sharer outbox
This commit is contained in:
fr33domlover
parent
4be444f5ab
commit
0a4c2ad817
1 changed files with 132 additions and 26 deletions
|
|
@ -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|
|
||||
<p>
|
||||
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.
|
||||
<form method=POST action=@{SharerOutboxR shr} enctype=#{enctype}>
|
||||
^{widget}
|
||||
<h1>Publish a ticket comment
|
||||
<form method=POST action=@{SharerOutboxR shr} enctype=#{enctype1}>
|
||||
^{widget1}
|
||||
<input type=submit>
|
||||
|
||||
<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
|
||||
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|
|
||||
<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
|
||||
|
|
|
|||
Loading…
Reference in a new issue