From 5a7700ffe45d91a779ea6f2ff3e955830c497871 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 25 Sep 2019 10:43:05 +0000 Subject: [PATCH] Implement remote following, disable automatic following This patch contains migrations that require that there are no follow records. If you have any, the migration will (hopefully) fail and you'll need to manually delete any follow records you have. In the next patch I'll try to add automatic following on the pseudo-client side by running both e.g. createNoteC and followC in the same POST request handler. --- config/models | 30 ++ config/routes | 4 + migrations/2019_09_25.model | 21 ++ src/Vervis/API.hs | 28 +- src/Vervis/Application.hs | 1 + src/Vervis/Client.hs | 99 ++++++ src/Vervis/Federation/Discussion.hs | 2 +- src/Vervis/Federation/Offer.hs | 229 ++++++------ src/Vervis/Federation/Ticket.hs | 2 +- src/Vervis/Foundation.hs | 4 + src/Vervis/Handler/Client.hs | 528 ++++++++++++++++++++++++++++ src/Vervis/Handler/Inbox.hs | 411 +--------------------- src/Vervis/Migration.hs | 18 + src/Vervis/Migration/Model.hs | 4 + src/Web/ActivityPub.hs | 31 +- src/Yesod/MonadSite.hs | 6 + vervis.cabal | 2 + 17 files changed, 860 insertions(+), 560 deletions(-) create mode 100644 migrations/2019_09_25.model create mode 100644 src/Vervis/Client.hs create mode 100644 src/Vervis/Handler/Client.hs diff --git a/config/models b/config/models index 625349d..5a5238e 100644 --- a/config/models +++ b/config/models @@ -149,6 +149,28 @@ RemoteCollection UniqueRemoteCollection instance ident +FollowRemoteRequest + person PersonId + target FedURI + recip FedURI Maybe + public Bool + activity OutboxItemId + + UniqueFollowRemoteRequest person target + UniqueFollowRemoteRequestActivity activity + +FollowRemote + person PersonId + recip RemoteActorId -- actor managing the followed object + target FedURI -- the followed object + public Bool + follow OutboxItemId + accept RemoteActivityId + + UniqueFollowRemote person target + UniqueFollowRemoteFollow follow + UniqueFollowRemoteAccept accept + FollowerSet Follow @@ -156,16 +178,24 @@ Follow target FollowerSetId manual Bool public Bool + follow OutboxItemId + accept OutboxItemId UniqueFollow person target + UniqueFollowFollow follow + UniqueFollowAccept accept RemoteFollow actor RemoteActorId target FollowerSetId manual Bool public Bool + follow RemoteActivityId + accept OutboxItemId UniqueRemoteFollow actor target + UniqueRemoteFollowFollow follow + UniqueRemoteFollowAccept accept SshKey ident KyIdent diff --git a/config/routes b/config/routes index 263f58a..b5519df 100644 --- a/config/routes +++ b/config/routes @@ -63,6 +63,7 @@ /s/#ShrIdent/outbox SharerOutboxR GET POST /s/#ShrIdent/outbox/#OutboxItemKeyHashid SharerOutboxItemR GET /s/#ShrIdent/followers SharerFollowersR GET +/s/#ShrIdent/follow SharerFollowR POST /p PeopleR GET @@ -91,6 +92,7 @@ /s/#ShrIdent/r/#RpIdent/team RepoTeamR GET /s/#ShrIdent/r/#RpIdent/followers RepoFollowersR GET /s/#ShrIdent/r/#RpIdent/edit RepoEditR GET +/s/#ShrIdent/r/#RpIdent/follow RepoFollowR POST /s/#ShrIdent/r/#RpIdent/s/+Texts RepoSourceR GET /s/#ShrIdent/r/#RpIdent/c RepoHeadChangesR GET /s/#ShrIdent/r/#RpIdent/b/#Text RepoBranchR GET @@ -114,6 +116,7 @@ /s/#ShrIdent/p/#PrjIdent/team ProjectTeamR GET /s/#ShrIdent/p/#PrjIdent/followers ProjectFollowersR GET /s/#ShrIdent/p/#PrjIdent/edit ProjectEditR GET +/s/#ShrIdent/p/#PrjIdent/follow ProjectFollowR POST /s/#ShrIdent/p/#PrjIdent/d ProjectDevsR GET POST /s/#ShrIdent/p/#PrjIdent/d/!new ProjectDevNewR GET /s/#ShrIdent/p/#PrjIdent/d/#ShrIdent ProjectDevR GET DELETE POST @@ -149,6 +152,7 @@ /s/#ShrIdent/p/#PrjIdent/t/#Int/unclaim TicketUnclaimR POST /s/#ShrIdent/p/#PrjIdent/t/#Int/assign TicketAssignR GET POST /s/#ShrIdent/p/#PrjIdent/t/#Int/unassign TicketUnassignR POST +/s/#ShrIdent/p/#PrjIdent/t/#Int/follow TicketFollowR POST /s/#ShrIdent/p/#PrjIdent/tcr ClaimRequestsProjectR GET /s/#ShrIdent/p/#PrjIdent/t/#Int/cr ClaimRequestsTicketR GET POST /s/#ShrIdent/p/#PrjIdent/t/#Int/cr/new ClaimRequestNewR GET diff --git a/migrations/2019_09_25.model b/migrations/2019_09_25.model new file mode 100644 index 0000000..6fbf6c6 --- /dev/null +++ b/migrations/2019_09_25.model @@ -0,0 +1,21 @@ +FollowRemoteRequest + person PersonId + target FedURI + recip FedURI Maybe + public Bool + activity OutboxItemId + + UniqueFollowRemoteRequest person target + UniqueFollowRemoteRequestActivity activity + +FollowRemote + person PersonId + recip RemoteActorId -- actor managing the followed object + target FedURI -- the followed object + public Bool + follow OutboxItemId + accept RemoteActivityId + + UniqueFollowRemote person target + UniqueFollowRemoteFollow follow + UniqueFollowRemoteAccept accept diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 261ccbc..185873a 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -182,7 +182,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source unless (messageRoot m == did) $ throwE "Remote parent belongs to a different discussion" return mid - lift $ insertUnique_ $ Follow pid (ticketFollowers t) False True + -- lift $ insertUnique_ $ Follow pid (ticketFollowers t) False True return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject, fsidProject)) Nothing -> do (rd, rdnew) <- lift $ do @@ -452,7 +452,7 @@ followC -> Audience URIMode -> AP.Follow URIMode -> Handler (Either Text OutboxItemId) -followC shrUser summary audience follow@(AP.Follow uObject hide) = runExceptT $ do +followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = runExceptT $ do (localRecips, remoteRecips) <- do mrecips <- parseAudience audience fromMaybeE mrecips "Follow with no recipients" @@ -490,12 +490,14 @@ followC shrUser summary audience follow@(AP.Follow uObject hide) = runExceptT $ 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 + case mfollowee of + Nothing -> lift $ insert_ $ FollowRemoteRequest pidAuthor uObject muContext (not hide) obiidFollow + Just (followee, actorRecip) -> do + (fsid, ibidRecip, unread, obidRecip) <- getFollowee followee + lift $ do + obiidAccept <- insertAcceptToOutbox luFollow actorRecip obidRecip + deliverFollowLocal pidAuthor fsid unread obiidFollow obiidAccept ibidRecip + 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 @@ -572,10 +574,10 @@ followC shrUser summary audience follow@(AP.Follow uObject hide) = runExceptT $ update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] return (obiid, doc, luAct) - deliverFollowLocal pidAuthor fsid unread obiid ibidRecip = do - insert_ $ Follow pidAuthor fsid True (not hide) + deliverFollowLocal pidAuthor fsid unread obiidF obiidA ibidRecip = do + insert_ $ Follow pidAuthor fsid True (not hide) obiidF obiidA ibiid <- insert $ InboxItem unread - insert_ $ InboxItemLocal ibidRecip obiid ibiid + insert_ $ InboxItemLocal ibidRecip obiidF ibiid insertAcceptToOutbox luFollow actorRecip obidRecip = do now <- liftIO getCurrentTime @@ -854,13 +856,13 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT , ticketFollowers = fsid , ticketAccept = obiidAccept } - insert TicketAuthorLocal + insert_ TicketAuthorLocal { ticketAuthorLocalTicket = tid , ticketAuthorLocalAuthor = pidAuthor , ticketAuthorLocalOffer = obiid } --insertMany_ $ map (TicketDependency tid) tidsDeps - insert_ $ Follow pidAuthor fsid False True + -- insert_ $ Follow pidAuthor fsid False True publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do now <- liftIO getCurrentTime let dont = Authority "dont-do.any-forwarding" Nothing diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 1fd9a5e..6ab9853 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -83,6 +83,7 @@ import Vervis.RemoteActorStore -- Import all relevant handler modules here. -- Don't forget to add new modules to your cabal file! +import Vervis.Handler.Client import Vervis.Handler.Common import Vervis.Handler.Git import Vervis.Handler.Group diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs new file mode 100644 index 0000000..487f929 --- /dev/null +++ b/src/Vervis/Client.hs @@ -0,0 +1,99 @@ +{- This file is part of Vervis. + - + - Written in 2019 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.Client + ( follow + , followSharer + , followProject + , followTicket + , followRepo + ) +where + +import Text.Blaze.Html.Renderer.Text +import Text.Hamlet +import Yesod.Core +import Yesod.Core.Handler + +import qualified Data.Text.Lazy as TL + +import Network.FedURI +import Web.ActivityPub +import Yesod.FedURI +import Yesod.MonadSite + +import Vervis.FedURI +import Vervis.Foundation +import Vervis.Model.Ident + +follow + :: (MonadHandler m, HandlerSite m ~ App) + => ShrIdent -> ObjURI URIMode -> ObjURI URIMode -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode) +follow shrAuthor uObject@(ObjURI hObject luObject) uRecip hide = do + summary <- + TextHtml . TL.toStrict . renderHtml <$> + withUrlRenderer + [hamlet| +

+ + #{shr2text shrAuthor} + \ requested to follow # + + #{renderAuthority hObject}#{localUriPath luObject} + \. + |] + let followAP = Follow + { followObject = uObject + , followContext = + if uObject == uRecip + then Nothing + else Just uRecip + , followHide = hide + } + audience = Audience [uRecip] [] [] [] [] [] + return (summary, audience, followAP) + +followSharer + :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent -> ShrIdent -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode) +followSharer shrAuthor shrObject hide = do + encodeRouteHome <- getEncodeRouteHome + let uObject = encodeRouteHome $ SharerR shrObject + follow shrAuthor uObject uObject hide + +followProject + :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent -> ShrIdent -> PrjIdent -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode) +followProject shrAuthor shrObject prjObject hide = do + encodeRouteHome <- getEncodeRouteHome + let uObject = encodeRouteHome $ ProjectR shrObject prjObject + follow shrAuthor uObject uObject hide + +followTicket + :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent -> ShrIdent -> PrjIdent -> Int -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode) +followTicket shrAuthor shrObject prjObject numObject hide = do + encodeRouteHome <- getEncodeRouteHome + let uObject = encodeRouteHome $ TicketR shrObject prjObject numObject + uRecip = encodeRouteHome $ ProjectR shrObject prjObject + follow shrAuthor uObject uRecip hide + +followRepo + :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) + => ShrIdent -> ShrIdent -> RpIdent -> Bool -> m (TextHtml, Audience URIMode, Follow URIMode) +followRepo shrAuthor shrObject rpObject hide = do + encodeRouteHome <- getEncodeRouteHome + let uObject = encodeRouteHome $ RepoR shrObject rpObject + follow shrAuthor uObject uObject hide diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index d059366..1dc9067 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/src/Vervis/Federation/Discussion.hs @@ -318,7 +318,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent delete mid return Nothing Just _ -> do - insertUnique_ $ RemoteFollow raidAuthor fsid False True + -- insertUnique_ $ RemoteFollow raidAuthor fsid False True ibiid <- insert $ InboxItem False insert_ $ InboxItemRemote ibid ractid ibiid return $ Just (ractid, mid) diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index ace9f3f..4da4a05 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -29,6 +29,7 @@ import Control.Monad import Control.Monad.Logger.CallStack import Control.Monad.Trans.Class import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe import Data.Aeson import Data.Bifunctor import Data.Foldable @@ -75,20 +76,32 @@ import Vervis.Model import Vervis.Model.Ident import Vervis.Model.Ticket -acceptF - :: AppDB InboxId - -> Route App +sharerAcceptF + :: ShrIdent -> UTCTime -> RemoteAuthor -> ActivityBody -> Accept URIMode -> ExceptT Text Handler Text -acceptF getIbid route now author body (Accept _uOffer _luTicket) = do +sharerAcceptF shr now author body (Accept (ObjURI hOffer luOffer) _) = do luAccept <- fromMaybeE (activityId $ actbActivity body) "Accept without 'id'" lift $ runDB $ do - ibidRecip <- getIbid - insertToInbox luAccept ibidRecip + Entity pidRecip recip <- do + sid <- getKeyBy404 $ UniqueSharer shr + getBy404 $ UniquePersonIdent sid + mractid <- insertToInbox luAccept $ personInbox recip + encodeRouteLocal <- getEncodeRouteLocal + let me = localUriPath $ encodeRouteLocal $ SharerR shr + case mractid of + Nothing -> return $ "Activity already exists in inbox of " <> me + Just ractid -> do + mv <- insertFollow pidRecip (personOutbox recip) ractid + case mv of + Nothing -> + return $ "Activity inserted to inbox of " <> me + Just () -> + return $ "Accept received for follow request by " <> me where insertToInbox luAccept ibidRecip = do let iidAuthor = remoteAuthorInstance author @@ -98,76 +111,64 @@ acceptF getIbid route now author body (Accept _uOffer _luTicket) = do ibiid <- insert $ InboxItem True mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid encodeRouteLocal <- getEncodeRouteLocal - let recip = localUriPath $ encodeRouteLocal route case mibrid of Nothing -> do delete ibiid - return $ "Activity already exists in inbox of " <> recip - Just _ -> return $ "Activity inserted to inbox of " <> recip + return Nothing + Just _ -> return $ Just ractid + insertFollow pidRecip obidRecip ractidAccept = runMaybeT $ do + guard =<< hostIsLocal hOffer + route <- MaybeT . pure $ decodeRouteLocal luOffer + obiid <- + case route of + SharerOutboxItemR shr' obikhid + | shr == shr' -> decodeKeyHashidM obikhid + _ -> MaybeT $ pure Nothing + obi <- MaybeT $ get obiid + guard $ outboxItemOutbox obi == obidRecip + Entity frrid frr <- MaybeT $ getBy $ UniqueFollowRemoteRequestActivity obiid + guard $ followRemoteRequestPerson frr == pidRecip + let originalRecip = + case followRemoteRequestRecip frr of + Nothing -> followRemoteRequestTarget frr + Just u -> u + guard $ originalRecip == remoteAuthorURI author + lift $ delete frrid + lift $ insert_ FollowRemote + { followRemotePerson = pidRecip + , followRemoteRecip = remoteAuthorId author + , followRemoteTarget = followRemoteRequestTarget frr + , followRemotePublic = followRemoteRequestPublic frr + , followRemoteFollow = followRemoteRequestActivity frr + , followRemoteAccept = ractidAccept + } -sharerAcceptF +sharerRejectF :: ShrIdent -> UTCTime -> RemoteAuthor -> ActivityBody - -> Accept URIMode - -> ExceptT Text Handler Text -sharerAcceptF shr = acceptF getIbid route - where - route = SharerR shr - getIbid = do - sid <- getKeyBy404 $ UniqueSharer shr - p <- getValBy404 $ UniquePersonIdent sid - return $ personInbox p - -{- -projectAcceptF - :: ShrIdent - -> PrjIdent - -> UTCTime - -> RemoteAuthor - -> ActivityBody - -> Accept URIMode - -> ExceptT Text Handler Text -projectAcceptF shr prj = acceptF getIbid route - where - route = ProjectR shr prj - getIbid = do - sid <- getKeyBy404 $ UniqueSharer shr - j <- getValBy404 $ UniqueProject prj sid - return $ projectInbox j - -repoAcceptF - :: ShrIdent - -> RpIdent - -> UTCTime - -> RemoteAuthor - -> ActivityBody - -> Accept URIMode - -> ExceptT Text Handler Text -repoAcceptF shr rp = acceptF getIbid route - where - route = RepoR shr rp - getIbid = do - sid <- getKeyBy404 $ UniqueSharer shr - r <- getValBy404 $ UniqueRepo rp sid - return $ repoInbox r --} - -rejectF - :: AppDB InboxId - -> Route App - -> UTCTime - -> RemoteAuthor - -> ActivityBody -> Reject URIMode -> ExceptT Text Handler Text -rejectF getIbid route now author body (Reject _uOffer) = do +sharerRejectF shr now author body (Reject (ObjURI hOffer luOffer)) = do luReject <- fromMaybeE (activityId $ actbActivity body) "Reject without 'id'" lift $ runDB $ do - ibidRecip <- getIbid - insertToInbox luReject ibidRecip + Entity pidRecip recip <- do + sid <- getKeyBy404 $ UniqueSharer shr + getBy404 $ UniquePersonIdent sid + mractid <- insertToInbox luReject $ personInbox recip + encodeRouteLocal <- getEncodeRouteLocal + let me = localUriPath $ encodeRouteLocal $ SharerR shr + case mractid of + Nothing -> return $ "Activity already exists in inbox of " <> me + Just ractid -> do + mv <- deleteFollow pidRecip (personOutbox recip) + case mv of + Nothing -> + return $ "Activity inserted to inbox of " <> me + Just () -> + return $ "Reject received for follow request by " <> me where insertToInbox luReject ibidRecip = do let iidAuthor = remoteAuthorInstance author @@ -177,61 +178,29 @@ rejectF getIbid route now author body (Reject _uOffer) = do ibiid <- insert $ InboxItem True mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid encodeRouteLocal <- getEncodeRouteLocal - let recip = localUriPath $ encodeRouteLocal route case mibrid of Nothing -> do delete ibiid - return $ "Activity already exists in inbox of " <> recip - Just _ -> return $ "Activity inserted to inbox of " <> recip - -sharerRejectF - :: ShrIdent - -> UTCTime - -> RemoteAuthor - -> ActivityBody - -> Reject URIMode - -> ExceptT Text Handler Text -sharerRejectF shr = rejectF getIbid route - where - route = SharerR shr - getIbid = do - sid <- getKeyBy404 $ UniqueSharer shr - p <- getValBy404 $ UniquePersonIdent sid - return $ personInbox p - -{- -projectRejectF - :: ShrIdent - -> PrjIdent - -> UTCTime - -> RemoteAuthor - -> ActivityBody - -> Reject URIMode - -> ExceptT Text Handler Text -projectRejectF shr prj = rejectF getIbid route - where - route = ProjectR shr prj - getIbid = do - sid <- getKeyBy404 $ UniqueSharer shr - j <- getValBy404 $ UniqueProject prj sid - return $ projectInbox j - -repoRejectF - :: ShrIdent - -> RpIdent - -> UTCTime - -> RemoteAuthor - -> ActivityBody - -> Reject URIMode - -> ExceptT Text Handler Text -repoRejectF shr rp = rejectF getIbid route - where - route = RepoR shr rp - getIbid = do - sid <- getKeyBy404 $ UniqueSharer shr - r <- getValBy404 $ UniqueRepo rp sid - return $ repoInbox r --} + return Nothing + Just _ -> return $ Just ractid + deleteFollow pidRecip obidRecip = runMaybeT $ do + guard =<< hostIsLocal hOffer + route <- MaybeT . pure $ decodeRouteLocal luOffer + obiid <- + case route of + SharerOutboxItemR shr' obikhid + | shr == shr' -> decodeKeyHashidM obikhid + _ -> MaybeT $ pure Nothing + obi <- MaybeT $ get obiid + guard $ outboxItemOutbox obi == obidRecip + Entity frrid frr <- MaybeT $ getBy $ UniqueFollowRemoteRequestActivity obiid + guard $ followRemoteRequestPerson frr == pidRecip + let originalRecip = + case followRemoteRequestRecip frr of + Nothing -> followRemoteRequestTarget frr + Just u -> u + guard $ originalRecip == remoteAuthorURI author + lift $ delete frrid followF :: (Route App -> Maybe a) @@ -248,7 +217,7 @@ followF -> ExceptT Text Handler Text followF objRoute recipRoute getRecip recipInbox recipOutbox recipFollowers outboxItemRoute - now author body (AP.Follow (ObjURI hObj luObj) hide) = do + now author body (AP.Follow (ObjURI hObj luObj) _mcontext hide) = do mobj <- do local <- hostIsLocal hObj return $ @@ -265,15 +234,16 @@ followF emsg <- lift $ runDB $ do recip <- getRecip obj newItem <- insertToInbox luFollow $ recipInbox recip - if newItem - then do - newFollow <- insertFollow $ recipFollowers recip + case newItem of + Nothing -> return $ Left "Activity already exists in inbox, not using" + Just ractid -> do + (obiid, doc) <- + insertAcceptToOutbox + luFollow + (recipOutbox recip) + newFollow <- insertFollow ractid obiid $ recipFollowers recip if newFollow then Right <$> do - (obiid, doc) <- - insertAcceptToOutbox - luFollow - (recipOutbox recip) let raidAuthor = remoteAuthorId author ra <- getJust raidAuthor let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra) @@ -281,8 +251,9 @@ followF hAuthor = objUriAuthority $ remoteAuthorURI author hostSection = ((iidAuthor, hAuthor), raInfo :| []) (obiid, doc,) <$> deliverRemoteDB' dont obiid [] [hostSection] - else return $ Left "You're already a follower of me" - else return $ Left "Activity already exists in inbox, not using" + else do + delete obiid + return $ Left "You're already a follower of me" case emsg of Left msg -> return msg Right (obiid, doc, remotesHttp) -> do @@ -302,12 +273,12 @@ followF case mibrid of Nothing -> do delete ibiid - return False - Just _ -> return True + return Nothing + Just _ -> return $ Just ractid - insertFollow fsid = do + insertFollow ractid obiidA fsid = do let raid = remoteAuthorId author - mrfid <- insertUnique $ RemoteFollow raid fsid True (not hide) + mrfid <- insertUnique $ RemoteFollow raid fsid True (not hide) ractid obiidA return $ isJust mrfid insertAcceptToOutbox luFollow obidRecip = do diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 924d2bf..10d358f 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -262,7 +262,7 @@ projectOfferTicketF , ticketAuthorRemoteOffer = ractid } -- insertMany_ $ map (TicketDependency tid) deps - insert_ $ RemoteFollow raidAuthor fsid False True + --insert_ $ RemoteFollow raidAuthor fsid False True return $ Just (ractid, next, obiidAccept, docAccept) deliverLocal diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 879056d..4ddfa5c 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -299,6 +299,7 @@ instance Yesod App where (SharerInboxR shr , False) -> person shr (NotificationsR shr , _ ) -> person shr (SharerOutboxR shr , True) -> person shr + (SharerFollowR shr , True) -> personAny (GroupsR , True) -> personAny (GroupNewR , _ ) -> personAny @@ -322,6 +323,7 @@ instance Yesod App where (RepoNewR shr , _ ) -> personOrGroupAdmin shr (RepoR shar _ , True) -> person shar (RepoEditR shr _rp , _ ) -> person shr + (RepoFollowR _shr _rp , True) -> personAny (RepoDevsR shr _rp , _ ) -> person shr (RepoDevNewR shr _rp , _ ) -> person shr (RepoDevR shr _rp _dev , _ ) -> person shr @@ -330,6 +332,7 @@ instance Yesod App where (ProjectNewR shr , _ ) -> personOrGroupAdmin shr (ProjectR shr _prj , True) -> person shr (ProjectEditR shr _prj , _ ) -> person shr + (ProjectFollowR _shr _prj , _ ) -> personAny (ProjectDevsR shr _prj , _ ) -> person shr (ProjectDevNewR shr _prj , _ ) -> person shr (ProjectDevR shr _prj _dev , _ ) -> person shr @@ -362,6 +365,7 @@ instance Yesod App where (TicketUnclaimR s j _ , _ ) -> projOp ProjOpUnclaimTicket s j (TicketAssignR s j _ , _ ) -> projOp ProjOpAssignTicket s j (TicketUnassignR s j _ , _ ) -> projOp ProjOpUnassignTicket s j + (TicketFollowR _ _ _ , True) -> personAny (ClaimRequestsTicketR s j _, True) -> projOp ProjOpRequestTicket s j (ClaimRequestNewR s j _ , _ ) -> projOp ProjOpRequestTicket s j (TicketDiscussionR _ _ _ , True) -> personAny diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs new file mode 100644 index 0000000..eaf7720 --- /dev/null +++ b/src/Vervis/Handler/Client.hs @@ -0,0 +1,528 @@ +{- This file is part of Vervis. + - + - Written in 2019 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.Handler.Client + ( getPublishR + , postSharerOutboxR + , postSharerFollowR + , postProjectFollowR + , postTicketFollowR + , postRepoFollowR + , getNotificationsR + , postNotificationsR + ) +where + +import Control.Applicative +import Control.Exception hiding (Handler) +import Control.Monad +import Control.Monad.Trans.Except +import Data.Bitraversable +import Data.Maybe +import Data.Text (Text) +import Data.Time.Clock +import Data.Traversable +import Database.Persist +import Text.Blaze.Html (preEscapedToHtml) +import Text.Blaze.Html.Renderer.Text +import Text.HTML.SanitizeXSS +import Yesod.Core +import Yesod.Core.Widget +import Yesod.Form +import Yesod.Persist.Core + +import qualified Data.HashMap.Strict as M +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Database.Esqueleto as E + +import Database.Persist.JSON +import Network.FedURI +import Web.ActivityPub hiding (Ticket) +import Yesod.Auth.Unverified +import Yesod.FedURI +import Yesod.Hashids +import Yesod.RenderSource + +import qualified Web.ActivityPub as AP + +import Data.Either.Local +import Data.EventTime.Local +import Data.Time.Clock.Local +import Database.Persist.Local +import Yesod.Persist.Local + +import Vervis.ActivityPub +import Vervis.API +import Vervis.Client +import Vervis.FedURI +import Vervis.Foundation +import Vervis.Model +import Vervis.Model.Ident +import Vervis.Settings + +import qualified Vervis.Client as C + +getShowTime = showTime <$> liftIO getCurrentTime + where + showTime now = + showEventTime . + intervalToEventTime . + FriendlyConvert . + diffUTCTime now + +objectSummary o = + case M.lookup "summary" o of + Just (String t) | not (T.null t) -> Just t + _ -> Nothing + +objectId o = + case M.lookup "id" o <|> M.lookup "@id" o of + Just (String t) | not (T.null t) -> t + _ -> error "'id' field not found" + +fedUriField + :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI +fedUriField = Field + { fieldParse = parseHelper $ \ t -> + case parseObjURI t of + Left e -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t + Right u -> Right u + , fieldView = \theId name attrs val isReq -> + [whamlet||] + , fieldEnctype = UrlEncoded + } + +ticketField + :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent, Int) +ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField + where + toTicket uTicket = runExceptT $ do + let ObjURI hTicket luTicket = uTicket + route <- + case decodeRouteLocal luTicket of + Nothing -> throwE ("Not a valid route" :: Text) + Just r -> return r + case route of + TicketR shr prj num -> return (hTicket, shr, prj, num) + _ -> throwE "Not a ticket route" + fromTicket (h, shr, prj, num) = + ObjURI h $ encodeRouteLocal $ TicketR shr prj num + +projectField + :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent) +projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField + where + toProject u = runExceptT $ do + let ObjURI h lu = u + route <- + case decodeRouteLocal lu of + Nothing -> throwE ("Not a valid route" :: Text) + Just r -> return r + case route of + ProjectR shr prj -> return (h, shr, prj) + _ -> throwE "Not a project route" + fromProject (h, shr, prj) = ObjURI h $ encodeRouteLocal $ ProjectR shr prj + +publishCommentForm + :: Form ((Host, ShrIdent, PrjIdent, Int), Maybe FedURI, Text) +publishCommentForm html = do + enc <- getEncodeRouteLocal + flip renderDivs html $ (,,) + <$> areq (ticketField enc) "Ticket" (Just deft) + <*> aopt fedUriField "Replying to" (Just $ Just defp) + <*> areq textField "Message" (Just defmsg) + where + deft = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox", 1) + defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7" + defmsg = "Hi! I'm testing federation. Can you see my message? :)" + +openTicketForm + :: Form ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown) +openTicketForm html = do + enc <- getEncodeRouteLocal + flip renderDivs html $ (,,) + <$> areq (projectField enc) "Project" (Just defj) + <*> ( TextHtml . sanitizeBalance <$> + areq textField "Title" (Just deft) + ) + <*> ( TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$> + areq textareaField "Description" (Just defd) + ) + where + defj = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox") + deft = "Time slows down when tasting coconut ice-cream" + defd = "Is that slow-motion effect intentional? :)" + +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 +
+ ^{widget1} + + +

Open a new ticket + + ^{widget2} + + +

Follow a person, a projet or a repo + + ^{widget3} + + |] + +getUserShrIdent :: Handler ShrIdent +getUserShrIdent = do + Entity _ p <- requireVerifiedAuth + s <- runDB $ getJust $ personIdent p + return $ sharerIdent s + +getPublishR :: Handler Html +getPublishR = do + shr <- getUserShrIdent + ((_result1, widget1), enctype1) <- + runFormPost $ identifyForm "f1" publishCommentForm + ((_result2, widget2), enctype2) <- + runFormPost $ identifyForm "f2" openTicketForm + ((_result3, widget3), enctype3) <- + runFormPost $ identifyForm "f3" followForm + defaultLayout $ + activityWidget shr widget1 enctype1 widget2 enctype2 widget3 enctype3 + +postSharerOutboxR :: ShrIdent -> Handler Html +postSharerOutboxR shrAuthor = do + federation <- getsYesod $ appFederation . appSettings + unless federation badMethod + + ((result1, widget1), enctype1) <- + runFormPost $ identifyForm "f1" publishCommentForm + ((result2, widget2), enctype2) <- + runFormPost $ identifyForm "f2" openTicketForm + ((result3, widget3), enctype3) <- + runFormPost $ identifyForm "f3" followForm + let result + = Left <$> result1 + <|> Right . Left <$> result2 + <|> Right . Right <$> result3 + + eid <- runExceptT $ do + input <- + case result of + FormMissing -> throwE "Field(s) missing" + FormFailure _l -> throwE "Invalid input, see below" + FormSuccess r -> return r + bitraverse publishComment (bitraverse openTicket follow) input + case eid of + Left err -> setMessage $ toHtml err + Right id_ -> + case id_ of + Left lmid -> do + lmkhid <- encodeKeyHashid lmid + renderUrl <- getUrlRender + let u = renderUrl $ MessageR shrAuthor lmkhid + setMessage $ toHtml $ "Message created! ID: " <> u + Right (Left _obiid) -> + setMessage "Ticket offer published!" + 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 + encodeRouteLocal <- getEncodeRouteLocal + let msg' = T.filter (/= '\r') msg + contentHtml <- ExceptT . pure $ renderPandocMarkdown msg' + let encodeRecipRoute = ObjURI hTicket . encodeRouteLocal + uTicket = encodeRecipRoute $ TicketR shrTicket prj num + ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor + collections = + [ ProjectFollowersR shrTicket prj + , TicketParticipantsR shrTicket prj num + , TicketTeamR shrTicket prj num + ] + recips = ProjectR shrTicket prj : collections + note = Note + { noteId = Nothing + , noteAttrib = luAuthor + , noteAudience = Audience + { audienceTo = map encodeRecipRoute recips + , audienceBto = [] + , audienceCc = [] + , audienceBcc = [] + , audienceGeneral = [] + , audienceNonActors = map encodeRecipRoute collections + } + , noteReplyTo = Just $ fromMaybe uTicket muParent + , noteContext = Just uTicket + , notePublished = Nothing + , noteSource = msg' + , noteContent = contentHtml + } + ExceptT $ createNoteC hLocal note + openTicket ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteFed <- getEncodeRouteFed + local <- hostIsLocal h + descHtml <- ExceptT . pure $ renderPandocMarkdown desc + summary <- + TextHtml . TL.toStrict . renderHtml <$> + withUrlRenderer + [hamlet| +

+ + #{shr2text shrAuthor} + \ offered a ticket to project # + $if local + + ./s/#{shr2text shr}/p/#{prj2text prj} + $else + + #{renderAuthority h}/s/#{shr2text shr}/p/#{prj2text prj} + : #{preEscapedToHtml title}. + |] + let recipsA = [ProjectR shr prj] + recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj] + ticketAP = AP.Ticket + { ticketLocal = Nothing + , ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor + , ticketPublished = Nothing + , ticketUpdated = Nothing + , ticketName = Nothing + , ticketSummary = TextHtml title + , ticketContent = TextHtml descHtml + , ticketSource = TextPandocMarkdown desc + , ticketAssignedTo = Nothing + , ticketIsResolved = False + } + offer = Offer + { offerObject = ticketAP + , offerTarget = encodeRouteFed h $ ProjectR shr prj + } + audience = Audience + { audienceTo = + map (encodeRouteFed h) $ recipsA ++ recipsC + , audienceBto = [] + , audienceCc = [] + , audienceBcc = [] + , audienceGeneral = [] + , audienceNonActors = map (encodeRouteFed h) recipsC + } + ExceptT $ offerTicketC shrAuthor summary audience offer + follow (uObject@(ObjURI hObject luObject), uRecip) = do + (summary, audience, followAP) <- + C.follow shrAuthor uObject uRecip False + ExceptT $ followC shrAuthor summary audience followAP + +setFollowMessage :: ShrIdent -> Either Text OutboxItemId -> Handler () +setFollowMessage _ (Left err) = setMessage $ toHtml err +setFollowMessage shr (Right obiid) = do + obikhid <- encodeKeyHashid obiid + setMessage =<< + withUrlRenderer + [hamlet| + + Follow request published! + |] + +postSharerFollowR :: ShrIdent -> Handler () +postSharerFollowR shrObject = do + shrAuthor <- getUserShrIdent + (summary, audience, follow) <- followSharer shrAuthor shrObject False + eid <- followC shrAuthor summary audience follow + setFollowMessage shrAuthor eid + redirect $ SharerR shrObject + +postProjectFollowR :: ShrIdent -> PrjIdent -> Handler () +postProjectFollowR shrObject prjObject = do + shrAuthor <- getUserShrIdent + (summary, audience, follow) <- followProject shrAuthor shrObject prjObject False + eid <- followC shrAuthor summary audience follow + setFollowMessage shrAuthor eid + redirect $ ProjectR shrObject prjObject + +postTicketFollowR :: ShrIdent -> PrjIdent -> Int -> Handler () +postTicketFollowR shrObject prjObject numObject = do + shrAuthor <- getUserShrIdent + (summary, audience, follow) <- followTicket shrAuthor shrObject prjObject numObject False + eid <- followC shrAuthor summary audience follow + setFollowMessage shrAuthor eid + redirect $ TicketR shrObject prjObject numObject + +postRepoFollowR :: ShrIdent -> RpIdent -> Handler () +postRepoFollowR shrObject rpObject = do + shrAuthor <- getUserShrIdent + (summary, audience, follow) <- followRepo shrAuthor shrObject rpObject False + eid <- followC shrAuthor summary audience follow + setFollowMessage shrAuthor eid + redirect $ RepoR shrObject rpObject + +notificationForm :: Maybe (Maybe (InboxItemId, Bool)) -> Form (Maybe (InboxItemId, Bool)) +notificationForm defs = renderDivs $ mk + <$> aopt hiddenField (name "Inbox Item ID#") (fmap fst <$> defs) + <*> aopt hiddenField (name "New unread flag") (fmap snd <$> defs) + where + name t = FieldSettings "" Nothing Nothing (Just t) [] + mk Nothing Nothing = Nothing + mk (Just ibid) (Just unread) = Just (ibid, unread) + mk _ _ = error "Missing hidden field?" + +getNotificationsR :: ShrIdent -> Handler Html +getNotificationsR shr = do + items <- runDB $ do + sid <- getKeyBy404 $ UniqueSharer shr + p <- getValBy404 $ UniquePersonIdent sid + let ibid = personInbox p + map adaptItem <$> getItems ibid + notifications <- for items $ \ (ibiid, activity) -> do + ((_result, widget), enctype) <- + runFormPost $ notificationForm $ Just $ Just (ibiid, False) + return (activity, widget, enctype) + ((_result, widgetAll), enctypeAll) <- + runFormPost $ notificationForm $ Just Nothing + showTime <- getShowTime + defaultLayout $(widgetFile "person/notifications") + where + getItems ibid = + E.select $ E.from $ + \ (ib `E.LeftOuterJoin` (ibl `E.InnerJoin` ob) `E.LeftOuterJoin` (ibr `E.InnerJoin` ract)) -> do + E.on $ ibr E.?. InboxItemRemoteActivity E.==. ract E.?. RemoteActivityId + E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem + E.on $ ibl E.?. InboxItemLocalActivity E.==. ob E.?. OutboxItemId + E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem + E.where_ + $ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||. + ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid) + ) + E.&&. + ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||. + ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid) + ) + E.&&. + ib E.^. InboxItemUnread E.==. E.val True + E.orderBy [E.desc $ ib E.^. InboxItemId] + return + ( ib E.^. InboxItemId + , ob E.?. OutboxItemActivity + , ob E.?. OutboxItemPublished + , ract E.?. RemoteActivityContent + , ract E.?. RemoteActivityReceived + ) + adaptItem + (E.Value ibid, E.Value mact, E.Value mpub, E.Value mobj, E.Value mrec) = + case (mact, mpub, mobj, mrec) of + (Nothing, Nothing, Nothing, Nothing) -> + error $ ibiidString ++ " neither local nor remote" + (Just _, Just _, Just _, Just _) -> + error $ ibiidString ++ " both local and remote" + (Just act, Just pub, Nothing, Nothing) -> + (ibid, (persistJSONObject act, (pub, False))) + (Nothing, Nothing, Just obj, Just rec) -> + (ibid, (persistJSONObject obj, (rec, True))) + _ -> error $ "Unexpected query result for " ++ ibiidString + where + ibiidString = "InboxItem #" ++ show (E.fromSqlKey ibid) + +postNotificationsR :: ShrIdent -> Handler Html +postNotificationsR shr = do + ((result, _widget), _enctype) <- runFormPost $ notificationForm Nothing + case result of + FormSuccess mitem -> do + (multi, markedUnread) <- runDB $ do + sid <- getKeyBy404 $ UniqueSharer shr + p <- getValBy404 $ UniquePersonIdent sid + let ibid = personInbox p + case mitem of + Nothing -> do + ibiids <- map E.unValue <$> getItems ibid + updateWhere + [InboxItemId <-. ibiids] + [InboxItemUnread =. False] + return (True, False) + Just (ibiid, unread) -> do + mibl <- getValBy $ UniqueInboxItemLocalItem ibiid + mibr <- getValBy $ UniqueInboxItemRemoteItem ibiid + mib <- + requireEitherM + mibl + mibr + "Unused InboxItem" + "InboxItem used more than once" + let samePid = + case mib of + Left ibl -> + inboxItemLocalInbox ibl == ibid + Right ibr -> + inboxItemRemoteInbox ibr == ibid + if samePid + then do + update ibiid [InboxItemUnread =. unread] + return (False, unread) + else + permissionDenied + "Notification belongs to different user" + setMessage $ + if multi + then "Items marked as read." + else if markedUnread + then "Item marked as unread." + else "Item marked as read." + FormMissing -> do + setMessage "Field(s) missing" + FormFailure l -> do + setMessage $ toHtml $ "Marking as read failed:" <> T.pack (show l) + redirect $ NotificationsR shr + where + getItems ibid = + E.select $ E.from $ + \ (ib `E.LeftOuterJoin` ibl `E.LeftOuterJoin` ibr) -> do + E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem + E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem + E.where_ + $ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||. + ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid) + ) + E.&&. + ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||. + ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid) + ) + E.&&. + ib E.^. InboxItemUnread E.==. E.val True + return $ ib E.^. InboxItemId + -- TODO copied from Vervis.Federation, put this in 1 place + 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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 50b166c..7e7d474 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -21,18 +21,14 @@ module Vervis.Handler.Inbox , postSharerInboxR , postProjectInboxR , postRepoInboxR - , getPublishR , getSharerOutboxR , getSharerOutboxItemR - , postSharerOutboxR , getProjectOutboxR , getProjectOutboxItemR , getRepoOutboxR , getRepoOutboxItemR , getActorKey1R , getActorKey2R - , getNotificationsR - , postNotificationsR ) where @@ -105,6 +101,8 @@ import Vervis.Model.Ident import Vervis.Paginate import Vervis.Settings +import qualified Vervis.Client as C + getShowTime = showTime <$> liftIO getCurrentTime where showTime now = @@ -334,127 +332,6 @@ jsonField = checkMMap fromTextarea toTextarea textareaField fromTextarea = return . first T.pack . eitherDecodeStrict' . encodeUtf8 . unTextarea -} -fedUriField - :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI -fedUriField = Field - { fieldParse = parseHelper $ \ t -> - case parseObjURI t of - Left e -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t - Right u -> Right u - , fieldView = \theId name attrs val isReq -> - [whamlet||] - , fieldEnctype = UrlEncoded - } - -ticketField - :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent, Int) -ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField - where - toTicket uTicket = runExceptT $ do - let ObjURI hTicket luTicket = uTicket - route <- - case decodeRouteLocal luTicket of - Nothing -> throwE ("Not a valid route" :: Text) - Just r -> return r - case route of - TicketR shr prj num -> return (hTicket, shr, prj, num) - _ -> throwE "Not a ticket route" - fromTicket (h, shr, prj, num) = - ObjURI h $ encodeRouteLocal $ TicketR shr prj num - -projectField - :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent) -projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField - where - toProject u = runExceptT $ do - let ObjURI h lu = u - route <- - case decodeRouteLocal lu of - Nothing -> throwE ("Not a valid route" :: Text) - Just r -> return r - case route of - ProjectR shr prj -> return (h, shr, prj) - _ -> throwE "Not a project route" - fromProject (h, shr, prj) = ObjURI h $ encodeRouteLocal $ ProjectR shr prj - -publishCommentForm - :: Form ((Host, ShrIdent, PrjIdent, Int), Maybe FedURI, Text) -publishCommentForm html = do - enc <- getEncodeRouteLocal - flip renderDivs html $ (,,) - <$> areq (ticketField enc) "Ticket" (Just deft) - <*> aopt fedUriField "Replying to" (Just $ Just defp) - <*> areq textField "Message" (Just defmsg) - where - deft = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox", 1) - defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7" - defmsg = "Hi! I'm testing federation. Can you see my message? :)" - -openTicketForm - :: Form ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown) -openTicketForm html = do - enc <- getEncodeRouteLocal - flip renderDivs html $ (,,) - <$> areq (projectField enc) "Project" (Just defj) - <*> ( TextHtml . sanitizeBalance <$> - areq textField "Title" (Just deft) - ) - <*> ( TextPandocMarkdown . T.filter (/= '\r') . unTextarea <$> - areq textareaField "Description" (Just defd) - ) - where - defj = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox") - deft = "Time slows down when tasting coconut ice-cream" - defd = "Is that slow-motion effect intentional? :)" - -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 - - ^{widget1} - - -

Open a new ticket - - ^{widget2} - - -

Follow a person, a projet or a repo - - ^{widget3} - - |] - -getUserShrIdent :: Handler ShrIdent -getUserShrIdent = do - Entity _ p <- requireVerifiedAuth - s <- runDB $ get404 $ personIdent p - return $ sharerIdent s - -getPublishR :: Handler Html -getPublishR = do - shr <- getUserShrIdent - ((_result1, widget1), enctype1) <- - runFormPost $ identifyForm "f1" publishCommentForm - ((_result2, widget2), enctype2) <- - runFormPost $ identifyForm "f2" openTicketForm - ((_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 @@ -538,150 +415,6 @@ getSharerOutboxItemR shr obikhid = getOutboxItem here getObid obikhid p <- getValBy404 $ UniquePersonIdent sid return $ personOutbox p -postSharerOutboxR :: ShrIdent -> Handler Html -postSharerOutboxR shrAuthor = do - federation <- getsYesod $ appFederation . appSettings - unless federation badMethod - - ((result1, widget1), enctype1) <- - runFormPost $ identifyForm "f1" publishCommentForm - ((result2, widget2), enctype2) <- - runFormPost $ identifyForm "f2" openTicketForm - ((result3, widget3), enctype3) <- - runFormPost $ identifyForm "f3" followForm - let result - = Left <$> result1 - <|> Right . Left <$> result2 - <|> Right . Right <$> result3 - - eid <- runExceptT $ do - input <- - case result of - FormMissing -> throwE "Field(s) missing" - FormFailure _l -> throwE "Invalid input, see below" - FormSuccess r -> return r - bitraverse publishComment (bitraverse openTicket follow) input - case eid of - Left err -> setMessage $ toHtml err - Right id_ -> - case id_ of - Left lmid -> do - lmkhid <- encodeKeyHashid lmid - renderUrl <- getUrlRender - let u = renderUrl $ MessageR shrAuthor lmkhid - setMessage $ toHtml $ "Message created! ID: " <> u - Right (Left _obiid) -> - setMessage "Ticket offer published!" - 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 - encodeRouteLocal <- getEncodeRouteLocal - let msg' = T.filter (/= '\r') msg - contentHtml <- ExceptT . pure $ renderPandocMarkdown msg' - let encodeRecipRoute = ObjURI hTicket . encodeRouteLocal - uTicket = encodeRecipRoute $ TicketR shrTicket prj num - ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor - collections = - [ ProjectFollowersR shrTicket prj - , TicketParticipantsR shrTicket prj num - , TicketTeamR shrTicket prj num - ] - recips = ProjectR shrTicket prj : collections - note = Note - { noteId = Nothing - , noteAttrib = luAuthor - , noteAudience = Audience - { audienceTo = map encodeRecipRoute recips - , audienceBto = [] - , audienceCc = [] - , audienceBcc = [] - , audienceGeneral = [] - , audienceNonActors = map encodeRecipRoute collections - } - , noteReplyTo = Just $ fromMaybe uTicket muParent - , noteContext = Just uTicket - , notePublished = Nothing - , noteSource = msg' - , noteContent = contentHtml - } - ExceptT $ createNoteC hLocal note - openTicket ((h, shr, prj), TextHtml title, TextPandocMarkdown desc) = do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteFed <- getEncodeRouteFed - local <- hostIsLocal h - descHtml <- ExceptT . pure $ renderPandocMarkdown desc - summary <- - TextHtml . TL.toStrict . renderHtml <$> - withUrlRenderer - [hamlet| -

- - #{shr2text shrAuthor} - \ offered a ticket to project # - $if local - - ./s/#{shr2text shr}/p/#{prj2text prj} - $else - - #{renderAuthority h}/s/#{shr2text shr}/p/#{prj2text prj} - : #{preEscapedToHtml title}. - |] - let recipsA = [ProjectR shr prj] - recipsC = [ProjectTeamR shr prj, ProjectFollowersR shr prj] - ticket = Ticket - { ticketLocal = Nothing - , ticketAttributedTo = encodeRouteLocal $ SharerR shrAuthor - , ticketPublished = Nothing - , ticketUpdated = Nothing - , ticketName = Nothing - , ticketSummary = TextHtml title - , ticketContent = TextHtml descHtml - , ticketSource = TextPandocMarkdown desc - , ticketAssignedTo = Nothing - , ticketIsResolved = False - } - offer = Offer - { offerObject = ticket - , offerTarget = encodeRouteFed h $ ProjectR shr prj - } - audience = Audience - { audienceTo = - map (encodeRouteFed h) $ recipsA ++ recipsC - , audienceBto = [] - , audienceCc = [] - , audienceBcc = [] - , audienceGeneral = [] - , 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 where @@ -739,143 +472,3 @@ getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R getActorKey2R :: Handler TypedContent getActorKey2R = getActorKey (\ (_, k2, _) -> k2) ActorKey2R - -notificationForm :: Maybe (Maybe (InboxItemId, Bool)) -> Form (Maybe (InboxItemId, Bool)) -notificationForm defs = renderDivs $ mk - <$> aopt hiddenField (name "Inbox Item ID#") (fmap fst <$> defs) - <*> aopt hiddenField (name "New unread flag") (fmap snd <$> defs) - where - name t = FieldSettings "" Nothing Nothing (Just t) [] - mk Nothing Nothing = Nothing - mk (Just ibid) (Just unread) = Just (ibid, unread) - mk _ _ = error "Missing hidden field?" - -getNotificationsR :: ShrIdent -> Handler Html -getNotificationsR shr = do - items <- runDB $ do - sid <- getKeyBy404 $ UniqueSharer shr - p <- getValBy404 $ UniquePersonIdent sid - let ibid = personInbox p - map adaptItem <$> getItems ibid - notifications <- for items $ \ (ibiid, activity) -> do - ((_result, widget), enctype) <- - runFormPost $ notificationForm $ Just $ Just (ibiid, False) - return (activity, widget, enctype) - ((_result, widgetAll), enctypeAll) <- - runFormPost $ notificationForm $ Just Nothing - showTime <- getShowTime - defaultLayout $(widgetFile "person/notifications") - where - getItems ibid = - E.select $ E.from $ - \ (ib `E.LeftOuterJoin` (ibl `E.InnerJoin` ob) `E.LeftOuterJoin` (ibr `E.InnerJoin` ract)) -> do - E.on $ ibr E.?. InboxItemRemoteActivity E.==. ract E.?. RemoteActivityId - E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem - E.on $ ibl E.?. InboxItemLocalActivity E.==. ob E.?. OutboxItemId - E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem - E.where_ - $ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||. - ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid) - ) - E.&&. - ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||. - ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid) - ) - E.&&. - ib E.^. InboxItemUnread E.==. E.val True - E.orderBy [E.desc $ ib E.^. InboxItemId] - return - ( ib E.^. InboxItemId - , ob E.?. OutboxItemActivity - , ob E.?. OutboxItemPublished - , ract E.?. RemoteActivityContent - , ract E.?. RemoteActivityReceived - ) - adaptItem - (E.Value ibid, E.Value mact, E.Value mpub, E.Value mobj, E.Value mrec) = - case (mact, mpub, mobj, mrec) of - (Nothing, Nothing, Nothing, Nothing) -> - error $ ibiidString ++ " neither local nor remote" - (Just _, Just _, Just _, Just _) -> - error $ ibiidString ++ " both local and remote" - (Just act, Just pub, Nothing, Nothing) -> - (ibid, (persistJSONObject act, (pub, False))) - (Nothing, Nothing, Just obj, Just rec) -> - (ibid, (persistJSONObject obj, (rec, True))) - _ -> error $ "Unexpected query result for " ++ ibiidString - where - ibiidString = "InboxItem #" ++ show (fromSqlKey ibid) - -postNotificationsR :: ShrIdent -> Handler Html -postNotificationsR shr = do - ((result, _widget), _enctype) <- runFormPost $ notificationForm Nothing - case result of - FormSuccess mitem -> do - (multi, markedUnread) <- runDB $ do - sid <- getKeyBy404 $ UniqueSharer shr - p <- getValBy404 $ UniquePersonIdent sid - let ibid = personInbox p - case mitem of - Nothing -> do - ibiids <- map E.unValue <$> getItems ibid - updateWhere - [InboxItemId <-. ibiids] - [InboxItemUnread =. False] - return (True, False) - Just (ibiid, unread) -> do - mibl <- getValBy $ UniqueInboxItemLocalItem ibiid - mibr <- getValBy $ UniqueInboxItemRemoteItem ibiid - mib <- - requireEitherM - mibl - mibr - "Unused InboxItem" - "InboxItem used more than once" - let samePid = - case mib of - Left ibl -> - inboxItemLocalInbox ibl == ibid - Right ibr -> - inboxItemRemoteInbox ibr == ibid - if samePid - then do - update ibiid [InboxItemUnread =. unread] - return (False, unread) - else - permissionDenied - "Notification belongs to different user" - setMessage $ - if multi - then "Items marked as read." - else if markedUnread - then "Item marked as unread." - else "Item marked as read." - FormMissing -> do - setMessage "Field(s) missing" - FormFailure l -> do - setMessage $ toHtml $ "Marking as read failed:" <> T.pack (show l) - redirect $ NotificationsR shr - where - getItems ibid = - E.select $ E.from $ - \ (ib `E.LeftOuterJoin` ibl `E.LeftOuterJoin` ibr) -> do - E.on $ E.just (ib E.^. InboxItemId) E.==. ibr E.?. InboxItemRemoteItem - E.on $ E.just (ib E.^. InboxItemId) E.==. ibl E.?. InboxItemLocalItem - E.where_ - $ ( E.isNothing (ibr E.?. InboxItemRemoteInbox) E.||. - ibr E.?. InboxItemRemoteInbox E.==. E.just (E.val ibid) - ) - E.&&. - ( E.isNothing (ibl E.?. InboxItemLocalInbox) E.||. - ibl E.?. InboxItemLocalInbox E.==. E.just (E.val ibid) - ) - E.&&. - ib E.^. InboxItemUnread E.==. E.val True - return $ ib E.^. InboxItemId - -- TODO copied from Vervis.Federation, put this in 1 place - 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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index a121a2c..cbb9bff 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -1069,6 +1069,24 @@ changes hLocal ctx = "Outbox" -- 139 , addUnique "Repo" $ Unique "UniqueRepoOutbox" ["outbox"] + -- 140 + , addFieldRefRequiredEmpty "Follow" "follow" "OutboxItem" + -- 141 + , addUnique "Follow" $ Unique "UniqueFollowFollow" ["follow"] + -- 142 + , addFieldRefRequiredEmpty "RemoteFollow" "follow" "RemoteActivity" + -- 143 + , addUnique "RemoteFollow" $ Unique "UniqueRemoteFollowFollow" ["follow"] + -- 144 + , addEntities model_2019_09_25 + -- 145 + , addFieldRefRequiredEmpty "Follow" "accept" "OutboxItem" + -- 146 + , addUnique "Follow" $ Unique "UniqueFollowAccept" ["accept"] + -- 147 + , addFieldRefRequiredEmpty "RemoteFollow" "accept" "OutboxItem" + -- 148 + , addUnique "RemoteFollow" $ Unique "UniqueRemoteFollowAccept" ["accept"] ] migrateDB diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 164022b..ad7d131 100644 --- a/src/Vervis/Migration/Model.hs +++ b/src/Vervis/Migration/Model.hs @@ -124,6 +124,7 @@ module Vervis.Migration.Model , Person130 , Outbox138Generic (..) , Repo138 + , model_2019_09_25 ) where @@ -251,3 +252,6 @@ makeEntitiesMigration "130" makeEntitiesMigration "138" $(modelFile "migrations/2019_09_10.model") + +model_2019_09_25 :: [Entity SqlBackend] +model_2019_09_25 = $(schema "2019_09_25") diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 6482c23..9338cd2 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -58,6 +58,7 @@ module Web.ActivityPub , Offer (..) , Push (..) , Reject (..) + , Undo (..) , Audience (..) , SpecificActivity (..) , Activity (..) @@ -1004,20 +1005,23 @@ encodeCreate authority actor (Create obj) = "object" `pair` pairs (toSeries authority obj) data Follow u = Follow - { followObject :: ObjURI u - , followHide :: Bool + { followObject :: ObjURI u + , followContext :: Maybe (ObjURI u) + , followHide :: Bool } parseFollow :: UriMode u => Object -> Parser (Follow u) parseFollow o = Follow - <$> o .: "object" - <*> o .: "hide" + <$> o .: "object" + <*> o .:? "context" + <*> o .: "hide" encodeFollow :: UriMode u => Follow u -> Series -encodeFollow (Follow obj hide) - = "object" .= obj - <> "hide" .= hide +encodeFollow (Follow obj mcontext hide) + = "object" .= obj + <> "context" .=? mcontext + <> "hide" .= hide data Offer u = Offer { offerObject :: Ticket u @@ -1086,6 +1090,16 @@ parseReject o = Reject <$> o .: "object" encodeReject :: UriMode u => Reject u -> Series encodeReject (Reject obj) = "object" .= obj +data Undo u = Undo + { undoObject :: LocalURI + } + +parseUndo :: UriMode u => Authority u -> Object -> Parser (Undo u) +parseUndo a o = Undo <$> withAuthorityO a (o .: "object") + +encodeUndo :: UriMode u => Authority u -> Undo u -> Series +encodeUndo a (Undo obj) = "object" .= ObjURI a obj + data SpecificActivity u = AcceptActivity (Accept u) | CreateActivity (Create u) @@ -1093,6 +1107,7 @@ data SpecificActivity u | OfferActivity (Offer u) | PushActivity (Push u) | RejectActivity (Reject u) + | UndoActivity (Undo u) data Activity u = Activity { activityId :: Maybe LocalURI @@ -1121,6 +1136,7 @@ instance ActivityPub Activity where "Offer" -> OfferActivity <$> parseOffer o a actor "Push" -> PushActivity <$> parsePush a o "Reject" -> RejectActivity <$> parseReject o + "Undo" -> UndoActivity <$> parseUndo a o _ -> fail $ "Unrecognized activity type: " ++ T.unpack typ @@ -1145,6 +1161,7 @@ instance ActivityPub Activity where encodeSpecific h u (OfferActivity a) = encodeOffer h u a encodeSpecific h _ (PushActivity a) = encodePush h a encodeSpecific _ _ (RejectActivity a) = encodeReject a + encodeSpecific h _ (UndoActivity a) = encodeUndo h a typeActivityStreams2 :: ContentType typeActivityStreams2 = "application/activity+json" diff --git a/src/Yesod/MonadSite.hs b/src/Yesod/MonadSite.hs index aab9e05..bd43d1c 100644 --- a/src/Yesod/MonadSite.hs +++ b/src/Yesod/MonadSite.hs @@ -38,6 +38,7 @@ import Control.Monad.IO.Unlift import Control.Monad.Logger.CallStack import Control.Monad.Trans.Class import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Functor import Data.Text (Text) @@ -77,6 +78,11 @@ instance MonadSite m => MonadSite (ReaderT r m) where askSite = lift askSite askUrlRenderParams = lift askUrlRenderParams +instance MonadSite m => MonadSite (MaybeT m) where + type SiteEnv (MaybeT m) = SiteEnv m + askSite = lift askSite + askUrlRenderParams = lift askUrlRenderParams + instance MonadSite m => MonadSite (ExceptT e m) where type SiteEnv (ExceptT e m) = SiteEnv m askSite = lift askSite diff --git a/vervis.cabal b/vervis.cabal index 5d41a7b..4020890 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -123,6 +123,7 @@ library Vervis.BinaryBody Vervis.Changes Vervis.ChangeFeed + Vervis.Client Vervis.Colour Vervis.Content Vervis.Darcs @@ -153,6 +154,7 @@ library Vervis.Foundation Vervis.Git Vervis.GraphProxy + Vervis.Handler.Client Vervis.Handler.Common Vervis.Handler.Discussion Vervis.Handler.Git