diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 6969cdc..72e1d69 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -118,6 +118,7 @@ import Vervis.ActivityPub import Vervis.ActorKey import Vervis.Cloth import Vervis.Darcs +import Vervis.Data.Collab import Vervis.Delivery import Vervis.Discussion import Vervis.FedURI @@ -1800,9 +1801,6 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje ibiid <- insert $ InboxItem True insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid -data GrantRecipBy f = GrantRecipPerson (f Person) - deriving (Generic, FunctorB, TraversableB, ConstraintsB) - data Result = ResultSomeException SomeException | ResultIdMismatch @@ -1821,7 +1819,7 @@ grantC grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do -- Check input - (resource, recipient) <- parseGrant grant + (resource, recipient) <- parseGrant (Just pidUser) grant ParsedAudience localRecips remoteRecips blinded fwdHosts <- do mrecips <- parseAudience audience recips <- fromMaybeE mrecips "Grant with no recipients" @@ -1966,78 +1964,6 @@ grantC (Entity pidUser personUser) senderActor muCap summary audience grant = do where - parseGrantResource (RepoR r) = Just $ GrantResourceRepo r - parseGrantResource (DeckR d) = Just $ GrantResourceDeck d - parseGrantResource (LoomR l) = Just $ GrantResourceLoom l - parseGrantResource _ = Nothing - - parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p - parseGrantRecip _ = Nothing - - unhashGrantRecipPure ctx = f - where - f (GrantRecipPerson p) = - GrantRecipPerson <$> decodeKeyHashidPure ctx p - - unhashGrantRecip resource = do - ctx <- asksSite siteHashidsContext - return $ unhashGrantRecipPure ctx resource - - unhashGrantRecipE resource e = - ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource - - parseGrant - :: Grant URIMode - -> ExceptT Text Handler - ( Either (GrantResourceBy Key) FedURI - , Either (GrantRecipBy Key) FedURI - ) - parseGrant (Grant object context target) = do - verifyRole object - (,) <$> parseContext context - <*> parseTarget target - where - verifyRole (Left RoleAdmin) = pure () - verifyRole (Right _) = - throwE "ForgeFed Admin is the only role allowed currently" - parseContext u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - "Grant context isn't a valid route" - resourceHash <- - fromMaybeE - (parseGrantResource route) - "Grant context isn't a shared resource route" - unhashGrantResourceE - resourceHash - "Grant resource contains invalid hashid" - else pure $ Right u - parseTarget u@(ObjURI h lu) = do - hl <- hostIsLocal h - if hl - then Left <$> do - route <- - fromMaybeE - (decodeRouteLocal lu) - "Grant target isn't a valid route" - recipHash <- - fromMaybeE - (parseGrantRecip route) - "Grant target isn't a grant recipient route" - recipKey <- - unhashGrantRecipE - recipHash - "Grant target contains invalid hashid" - case recipKey of - GrantRecipPerson p | p == pidUser -> - throwE "Grant sender and recipient are the same Person" - _ -> return recipKey - else pure $ Right u - fetchRemoteResource instanceID host localURI = do maybeActor <- runSiteDB $ runMaybeT $ do roid <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID localURI diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 0e04e06..dcf29d8 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -32,6 +32,7 @@ module Vervis.ActivityPub , parseActivityURI , getActivity --, ActorEntity (..) + , getLocalActor' , getLocalActor --, getOutboxActorEntity --, actorEntityPath @@ -332,6 +333,29 @@ data ActorEntity | ActorRepo (Entity Repo) -} +getLocalActor' + :: ( BaseBackend b ~ SqlBackend + , PersistUniqueRead b + , MonadIO m + ) + => ActorId + -> ReaderT b m (LocalActorBy Key) +getLocalActor' actorID = do + mp <- getKeyBy $ UniquePersonActor actorID + mg <- getKeyBy $ UniqueGroupActor actorID + mr <- getKeyBy $ UniqueRepoActor actorID + md <- getKeyBy $ UniqueDeckActor actorID + ml <- getKeyBy $ UniqueLoomActor actorID + return $ + case (mp, mg, mr, md, ml) of + (Nothing, Nothing, Nothing, Nothing, Nothing) -> error "Unused ActorId" + (Just p, Nothing, Nothing, Nothing, Nothing) -> LocalActorPerson p + (Nothing, Just g, Nothing, Nothing, Nothing) -> LocalActorGroup g + (Nothing, Nothing, Just r, Nothing, Nothing) -> LocalActorRepo r + (Nothing, Nothing, Nothing, Just d, Nothing) -> LocalActorDeck d + (Nothing, Nothing, Nothing, Nothing, Just l) -> LocalActorLoom l + _ -> error "Multi-usage of an ActorId" + getLocalActor :: ( BaseBackend b ~ SqlBackend , PersistUniqueRead b diff --git a/src/Vervis/Actor.hs b/src/Vervis/Actor.hs index c2bde44..28413c7 100644 --- a/src/Vervis/Actor.hs +++ b/src/Vervis/Actor.hs @@ -15,6 +15,7 @@ module Vervis.Actor ( getInbox + , postInbox , getOutbox , getOutboxItem , getFollowersCollection @@ -213,6 +214,61 @@ getInbox here actor hash = do where ibiidString = "InboxItem #" ++ show (fromSqlKey ibid) +postInbox + :: ( UTCTime + -> ActivityAuthentication + -> ActivityBody + -> ExceptT Text Handler + ( Text + , Maybe (ExceptT Text Worker Text) + ) + ) + -> Handler () +postInbox handler = do + federation <- getsYesod $ appFederation . appSettings + unless federation badMethod + contentTypes <- lookupHeaders "Content-Type" + now <- liftIO getCurrentTime + result <- runExceptT $ do + (auth, body) <- authenticateActivity now + (actbObject body,) <$> handler now auth body + recordActivity now result contentTypes + case result of + Left err -> do + logDebug err + sendResponseStatus badRequest400 err + Right (obj, (_, mworker)) -> + for_ mworker $ \ worker -> forkWorker "postInbox worker" $ do + wait <- asyncWorker $ runExceptT worker + result' <- wait + let result'' = + case result' of + Left e -> Left $ T.pack $ displayException e + Right (Left e) -> Left e + Right (Right t) -> Right (obj, (t, Nothing)) + now' <- liftIO getCurrentTime + recordActivity now' result'' contentTypes + case result'' of + Left err -> logDebug err + Right _ -> return () + where + recordActivity + :: (MonadSite m, SiteEnv m ~ App) + => UTCTime -> Either Text (Object, (Text, w)) -> [ContentType] -> m () + recordActivity now result contentTypes = do + macts <- asksSite appActivities + for_ macts $ \ (size, acts) -> + liftIO $ atomically $ modifyTVar' acts $ \ vec -> + let (msg, body) = + case result of + Left t -> (t, "{?}") + Right (o, (t, _)) -> (t, encodePretty o) + item = ActivityReport now msg contentTypes body + vec' = item `V.cons` vec + in if V.length vec' > size + then V.init vec' + else vec' + getOutbox here actor hash = do key <- decodeKeyHashid404 hash (total, pages, mpage) <- runDB $ do diff --git a/src/Vervis/Data/Actor.hs b/src/Vervis/Data/Actor.hs new file mode 100644 index 0000000..f32126f --- /dev/null +++ b/src/Vervis/Data/Actor.hs @@ -0,0 +1,56 @@ +{- This file is part of Vervis. + - + - Written in 2022 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Data.Actor + ( parseLocalActivityURI + ) +where + +import Control.Monad.Trans.Except +import Data.Text (Text) + +import Network.FedURI +import Yesod.FedURI +import Yesod.Hashids +import Yesod.MonadSite + +import Control.Monad.Trans.Except.Local + +import Vervis.Foundation +import Vervis.Model +import Vervis.Recipient + +parseLocalActivityURI + :: (MonadSite m, YesodHashids (SiteEnv m)) + => LocalURI + -> ExceptT Text m (LocalActorBy Key, LocalActorBy KeyHashid, OutboxItemId) +parseLocalActivityURI luAct = do + route <- + fromMaybeE (decodeRouteLocal luAct) "Local activity: Not a valid route" + (actorHash, outboxItemHash) <- + fromMaybeE + (parseOutboxItemRoute route) + "Local activity: Valid local route, but not an outbox item route" + outboxItemID <- + decodeKeyHashidE outboxItemHash "Local activity: Invalid outbox item hash" + actorKey <- unhashLocalActorE actorHash "Local activity: Invalid actor hash" + return (actorKey, actorHash, outboxItemID) + where + parseOutboxItemRoute (PersonOutboxItemR p i) = Just (LocalActorPerson p, i) + parseOutboxItemRoute (GroupOutboxItemR g i) = Just (LocalActorGroup g, i) + parseOutboxItemRoute (RepoOutboxItemR r i) = Just (LocalActorRepo r, i) + parseOutboxItemRoute (DeckOutboxItemR d i) = Just (LocalActorDeck d, i) + parseOutboxItemRoute (LoomOutboxItemR l i) = Just (LocalActorLoom l, i) + parseOutboxItemRoute _ = Nothing diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs new file mode 100644 index 0000000..99ce30c --- /dev/null +++ b/src/Vervis/Data/Collab.hs @@ -0,0 +1,119 @@ +{- This file is part of Vervis. + - + - Written in 2022 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} + +module Vervis.Data.Collab + ( GrantRecipBy (..) + , parseGrant + ) +where + +import Control.Monad.Trans.Except +import Data.Barbie +import Data.Text (Text) +import Database.Persist.Types +import GHC.Generics + +import Network.FedURI +import Web.ActivityPub +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.Hashids +import Yesod.MonadSite + +import Control.Monad.Trans.Except.Local + +import Vervis.Access +import Vervis.FedURI +import Vervis.Foundation +import Vervis.Model + +data GrantRecipBy f = GrantRecipPerson (f Person) + deriving (Generic, FunctorB, TraversableB, ConstraintsB) + +parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p +parseGrantRecip _ = Nothing + +unhashGrantRecipPure ctx = f + where + f (GrantRecipPerson p) = + GrantRecipPerson <$> decodeKeyHashidPure ctx p + +unhashGrantRecip resource = do + ctx <- asksSite siteHashidsContext + return $ unhashGrantRecipPure ctx resource + +unhashGrantRecipE resource e = + ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource + +parseGrant + :: Maybe PersonId + -> Grant URIMode + -> ExceptT Text Handler + ( Either (GrantResourceBy Key) FedURI + , Either (GrantRecipBy Key) FedURI + ) +parseGrant maybeSenderID (Grant object context target) = do + verifyRole object + (,) <$> parseContext context + <*> parseTarget target + where + verifyRole (Left RoleAdmin) = pure () + verifyRole (Right _) = + throwE "ForgeFed Admin is the only role allowed currently" + parseContext u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- + fromMaybeE + (decodeRouteLocal lu) + "Grant context isn't a valid route" + resourceHash <- + fromMaybeE + (parseGrantResource route) + "Grant context isn't a shared resource route" + unhashGrantResourceE + resourceHash + "Grant resource contains invalid hashid" + else pure $ Right u + where + parseGrantResource (RepoR r) = Just $ GrantResourceRepo r + parseGrantResource (DeckR d) = Just $ GrantResourceDeck d + parseGrantResource (LoomR l) = Just $ GrantResourceLoom l + parseGrantResource _ = Nothing + parseTarget u@(ObjURI h lu) = do + hl <- hostIsLocal h + if hl + then Left <$> do + route <- + fromMaybeE + (decodeRouteLocal lu) + "Grant target isn't a valid route" + recipHash <- + fromMaybeE + (parseGrantRecip route) + "Grant target isn't a grant recipient route" + recipKey <- + unhashGrantRecipE + recipHash + "Grant target contains invalid hashid" + case recipKey of + GrantRecipPerson p | Just p == maybeSenderID -> + throwE "Grant sender and recipient are the same Person" + _ -> return recipKey + else pure $ Right u diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index fcbe049..49c36b5 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -117,187 +117,6 @@ import Vervis.RemoteActorStore import Vervis.Settings {- -handlePersonInbox - :: KeyHashid Person - -> ActivityAuthentication - -> ActivityBody - -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -handlePersonInbox recipHash (ActivityAuthLocal (LocalActorPerson pidAuthor)) body = (,Nothing) <$> do - (shrActivity, obiid) <- do - luAct <- - fromMaybeE - (activityId $ actbActivity body) - "Local activity: No 'id'" - route <- - fromMaybeE - (decodeRouteLocal luAct) - "Local activity: Not a valid route" - case route of - SharerOutboxItemR shr obikhid -> - (shr,) <$> decodeKeyHashidE obikhid "Local activity: ID is invalid hashid" - _ -> throwE "Local activity: Not an activity route" - runDBExcept $ do - Entity pidRecip personRecip <- lift $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - getBy404 $ UniquePersonIdent sid - mobi <- lift $ get obiid - obi <- fromMaybeE mobi "Local activity: No such ID in DB" - mpidOutbox <- - lift $ getKeyBy $ UniquePersonOutbox $ outboxItemOutbox obi - pidOutbox <- - fromMaybeE mpidOutbox "Local activity not in a user outbox" - p <- lift $ getJust pidOutbox - s <- lift $ getJust $ personIdent p - unless (sharerIdent s == shrActivity) $ - throwE "Local activity: ID invalid, hashid and author mismatch" - unless (pidAuthor == pidOutbox) $ - throwE "Activity author in DB and in received JSON don't match" - if pidRecip == pidAuthor - then return "Received activity authored by self, ignoring" - else lift $ do - ibiid <- insert $ InboxItem True - let ibid = personInbox personRecip - miblid <- insertUnique $ InboxItemLocal ibid obiid ibiid - let recip = shr2text shrRecip - case miblid of - Nothing -> do - delete ibiid - return $ - "Activity already exists in inbox of /s/" <> recip - Just _ -> - return $ "Activity inserted to inbox of /s/" <> recip -handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalProject jidAuthor)) body = (,Nothing) <$> do - (shrActivity, prjActivity, obiid) <- do - luAct <- - fromMaybeE - (activityId $ actbActivity body) - "Local activity: No 'id'" - route <- - fromMaybeE - (decodeRouteLocal luAct) - "Local activity: Not a valid route" - case route of - ProjectOutboxItemR shr prj obikhid -> - (shr,prj,) <$> decodeKeyHashidE obikhid "Local activity: ID is invalid hashid" - _ -> throwE "Local activity: Not an activity route" - runDBExcept $ do - Entity pidRecip personRecip <- lift $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - getBy404 $ UniquePersonIdent sid - mobi <- lift $ get obiid - obi <- fromMaybeE mobi "Local activity: No such ID in DB" - maidOutbox <- - lift $ getKeyBy $ UniqueActorOutbox $ outboxItemOutbox obi - aidOutbox <- - fromMaybeE maidOutbox "Local activity not in an actor outbox" - mejOutbox <- - lift $ getBy $ UniqueProjectActor aidOutbox - Entity jidOutbox j <- - fromMaybeE mejOutbox "Local activity not in a project outbox" - s <- lift $ getJust $ projectSharer j - unless (sharerIdent s == shrActivity) $ - throwE "Local activity: ID invalid, hashid and author shr mismatch" - unless (projectIdent j == prjActivity) $ - throwE "Local activity: ID invalid, hashid and author prj mismatch" - unless (jidAuthor == jidOutbox) $ - throwE "Activity author in DB and in received JSON don't match" - lift $ do - ibiid <- insert $ InboxItem True - let ibid = personInbox personRecip - miblid <- insertUnique $ InboxItemLocal ibid obiid ibiid - let recip = shr2text shrRecip - case miblid of - Nothing -> do - delete ibiid - return $ - "Activity already exists in inbox of /s/" <> recip - Just _ -> - return $ "Activity inserted to inbox of /s/" <> recip -handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalRepo ridAuthor)) body = (,Nothing) <$> do - (shrActivity, rpActivity, obiid) <- do - luAct <- - fromMaybeE - (activityId $ actbActivity body) - "Local activity: No 'id'" - route <- - fromMaybeE - (decodeRouteLocal luAct) - "Local activity: Not a valid route" - case route of - RepoOutboxItemR shr rp obikhid -> - (shr,rp,) <$> decodeKeyHashidE obikhid "Local activity: ID is invalid hashid" - _ -> throwE "Local activity: Not an activity route" - runDBExcept $ do - Entity pidRecip personRecip <- lift $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - getBy404 $ UniquePersonIdent sid - mobi <- lift $ get obiid - obi <- fromMaybeE mobi "Local activity: No such ID in DB" - mridOutbox <- - lift $ getKeyBy $ UniqueRepoOutbox $ outboxItemOutbox obi - ridOutbox <- - fromMaybeE mridOutbox "Local activity not in a repo outbox" - r <- lift $ getJust ridOutbox - s <- lift $ getJust $ repoSharer r - unless (sharerIdent s == shrActivity) $ - throwE "Local activity: ID invalid, hashid and author shr mismatch" - unless (repoIdent r == rpActivity) $ - throwE "Local activity: ID invalid, hashid and author rp mismatch" - unless (ridAuthor == ridOutbox) $ - throwE "Activity author in DB and in received JSON don't match" - lift $ do - ibiid <- insert $ InboxItem True - let ibid = personInbox personRecip - miblid <- insertUnique $ InboxItemLocal ibid obiid ibiid - let recip = shr2text shrRecip - case miblid of - Nothing -> do - delete ibiid - return $ - "Activity already exists in inbox of /s/" <> recip - Just _ -> - return $ "Activity inserted to inbox of /s/" <> recip -handleSharerInbox shrRecip now (ActivityAuthRemote author) body = do - luActivity <- - fromMaybeE (activityId $ actbActivity body) "Activity without 'id'" - localRecips <- do - mrecips <- parseAudience $ activityAudience $ actbActivity body - paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients" - msig <- checkForwarding $ LocalActorSharer shrRecip - let mfwd = (localRecips,) <$> msig - case activitySpecific $ actbActivity body of - AcceptActivity accept -> - (,Nothing) <$> sharerAcceptF shrRecip now author body mfwd luActivity accept - AddActivity (AP.Add obj target) -> - case obj of - Right (AddBundle patches) -> - sharerAddBundleF now shrRecip author body mfwd luActivity patches target - _ -> return ("Unsupported add object type for sharers", Nothing) - CreateActivity (Create obj mtarget) -> - case obj of - CreateNote _ note -> - (,Nothing) <$> sharerCreateNoteF now shrRecip author body mfwd luActivity note - CreateTicket _ ticket -> - (,Nothing) <$> sharerCreateTicketF now shrRecip author body mfwd luActivity ticket mtarget - _ -> return ("Unsupported create object type for sharers", Nothing) - FollowActivity follow -> - (,Nothing) <$> sharerFollowF shrRecip now author body mfwd luActivity follow - OfferActivity (Offer obj target) -> - case obj of - OfferTicket ticket -> - (,Nothing) <$> sharerOfferTicketF now shrRecip author body mfwd luActivity ticket target - OfferDep dep -> - sharerOfferDepF now shrRecip author body mfwd luActivity dep target - _ -> return ("Unsupported offer object type for sharers", Nothing) - PushActivity push -> - (,Nothing) <$> sharerPushF shrRecip now author body mfwd luActivity push - RejectActivity reject -> - (,Nothing) <$> sharerRejectF shrRecip now author body mfwd luActivity reject - ResolveActivity resolve -> - (,Nothing) <$> sharerResolveF now shrRecip author body mfwd luActivity resolve - UndoActivity undo -> - (,Nothing) <$> sharerUndoF shrRecip now author body mfwd luActivity undo - _ -> return ("Unsupported activity type for sharers", Nothing) handleProjectInbox :: ShrIdent diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index ed20bab..eab3496 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -160,61 +160,6 @@ getRepoInboxR shr rp = getInbox here getInboxId r <- getValBy404 $ UniqueRepo rp sid return $ repoInbox r -recordActivity - :: (MonadSite m, SiteEnv m ~ App) - => UTCTime -> Either Text (Object, (Text, w)) -> [ContentType] -> m () -recordActivity now result contentTypes = do - macts <- asksSite appActivities - for_ macts $ \ (size, acts) -> - liftIO $ atomically $ modifyTVar' acts $ \ vec -> - let (msg, body) = - case result of - Left t -> (t, "{?}") - Right (o, (t, _)) -> (t, encodePretty o) - item = ActivityReport now msg contentTypes body - vec' = item `V.cons` vec - in if V.length vec' > size - then V.init vec' - else vec' - -handleInbox - :: ( UTCTime - -> ActivityAuthentication - -> ActivityBody - -> ExceptT Text Handler - ( Text - , Maybe (ExceptT Text Worker Text) - ) - ) - -> Handler () -handleInbox handler = do - federation <- getsYesod $ appFederation . appSettings - unless federation badMethod - contentTypes <- lookupHeaders "Content-Type" - now <- liftIO getCurrentTime - result <- runExceptT $ do - (auth, body) <- authenticateActivity now - (actbObject body,) <$> handler now auth body - recordActivity now result contentTypes - case result of - Left err -> do - logDebug err - sendResponseStatus badRequest400 err - Right (obj, (_, mworker)) -> - for_ mworker $ \ worker -> forkWorker "handleInbox worker" $ do - wait <- asyncWorker $ runExceptT worker - result' <- wait - let result'' = - case result' of - Left e -> Left $ T.pack $ displayException e - Right (Left e) -> Left e - Right (Right t) -> Right (obj, (t, Nothing)) - now' <- liftIO getCurrentTime - recordActivity now' result'' contentTypes - case result'' of - Left err -> logDebug err - Right _ -> return () - postSharerInboxR :: ShrIdent -> Handler () postSharerInboxR shrRecip = handleInbox $ handleSharerInbox shrRecip diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 76b9344..0434fcc 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -32,9 +32,13 @@ where import Control.Monad import Control.Monad.Trans.Except +import Control.Monad.Trans.Reader import Data.Maybe +import Data.Text (Text) +import Data.Time.Clock import Data.Traversable import Database.Persist +import Database.Persist.Sql import Dvara import Text.Blaze.Html (toHtml) import Yesod.Core @@ -52,9 +56,11 @@ import Network.FedURI import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids +import Yesod.MonadSite import qualified Web.ActivityPub as AP +import Control.Monad.Trans.Except.Local import Data.Either.Local import Database.Persist.Local @@ -62,9 +68,12 @@ import Vervis.ActivityPub import Vervis.Actor import Vervis.ActorKey import Vervis.API +import Vervis.Data.Actor +import Vervis.Federation.Auth import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident +import Vervis.Recipient import Vervis.Secure import Vervis.Settings import Vervis.Ticket @@ -116,8 +125,115 @@ getPersonR personHash = do getPersonInboxR :: KeyHashid Person -> Handler TypedContent getPersonInboxR = getInbox PersonInboxR personActor -postPersonInboxR :: KeyHashid Person -> Handler TypedContent -postPersonInboxR _ = error "Temporarily disabled" +parseAuthenticatedLocalActivityURI + :: (MonadSite m, YesodHashids (SiteEnv m)) + => LocalActorBy Key -> Maybe LocalURI -> ExceptT Text m OutboxItemId +parseAuthenticatedLocalActivityURI author maybeActivityURI = do + luAct <- fromMaybeE maybeActivityURI "No 'id'" + (actorByKey, _, outboxItemID) <- parseLocalActivityURI luAct + unless (actorByKey == author) $ + throwE "'actor' actor and 'id' actor mismatch" + return outboxItemID + +verifyLocalActivityExistsInDB + :: MonadIO m + => LocalActorBy Key + -> OutboxItemId + -> ExceptT Text (ReaderT SqlBackend m) () +verifyLocalActivityExistsInDB actorByKey outboxItemID = do + outboxID <- outboxItemOutbox <$> getE outboxItemID "No such OutboxItemId in DB" + itemActorID <- do + maybeActorID <- + lift $ getKeyBy $ UniqueActorOutbox outboxID + fromMaybeE maybeActorID "Outbox item's outbox doesn't belong to any Actor" + itemActorByKey <- lift $ getLocalActor' itemActorID + unless (itemActorByKey == actorByKey) $ + throwE "Actor-in-URI and Actor-owning-the-outbox-item-in-DB mismatch" + +insertActivityToInbox + :: MonadIO m => ActorId -> OutboxItemId -> ReaderT SqlBackend m Bool +insertActivityToInbox recipActorID outboxItemID = do + inboxID <- actorInbox <$> getJust recipActorID + inboxItemID <- insert $ InboxItem True + maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID + case maybeItem of + Nothing -> do + delete inboxItemID + return False + Just _ -> return True + +postPersonInboxR :: KeyHashid Person -> Handler () +postPersonInboxR recipPersonHash = postInbox handle + where + handle + :: UTCTime + -> ActivityAuthentication + -> ActivityBody + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) + + handle _ (ActivityAuthLocal authorByKey) body = (,Nothing) <$> do + outboxItemID <- + parseAuthenticatedLocalActivityURI + authorByKey + (AP.activityId $ actbActivity body) + recipPersonID <- decodeKeyHashid404 recipPersonHash + runDBExcept $ do + recipPerson <- lift $ get404 recipPersonID + verifyLocalActivityExistsInDB authorByKey outboxItemID + if LocalActorPerson recipPersonID == authorByKey + then return "Received activity authored by self, ignoring" + else lift $ do + inserted <- insertActivityToInbox (personActor recipPerson) outboxItemID + return $ + if inserted + then "Activity inserted to recipient's inbox" + else "Activity already exists in recipient's inbox" + + handle now (ActivityAuthRemote author) body = do + luActivity <- + fromMaybeE (AP.activityId $ actbActivity body) "Activity without 'id'" + localRecips <- do + mrecips <- parseAudience $ AP.activityAudience $ actbActivity body + paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients" + msig <- checkForwarding $ LocalActorPerson recipPersonHash + let mfwd = (localRecips,) <$> msig + case AP.activitySpecific $ actbActivity body of + {- + AcceptActivity accept -> + (,Nothing) <$> sharerAcceptF shrRecip now author body mfwd luActivity accept + AddActivity (AP.Add obj target) -> + case obj of + Right (AddBundle patches) -> + sharerAddBundleF now shrRecip author body mfwd luActivity patches target + _ -> return ("Unsupported add object type for sharers", Nothing) + CreateActivity (Create obj mtarget) -> + case obj of + CreateNote _ note -> + (,Nothing) <$> sharerCreateNoteF now shrRecip author body mfwd luActivity note + CreateTicket _ ticket -> + (,Nothing) <$> sharerCreateTicketF now shrRecip author body mfwd luActivity ticket mtarget + _ -> return ("Unsupported create object type for sharers", Nothing) + FollowActivity follow -> + (,Nothing) <$> sharerFollowF shrRecip now author body mfwd luActivity follow + -} + {- + OfferActivity (Offer obj target) -> + case obj of + OfferTicket ticket -> + (,Nothing) <$> sharerOfferTicketF now shrRecip author body mfwd luActivity ticket target + OfferDep dep -> + sharerOfferDepF now shrRecip author body mfwd luActivity dep target + _ -> return ("Unsupported offer object type for sharers", Nothing) + PushActivity push -> + (,Nothing) <$> sharerPushF shrRecip now author body mfwd luActivity push + RejectActivity reject -> + (,Nothing) <$> sharerRejectF shrRecip now author body mfwd luActivity reject + ResolveActivity resolve -> + (,Nothing) <$> sharerResolveF now shrRecip author body mfwd luActivity resolve + UndoActivity undo -> + (,Nothing) <$> sharerUndoF shrRecip now author body mfwd luActivity undo + -} + _ -> return ("Unsupported activity type for Person", Nothing) getPersonOutboxR :: KeyHashid Person -> Handler TypedContent getPersonOutboxR = getOutbox PersonOutboxR personActor diff --git a/vervis.cabal b/vervis.cabal index 1eda6c1..5947d19 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -134,6 +134,8 @@ library Vervis.Colour Vervis.Content Vervis.Darcs + Vervis.Data.Actor + Vervis.Data.Collab Vervis.Delivery Vervis.Discussion Vervis.Federation