Switch postOutboxR to the new handler
This commit is contained in:
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.Foldable (for_)
|
||||||
import Data.HashMap.Strict (HashMap)
|
import Data.HashMap.Strict (HashMap)
|
||||||
import Data.List.NonEmpty (NonEmpty (..))
|
import Data.List.NonEmpty (NonEmpty (..))
|
||||||
|
import Data.Maybe
|
||||||
import Data.PEM (PEM (..))
|
import Data.PEM (PEM (..))
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Data.Text.Encoding (encodeUtf8)
|
import Data.Text.Encoding (encodeUtf8)
|
||||||
|
@ -203,15 +204,32 @@ fedUriField = Field
|
||||||
, fieldEnctype = UrlEncoded
|
, fieldEnctype = UrlEncoded
|
||||||
}
|
}
|
||||||
|
|
||||||
activityForm :: Form (FedURI, Maybe FedURI, Maybe FedURI, Text)
|
ticketField
|
||||||
activityForm = renderDivs $ (,,,)
|
:: (Route App -> LocalURI) -> Field Handler (Text, ShrIdent, PrjIdent, Int)
|
||||||
<$> areq fedUriField "To" (Just defto)
|
ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
|
||||||
<*> aopt fedUriField "Replying on" (Just $ Just defctx)
|
where
|
||||||
<*> aopt fedUriField "Context" (Just $ Just defctx)
|
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)
|
<*> areq textField "Message" (Just defmsg)
|
||||||
where
|
where
|
||||||
defto = FedURI "forge.angeley.es" "/s/fr33/p/sandbox" ""
|
deft = ("forge.angeley.es", text2shr "fr33", text2prj "sandbox", 1)
|
||||||
defctx = FedURI "forge.angeley.es" "/s/fr33/p/sandbox/t/1" ""
|
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
|
activityWidget :: ShrIdent -> Widget -> Enctype -> Widget
|
||||||
|
@ -245,69 +263,51 @@ getOutboxItemR :: ShrIdent -> KeyHashid OutboxItem -> Handler TypedContent
|
||||||
getOutboxItemR = error "Not implemented yet"
|
getOutboxItemR = error "Not implemented yet"
|
||||||
|
|
||||||
postOutboxR :: ShrIdent -> Handler Html
|
postOutboxR :: ShrIdent -> Handler Html
|
||||||
postOutboxR shr = do
|
postOutboxR shrAuthor = do
|
||||||
federation <- getsYesod $ appFederation . appSettings
|
federation <- getsYesod $ appFederation . appSettings
|
||||||
unless federation badMethod
|
unless federation badMethod
|
||||||
((result, widget), enctype) <- runFormPost activityForm
|
((result, widget), enctype) <- runFormPost activityForm
|
||||||
|
elmid <- runExceptT $ do
|
||||||
|
((hTicket, shrTicket, prj, num), muParent, msg) <-
|
||||||
case result of
|
case result of
|
||||||
FormMissing -> setMessage "Field(s) missing"
|
FormMissing -> throwE "Field(s) missing"
|
||||||
FormFailure _l -> setMessage "Invalid input, see below"
|
FormFailure _l -> throwE "Invalid input, see below"
|
||||||
FormSuccess (to, mparent, mcontext, msg) -> do
|
FormSuccess r -> return r
|
||||||
renderUrl <- getUrlRender
|
encodeRouteFed <- getEncodeRouteFed
|
||||||
route2uri <- getEncodeRouteFed
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
let encodeRecipRoute = l2f hTicket . encodeRouteLocal
|
||||||
|
uTicket = encodeRecipRoute $ TicketR shrTicket prj num
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
let (h, actor) = f2l $ route2uri $ SharerR shr
|
let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
|
||||||
actorID = renderUrl $ SharerR shr
|
recips =
|
||||||
appendPath u t = u { luriPath = luriPath u <> t }
|
[ ProjectR shrTicket prj
|
||||||
activity = Activity
|
, TicketParticipantsR shrTicket prj num
|
||||||
{ activityId = appendPath actor "/fake-activity"
|
, TicketTeamR shrTicket prj num
|
||||||
, activityActor = actor
|
]
|
||||||
, activityAudience = deliverTo to
|
note = Note
|
||||||
, activitySpecific = CreateActivity Create
|
{ noteId = Nothing
|
||||||
{ createObject = Note
|
, noteAttrib = luAuthor
|
||||||
{ noteId = Just $ appendPath actor "/fake-note"
|
, noteAudience = Audience
|
||||||
, noteAttrib = actor
|
{ audienceTo = map encodeRecipRoute recips
|
||||||
, noteAudience = deliverTo to
|
, audienceBto = []
|
||||||
, noteReplyTo = mparent
|
, audienceCc = []
|
||||||
, noteContext = mcontext
|
, audienceBcc = []
|
||||||
|
, audienceGeneral = []
|
||||||
|
}
|
||||||
|
, noteReplyTo = Just $ fromMaybe uTicket muParent
|
||||||
|
, noteContext = Just uTicket
|
||||||
, notePublished = Just now
|
, notePublished = Just now
|
||||||
, noteContent = msg
|
, noteContent = msg
|
||||||
}
|
}
|
||||||
}
|
ExceptT $ handleOutboxNote hLocal note
|
||||||
}
|
case elmid of
|
||||||
manager <- getsYesod appHttpManager
|
Left err -> setMessage $ toHtml err
|
||||||
let (host, lto) = f2l to
|
Right lmid -> do
|
||||||
minbox <- fetchInboxURI manager host lto
|
lmkhid <- encodeKeyHashid lmid
|
||||||
for_ minbox $ \ inbox -> do
|
renderUrl <- getUrlRender
|
||||||
(akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys
|
let u = renderUrl $ MessageR shrAuthor lmkhid
|
||||||
let (keyID, akey) =
|
setMessage $ toHtml $ "Message created! ID: " <> u
|
||||||
if new1
|
defaultLayout $ activityWidget shrAuthor widget enctype
|
||||||
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
|
|
||||||
|
|
||||||
getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
|
getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
|
||||||
getActorKey choose route = selectRep $ provideAP $ do
|
getActorKey choose route = selectRep $ provideAP $ do
|
||||||
|
|
Loading…
Reference in a new issue