diff --git a/config/models b/config/models index 1576630..3b253c4 100644 --- a/config/models +++ b/config/models @@ -43,6 +43,11 @@ Person UniquePersonLogin login UniquePersonEmail email +OutboxItem + person PersonId + activity PersistActivity + published UTCTime + VerifKey ident LocalURI instance InstanceId @@ -225,10 +230,11 @@ TicketClaimRequest Discussion RemoteDiscussion - sharer RemoteSharerId - instance InstanceId - ident LocalURI - discuss DiscussionId + actor RemoteSharerId Maybe + instance InstanceId + ident LocalURI + discuss DiscussionId + unlinkedActor FedURI Maybe UniqueRemoteDiscussionIdent instance ident UniqueRemoteDiscussion discuss @@ -240,8 +246,9 @@ Message root DiscussionId LocalMessage - author PersonId - rest MessageId + author PersonId + rest MessageId + unlinkedParent FedURI Maybe UniqueLocalMessage rest diff --git a/config/routes b/config/routes index 34b8450..9e3bfd9 100644 --- a/config/routes +++ b/config/routes @@ -26,7 +26,6 @@ /publish PublishR GET /inbox InboxR GET POST -/outbox OutboxR GET POST /akey1 ActorKey1R GET /akey2 ActorKey2R GET @@ -51,6 +50,8 @@ /s SharersR GET /s/#ShrIdent SharerR GET +/s/#ShrIdent/outbox OutboxR GET POST +/s/#ShrIdent/outbox/#Text OutboxItemR GET /p PeopleR GET diff --git a/migrations/2019_03_19.model b/migrations/2019_03_19.model index 7f52356..7eef8a3 100644 --- a/migrations/2019_03_19.model +++ b/migrations/2019_03_19.model @@ -1,19 +1,26 @@ RemoteRawObject - content PersistJSONObject + content PersistJSONValue received UTCTime +OutboxItem + person PersonId + activity PersistJSONValue + published UTCTime + RemoteDiscussion - sharer RemoteSharerId - instance InstanceId - ident Text - discuss DiscussionId + actor RemoteSharerId Maybe + instance InstanceId + ident Text + discuss DiscussionId + unlinkedActor Text Maybe UniqueRemoteDiscussionIdent instance ident UniqueRemoteDiscussion discuss LocalMessage - author PersonId - rest MessageId + author PersonId + rest MessageId + unlinkedParent Text Maybe UniqueLocalMessage rest diff --git a/src/Data/Either/Local.hs b/src/Data/Either/Local.hs index 202a80c..19dbf51 100644 --- a/src/Data/Either/Local.hs +++ b/src/Data/Either/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016 by fr33domlover . + - Written in 2016, 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -16,6 +16,7 @@ module Data.Either.Local ( maybeRight , maybeLeft + , requireEither ) where @@ -28,3 +29,9 @@ maybeRight (Right b) = Just b maybeLeft :: Either a b -> Maybe a maybeLeft (Left a) = Just a maybeLeft (Right _) = Nothing + +requireEither :: Maybe a -> Maybe b -> Either Bool (Either a b) +requireEither Nothing Nothing = Left False +requireEither (Just _) (Just _) = Left True +requireEither (Just x) Nothing = Right $ Left x +requireEither Nothing (Just y) = Right $ Right y diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 3734227..62dcafd 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -15,40 +15,143 @@ module Vervis.Federation ( handleInboxActivity + , handleOutboxNote ) where import Prelude +import Control.Concurrent.STM.TVar +import Control.Exception hiding (Handler) import Control.Monad import Control.Monad.Logger.CallStack import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Data.Aeson (Object) import Data.Foldable +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Maybe import Data.Text (Text) import Data.Text.Encoding import Data.Time.Clock +import Data.Traversable import Database.Persist import Database.Persist.Sql +import Network.HTTP.Types.Header import Network.HTTP.Types.URI -import Yesod.Core hiding (logWarn) +import Yesod.Core hiding (logError, logWarn, logInfo) import Yesod.Persist.Core import qualified Data.Text as T import qualified Data.Vector as V import qualified Database.Esqueleto as E +import Network.HTTP.Signature + import Database.Persist.JSON import Network.FedURI import Web.ActivityPub +import Yesod.Auth.Unverified +import Yesod.FedURI +import Data.Either.Local import Database.Persist.Local +import Vervis.ActorKey import Vervis.Foundation import Vervis.Model +import Vervis.Model.Ident +import Vervis.RemoteActorStore import Vervis.Settings +hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool +hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings + +verifyHostLocal + :: (MonadHandler m, HandlerSite m ~ App) + => Text -> Text -> ExceptT Text m () +verifyHostLocal h t = do + local <- hostIsLocal h + unless local $ throwE t + +parseAudience :: Monad m => Audience -> Text -> ExceptT Text m FedURI +parseAudience (Audience to bto cc bcc aud) t = + case toSingleton to of + Just fu + | V.null bto && V.null cc && V.null bcc && V.null aud -> + return fu + _ -> throwE t + where + toSingleton v = + case V.toList v of + [x] -> Just x + _ -> Nothing + +fromMaybeE :: Monad m => Maybe a -> Text -> ExceptT Text m a +fromMaybeE Nothing t = throwE t +fromMaybeE (Just x) _ = return x + +requireEitherM + :: MonadIO m => Maybe a -> Maybe b -> String -> String -> m (Either a b) +requireEitherM mx my f t = + case requireEither mx my of + Left b -> liftIO $ throwIO $ userError $ if b then t else f + Right exy -> return exy + +prependError :: Monad m => Text -> ExceptT Text m a -> ExceptT Text m a +prependError t a = do + r <- lift $ runExceptT a + case r of + Left e -> throwE $ t <> ": " <> e + Right x -> return x + +parseProject :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent) +parseProject luRecip = do + route <- case decodeRouteLocal luRecip of + Nothing -> throwE "Got Create Note with recipient that isn't a valid route" + Just r -> return r + case route of + ProjectR shr prj -> return (shr, prj) + _ -> throwE "Got Create Note with non-project recipient" + +parseTicket :: Monad m => (ShrIdent, PrjIdent) -> LocalURI -> ExceptT Text m Int +parseTicket project luContext = do + route <- case decodeRouteLocal luContext of + Nothing -> throwE "Local context isn't a valid route" + Just r -> return r + case route of + TicketR shr prj num -> + if (shr, prj) == project + then return num + else throwE "Local context ticket doesn't belong to the recipient project" + _ -> throwE "Local context isn't a ticket route" + +parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId) +parseComment luParent = do + route <- case decodeRouteLocal luParent of + Nothing -> throwE "Not a local route" + Just r -> return r + case route of + MessageR shr hid -> do + decodeHid <- getsYesod appHashidDecode + case toSqlKey <$> decodeHid hid of + Nothing -> throwE "Non-existent local message hashid" + Just k -> return (shr, k) + _ -> throwE "Not a local message route" + +getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId +getLocalParentMessageId did shr lmid = do + mlm <- lift $ get lmid + lm <- fromMaybeE mlm "Local parent: no such lmid" + p <- lift $ getJust $ localMessageAuthor lm + s <- lift $ getJust $ personIdent p + unless (shr == sharerIdent s) $ throwE "Local parent: No such message, lmid mismatches sharer" + let mid = localMessageRest lm + m <- lift $ getJust mid + unless (messageRoot m == did) $ + throwE "Local parent belongs to a different discussion" + return mid + -- | Handle an activity that came to our inbox. Return a description of what we -- did, and whether we stored the activity or not (so that we can decide -- whether to log it for debugging). @@ -57,10 +160,10 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc case specific of CreateActivity (Create note) -> do result <- runExceptT $ handleCreate iidActor hActor rsidActor raw audience note - return $ - case result of - Left e -> (e, False) - Right (uNew, luTicket) -> + case result of + Left e -> logWarn e >> return ("Create Note: " <> e, False) + Right (uNew, luTicket) -> + return ( T.concat [ "Inserted remote comment <" , renderFedURI uNew @@ -72,73 +175,20 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc ) _ -> return ("Unsupported activity type", False) where - toSingleton v = - case V.toList v of - [x] -> Just x - _ -> Nothing - --result t = logWarn t >> return (t, False) - done t = logWarn t >> throwE t - fromMaybeE Nothing t = done t - fromMaybeE (Just x) _ = return x - --hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool - hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings verifyLocal fu t = do let (h, lu) = f2l fu local <- hostIsLocal h if local then return lu - else done t - parseAudience (Audience to bto cc bcc aud) = - case toSingleton to of - Just fu - | V.null bto && V.null cc && V.null bcc && V.null aud -> - return fu - _ -> done "Got a Create Note with a not-just-single-to audience" - local2route = parseRoute . (,[]) . decodePathSegments . encodeUtf8 . luriPath <=< noFrag - where - noFrag lu = - if T.null $ luriFragment lu - then Just lu - else Nothing - parseProject uRecip = do - let (hRecip, luRecip) = f2l uRecip - local <- hostIsLocal hRecip - unless local $ done "Got Create Note with non-local recipient" - route <- case local2route luRecip of - Nothing -> done "Got Create Note with recipient that isn't a valid route" - Just r -> return r - case route of - ProjectR shr prj -> return (shr, prj) - _ -> done "Got Create Note with non-project recipient" - parseTicket project luContext = do - route <- case local2route luContext of - Nothing -> done "Got Create Note with context that isn't a valid route" - Just r -> return r - case route of - TicketR shr prj num -> - if (shr, prj) == project - then return num - else done "Got Create Note under ticket that doesn't belong to the recipient project" - _ -> done "Got Create Note with non-ticket context" - parseParent luContext ticket uParent = do + else throwE t + parseParent :: LocalURI -> FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))) + parseParent luContext uParent = do let (hParent, luParent) = f2l uParent local <- hostIsLocal hParent if local then if luParent == luContext then return Nothing - else do - route <- case local2route luParent of - Nothing -> done "Got Create Note with local non-route parent" - Just r -> return r - case route of - TicketMessageR shr prj num hid -> do - unless (ticket == (shr, prj, num)) $ - done "Got Create Note with local parent not under the same ticket as the context" - decodeHid <- getsYesod appHashidDecode - case toSqlKey <$> decodeHid hid of - Nothing -> done "Got Create Note non-existent ticket message parent hashid" - Just k -> return $ Just $ Left k - _ -> done "Got Create Note with local non-ticket-message parent" + else prependError "Local parent" $ Just . Left <$> parseComment luParent else return $ Just $ Right (hParent, luParent) selectOrphans uNote did op = E.select $ E.from $ \ (rm `E.InnerJoin` m) -> do @@ -150,20 +200,21 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc handleCreate iidActor hActor rsidActor raw audience (Note mluNote _luAttrib _aud muParent muContext mpublished content) = do luNote <- fromMaybeE mluNote "Got Create Note without note id" (shr, prj) <- do - uRecip <- parseAudience audience - parseProject uRecip + (hRecip, luRecip) <- f2l <$> parseAudience audience "Got a Create Note with a not-just-single-to audience" + verifyHostLocal hRecip "Non-local recipient" + parseProject luRecip luContext <- do uContext <- fromMaybeE muContext "Got a Create Note without context" verifyLocal uContext "Got a Create Note with non-local context" num <- parseTicket (shr, prj) luContext mparent <- do uParent <- fromMaybeE muParent "Got a Create Note without inReplyTo" - parseParent luContext (shr, prj, num) uParent + parseParent luContext uParent published <- fromMaybeE mpublished "Got Create Note without 'published' field" ExceptT $ runDB $ runExceptT $ do mrmid <- lift $ getKeyBy $ UniqueRemoteMessageIdent iidActor luNote for_ mrmid $ \ rmid -> - done $ + throwE $ "Got a Create Note with a note ID we already have, \ \RemoteMessageId " <> T.pack (show rmid) mdid <- lift $ runMaybeT $ do @@ -172,33 +223,23 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc t <- MaybeT $ getValBy $ UniqueTicket jid num return $ ticketDiscuss t did <- fromMaybeE mdid "Got Create Note on non-existent ticket" - meparent <- - case mparent of - Nothing -> return Nothing - Just parent -> - case parent of - Left lmid -> do - mlm <- lift $ get lmid - lm <- fromMaybeE mlm "Got Create Note replying to non-existent local message, no such lmid" - let mid = localMessageRest lm + meparent <- for mparent $ \ parent -> + case parent of + Left (shrParent, lmid) -> Left <$> getLocalParentMessageId did shrParent lmid + Right (hParent, luParent) -> do + mrm <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hParent + MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent + case mrm of + Nothing -> do + logWarn "Got Create Note replying to a remote message we don't have" + return $ Right $ l2f hParent luParent + Just rm -> do + let mid = remoteMessageRest rm m <- lift $ getJust mid unless (messageRoot m == did) $ - done "Got Create Note replying to non-existent local message, lmid not under the context ticket" - return $ Just $ Left mid - Right (hParent, luParent) -> do - mrm <- lift $ runMaybeT $ do - iid <- MaybeT $ getKeyBy $ UniqueInstance hParent - MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent - case mrm of - Nothing -> do - logWarn "Got Create Note replying to a remote message we don't have" - return $ Just $ Right $ l2f hParent luParent - Just rm -> do - let mid = remoteMessageRest rm - m <- lift $ getJust mid - unless (messageRoot m == did) $ - done "Got Create Note replying to remote message which belongs to a different discussion" - return $ Just $ Left mid + throwE "Got Create Note replying to remote message which belongs to a different discussion" + return $ Left mid now <- liftIO getCurrentTime rroid <- lift $ insert $ RemoteRawObject (PersistJSON raw) now mid <- lift $ insert Message @@ -247,3 +288,323 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc , " because they have different DiscussionId!" ] return (uNote, luContext) + +-- | Handle a Note submitted by a local user to their outbox. It can be either +-- a comment on a local ticket, or a comment on some remote context. Return an +-- error message if the Note is rejected, otherwise the new 'LocalMessageId'. +handleOutboxNote :: Text -> Note -> Handler (Either Text LocalMessageId) +handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished content) = runExceptT $ do + verifyHostLocal host "Attributed to non-local actor" + verifyNothing mluNote "Note specifies an id" + verifyNothing mpublished "Note specifies published" + uContext <- fromMaybeE muContext "Note without context" + uRecip <- parseAudience aud "Note has not-just-single-to audience" + recipContextParent <- parseRecipContextParent uRecip uContext muParent + (lmid, mdeliver) <- ExceptT $ runDB $ runExceptT $ do + (pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor" + case recipContextParent of + (mparent, Left (shr, prj, num)) -> do + mdid <- lift $ runMaybeT $ do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + jid <- MaybeT $ getKeyBy $ UniqueProject prj sid + t <- MaybeT $ getValBy $ UniqueTicket jid num + return $ ticketDiscuss t + did <- fromMaybeE mdid "Context: No such local ticket" + mmidParent <- for mparent $ \ parent -> + case parent of + Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent + Right (hParent, luParent) -> do + mrm <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hParent + MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent + rm <- fromMaybeE mrm "Remote parent unknown locally" + let mid = remoteMessageRest rm + m <- lift $ getJust mid + unless (messageRoot m == did) $ + throwE "Remote parent belongs to a different discussion" + return mid + let meparent = Left <$> mmidParent + (lmid, _doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content + return (lmid, Nothing) + (mparent, Right (hRecip, luRecip, luContext)) -> do + (did, rdid, rdnew, mluInbox) <- do + miid <- lift $ getKeyBy $ UniqueInstance hRecip + erd <- + case miid of + Just iid -> findExistingRemoteDiscussion iid hRecip luRecip luContext + Nothing -> return Nothing + case erd of + Just (d, rd, minb) -> return (d, rd, False, minb) + Nothing -> ExceptT $ withHostLock hRecip $ runExceptT $ storeRemoteDiscussion miid hRecip luRecip luContext + meparent <- for mparent $ \ parent -> + case parent of + Left (shrParent, lmidParent) -> do + when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new" + Left <$> getLocalParentMessageId did shrParent lmidParent + Right (hParent, luParent) -> do + mrm <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hParent + MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent + case mrm of + Nothing -> return $ Right $ l2f hParent luParent + Just rm -> Left <$> do + let mid = remoteMessageRest rm + m <- lift $ getJust mid + unless (messageRoot m == did) $ + throwE "Remote parent belongs to a different discussion" + return mid + (lmid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content + return (lmid, Just (doc, hRecip, maybe (Right (luRecip, rdid)) Left mluInbox)) + let handleDeliverError e = logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e) + lift $ for_ mdeliver $ \ (doc, hRecip, einb) -> forkHandler handleDeliverError $ do + uInbox <- + case einb of + Left luInbox -> return $ l2f hRecip luInbox + Right (luRecip, rdid) -> do + mluInbox <- runDB $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip + rs <- MaybeT $ getValBy $ UniqueRemoteSharer iid luRecip + return $ remoteSharerInbox rs + case mluInbox of + Just luInbox -> return $ l2f hRecip luInbox + Nothing -> do + manager <- getsYesod appHttpManager + eactor <- fetchAPID manager actorId hRecip luRecip + case eactor of + Left s -> fail $ "Fetched recipient actor: " ++ s + Right actor -> withHostLock hRecip $ runDB $ do + iid <- either entityKey id <$> insertBy (Instance hRecip) + let luInbox = actorInbox actor + rsid <- either entityKey id <$> insertBy (RemoteSharer luRecip iid luInbox) + update rdid [RemoteDiscussionActor =. Just rsid, RemoteDiscussionUnlinkedActor =. Nothing] + return $ l2f hRecip luInbox + -- TODO based on the httpPostAP usage in postOutboxR + manager <- getsYesod appHttpManager + (akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys + renderUrl <- getUrlRender + let (keyID, akey) = + if new1 + then (renderUrl ActorKey1R, akey1) + else (renderUrl ActorKey2R, akey2) + sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b) + actorID = renderFedURI $ l2f host luAttrib + eres <- httpPostAP manager uInbox (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID doc + case eres of + Left e -> logError $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e) + Right _ -> logInfo $ T.concat + [ "Successful delivery of <" + , renderFedURI $ l2f (docHost doc) (activityId $ docValue doc) + , " to <" + , renderFedURI uRecip + , ">" + ] + return lmid + where + verifyNothing :: Monad m => Maybe a -> Text -> ExceptT Text m () + verifyNothing Nothing _ = return () + verifyNothing (Just _) t = throwE t + + verifySameHost + :: Monad m => Text -> FedURI -> Text -> ExceptT Text m LocalURI + verifySameHost h fu t = do + let (h', lu) = f2l fu + if h == h' + then return lu + else throwE t + + parseRecipContextParent + :: FedURI + -> FedURI + -> Maybe FedURI + -> ExceptT + Text + Handler + ( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)) + , Either + (ShrIdent, PrjIdent, Int) + (Text, LocalURI, LocalURI) + ) + parseRecipContextParent uRecip uContext muParent = do + let r@(hRecip, luRecip) = f2l uRecip + luContext <- verifySameHost hRecip uContext "Recipient and context on different hosts" + meparent <- + case muParent of + Nothing -> return Nothing + Just uParent -> + if uParent == uContext + then return Nothing + else Just <$> do + let (hParent, luParent) = f2l uParent + parentLocal <- hostIsLocal hParent + if parentLocal + then Left <$> parseComment luParent + else return $ Right (hParent, luParent) + local <- hostIsLocal hRecip + if local + then do + (shr, prj) <- parseProject luRecip + num <- parseTicket (shr, prj) luContext + return (meparent, Left (shr, prj, num)) + else do + when (luRecip == luContext) $ + throwE "Identical recipient and context" + {- + mrs <- lift $ runDB $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip + MaybeT $ getBy $ UniqueRemoteSharer iid luRecip + erecip <- + case mrs of + Just ers -> return $ Left ers + Nothing -> do + manager <- getsYesod appHttpManager + eactor <- fetchAPID manager actorId hRecip luRecip + case eactor of + Left s -> throwE $ "Fetched recipient actor: " <> T.pack s + Right actor -> return $ Right actor + -} + return (meparent, Right (hRecip, luRecip, luContext)) + + verifyIsLoggedInUser + :: LocalURI -> Text -> ExceptT Text AppDB (PersonId, ShrIdent) + verifyIsLoggedInUser lu t = do + Entity pid p <- requireVerifiedAuth + s <- lift $ getJust $ personIdent p + route2local <- getEncodeRouteLocal + let shr = sharerIdent s + if route2local (SharerR shr) == lu + then return (pid, shr) + else throwE t + + findExistingRemoteDiscussion + :: InstanceId + -> Text + -> LocalURI + -> LocalURI + -> ExceptT Text AppDB + (Maybe (DiscussionId, RemoteDiscussionId, Maybe LocalURI)) + findExistingRemoteDiscussion iid hRecip luRecip luContext = do + merd <- lift $ getBy $ UniqueRemoteDiscussionIdent iid luContext + for merd $ \ (Entity rdid rd) -> do + eactor <- + requireEitherM + (remoteDiscussionActor rd) + (remoteDiscussionUnlinkedActor rd) + "RemoteDiscussion actor and unlinkedActor both unset" + "RemoteDiscussion actor and unlinkedActor both set" + minb <- case eactor of + Left rsid -> do + rs <- lift $ getJust rsid + unless (remoteSharerInstance rs == iid && remoteSharerIdent rs == luRecip) $ + throwE "Known remote context, but its actor doesn't match the new Note's recipient" + return $ Just $ remoteSharerInbox rs + Right uActor -> do + unless (uActor == l2f hRecip luRecip) $ + throwE "Known remote context, but its unlinked actor doesn't match the new Note's recipient" + return Nothing + return (remoteDiscussionDiscuss rd, rdid, minb) + + insertRemoteDiscussion + :: InstanceId + -> Bool + -> Text + -> LocalURI + -> LocalURI + -> AppDB (DiscussionId, RemoteDiscussionId, Maybe LocalURI) + insertRemoteDiscussion iid inew hRecip luRecip luContext = do + mrs <- + if inew + then return Nothing + else getBy $ UniqueRemoteSharer iid luRecip + did <- insert Discussion + rdid <- insert RemoteDiscussion + { remoteDiscussionActor = entityKey <$> mrs + , remoteDiscussionInstance = iid + , remoteDiscussionIdent = luContext + , remoteDiscussionDiscuss = did + , remoteDiscussionUnlinkedActor = + case mrs of + Nothing -> Just $ l2f hRecip luRecip + Just _ -> Nothing + } + return (did, rdid, remoteSharerInbox . entityVal <$> mrs) + + storeRemoteDiscussion + :: Maybe InstanceId + -> Text + -> LocalURI + -> LocalURI + -> ExceptT Text AppDB + (DiscussionId, RemoteDiscussionId, Bool, Maybe LocalURI) + storeRemoteDiscussion miid hRecip luRecip luContext = do + (iid, inew) <- + case miid of + Just i -> return (i, False) + Nothing -> lift $ idAndNew <$> insertBy (Instance hRecip) + if inew + then do + (did, rdid, minb) <- lift $ insertRemoteDiscussion iid True hRecip luRecip luContext + return (did, rdid, True, minb) + else do + erd <- findExistingRemoteDiscussion iid hRecip luRecip luContext + case erd of + Just (did, rdid, minb) -> return (did, rdid, False, minb) + Nothing -> do + (did, rdid, minb) <- lift $ insertRemoteDiscussion iid False hRecip luRecip luContext + return (did, rdid, True, minb) + + insertMessage + :: LocalURI + -> ShrIdent + -> PersonId + -> FedURI + -> DiscussionId + -> Maybe FedURI + -> Maybe (Either MessageId FedURI) + -> Text + -> AppDB (LocalMessageId, Doc Activity) + insertMessage luAttrib shrUser pid uContext did muParent meparent content = do + now <- liftIO getCurrentTime + mid <- insert Message + { messageCreated = now + , messageContent = content + , messageParent = + case meparent of + Just (Left midParent) -> Just midParent + _ -> Nothing + , messageRoot = did + } + lmid <- insert LocalMessage + { localMessageAuthor = pid + , localMessageRest = mid + , localMessageUnlinkedParent = + case meparent of + Just (Right uParent) -> Just uParent + _ -> Nothing + } + route2local <- getEncodeRouteLocal + encodeHid <- getsYesod appHashidEncode + let activity luAct = Doc host Activity + { activityId = luAct + , activityActor = luAttrib + , activityAudience = aud + , activitySpecific = CreateActivity Create + { createObject = Note + { noteId = Just $ route2local $ MessageR shrUser $ encodeHid $ fromSqlKey lmid + , noteAttrib = luAttrib + , noteAudience = aud + , noteReplyTo = Just $ fromMaybe uContext muParent + , noteContext = Just uContext + , notePublished = Just now + , noteContent = content + } + } + } + obid <- insert OutboxItem + { outboxItemPerson = pid + , outboxItemActivity = PersistJSON $ activity $ LocalURI "" "" + , outboxItemPublished = now + } + let luAct = route2local $ OutboxItemR shrUser $ encodeHid $ fromSqlKey obid + doc = activity luAct + update obid [OutboxItemActivity =. PersistJSON doc] + return (lmid, doc) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 03281c9..6140f4b 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -210,7 +210,7 @@ instance Yesod App where | a == resendVerifyR -> personFromResendForm (AuthR (PluginR "account" ["verify", u, _]), False) -> personUnver u - (OutboxR , True) -> personAny + (OutboxR shr , True) -> person shr (GroupsR , True) -> personAny (GroupNewR , _ ) -> personAny @@ -767,7 +767,8 @@ instance YesodBreadcrumbs App where PublishR -> ("Publish", Just HomeR) InboxR -> ("Inbox", Just HomeR) - OutboxR -> ("Outbox", Just HomeR) + OutboxR shr -> ("Outbox", Just $ SharerR shr) + OutboxItemR shr hid -> ("#" <> hid, Just $ OutboxR shr) ActorKey1R -> ("Actor Key 1", Nothing) ActorKey2R -> ("Actor Key 2", Nothing) diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index 0989602..99249e4 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/src/Vervis/Handler/Discussion.hs @@ -125,12 +125,24 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do (Nothing, Just rd) -> do let iid = remoteDiscussionInstance rd i <- getJust iid - rs <- getJust $ remoteDiscussionSharer rd - unless (iid == remoteSharerInstance rs) $ - fail "RemoteDiscussion and its sharer on different hosts" + let hInstance = instanceHost i + mrs <- traverse getJust $ remoteDiscussionActor rd + let muActor = f2l <$> remoteDiscussionUnlinkedActor rd + luActor <- + case (mrs, muActor) of + (Nothing, Nothing) -> fail "RemoteDiscussion actor and unlinkedActor both unset" + (Just _, Just _) -> fail "RemoteDiscussion actor and unlinkedActor both set" + (Just rs, Nothing) -> do + unless (iid == remoteSharerInstance rs) $ + fail "RemoteDiscussion and its actor on different hosts" + return $ remoteSharerIdent rs + (Nothing, Just (h, lu)) -> do + unless (hInstance == h) $ + fail "RemoteDiscussion and its unlinked actor on different hosts" + return lu return - ( l2f (instanceHost i) (remoteSharerIdent rs) - , l2f (instanceHost i) (remoteDiscussionIdent rd) + ( l2f hInstance luActor + , l2f hInstance (remoteDiscussionIdent rd) ) muParent <- for (messageParent m) $ \ midParent -> do mlocal <- getBy $ UniqueLocalMessage midParent @@ -186,8 +198,9 @@ postTopReply replyP after getdid = do , messageRoot = did } lmid <- insert LocalMessage - { localMessageAuthor = author - , localMessageRest = mid + { localMessageAuthor = author + , localMessageRest = mid + , localMessageUnlinkedParent = Nothing } return lmid setMessage "Message submitted." @@ -237,8 +250,9 @@ postReply replyG replyP after getdid mid = do , messageRoot = did } lmid <- insert LocalMessage - { localMessageAuthor = author - , localMessageRest = mid + { localMessageAuthor = author + , localMessageRest = mid + , localMessageUnlinkedParent = Nothing } return lmid setMessage "Message submitted." diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 38fe006..12a0e72 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -18,6 +18,7 @@ module Vervis.Handler.Inbox , postInboxR , getPublishR , getOutboxR + , getOutboxItemR , postOutboxR , getActorKey1R , getActorKey2R @@ -212,40 +213,45 @@ activityForm = renderDivs $ (,,,) defctx = FedURI "forge.angeley.es" "/s/fr33/p/sandbox/t/1" "" defmsg = "Hi! I'm testing federation. Can you see my message? :)" -activityWidget :: Widget -> Enctype -> Widget -activityWidget widget enctype = +activityWidget :: ShrIdent -> Widget -> Enctype -> Widget +activityWidget shr widget enctype = [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. -

+ ^{widget} |] +getUserShrIdent :: Handler ShrIdent +getUserShrIdent = do + Entity _ p <- requireVerifiedAuth + s <- runDB $ get404 $ personIdent p + return $ sharerIdent s + getPublishR :: Handler Html getPublishR = do + shr <- getUserShrIdent ((_result, widget), enctype) <- runFormPost activityForm - defaultLayout $ activityWidget widget enctype + defaultLayout $ activityWidget shr widget enctype -getOutboxR :: Handler TypedContent +getOutboxR :: ShrIdent -> Handler TypedContent getOutboxR = error "Not implemented yet" -postOutboxR :: Handler Html -postOutboxR = do +getOutboxItemR :: ShrIdent -> Text -> Handler TypedContent +getOutboxItemR = error "Not implemented yet" + +postOutboxR :: ShrIdent -> Handler Html +postOutboxR shr = do federation <- getsYesod $ appFederation . appSettings unless federation badMethod ((result, widget), enctype) <- runFormPost activityForm - defaultLayout $ activityWidget widget enctype case result of FormMissing -> setMessage "Field(s) missing" FormFailure _l -> setMessage "Invalid input, see below" FormSuccess (to, mparent, mcontext, msg) -> do - shr <- do - Entity _pid person <- requireVerifiedAuth - sharer <- runDB $ get404 $ personIdent person - return $ sharerIdent sharer renderUrl <- getUrlRender route2uri <- getEncodeRouteFed now <- liftIO getCurrentTime @@ -282,7 +288,7 @@ postOutboxR = do 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 widget enctype + defaultLayout $ activityWidget shr widget enctype where fetchInboxURI :: Manager -> Text -> LocalURI -> Handler (Maybe LocalURI) fetchInboxURI manager h lto = do diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index df47720..3dfd014 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -40,7 +40,7 @@ import Data.ByteString (ByteString) import Data.Text (Text) import Data.Time (UTCTime) import Database.Persist.Class (EntityField) -import Database.Persist.JSON (PersistJSONObject) +import Database.Persist.JSON (PersistJSONValue) import Database.Persist.Schema.Types (Entity) import Database.Persist.Schema.SQL () import Database.Persist.Sql (SqlBackend) diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 63db429..ad47653 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -30,6 +30,7 @@ import Database.Persist.EmailAddress import Database.Persist.Graph.Class import Database.Persist.JSON import Network.FedURI (FedURI, LocalURI) +import Web.ActivityPub (Doc, Activity) import Vervis.Model.Group import Vervis.Model.Ident @@ -39,6 +40,8 @@ import Vervis.Model.Ticket import Vervis.Model.TH import Vervis.Model.Workflow +type PersistActivity = PersistJSON (Doc Activity) + makeEntities $(modelFile "config/models") instance PersistUserCredentials Person where diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs index db45b2e..6de704e 100644 --- a/src/Vervis/RemoteActorStore.hs +++ b/src/Vervis/RemoteActorStore.hs @@ -83,10 +83,14 @@ stateTVar var f = do return a withHostLock - :: YesodRemoteActorStore site + :: ( MonadHandler m + , MonadUnliftIO m + , HandlerSite m ~ site + , YesodRemoteActorStore site + ) => Text - -> HandlerFor site a - -> HandlerFor site a + -> m a + -> m a withHostLock host action = do InstanceMutex tvar <- getsYesod siteInstanceMutex mvar <- liftIO $ do diff --git a/src/Yesod/FedURI.hs b/src/Yesod/FedURI.hs index 0df472a..e585215 100644 --- a/src/Yesod/FedURI.hs +++ b/src/Yesod/FedURI.hs @@ -16,14 +16,20 @@ module Yesod.FedURI ( getEncodeRouteFed , getEncodeRouteLocal + , decodeRouteLocal ) where import Prelude +import Control.Monad +import Data.Text.Encoding +import Network.HTTP.Types.URI import Yesod.Core import Yesod.Core.Handler +import qualified Data.Text as T + import Network.FedURI getEncodeRouteFed :: MonadHandler m => m (Route (HandlerSite m) -> FedURI) @@ -36,3 +42,12 @@ getEncodeRouteFed = toFed <$> getUrlRender getEncodeRouteLocal :: MonadHandler m => m (Route (HandlerSite m) -> LocalURI) getEncodeRouteLocal = (\ f -> snd . f2l . f) <$> getEncodeRouteFed + +decodeRouteLocal :: ParseRoute site => LocalURI -> Maybe (Route site) +decodeRouteLocal = + parseRoute . (,[]) . decodePathSegments . encodeUtf8 . luriPath <=< noFrag + where + noFrag lu = + if T.null $ luriFragment lu + then Just lu + else Nothing