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