diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index a758a25..ad6356a 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -146,7 +146,8 @@ handleActivity raw hActor iidActor rsidActor (Activity _id _luActor audience spe rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&. m E.^. MessageRoot `op` E.val did return (rm E.^. RemoteMessageId, m E.^. MessageId) - handleCreate iidActor hActor rsidActor raw audience (Note luNote _luAttrib muParent muContext mpublished content) = do + handleCreate iidActor hActor rsidActor raw audience (Note mluNote _luAttrib muParent muContext mpublished content) = do + luNote <- fromMaybeE mluNote "Got Create Note without note id" (shr, prj) <- do uRecip <- parseAudience audience parseProject uRecip diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index 9095aca..8bc85b8 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/src/Vervis/Handler/Discussion.hs @@ -141,7 +141,7 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do route2local <- getEncodeRouteLocal let lmhid = encodeHid $ fromSqlKey lmid return $ Doc host Note - { noteId = route2local $ MessageR shr lmhid + { noteId = Just $ route2local $ MessageR shr lmhid , noteAttrib = route2local $ SharerR shr , noteReplyTo = Just $ fromMaybe uContext muParent , noteContext = Just uContext diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 61dc205..772db50 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -85,6 +85,7 @@ import Database.Persist.Local import Network.FedURI import Web.ActivityPub import Yesod.Auth.Unverified +import Yesod.FedURI import Vervis.ActorKey import Vervis.Federation @@ -228,12 +229,6 @@ getPublishR = do getOutboxR :: Handler TypedContent getOutboxR = error "Not implemented yet" -route2uri' :: (Route App -> Text) -> Route App -> FedURI -route2uri' renderUrl r = - case parseFedURI $ renderUrl r of - Left e -> error e - Right u -> u - postOutboxR :: Handler Html postOutboxR = do ((result, widget), enctype) <- runFormPost activityForm @@ -247,9 +242,9 @@ postOutboxR = do sharer <- runDB $ get404 $ personIdent person return $ sharerIdent sharer renderUrl <- getUrlRender + route2uri <- getEncodeRouteFed now <- liftIO getCurrentTime - let route2uri = route2uri' renderUrl - (h, actor) = f2l $ route2uri $ SharerR shr + let (h, actor) = f2l $ route2uri $ SharerR shr actorID = renderUrl $ SharerR shr appendPath u t = u { luriPath = luriPath u <> t } activity = Activity @@ -264,7 +259,8 @@ postOutboxR = do } , activitySpecific = CreateActivity Create { createObject = Note - { noteId = appendPath actor "/fake-note" + { noteId = Just $ appendPath actor "/fake-note" + , noteAttrib = actor , noteReplyTo = mparent , noteContext = mcontext , notePublished = Just now @@ -328,7 +324,7 @@ getActorKey choose route = selectRep $ provideAP $ do actorKey <- liftIO . fmap (actorKeyPublicBin . choose) . readTVarIO =<< getsYesod appActorKeys - route2uri <- route2uri' <$> getUrlRender + route2uri <- getEncodeRouteFed let (host, id_) = f2l $ route2uri route return $ Doc host PublicKey { publicKeyId = id_ diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 35d3f01..a481e73 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -81,6 +81,7 @@ import Data.Semigroup (Endo, First (..)) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Time.Clock (UTCTime) +import Data.Traversable import Data.Vector (Vector) import Network.HTTP.Client hiding (Proxy, proxy) import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither) @@ -316,7 +317,7 @@ instance ActivityPub Actor where <> "publicKey" `pair` encodePublicKeySet host pkeys data Note = Note - { noteId :: LocalURI + { noteId :: Maybe LocalURI , noteAttrib :: LocalURI --, noteTo :: FedURI , noteReplyTo :: Maybe FedURI @@ -331,22 +332,31 @@ withHost h a = do then return v else fail "URI host mismatch" +withHostM h a = do + mp <- a + for mp $ \ (h', v) -> + if h == h' + then return v + else fail "URI host mismatch" + instance ActivityPub Note where jsonldContext _ = ContextAS2 parseObject o = do typ <- o .: "type" unless (typ == ("Note" :: Text)) $ fail "type isn't Note" + (h, attrib) <- f2l <$> o .: "attributedTo" (h, id_) <- f2l <$> o .: "id" fmap (h,) $ - Note id_ - <$> withHost h (f2l <$> o .: "attributedTo") + Note + <$> withHostM h (fmap f2l <$> o .:? "id") + <*> pure attrib <*> o .:? "inReplyTo" <*> o .:? "context" <*> o .:? "published" <*> o .: "content" - toSeries host (Note id_ attrib mreply mcontext mpublished content) + toSeries host (Note mid attrib mreply mcontext mpublished content) = "type" .= ("Note" :: Text) - <> "id" .= l2f host id_ + <> "id" .=? (l2f host <$> mid) <> "attributedTo" .= l2f host attrib <> "inReplyTo" .=? mreply <> "context" .=? mcontext