forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Implement remote following, disable automatic following

Browse source 
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.
This commit is contained in:
fr33domlover 2019-09-25 10:43:05 +00:00
parent 1673851db0
commit 5a7700ffe4
17 changed files with 860 additions and 560 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

30
config/models
View file

@ -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

4
config/routes
View file

@ -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

21
migrations/2019_09_25.model Normal file
View file

@ -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

20
src/Vervis/API.hs
View file

@ -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,11 +490,13 @@ 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
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
deliverFollowLocal pidAuthor fsid unread obiidFollow ibidRecip
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)
@ -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

1
src/Vervis/Application.hs
View file

@ -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

99
src/Vervis/Client.hs Normal file
View file

@ -0,0 +1,99 @@
{- This file is part of Vervis.
-
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
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|
<p>
<a href=@{SharerR shrAuthor}>
#{shr2text shrAuthor}
\ requested to follow #
<a href=#{renderObjURI uObject}>
#{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

2
src/Vervis/Federation/Discussion.hs
View file

@ -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)

225
src/Vervis/Federation/Offer.hs
View file

@ -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
if newFollow
then Right <$> do
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
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

2
src/Vervis/Federation/Ticket.hs
View file

@ -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

4
src/Vervis/Foundation.hs
View file

@ -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

528
src/Vervis/Handler/Client.hs Normal file
View file

@ -0,0 +1,528 @@
{- This file is part of Vervis.
-
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ 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
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
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|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderObjURI val}>|]
, 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|
<h1>Publish a ticket comment
<form method=POST action=@{SharerOutboxR shr} enctype=#{enctype1}>
^{widget1}
<input type=submit>
<h1>Open a new ticket
<form method=POST action=@{SharerOutboxR shr} enctype=#{enctype2}>
^{widget2}
<input type=submit>
<h1>Follow a person, a projet or a repo
<form method=POST action=@{SharerOutboxR shr} enctype=#{enctype3}>
^{widget3}
<input type=submit>
|]
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|
<p>
<a href=@{SharerR shrAuthor}>
#{shr2text shrAuthor}
\ offered a ticket to project #
$if local
<a href=@{ProjectR shr prj}>
./s/#{shr2text shr}/p/#{prj2text prj}
$else
<a href=#{renderObjURI $ encodeRouteFed h $ ProjectR shr prj}>
#{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|
<a href=@{SharerOutboxItemR shr obikhid}>
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

411
src/Vervis/Handler/Inbox.hs
View file

@ -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|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderObjURI val}>|]
, 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|
<h1>Publish a ticket comment
<form method=POST action=@{SharerOutboxR shr} enctype=#{enctype1}>
^{widget1}
<input type=submit>
<h1>Open a new ticket
<form method=POST action=@{SharerOutboxR shr} enctype=#{enctype2}>
^{widget2}
<input type=submit>
<h1>Follow a person, a projet or a repo
<form method=POST action=@{SharerOutboxR shr} enctype=#{enctype3}>
^{widget3}
<input type=submit>
|]
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|
<p>
<a href=@{SharerR shrAuthor}>
#{shr2text shrAuthor}
\ offered a ticket to project #
$if local
<a href=@{ProjectR shr prj}>
./s/#{shr2text shr}/p/#{prj2text prj}
$else
<a href=#{renderObjURI $ encodeRouteFed h $ ProjectR shr prj}>
#{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|
<p>
<a href=@{SharerR shrAuthor}>
#{shr2text shrAuthor}
\ requested to follow #
<a href=#{renderObjURI uObject}>
#{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

18
src/Vervis/Migration.hs
View file

@ -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

4
src/Vervis/Migration/Model.hs
View file

@ -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")

19
src/Web/ActivityPub.hs
View file

@ -58,6 +58,7 @@ module Web.ActivityPub
, Offer (..)
, Push (..)
, Reject (..)
, Undo (..)
, Audience (..)
, SpecificActivity (..)
, Activity (..)
@ -1005,6 +1006,7 @@ encodeCreate authority actor (Create obj) =
data Follow u = Follow
{ followObject :: ObjURI u
, followContext :: Maybe (ObjURI u)
, followHide :: Bool
}
@ -1012,11 +1014,13 @@ parseFollow :: UriMode u => Object -> Parser (Follow u)
parseFollow o =
Follow
<$> o .: "object"
<*> o .:? "context"
<*> o .: "hide"
encodeFollow :: UriMode u => Follow u -> Series
encodeFollow (Follow obj hide)
encodeFollow (Follow obj mcontext hide)
= "object" .= obj
<> "context" .=? mcontext
<> "hide" .= hide
data Offer u = Offer
@ -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"

6
src/Yesod/MonadSite.hs
View file

@ -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

2
vervis.cabal
View file

@ -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