Switch postOutboxR to the new handler
This commit is contained in:
fr33domlover
parent
fc2ace3370
commit
4f5c6532ee
1 changed files with 67 additions and 67 deletions
|
|
@ -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)
|
||||
ticketField
|
||||
:: (Route App -> LocalURI) -> Field Handler (Text, ShrIdent, PrjIdent, Int)
|
||||
ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
|
||||
where
|
||||
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
|
||||
defto = FedURI "forge.angeley.es" "/s/fr33/p/sandbox" ""
|
||||
defctx = FedURI "forge.angeley.es" "/s/fr33/p/sandbox/t/1" ""
|
||||
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
|
||||
elmid <- runExceptT $ do
|
||||
((hTicket, shrTicket, prj, num), muParent, msg) <-
|
||||
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
|
||||
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 (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
|
||||
let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
|
||||
recips =
|
||||
[ ProjectR shrTicket prj
|
||||
, TicketParticipantsR shrTicket prj num
|
||||
, TicketTeamR shrTicket prj num
|
||||
]
|
||||
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
|
||||
}
|
||||
}
|
||||
}
|
||||
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
|
||||
]
|
||||
return Nothing
|
||||
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
|
||||
|
|
|
|||
Loading…
Reference in a new issue