From 4f5c6532ee7b180a161a9f834ff4629cd994a027 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Fri, 19 Apr 2019 03:14:12 +0000 Subject: [PATCH] Switch postOutboxR to the new handler --- src/Vervis/Handler/Inbox.hs | 134 ++++++++++++++++++------------------ 1 file changed, 67 insertions(+), 67 deletions(-) diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 5403523..95436dc 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -43,6 +43,7 @@ import Data.Bifunctor (first, second) import Data.Foldable (for_) import Data.HashMap.Strict (HashMap) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe import Data.PEM (PEM (..)) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8) @@ -203,15 +204,32 @@ fedUriField = Field , fieldEnctype = UrlEncoded } -activityForm :: Form (FedURI, Maybe FedURI, Maybe FedURI, Text) -activityForm = renderDivs $ (,,,) - <$> areq fedUriField "To" (Just defto) - <*> aopt fedUriField "Replying on" (Just $ Just defctx) - <*> aopt fedUriField "Context" (Just $ Just defctx) - <*> areq textField "Message" (Just defmsg) +ticketField + :: (Route App -> LocalURI) -> Field Handler (Text, ShrIdent, PrjIdent, Int) +ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField where - defto = FedURI "forge.angeley.es" "/s/fr33/p/sandbox" "" - defctx = FedURI "forge.angeley.es" "/s/fr33/p/sandbox/t/1" "" + toTicket uTicket = runExceptT $ do + let (hTicket, luTicket) = f2l uTicket + route <- + case decodeRouteLocal luTicket of + Nothing -> throwE ("Not a valid route" :: Text) + Just r -> return r + case route of + TicketR shr prj num -> return (hTicket, shr, prj, num) + _ -> throwE "Not a ticket route" + fromTicket (h, shr, prj, num) = + l2f h $ encodeRouteLocal $ TicketR shr prj num + +activityForm :: Form ((Text, ShrIdent, PrjIdent, Int), Maybe FedURI, Text) +activityForm html = do + enc <- getEncodeRouteLocal + flip renderDivs html $ (,,) + <$> areq (ticketField enc) "Ticket" (Just deft) + <*> aopt fedUriField "Replying to" (Just $ Just defp) + <*> areq textField "Message" (Just defmsg) + where + deft = ("forge.angeley.es", text2shr "fr33", text2prj "sandbox", 1) + 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 @@ -245,69 +263,51 @@ getOutboxItemR :: ShrIdent -> KeyHashid OutboxItem -> Handler TypedContent getOutboxItemR = error "Not implemented yet" postOutboxR :: ShrIdent -> Handler Html -postOutboxR shr = do +postOutboxR shrAuthor = do federation <- getsYesod $ appFederation . appSettings unless federation badMethod ((result, widget), enctype) <- runFormPost activityForm - case result of - FormMissing -> setMessage "Field(s) missing" - FormFailure _l -> setMessage "Invalid input, see below" - FormSuccess (to, mparent, mcontext, msg) -> do - renderUrl <- getUrlRender - route2uri <- getEncodeRouteFed - now <- liftIO getCurrentTime - let (h, actor) = f2l $ route2uri $ SharerR shr - actorID = renderUrl $ SharerR shr - appendPath u t = u { luriPath = luriPath u <> t } - activity = Activity - { activityId = appendPath actor "/fake-activity" - , activityActor = actor - , activityAudience = deliverTo to - , activitySpecific = CreateActivity Create - { createObject = Note - { noteId = Just $ appendPath actor "/fake-note" - , noteAttrib = actor - , noteAudience = deliverTo to - , noteReplyTo = mparent - , noteContext = mcontext - , notePublished = Just now - , noteContent = msg - } - } - } - manager <- getsYesod appHttpManager - let (host, lto) = f2l to - minbox <- fetchInboxURI manager host lto - for_ minbox $ \ inbox -> do - (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys - let (keyID, akey) = - if new1 - then (renderUrl ActorKey1R, akey1) - else (renderUrl ActorKey2R, akey2) - sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b) - eres' <- httpPostAP manager (l2f host inbox) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID $ Doc h activity - case eres' of - Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e) - Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result." - defaultLayout $ activityWidget shr widget enctype - where - fetchInboxURI :: Manager -> Text -> LocalURI -> Handler (Maybe LocalURI) - fetchInboxURI manager h lto = do - iid <- runDB $ either entityKey id <$> insertBy' (Instance h) - result <- fetchRemoteActor iid h lto - case result of - Left err -> setErrorMsg $ displayException err - Right (Left err) -> setErrorMsg $ show err - Right (Right (Entity _ ra)) -> return $ Just $ remoteActorInbox ra - where - setErrorMsg err = do - setMessage $ toHtml $ T.concat - [ "Tried to fetch recipient actor <" - , renderFedURI $ l2f h lto - , "> and got an error: " - , T.pack err + elmid <- runExceptT $ do + ((hTicket, shrTicket, prj, num), muParent, msg) <- + case result of + FormMissing -> throwE "Field(s) missing" + FormFailure _l -> throwE "Invalid input, see below" + FormSuccess r -> return r + encodeRouteFed <- getEncodeRouteFed + encodeRouteLocal <- getEncodeRouteLocal + let encodeRecipRoute = l2f hTicket . encodeRouteLocal + uTicket = encodeRecipRoute $ TicketR shrTicket prj num + now <- liftIO getCurrentTime + let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor + recips = + [ ProjectR shrTicket prj + , TicketParticipantsR shrTicket prj num + , TicketTeamR shrTicket prj num ] - return Nothing + note = Note + { noteId = Nothing + , noteAttrib = luAuthor + , noteAudience = Audience + { audienceTo = map encodeRecipRoute recips + , audienceBto = [] + , audienceCc = [] + , audienceBcc = [] + , audienceGeneral = [] + } + , noteReplyTo = Just $ fromMaybe uTicket muParent + , noteContext = Just uTicket + , notePublished = Just now + , noteContent = msg + } + ExceptT $ handleOutboxNote 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 getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent getActorKey choose route = selectRep $ provideAP $ do