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. -