Add a new-ticket form to /publish page, and handle in sharer outbox
This commit is contained in:
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 Crypto.PubKey.Ed25519 (publicKey, signature, verify)
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Aeson.Encode.Pretty
|
import Data.Aeson.Encode.Pretty
|
||||||
import Data.Bifunctor (first, second)
|
import Data.Bifunctor
|
||||||
|
import Data.Bitraversable
|
||||||
import Data.Foldable (for_)
|
import Data.Foldable (for_)
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import Data.List
|
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.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
|
||||||
import Network.HTTP.Types.Header (hDate, hHost)
|
import Network.HTTP.Types.Header (hDate, hHost)
|
||||||
import Network.HTTP.Types.Status
|
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 Text.Shakespeare.I18N (RenderMessage)
|
||||||
import UnliftIO.Exception (try)
|
import UnliftIO.Exception (try)
|
||||||
import Yesod.Auth (requireAuth)
|
import Yesod.Auth (requireAuth)
|
||||||
|
@ -110,12 +113,13 @@ import Data.Time.Clock.Local
|
||||||
import Database.Persist.Local
|
import Database.Persist.Local
|
||||||
import Yesod.Persist.Local
|
import Yesod.Persist.Local
|
||||||
|
|
||||||
|
import Vervis.ActivityPub
|
||||||
import Vervis.ActorKey
|
import Vervis.ActorKey
|
||||||
import Vervis.API
|
import Vervis.API
|
||||||
import Vervis.Federation
|
import Vervis.Federation
|
||||||
import Vervis.Federation.Auth
|
import Vervis.Federation.Auth
|
||||||
import Vervis.Foundation
|
import Vervis.Foundation
|
||||||
import Vervis.Model
|
import Vervis.Model hiding (Ticket)
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
import Vervis.Paginate
|
import Vervis.Paginate
|
||||||
import Vervis.RemoteActorStore
|
import Vervis.RemoteActorStore
|
||||||
|
@ -329,8 +333,24 @@ ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
|
||||||
fromTicket (h, shr, prj, num) =
|
fromTicket (h, shr, prj, num) =
|
||||||
l2f h $ encodeRouteLocal $ TicketR 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
|
enc <- getEncodeRouteLocal
|
||||||
flip renderDivs html $ (,,)
|
flip renderDivs html $ (,,)
|
||||||
<$> areq (ticketField enc) "Ticket" (Just deft)
|
<$> areq (ticketField enc) "Ticket" (Just deft)
|
||||||
|
@ -341,15 +361,34 @@ activityForm html = do
|
||||||
defp = FedURI "forge.angeley.es" "/s/fr33/m/2f1a7" ""
|
defp = FedURI "forge.angeley.es" "/s/fr33/m/2f1a7" ""
|
||||||
defmsg = "Hi! I'm testing federation. Can you see my message? :)"
|
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|
|
[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>
|
<input type=submit>
|
||||||
|]
|
|]
|
||||||
|
|
||||||
|
@ -362,8 +401,11 @@ getUserShrIdent = do
|
||||||
getPublishR :: Handler Html
|
getPublishR :: Handler Html
|
||||||
getPublishR = do
|
getPublishR = do
|
||||||
shr <- getUserShrIdent
|
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 :: Route App -> AppDB OutboxId -> Handler TypedContent
|
||||||
getOutbox here getObid = do
|
getOutbox here getObid = do
|
||||||
|
@ -456,13 +498,34 @@ postSharerOutboxR :: ShrIdent -> Handler Html
|
||||||
postSharerOutboxR shrAuthor = do
|
postSharerOutboxR shrAuthor = do
|
||||||
federation <- getsYesod $ appFederation . appSettings
|
federation <- getsYesod $ appFederation . appSettings
|
||||||
unless federation badMethod
|
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
|
case result of
|
||||||
FormMissing -> throwE "Field(s) missing"
|
FormMissing -> throwE "Field(s) missing"
|
||||||
FormFailure _l -> throwE "Invalid input, see below"
|
FormFailure _l -> throwE "Invalid input, see below"
|
||||||
FormSuccess r -> return r
|
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
|
encodeRouteFed <- getEncodeRouteHome
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
let msg' = T.filter (/= '\r') msg
|
let msg' = T.filter (/= '\r') msg
|
||||||
|
@ -494,14 +557,57 @@ postSharerOutboxR shrAuthor = do
|
||||||
, noteContent = contentHtml
|
, noteContent = contentHtml
|
||||||
}
|
}
|
||||||
ExceptT $ createNoteC hLocal note
|
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 :: ShrIdent -> PrjIdent -> Handler TypedContent
|
||||||
getProjectOutboxR shr prj = getOutbox here getObid
|
getProjectOutboxR shr prj = getOutbox here getObid
|
||||||
|
|
Loading…
Reference in a new issue