diff --git a/config/models b/config/models index 779afc8..625349d 100644 --- a/config/models +++ b/config/models @@ -240,10 +240,12 @@ Repo collabUser RoleId Maybe collabAnon RoleId Maybe inbox InboxId + outbox OutboxId followers FollowerSetId UniqueRepo ident sharer UniqueRepoInbox inbox + UniqueRepoOutbox outbox UniqueRepoFollowers followers Workflow diff --git a/config/routes b/config/routes index b4a86bf..263f58a 100644 --- a/config/routes +++ b/config/routes @@ -86,6 +86,8 @@ /s/#ShrIdent/r/!new RepoNewR GET /s/#ShrIdent/r/#RpIdent RepoR GET PUT DELETE POST /s/#ShrIdent/r/#RpIdent/inbox RepoInboxR GET POST +/s/#ShrIdent/r/#RpIdent/outbox RepoOutboxR GET +/s/#ShrIdent/r/#RpIdent/outbox/#OutboxItemKeyHashid RepoOutboxItemR GET /s/#ShrIdent/r/#RpIdent/team RepoTeamR GET /s/#ShrIdent/r/#RpIdent/followers RepoFollowersR GET /s/#ShrIdent/r/#RpIdent/edit RepoEditR GET diff --git a/migrations/2019_09_10.model b/migrations/2019_09_10.model new file mode 100644 index 0000000..9d6f176 --- /dev/null +++ b/migrations/2019_09_10.model @@ -0,0 +1,4 @@ +Outbox + +Repo + outbox OutboxId diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 611acac..ca99ac7 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -15,6 +15,7 @@ module Vervis.API ( createNoteC + , followC , offerTicketC , pushCommitsC , getFollowersCollection @@ -282,8 +283,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source _ -> throwE "Local context isn't a ticket route" atMostSharer :: e -> (ShrIdent, LocalSharerRelatedSet) -> ExceptT e Handler (Maybe ShrIdent) - atMostSharer _ (shr, LocalSharerRelatedSet s []) = return $ if localRecipSharer s then Just shr else Nothing - atMostSharer e (_ , LocalSharerRelatedSet _ _ ) = throwE e + atMostSharer _ (shr, LocalSharerRelatedSet s [] []) = return $ if localRecipSharer s then Just shr else Nothing + atMostSharer e (_ , LocalSharerRelatedSet _ _ _ ) = throwE e verifyTicketRecipients :: (ShrIdent, PrjIdent, Int) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent] verifyTicketRecipients (shr, prj, num) recips = do @@ -439,6 +440,190 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source Right _gid -> throwE "Local Note addresses a local group" -} +data Followee + = FolloweeSharer ShrIdent + | FolloweeProject ShrIdent PrjIdent + | FolloweeTicket ShrIdent PrjIdent Int + | FolloweeRepo ShrIdent RpIdent + +followC + :: ShrIdent + -> TextHtml + -> Audience URIMode + -> AP.Follow URIMode + -> Handler (Either Text OutboxItemId) +followC shrUser summary audience follow@(AP.Follow uObject hide) = runExceptT $ do + (localRecips, remoteRecips) <- do + mrecips <- parseAudience audience + fromMaybeE mrecips "Follow with no recipients" + federation <- asksSite $ appFederation . appSettings + unless (federation || null remoteRecips) $ + throwE "Federation disabled, but remote recipients specified" + mfollowee <- do + let ObjURI h luObject = uObject + local <- hostIsLocal h + if local + then Just <$> do + route <- + fromMaybeE + (decodeRouteLocal luObject) + "Follow object isn't a valid route" + followee <- + fromMaybeE + (parseFollowee route) + "Follow object isn't a followee route" + let actor = followeeActor followee + unless (actorRecips actor == localRecips) $ + throwE "Follow object isn't the recipient" + case followee of + FolloweeSharer shr | shr == shrUser -> + throwE "User trying to follow themselves" + _ -> return () + return (followee, actor) + else do + unless (null localRecips) $ + throwE "Follow object is remote but local recips listed" + return Nothing + let dont = Authority "dont-do.any-forwarding" Nothing + (obiidFollow, doc, remotesHttp) <- runDBExcept $ do + Entity pidAuthor personAuthor <- lift $ getAuthor shrUser + let ibidAuthor = personInbox personAuthor + obidAuthor = personOutbox personAuthor + (obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox obidAuthor + for_ mfollowee $ \ (followee, actorRecip) -> do + (fsid, ibidRecip, unread, obidRecip) <- getFollowee followee + lift $ do + deliverFollowLocal pidAuthor fsid unread obiidFollow ibidRecip + obiidAccept <- insertAcceptToOutbox luFollow actorRecip obidRecip + deliverAcceptLocal obiidAccept ibidAuthor + remotesHttp <- lift $ deliverRemoteDB' dont obiidFollow remoteRecips [] + return (obiidFollow, doc, remotesHttp) + lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp dont obiidFollow doc remotesHttp + return obiidFollow + where + parseFollowee (SharerR shr) = Just $ FolloweeSharer shr + parseFollowee (ProjectR shr prj) = Just $ FolloweeProject shr prj + parseFollowee (TicketR shr prj num) = Just $ FolloweeTicket shr prj num + parseFollowee (RepoR shr rp) = Just $ FolloweeRepo shr rp + parseFollowee _ = Nothing + + followeeActor (FolloweeSharer shr) = LocalActorSharer shr + followeeActor (FolloweeProject shr prj) = LocalActorProject shr prj + followeeActor (FolloweeTicket shr prj _) = LocalActorProject shr prj + followeeActor (FolloweeRepo shr rp) = LocalActorRepo shr rp + + getAuthor shr = do + sid <- getKeyBy404 $ UniqueSharer shr + getBy404 $ UniquePersonIdent sid + + getFollowee (FolloweeSharer shr) = do + msid <- lift $ getKeyBy $ UniqueSharer shr + sid <- fromMaybeE msid "Follow object: No such sharer in DB" + mval <- runMaybeT + $ Left <$> MaybeT (lift $ getValBy $ UniquePersonIdent sid) + <|> Right <$> MaybeT (lift $ getValBy $ UniqueGroup sid) + val <- + fromMaybeE mval $ + "Found non-person non-group sharer: " <> shr2text shr + case val of + Left person -> return (personFollowers person, personInbox person, True, personOutbox person) + Right _group -> throwE "Follow object is a group" + getFollowee (FolloweeProject shr prj) = do + mproject <- lift $ runMaybeT $ do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + MaybeT $ getValBy $ UniqueProject prj sid + project <- fromMaybeE mproject "Follow object: No such project in DB" + return (projectFollowers project, projectInbox project, False, projectOutbox project) + getFollowee (FolloweeTicket shr prj num) = do + mproject <- lift $ runMaybeT $ do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + Entity jid project <- MaybeT $ getBy $ UniqueProject prj sid + ticket <- MaybeT $ getValBy $ UniqueTicket jid num + return (ticket, project) + (ticket, project) <- fromMaybeE mproject "Follow object: No such ticket in DB" + return (ticketFollowers ticket, projectInbox project, False, projectOutbox project) + getFollowee (FolloweeRepo shr rp) = do + mrepo <- lift $ runMaybeT $ do + sid <- MaybeT $ getKeyBy $ UniqueSharer shr + MaybeT $ getValBy $ UniqueRepo rp sid + repo <- fromMaybeE mrepo "Follow object: No such repo in DB" + return (repoFollowers repo, repoInbox repo, False, repoOutbox repo) + + insertFollowToOutbox obid = do + hLocal <- asksSite siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + let activity mluAct = Doc hLocal Activity + { activityId = mluAct + , activityActor = encodeRouteLocal $ SharerR shrUser + , activitySummary = Just summary + , activityAudience = audience + , activitySpecific = FollowActivity follow + } + now <- liftIO getCurrentTime + obiid <- insert OutboxItem + { outboxItemOutbox = obid + , outboxItemActivity = + persistJSONObjectFromDoc $ activity Nothing + , outboxItemPublished = now + } + obikhid <- encodeKeyHashid obiid + let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid + doc = activity $ Just luAct + update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (obiid, doc, luAct) + + deliverFollowLocal pidAuthor fsid unread obiid ibidRecip = do + insert_ $ Follow pidAuthor fsid True True + ibiid <- insert $ InboxItem unread + insert_ $ InboxItemLocal ibidRecip obiid ibiid + + insertAcceptToOutbox luFollow actorRecip obidRecip = do + now <- liftIO getCurrentTime + summary <- + TextHtml . TL.toStrict . renderHtml <$> + withUrlRenderer + [hamlet| +

+ + #{shr2text shrUser} + 's follow request accepted by # + + #{localUriPath $ objUriLocal uObject} + |] + hLocal <- asksSite siteInstanceHost + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + let recips = [encodeRouteHome $ SharerR shrUser] + accept mluAct = Doc hLocal Activity + { activityId = mluAct + , activityActor = objUriLocal uObject + , activitySummary = Just summary + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = ObjURI hLocal luFollow + , acceptResult = Nothing + } + } + obiid <- insert OutboxItem + { outboxItemOutbox = obidRecip + , outboxItemActivity = + persistJSONObjectFromDoc $ accept Nothing + , outboxItemPublished = now + } + obikhid <- encodeKeyHashid obiid + let luAct = encodeRouteLocal $ actorOutboxItem actorRecip obikhid + doc = accept $ Just luAct + update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return obiid + where + actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr + actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj + actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp + + deliverAcceptLocal obiidAccept ibidAuthor = do + ibiid <- insert $ InboxItem True + insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid + offerTicketC :: ShrIdent -> TextHtml @@ -498,7 +683,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT else verifyOnlySharer lsrSet where offerRecips prj = LocalSharerRelatedSet - { localRecipSharerDirect = LocalSharerDirectSet False + { localRecipSharerDirect = LocalSharerDirectSet False False , localRecipProjectRelated = [ ( prj , LocalProjectRelatedSet @@ -508,10 +693,13 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT } ) ] + , localRecipRepoRelated = [] } - verifyOnlySharer lsrSet = + verifyOnlySharer lsrSet = do unless (null $ localRecipProjectRelated lsrSet) $ throwE "Unexpected recipients unrelated to offer target" + unless (null $ localRecipRepoRelated lsrSet) $ + throwE "Unexpected recipients unrelated to offer target" insertToOutbox now obid = do hLocal <- asksSite siteInstanceHost let activity mluAct = Doc hLocal Activity @@ -534,7 +722,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (obiid, doc, luAct) deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do - (pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer projects) -> do + (pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer projects _) -> do (pids, remotes) <- traverseCollect (uncurry $ deliverLocalProject shr) projects pids' <- do @@ -629,7 +817,8 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT , activitySpecific = AcceptActivity Accept { acceptObject = ObjURI hLocal luOffer , acceptResult = - encodeRouteLocal $ TicketR shrProject prjProject num + Just $ encodeRouteLocal $ + TicketR shrProject prjProject num } } obiid <- insert OutboxItem diff --git a/src/Vervis/API/Recipient.hs b/src/Vervis/API/Recipient.hs index 92691a3..b24c509 100644 --- a/src/Vervis/API/Recipient.hs +++ b/src/Vervis/API/Recipient.hs @@ -14,13 +14,15 @@ -} module Vervis.API.Recipient - ( LocalTicketDirectSet (..) + ( LocalActor (..) + , LocalTicketDirectSet (..) , LocalProjectDirectSet (..) , LocalProjectRelatedSet (..) , LocalSharerDirectSet (..) , LocalSharerRelatedSet (..) , LocalRecipientSet , parseAudience + , actorRecips ) where @@ -32,6 +34,7 @@ import Data.Either import Data.Foldable import Data.List ((\\)) import Data.List.NonEmpty (NonEmpty, nonEmpty) +import Data.Maybe import Data.Text (Text) import Data.Traversable @@ -62,20 +65,27 @@ import Vervis.Model.Ident data LocalActor = LocalActorSharer ShrIdent | LocalActorProject ShrIdent PrjIdent + | LocalActorRepo ShrIdent RpIdent parseLocalActor :: Route App -> Maybe LocalActor parseLocalActor (SharerR shr) = Just $ LocalActorSharer shr parseLocalActor (ProjectR shr prj) = Just $ LocalActorProject shr prj +parseLocalActor (RepoR shr rp) = Just $ LocalActorRepo shr rp parseLocalActor _ = Nothing data LocalPersonCollection - = LocalPersonCollectionProjectTeam ShrIdent PrjIdent + = LocalPersonCollectionSharerFollowers ShrIdent + | LocalPersonCollectionProjectTeam ShrIdent PrjIdent | LocalPersonCollectionProjectFollowers ShrIdent PrjIdent | LocalPersonCollectionTicketTeam ShrIdent PrjIdent Int | LocalPersonCollectionTicketFollowers ShrIdent PrjIdent Int + | LocalPersonCollectionRepoTeam ShrIdent RpIdent + | LocalPersonCollectionRepoFollowers ShrIdent RpIdent parseLocalPersonCollection :: Route App -> Maybe LocalPersonCollection +parseLocalPersonCollection (SharerFollowersR shr) = + Just $ LocalPersonCollectionSharerFollowers shr parseLocalPersonCollection (ProjectTeamR shr prj) = Just $ LocalPersonCollectionProjectTeam shr prj parseLocalPersonCollection (ProjectFollowersR shr prj) = @@ -84,6 +94,10 @@ parseLocalPersonCollection (TicketTeamR shr prj num) = Just $ LocalPersonCollectionTicketTeam shr prj num parseLocalPersonCollection (TicketParticipantsR shr prj num) = Just $ LocalPersonCollectionTicketFollowers shr prj num +parseLocalPersonCollection (RepoTeamR shr rp) = + Just $ LocalPersonCollectionRepoTeam shr rp +parseLocalPersonCollection (RepoFollowersR shr rp) = + Just $ LocalPersonCollectionRepoFollowers shr rp parseLocalPersonCollection _ = Nothing parseLocalRecipient @@ -113,13 +127,24 @@ data LocalProjectRecipient | LocalTicketRelated Int LocalTicketRecipientDirect deriving (Eq, Ord) +data LocalRepoRecipientDirect + = LocalRepo + | LocalRepoTeam + | LocalRepoFollowers + deriving (Eq, Ord) + +data LocalRepoRecipient = LocalRepoDirect LocalRepoRecipientDirect + deriving (Eq, Ord) + data LocalSharerRecipientDirect = LocalSharer + | LocalSharerFollowers deriving (Eq, Ord) data LocalSharerRecipient = LocalSharerDirect LocalSharerRecipientDirect | LocalProjectRelated PrjIdent LocalProjectRecipient + | LocalRepoRelated RpIdent LocalRepoRecipient deriving (Eq, Ord) data LocalGroupedRecipient = LocalSharerRelated ShrIdent LocalSharerRecipient @@ -131,9 +156,14 @@ groupedRecipientFromActor (LocalActorSharer shr) = groupedRecipientFromActor (LocalActorProject shr prj) = LocalSharerRelated shr $ LocalProjectRelated prj $ LocalProjectDirect LocalProject +groupedRecipientFromActor (LocalActorRepo shr rp) = + LocalSharerRelated shr $ LocalRepoRelated rp $ LocalRepoDirect LocalRepo groupedRecipientFromCollection :: LocalPersonCollection -> LocalGroupedRecipient +groupedRecipientFromCollection + (LocalPersonCollectionSharerFollowers shr) = + LocalSharerRelated shr $ LocalSharerDirect LocalSharerFollowers groupedRecipientFromCollection (LocalPersonCollectionProjectTeam shr prj) = LocalSharerRelated shr $ LocalProjectRelated prj $ @@ -150,6 +180,14 @@ groupedRecipientFromCollection (LocalPersonCollectionTicketFollowers shr prj num) = LocalSharerRelated shr $ LocalProjectRelated prj $ LocalTicketRelated num LocalTicketFollowers +groupedRecipientFromCollection + (LocalPersonCollectionRepoTeam shr rp) = + LocalSharerRelated shr $ LocalRepoRelated rp $ + LocalRepoDirect LocalRepoTeam +groupedRecipientFromCollection + (LocalPersonCollectionRepoFollowers shr rp) = + LocalSharerRelated shr $ LocalRepoRelated rp $ + LocalRepoDirect LocalRepoFollowers ------------------------------------------------------------------------------- -- Recipient set types @@ -179,14 +217,28 @@ data LocalProjectRelatedSet = LocalProjectRelatedSet } deriving Eq +data LocalRepoDirectSet = LocalRepoDirectSet + { localRecipRepo :: Bool + , localRecipRepoTeam :: Bool + , localRecipRepoFollowers :: Bool + } + deriving Eq + +data LocalRepoRelatedSet = LocalRepoRelatedSet + { localRecipRepoDirect :: LocalRepoDirectSet + } + deriving Eq + data LocalSharerDirectSet = LocalSharerDirectSet - { localRecipSharer :: Bool + { localRecipSharer :: Bool + , localRecipSharerFollowers :: Bool } deriving Eq data LocalSharerRelatedSet = LocalSharerRelatedSet { localRecipSharerDirect :: LocalSharerDirectSet , localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)] + , localRecipRepoRelated :: [(RpIdent, LocalRepoRelatedSet)] } deriving Eq @@ -199,19 +251,24 @@ groupLocalRecipients (\ (LocalSharerRelated shr _) -> shr) (\ (LocalSharerRelated _ lsr) -> lsr) where - lsr2set = uncurry mk . partitionEithers . map lsr2e . NE.toList + lsr2set = mk . partitionEithers3 . map lsr2e . NE.toList where lsr2e (LocalSharerDirect d) = Left d - lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr) - mk ds ts = + lsr2e (LocalProjectRelated prj lpr) = Right $ Left (prj, lpr) + lsr2e (LocalRepoRelated rp lrr) = Right $ Right (rp, lrr) + mk (ds, ps, rs) = LocalSharerRelatedSet (lsrs2set ds) - (map (second lpr2set) $ groupWithExtract fst snd ts) + (map (second lpr2set) $ groupWithExtract fst snd ps) + (map (second lrr2set) $ groupWithExtract fst snd rs) where lsrs2set = foldl' f initial where - initial = LocalSharerDirectSet False - f s LocalSharer = s { localRecipSharer = True } + initial = LocalSharerDirectSet False False + f s LocalSharer = + s { localRecipSharer = True } + f s LocalSharerFollowers = + s { localRecipSharerFollowers = True } lpr2set = uncurry mk . partitionEithers . map lpr2e . NE.toList where lpr2e (LocalProjectDirect d) = Left d @@ -237,6 +294,16 @@ groupLocalRecipients s { localRecipTicketTeam = True } f s LocalTicketFollowers = s { localRecipTicketFollowers = True } + lrr2set = LocalRepoRelatedSet . foldl' f initial . NE.map unwrap + where + unwrap (LocalRepoDirect d) = d + initial = LocalRepoDirectSet False False False + f s LocalRepo = s { localRecipRepo = True } + f s LocalRepoTeam = s { localRecipRepoTeam = True } + f s LocalRepoFollowers = s { localRecipRepoFollowers = True } + partitionEithers3 = adapt . second partitionEithers . partitionEithers + where + adapt (l1, (l2, l3)) = (l1, l2, l3) ------------------------------------------------------------------------------- -- Parse URIs into a grouped recipient set @@ -299,3 +366,20 @@ parseAudience audience = do where groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)] groupByHost = groupAllExtract objUriAuthority objUriLocal + +actorIsMember :: LocalActor -> LocalRecipientSet -> Bool +actorIsMember (LocalActorSharer shr) lrSet = + case lookup shr lrSet of + Just lsrSet -> localRecipSharer $ localRecipSharerDirect lsrSet + Nothing -> False +actorIsMember (LocalActorProject shr prj) lrSet = fromMaybe False $ do + lsrSet <- lookup shr lrSet + lprSet <- lookup prj $ localRecipProjectRelated lsrSet + return $ localRecipProject $ localRecipProjectDirect $ lprSet +actorIsMember (LocalActorRepo shr rp) lrSet = fromMaybe False $ do + lsrSet <- lookup shr lrSet + lrrSet <- lookup rp $ localRecipRepoRelated lsrSet + return $ localRecipRepo $ localRecipRepoDirect $ lrrSet + +actorRecips :: LocalActor -> LocalRecipientSet +actorRecips = groupLocalRecipients . (: []) . groupedRecipientFromActor diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index d6c65d1..a2da78c 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -398,7 +398,8 @@ projectOfferTicketF (objUriAuthority $ remoteAuthorURI author) luOffer , acceptResult = - encodeRouteLocal $ TicketR shrRecip prjRecip num + Just $ encodeRouteLocal $ + TicketR shrRecip prjRecip num } } obiid <- insert OutboxItem diff --git a/src/Vervis/Form/Repo.hs b/src/Vervis/Form/Repo.hs index f98979c..5a680d5 100644 --- a/src/Vervis/Form/Repo.hs +++ b/src/Vervis/Form/Repo.hs @@ -100,6 +100,7 @@ editRepoAForm sid (Entity rid repo) = Repo <*> aopt selectRole "User role" (Just $ repoCollabUser repo) <*> aopt selectRole "Guest role" (Just $ repoCollabAnon repo) <*> pure (repoInbox repo) + <*> pure (repoOutbox repo) <*> pure (repoFollowers repo) where selectProject' = selectProjectForExisting (repoSharer repo) rid diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 3a11c63..879056d 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -793,6 +793,10 @@ instance YesodBreadcrumbs App where ReposR shar -> ("Repos", Just $ SharerR shar) RepoNewR shar -> ("New", Just $ ReposR shar) RepoR shar repo -> (rp2text repo, Just $ ReposR shar) + RepoOutboxR shr rp -> ("Outbox", Just $ RepoR shr rp) + RepoOutboxItemR shr rp hid -> ( "#" <> keyHashidText hid + , Just $ RepoOutboxR shr rp + ) RepoEditR shr rp -> ("Edit", Just $ RepoR shr rp) RepoSourceR shar repo [] -> ("Files", Just $ RepoR shar repo) RepoSourceR shar repo refdir -> ( last refdir diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 216930c..50b166c 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -27,6 +27,8 @@ module Vervis.Handler.Inbox , postSharerOutboxR , getProjectOutboxR , getProjectOutboxItemR + , getRepoOutboxR + , getRepoOutboxItemR , getActorKey1R , getActorKey2R , getNotificationsR @@ -39,24 +41,15 @@ import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar') import Control.Exception hiding (Handler) import Control.Monad import Control.Monad.IO.Class (liftIO) -import Control.Monad.Logger.CallStack import Control.Monad.STM (atomically) import Control.Monad.Trans.Except -import Control.Monad.Trans.Maybe -import Crypto.Error (CryptoFailable (..)) -import Crypto.PubKey.Ed25519 (publicKey, signature, verify) import Data.Aeson import Data.Aeson.Encode.Pretty -import Data.Bifunctor import Data.Bitraversable import Data.Foldable (for_) -import Data.HashMap.Strict (HashMap) import Data.List -import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe -import Data.PEM (PEM (..)) import Data.Text (Text) -import Data.Text.Encoding (encodeUtf8, decodeUtf8') import Data.Text.Lazy.Encoding (decodeUtf8) import Data.Time.Clock import Data.Time.Interval (TimeInterval, toTimeUnit) @@ -64,18 +57,12 @@ import Data.Time.Units (Second) import Data.Traversable import Database.Persist import Database.Persist.Sql -import Network.HTTP.Client (Manager, HttpException, requestFromURI) -import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader) -import Network.HTTP.Types.Header (hDate, hHost) import Network.HTTP.Types.Status import Text.Blaze.Html (Html, preEscapedToHtml) import Text.Blaze.Html.Renderer.Text import Text.HTML.SanitizeXSS import Text.Shakespeare.I18N (RenderMessage) -import UnliftIO.Exception (try) -import Yesod.Auth (requireAuth) import Yesod.Core -import Yesod.Core.Json (requireJsonBody) import Yesod.Core.Handler import Yesod.Form.Fields import Yesod.Form.Functions @@ -83,20 +70,11 @@ import Yesod.Form.Types import Yesod.Persist.Core import qualified Data.ByteString.Char8 as BC (unpack) -import qualified Data.ByteString.Lazy as BL -import qualified Data.CaseInsensitive as CI (mk) -import qualified Data.HashMap.Strict as M (lookup, insert, adjust, fromList) +import qualified Data.HashMap.Strict as M import qualified Data.Text as T import qualified Data.Text.Lazy as TL (toStrict) -import qualified Data.Text.Lazy.Builder as TLB import qualified Data.Vector as V import qualified Database.Esqueleto as E -import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders) - -import Network.HTTP.Signature hiding (Algorithm (..)) -import Yesod.HttpSignature (verifyRequestSignature) - -import qualified Network.HTTP.Signature as S (Algorithm (..)) import Database.Persist.JSON import Network.FedURI @@ -107,8 +85,6 @@ import Yesod.FedURI import Yesod.Hashids import Yesod.RenderSource -import qualified Data.Aeson.Encode.Pretty.ToEncoding as AEP - import Data.Aeson.Local import Data.Either.Local import Data.EventTime.Local @@ -127,8 +103,6 @@ import Vervis.Foundation import Vervis.Model hiding (Ticket) import Vervis.Model.Ident import Vervis.Paginate -import Vervis.RemoteActorStore -import Yesod.RenderSource import Vervis.Settings getShowTime = showTime <$> liftIO getCurrentTime @@ -433,8 +407,20 @@ openTicketForm html = do deft = "Time slows down when tasting coconut ice-cream" defd = "Is that slow-motion effect intentional? :)" -activityWidget :: ShrIdent -> Widget -> Enctype -> Widget -> Enctype -> Widget -activityWidget shr widget1 enctype1 widget2 enctype2 = +followForm :: Form (FedURI, FedURI) +followForm = renderDivs $ (,) + <$> areq fedUriField "Target" (Just deft) + <*> areq fedUriField "Recipient" (Just deft) + where + deft = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33" + +activityWidget + :: ShrIdent + -> Widget -> Enctype + -> Widget -> Enctype + -> Widget -> Enctype + -> Widget +activityWidget shr widget1 enctype1 widget2 enctype2 widget3 enctype3 = [whamlet|

Publish a ticket comment
@@ -445,6 +431,11 @@ activityWidget shr widget1 enctype1 widget2 enctype2 = ^{widget2} + +

Follow a person, a projet or a repo + + ^{widget3} + |] getUserShrIdent :: Handler ShrIdent @@ -460,7 +451,10 @@ getPublishR = do runFormPost $ identifyForm "f1" publishCommentForm ((_result2, widget2), enctype2) <- runFormPost $ identifyForm "f2" openTicketForm - defaultLayout $ activityWidget shr widget1 enctype1 widget2 enctype2 + ((_result3, widget3), enctype3) <- + runFormPost $ identifyForm "f3" followForm + defaultLayout $ + activityWidget shr widget1 enctype1 widget2 enctype2 widget3 enctype3 getOutbox :: Route App -> AppDB OutboxId -> Handler TypedContent getOutbox here getObid = do @@ -553,7 +547,12 @@ postSharerOutboxR shrAuthor = do runFormPost $ identifyForm "f1" publishCommentForm ((result2, widget2), enctype2) <- runFormPost $ identifyForm "f2" openTicketForm - let result = Left <$> result1 <|> Right <$> result2 + ((result3, widget3), enctype3) <- + runFormPost $ identifyForm "f3" followForm + let result + = Left <$> result1 + <|> Right . Left <$> result2 + <|> Right . Right <$> result3 eid <- runExceptT $ do input <- @@ -561,7 +560,7 @@ postSharerOutboxR shrAuthor = do FormMissing -> throwE "Field(s) missing" FormFailure _l -> throwE "Invalid input, see below" FormSuccess r -> return r - bitraverse publishComment openTicket input + bitraverse publishComment (bitraverse openTicket follow) input case eid of Left err -> setMessage $ toHtml err Right id_ -> @@ -571,9 +570,16 @@ postSharerOutboxR shrAuthor = do renderUrl <- getUrlRender let u = renderUrl $ MessageR shrAuthor lmkhid setMessage $ toHtml $ "Message created! ID: " <> u - Right _obiid -> + Right (Left _obiid) -> setMessage "Ticket offer published!" - defaultLayout $ activityWidget shrAuthor widget1 enctype1 widget2 enctype2 + Right (Right _obiid) -> + setMessage "Follow request published!" + defaultLayout $ + activityWidget + shrAuthor + widget1 enctype1 + widget2 enctype2 + widget3 enctype3 where publishComment ((hTicket, shrTicket, prj, num), muParent, msg) = do encodeRouteFed <- getEncodeRouteHome @@ -656,6 +662,25 @@ postSharerOutboxR shrAuthor = do , audienceNonActors = map (encodeRouteFed h) recipsC } ExceptT $ offerTicketC shrAuthor summary audience offer + follow (uObject@(ObjURI hObject luObject), uRecip) = do + summary <- + TextHtml . TL.toStrict . renderHtml <$> + withUrlRenderer + [hamlet| +

+ + #{shr2text shrAuthor} + \ requested to follow # + + #{renderAuthority hObject}#{localUriPath luObject} + \. + |] + let followAP = followAP + { followObject = uObject + , followHide = False + } + audience = Audience [uRecip] [] [] [] [] [] + ExceptT $ followC shrAuthor summary audience followAP getProjectOutboxR :: ShrIdent -> PrjIdent -> Handler TypedContent getProjectOutboxR shr prj = getOutbox here getObid @@ -676,6 +701,25 @@ getProjectOutboxItemR shr prj obikhid = getOutboxItem here getObid obikhid j <- getValBy404 $ UniqueProject prj sid return $ projectOutbox j +getRepoOutboxR :: ShrIdent -> RpIdent -> Handler TypedContent +getRepoOutboxR shr rp = getOutbox here getObid + where + here = RepoOutboxR shr rp + getObid = do + sid <- getKeyBy404 $ UniqueSharer shr + r <- getValBy404 $ UniqueRepo rp sid + return $ repoOutbox r + +getRepoOutboxItemR + :: ShrIdent -> RpIdent -> KeyHashid OutboxItem -> Handler TypedContent +getRepoOutboxItemR shr rp obikhid = getOutboxItem here getObid obikhid + where + here = RepoOutboxItemR shr rp obikhid + getObid = do + sid <- getKeyBy404 $ UniqueSharer shr + r <- getValBy404 $ UniqueRepo rp sid + return $ repoOutbox r + getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent getActorKey choose route = do actorKey <- diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index e874996..6642299 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -159,6 +159,7 @@ postReposR user = do pid <- requireAuthId runDB $ do ibid <- insert Inbox + obid <- insert Outbox fsid <- insert FollowerSet let repo = Repo { repoIdent = nrpIdent nrp @@ -170,6 +171,7 @@ postReposR user = do , repoCollabUser = Nothing , repoCollabAnon = Nothing , repoInbox = ibid + , repoOutbox = obid , repoFollowers = fsid } rid <- insert repo @@ -213,10 +215,14 @@ getRepoR shr rp = do , actorName = Just $ rp2text rp , actorSummary = repoDesc repo , actorInbox = encodeRouteLocal $ RepoInboxR shr rp - , actorOutbox = Nothing + , actorOutbox = + Just $ encodeRouteLocal $ RepoOutboxR shr rp , actorFollowers = Just $ encodeRouteLocal $ RepoFollowersR shr rp - , actorPublicKeys = [] + , actorPublicKeys = + [ Left $ encodeRouteLocal ActorKey1R + , Left $ encodeRouteLocal ActorKey2R + ] } , AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp } diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 22d3cb7..a121a2c 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -941,7 +941,8 @@ changes hLocal ctx = , activitySpecific = AcceptActivity Accept { acceptObject = encodeRouteHome offerR , acceptResult = - encodeRouteLocal $ TicketR shrProject prj num + Just $ encodeRouteLocal $ + TicketR shrProject prj num } } obiidNew <- insert OutboxItem20190624 @@ -1054,6 +1055,20 @@ changes hLocal ctx = , addFieldPrimRequired "Follow" True "public" -- 137 , addFieldPrimRequired "RemoteFollow" True "public" + -- 138 + , addFieldRefRequired' + "Repo" + Outbox138 + (Just $ do + rids <- selectKeysList ([] :: [Filter Repo138]) [] + for_ rids $ \ rid -> do + obid <- insert Outbox138 + update rid [Repo138Outbox =. obid] + ) + "outbox" + "Outbox" + -- 139 + , addUnique "Repo" $ Unique "UniqueRepoOutbox" ["outbox"] ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index d6464c1..164022b 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -122,6 +122,8 @@ module Vervis.Migration.Model , FollowerSet130Generic (..) , Repo130 , Person130 + , Outbox138Generic (..) + , Repo138 ) where @@ -246,3 +248,6 @@ makeEntitiesMigration "127" makeEntitiesMigration "130" $(modelFile "migrations/2019_09_06.model") + +makeEntitiesMigration "138" + $(modelFile "migrations/2019_09_10.model") diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index c686bf7..6482c23 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -975,19 +975,19 @@ instance ActivityPub Branch where data Accept u = Accept { acceptObject :: ObjURI u - , acceptResult :: LocalURI + , acceptResult :: Maybe LocalURI } parseAccept :: UriMode u => Authority u -> Object -> Parser (Accept u) parseAccept a o = Accept <$> o .: "object" - <*> withAuthorityO a (o .: "result") + <*> withAuthorityMaybeO a (o .:? "result") encodeAccept :: UriMode u => Authority u -> Accept u -> Series -encodeAccept authority (Accept obj result) - = "object" .= obj - <> "result" .= ObjURI authority result +encodeAccept authority (Accept obj mresult) + = "object" .= obj + <> "result" .=? (ObjURI authority <$> mresult) data Create u = Create { createObject :: Note u