Implement C2S Follow activity and add form on /publish page
This commit is contained in:
fr33domlover
parent
3a68a3e7e6
commit
525a722439
13 changed files with 417 additions and 60 deletions
|
|
@ -240,10 +240,12 @@ Repo
|
|||
collabUser RoleId Maybe
|
||||
collabAnon RoleId Maybe
|
||||
inbox InboxId
|
||||
outbox OutboxId
|
||||
followers FollowerSetId
|
||||
|
||||
UniqueRepo ident sharer
|
||||
UniqueRepoInbox inbox
|
||||
UniqueRepoOutbox outbox
|
||||
UniqueRepoFollowers followers
|
||||
|
||||
Workflow
|
||||
|
|
|
|||
|
|
@ -86,6 +86,8 @@
|
|||
/s/#ShrIdent/r/!new RepoNewR GET
|
||||
/s/#ShrIdent/r/#RpIdent RepoR GET PUT DELETE POST
|
||||
/s/#ShrIdent/r/#RpIdent/inbox RepoInboxR GET POST
|
||||
/s/#ShrIdent/r/#RpIdent/outbox RepoOutboxR GET
|
||||
/s/#ShrIdent/r/#RpIdent/outbox/#OutboxItemKeyHashid RepoOutboxItemR GET
|
||||
/s/#ShrIdent/r/#RpIdent/team RepoTeamR GET
|
||||
/s/#ShrIdent/r/#RpIdent/followers RepoFollowersR GET
|
||||
/s/#ShrIdent/r/#RpIdent/edit RepoEditR GET
|
||||
|
|
|
|||
4
migrations/2019_09_10.model
Normal file
4
migrations/2019_09_10.model
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
Outbox
|
||||
|
||||
Repo
|
||||
outbox OutboxId
|
||||
|
|
@ -15,6 +15,7 @@
|
|||
|
||||
module Vervis.API
|
||||
( createNoteC
|
||||
, followC
|
||||
, offerTicketC
|
||||
, pushCommitsC
|
||||
, getFollowersCollection
|
||||
|
|
@ -282,8 +283,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
|
|||
_ -> throwE "Local context isn't a ticket route"
|
||||
|
||||
atMostSharer :: e -> (ShrIdent, LocalSharerRelatedSet) -> ExceptT e Handler (Maybe ShrIdent)
|
||||
atMostSharer _ (shr, LocalSharerRelatedSet s []) = return $ if localRecipSharer s then Just shr else Nothing
|
||||
atMostSharer e (_ , LocalSharerRelatedSet _ _ ) = throwE e
|
||||
atMostSharer _ (shr, LocalSharerRelatedSet s [] []) = return $ if localRecipSharer s then Just shr else Nothing
|
||||
atMostSharer e (_ , LocalSharerRelatedSet _ _ _ ) = throwE e
|
||||
|
||||
verifyTicketRecipients :: (ShrIdent, PrjIdent, Int) -> LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
|
||||
verifyTicketRecipients (shr, prj, num) recips = do
|
||||
|
|
@ -439,6 +440,190 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
|
|||
Right _gid -> throwE "Local Note addresses a local group"
|
||||
-}
|
||||
|
||||
data Followee
|
||||
= FolloweeSharer ShrIdent
|
||||
| FolloweeProject ShrIdent PrjIdent
|
||||
| FolloweeTicket ShrIdent PrjIdent Int
|
||||
| FolloweeRepo ShrIdent RpIdent
|
||||
|
||||
followC
|
||||
:: ShrIdent
|
||||
-> TextHtml
|
||||
-> Audience URIMode
|
||||
-> AP.Follow URIMode
|
||||
-> Handler (Either Text OutboxItemId)
|
||||
followC shrUser summary audience follow@(AP.Follow uObject hide) = runExceptT $ do
|
||||
(localRecips, remoteRecips) <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Follow with no recipients"
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
unless (federation || null remoteRecips) $
|
||||
throwE "Federation disabled, but remote recipients specified"
|
||||
mfollowee <- do
|
||||
let ObjURI h luObject = uObject
|
||||
local <- hostIsLocal h
|
||||
if local
|
||||
then Just <$> do
|
||||
route <-
|
||||
fromMaybeE
|
||||
(decodeRouteLocal luObject)
|
||||
"Follow object isn't a valid route"
|
||||
followee <-
|
||||
fromMaybeE
|
||||
(parseFollowee route)
|
||||
"Follow object isn't a followee route"
|
||||
let actor = followeeActor followee
|
||||
unless (actorRecips actor == localRecips) $
|
||||
throwE "Follow object isn't the recipient"
|
||||
case followee of
|
||||
FolloweeSharer shr | shr == shrUser ->
|
||||
throwE "User trying to follow themselves"
|
||||
_ -> return ()
|
||||
return (followee, actor)
|
||||
else do
|
||||
unless (null localRecips) $
|
||||
throwE "Follow object is remote but local recips listed"
|
||||
return Nothing
|
||||
let dont = Authority "dont-do.any-forwarding" Nothing
|
||||
(obiidFollow, doc, remotesHttp) <- runDBExcept $ do
|
||||
Entity pidAuthor personAuthor <- lift $ getAuthor shrUser
|
||||
let ibidAuthor = personInbox personAuthor
|
||||
obidAuthor = personOutbox personAuthor
|
||||
(obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox obidAuthor
|
||||
for_ mfollowee $ \ (followee, actorRecip) -> do
|
||||
(fsid, ibidRecip, unread, obidRecip) <- getFollowee followee
|
||||
lift $ do
|
||||
deliverFollowLocal pidAuthor fsid unread obiidFollow ibidRecip
|
||||
obiidAccept <- insertAcceptToOutbox luFollow actorRecip obidRecip
|
||||
deliverAcceptLocal obiidAccept ibidAuthor
|
||||
remotesHttp <- lift $ deliverRemoteDB' dont obiidFollow remoteRecips []
|
||||
return (obiidFollow, doc, remotesHttp)
|
||||
lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp dont obiidFollow doc remotesHttp
|
||||
return obiidFollow
|
||||
where
|
||||
parseFollowee (SharerR shr) = Just $ FolloweeSharer shr
|
||||
parseFollowee (ProjectR shr prj) = Just $ FolloweeProject shr prj
|
||||
parseFollowee (TicketR shr prj num) = Just $ FolloweeTicket shr prj num
|
||||
parseFollowee (RepoR shr rp) = Just $ FolloweeRepo shr rp
|
||||
parseFollowee _ = Nothing
|
||||
|
||||
followeeActor (FolloweeSharer shr) = LocalActorSharer shr
|
||||
followeeActor (FolloweeProject shr prj) = LocalActorProject shr prj
|
||||
followeeActor (FolloweeTicket shr prj _) = LocalActorProject shr prj
|
||||
followeeActor (FolloweeRepo shr rp) = LocalActorRepo shr rp
|
||||
|
||||
getAuthor shr = do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
getBy404 $ UniquePersonIdent sid
|
||||
|
||||
getFollowee (FolloweeSharer shr) = do
|
||||
msid <- lift $ getKeyBy $ UniqueSharer shr
|
||||
sid <- fromMaybeE msid "Follow object: No such sharer in DB"
|
||||
mval <- runMaybeT
|
||||
$ Left <$> MaybeT (lift $ getValBy $ UniquePersonIdent sid)
|
||||
<|> Right <$> MaybeT (lift $ getValBy $ UniqueGroup sid)
|
||||
val <-
|
||||
fromMaybeE mval $
|
||||
"Found non-person non-group sharer: " <> shr2text shr
|
||||
case val of
|
||||
Left person -> return (personFollowers person, personInbox person, True, personOutbox person)
|
||||
Right _group -> throwE "Follow object is a group"
|
||||
getFollowee (FolloweeProject shr prj) = do
|
||||
mproject <- lift $ runMaybeT $ do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
MaybeT $ getValBy $ UniqueProject prj sid
|
||||
project <- fromMaybeE mproject "Follow object: No such project in DB"
|
||||
return (projectFollowers project, projectInbox project, False, projectOutbox project)
|
||||
getFollowee (FolloweeTicket shr prj num) = do
|
||||
mproject <- lift $ runMaybeT $ do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
Entity jid project <- MaybeT $ getBy $ UniqueProject prj sid
|
||||
ticket <- MaybeT $ getValBy $ UniqueTicket jid num
|
||||
return (ticket, project)
|
||||
(ticket, project) <- fromMaybeE mproject "Follow object: No such ticket in DB"
|
||||
return (ticketFollowers ticket, projectInbox project, False, projectOutbox project)
|
||||
getFollowee (FolloweeRepo shr rp) = do
|
||||
mrepo <- lift $ runMaybeT $ do
|
||||
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
|
||||
MaybeT $ getValBy $ UniqueRepo rp sid
|
||||
repo <- fromMaybeE mrepo "Follow object: No such repo in DB"
|
||||
return (repoFollowers repo, repoInbox repo, False, repoOutbox repo)
|
||||
|
||||
insertFollowToOutbox obid = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let activity mluAct = Doc hLocal Activity
|
||||
{ activityId = mluAct
|
||||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
, activitySummary = Just summary
|
||||
, activityAudience = audience
|
||||
, activitySpecific = FollowActivity follow
|
||||
}
|
||||
now <- liftIO getCurrentTime
|
||||
obiid <- insert OutboxItem
|
||||
{ outboxItemOutbox = obid
|
||||
, outboxItemActivity =
|
||||
persistJSONObjectFromDoc $ activity Nothing
|
||||
, outboxItemPublished = now
|
||||
}
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
doc = activity $ Just luAct
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (obiid, doc, luAct)
|
||||
|
||||
deliverFollowLocal pidAuthor fsid unread obiid ibidRecip = do
|
||||
insert_ $ Follow pidAuthor fsid True True
|
||||
ibiid <- insert $ InboxItem unread
|
||||
insert_ $ InboxItemLocal ibidRecip obiid ibiid
|
||||
|
||||
insertAcceptToOutbox luFollow actorRecip obidRecip = do
|
||||
now <- liftIO getCurrentTime
|
||||
summary <-
|
||||
TextHtml . TL.toStrict . renderHtml <$>
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<p>
|
||||
<a href=@{SharerR shrUser}>
|
||||
#{shr2text shrUser}
|
||||
's follow request accepted by #
|
||||
<a href=#{renderObjURI uObject}>
|
||||
#{localUriPath $ objUriLocal uObject}
|
||||
|]
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
let recips = [encodeRouteHome $ SharerR shrUser]
|
||||
accept mluAct = Doc hLocal Activity
|
||||
{ activityId = mluAct
|
||||
, activityActor = objUriLocal uObject
|
||||
, activitySummary = Just summary
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hLocal luFollow
|
||||
, acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
obiid <- insert OutboxItem
|
||||
{ outboxItemOutbox = obidRecip
|
||||
, outboxItemActivity =
|
||||
persistJSONObjectFromDoc $ accept Nothing
|
||||
, outboxItemPublished = now
|
||||
}
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let luAct = encodeRouteLocal $ actorOutboxItem actorRecip obikhid
|
||||
doc = accept $ Just luAct
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return obiid
|
||||
where
|
||||
actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr
|
||||
actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj
|
||||
actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp
|
||||
|
||||
deliverAcceptLocal obiidAccept ibidAuthor = do
|
||||
ibiid <- insert $ InboxItem True
|
||||
insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid
|
||||
|
||||
offerTicketC
|
||||
:: ShrIdent
|
||||
-> TextHtml
|
||||
|
|
@ -498,7 +683,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
|||
else verifyOnlySharer lsrSet
|
||||
where
|
||||
offerRecips prj = LocalSharerRelatedSet
|
||||
{ localRecipSharerDirect = LocalSharerDirectSet False
|
||||
{ localRecipSharerDirect = LocalSharerDirectSet False False
|
||||
, localRecipProjectRelated =
|
||||
[ ( prj
|
||||
, LocalProjectRelatedSet
|
||||
|
|
@ -508,10 +693,13 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
|||
}
|
||||
)
|
||||
]
|
||||
, localRecipRepoRelated = []
|
||||
}
|
||||
verifyOnlySharer lsrSet =
|
||||
verifyOnlySharer lsrSet = do
|
||||
unless (null $ localRecipProjectRelated lsrSet) $
|
||||
throwE "Unexpected recipients unrelated to offer target"
|
||||
unless (null $ localRecipRepoRelated lsrSet) $
|
||||
throwE "Unexpected recipients unrelated to offer target"
|
||||
insertToOutbox now obid = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
let activity mluAct = Doc hLocal Activity
|
||||
|
|
@ -534,7 +722,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
|||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (obiid, doc, luAct)
|
||||
deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do
|
||||
(pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer projects) -> do
|
||||
(pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer projects _) -> do
|
||||
(pids, remotes) <-
|
||||
traverseCollect (uncurry $ deliverLocalProject shr) projects
|
||||
pids' <- do
|
||||
|
|
@ -629,7 +817,8 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
|||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hLocal luOffer
|
||||
, acceptResult =
|
||||
encodeRouteLocal $ TicketR shrProject prjProject num
|
||||
Just $ encodeRouteLocal $
|
||||
TicketR shrProject prjProject num
|
||||
}
|
||||
}
|
||||
obiid <- insert OutboxItem
|
||||
|
|
|
|||
|
|
@ -14,13 +14,15 @@
|
|||
-}
|
||||
|
||||
module Vervis.API.Recipient
|
||||
( LocalTicketDirectSet (..)
|
||||
( LocalActor (..)
|
||||
, LocalTicketDirectSet (..)
|
||||
, LocalProjectDirectSet (..)
|
||||
, LocalProjectRelatedSet (..)
|
||||
, LocalSharerDirectSet (..)
|
||||
, LocalSharerRelatedSet (..)
|
||||
, LocalRecipientSet
|
||||
, parseAudience
|
||||
, actorRecips
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -32,6 +34,7 @@ import Data.Either
|
|||
import Data.Foldable
|
||||
import Data.List ((\\))
|
||||
import Data.List.NonEmpty (NonEmpty, nonEmpty)
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Traversable
|
||||
|
||||
|
|
@ -62,20 +65,27 @@ import Vervis.Model.Ident
|
|||
data LocalActor
|
||||
= LocalActorSharer ShrIdent
|
||||
| LocalActorProject ShrIdent PrjIdent
|
||||
| LocalActorRepo ShrIdent RpIdent
|
||||
|
||||
parseLocalActor :: Route App -> Maybe LocalActor
|
||||
parseLocalActor (SharerR shr) = Just $ LocalActorSharer shr
|
||||
parseLocalActor (ProjectR shr prj) = Just $ LocalActorProject shr prj
|
||||
parseLocalActor (RepoR shr rp) = Just $ LocalActorRepo shr rp
|
||||
parseLocalActor _ = Nothing
|
||||
|
||||
data LocalPersonCollection
|
||||
= LocalPersonCollectionProjectTeam ShrIdent PrjIdent
|
||||
= LocalPersonCollectionSharerFollowers ShrIdent
|
||||
| LocalPersonCollectionProjectTeam ShrIdent PrjIdent
|
||||
| LocalPersonCollectionProjectFollowers ShrIdent PrjIdent
|
||||
| LocalPersonCollectionTicketTeam ShrIdent PrjIdent Int
|
||||
| LocalPersonCollectionTicketFollowers ShrIdent PrjIdent Int
|
||||
| LocalPersonCollectionRepoTeam ShrIdent RpIdent
|
||||
| LocalPersonCollectionRepoFollowers ShrIdent RpIdent
|
||||
|
||||
parseLocalPersonCollection
|
||||
:: Route App -> Maybe LocalPersonCollection
|
||||
parseLocalPersonCollection (SharerFollowersR shr) =
|
||||
Just $ LocalPersonCollectionSharerFollowers shr
|
||||
parseLocalPersonCollection (ProjectTeamR shr prj) =
|
||||
Just $ LocalPersonCollectionProjectTeam shr prj
|
||||
parseLocalPersonCollection (ProjectFollowersR shr prj) =
|
||||
|
|
@ -84,6 +94,10 @@ parseLocalPersonCollection (TicketTeamR shr prj num) =
|
|||
Just $ LocalPersonCollectionTicketTeam shr prj num
|
||||
parseLocalPersonCollection (TicketParticipantsR shr prj num) =
|
||||
Just $ LocalPersonCollectionTicketFollowers shr prj num
|
||||
parseLocalPersonCollection (RepoTeamR shr rp) =
|
||||
Just $ LocalPersonCollectionRepoTeam shr rp
|
||||
parseLocalPersonCollection (RepoFollowersR shr rp) =
|
||||
Just $ LocalPersonCollectionRepoFollowers shr rp
|
||||
parseLocalPersonCollection _ = Nothing
|
||||
|
||||
parseLocalRecipient
|
||||
|
|
@ -113,13 +127,24 @@ data LocalProjectRecipient
|
|||
| LocalTicketRelated Int LocalTicketRecipientDirect
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data LocalRepoRecipientDirect
|
||||
= LocalRepo
|
||||
| LocalRepoTeam
|
||||
| LocalRepoFollowers
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data LocalRepoRecipient = LocalRepoDirect LocalRepoRecipientDirect
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data LocalSharerRecipientDirect
|
||||
= LocalSharer
|
||||
| LocalSharerFollowers
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data LocalSharerRecipient
|
||||
= LocalSharerDirect LocalSharerRecipientDirect
|
||||
| LocalProjectRelated PrjIdent LocalProjectRecipient
|
||||
| LocalRepoRelated RpIdent LocalRepoRecipient
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data LocalGroupedRecipient = LocalSharerRelated ShrIdent LocalSharerRecipient
|
||||
|
|
@ -131,9 +156,14 @@ groupedRecipientFromActor (LocalActorSharer shr) =
|
|||
groupedRecipientFromActor (LocalActorProject shr prj) =
|
||||
LocalSharerRelated shr $ LocalProjectRelated prj $
|
||||
LocalProjectDirect LocalProject
|
||||
groupedRecipientFromActor (LocalActorRepo shr rp) =
|
||||
LocalSharerRelated shr $ LocalRepoRelated rp $ LocalRepoDirect LocalRepo
|
||||
|
||||
groupedRecipientFromCollection
|
||||
:: LocalPersonCollection -> LocalGroupedRecipient
|
||||
groupedRecipientFromCollection
|
||||
(LocalPersonCollectionSharerFollowers shr) =
|
||||
LocalSharerRelated shr $ LocalSharerDirect LocalSharerFollowers
|
||||
groupedRecipientFromCollection
|
||||
(LocalPersonCollectionProjectTeam shr prj) =
|
||||
LocalSharerRelated shr $ LocalProjectRelated prj $
|
||||
|
|
@ -150,6 +180,14 @@ groupedRecipientFromCollection
|
|||
(LocalPersonCollectionTicketFollowers shr prj num) =
|
||||
LocalSharerRelated shr $ LocalProjectRelated prj $
|
||||
LocalTicketRelated num LocalTicketFollowers
|
||||
groupedRecipientFromCollection
|
||||
(LocalPersonCollectionRepoTeam shr rp) =
|
||||
LocalSharerRelated shr $ LocalRepoRelated rp $
|
||||
LocalRepoDirect LocalRepoTeam
|
||||
groupedRecipientFromCollection
|
||||
(LocalPersonCollectionRepoFollowers shr rp) =
|
||||
LocalSharerRelated shr $ LocalRepoRelated rp $
|
||||
LocalRepoDirect LocalRepoFollowers
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Recipient set types
|
||||
|
|
@ -179,14 +217,28 @@ data LocalProjectRelatedSet = LocalProjectRelatedSet
|
|||
}
|
||||
deriving Eq
|
||||
|
||||
data LocalRepoDirectSet = LocalRepoDirectSet
|
||||
{ localRecipRepo :: Bool
|
||||
, localRecipRepoTeam :: Bool
|
||||
, localRecipRepoFollowers :: Bool
|
||||
}
|
||||
deriving Eq
|
||||
|
||||
data LocalRepoRelatedSet = LocalRepoRelatedSet
|
||||
{ localRecipRepoDirect :: LocalRepoDirectSet
|
||||
}
|
||||
deriving Eq
|
||||
|
||||
data LocalSharerDirectSet = LocalSharerDirectSet
|
||||
{ localRecipSharer :: Bool
|
||||
{ localRecipSharer :: Bool
|
||||
, localRecipSharerFollowers :: Bool
|
||||
}
|
||||
deriving Eq
|
||||
|
||||
data LocalSharerRelatedSet = LocalSharerRelatedSet
|
||||
{ localRecipSharerDirect :: LocalSharerDirectSet
|
||||
, localRecipProjectRelated :: [(PrjIdent, LocalProjectRelatedSet)]
|
||||
, localRecipRepoRelated :: [(RpIdent, LocalRepoRelatedSet)]
|
||||
}
|
||||
deriving Eq
|
||||
|
||||
|
|
@ -199,19 +251,24 @@ groupLocalRecipients
|
|||
(\ (LocalSharerRelated shr _) -> shr)
|
||||
(\ (LocalSharerRelated _ lsr) -> lsr)
|
||||
where
|
||||
lsr2set = uncurry mk . partitionEithers . map lsr2e . NE.toList
|
||||
lsr2set = mk . partitionEithers3 . map lsr2e . NE.toList
|
||||
where
|
||||
lsr2e (LocalSharerDirect d) = Left d
|
||||
lsr2e (LocalProjectRelated prj lpr) = Right (prj, lpr)
|
||||
mk ds ts =
|
||||
lsr2e (LocalProjectRelated prj lpr) = Right $ Left (prj, lpr)
|
||||
lsr2e (LocalRepoRelated rp lrr) = Right $ Right (rp, lrr)
|
||||
mk (ds, ps, rs) =
|
||||
LocalSharerRelatedSet
|
||||
(lsrs2set ds)
|
||||
(map (second lpr2set) $ groupWithExtract fst snd ts)
|
||||
(map (second lpr2set) $ groupWithExtract fst snd ps)
|
||||
(map (second lrr2set) $ groupWithExtract fst snd rs)
|
||||
where
|
||||
lsrs2set = foldl' f initial
|
||||
where
|
||||
initial = LocalSharerDirectSet False
|
||||
f s LocalSharer = s { localRecipSharer = True }
|
||||
initial = LocalSharerDirectSet False False
|
||||
f s LocalSharer =
|
||||
s { localRecipSharer = True }
|
||||
f s LocalSharerFollowers =
|
||||
s { localRecipSharerFollowers = True }
|
||||
lpr2set = uncurry mk . partitionEithers . map lpr2e . NE.toList
|
||||
where
|
||||
lpr2e (LocalProjectDirect d) = Left d
|
||||
|
|
@ -237,6 +294,16 @@ groupLocalRecipients
|
|||
s { localRecipTicketTeam = True }
|
||||
f s LocalTicketFollowers =
|
||||
s { localRecipTicketFollowers = True }
|
||||
lrr2set = LocalRepoRelatedSet . foldl' f initial . NE.map unwrap
|
||||
where
|
||||
unwrap (LocalRepoDirect d) = d
|
||||
initial = LocalRepoDirectSet False False False
|
||||
f s LocalRepo = s { localRecipRepo = True }
|
||||
f s LocalRepoTeam = s { localRecipRepoTeam = True }
|
||||
f s LocalRepoFollowers = s { localRecipRepoFollowers = True }
|
||||
partitionEithers3 = adapt . second partitionEithers . partitionEithers
|
||||
where
|
||||
adapt (l1, (l2, l3)) = (l1, l2, l3)
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Parse URIs into a grouped recipient set
|
||||
|
|
@ -299,3 +366,20 @@ parseAudience audience = do
|
|||
where
|
||||
groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
|
||||
groupByHost = groupAllExtract objUriAuthority objUriLocal
|
||||
|
||||
actorIsMember :: LocalActor -> LocalRecipientSet -> Bool
|
||||
actorIsMember (LocalActorSharer shr) lrSet =
|
||||
case lookup shr lrSet of
|
||||
Just lsrSet -> localRecipSharer $ localRecipSharerDirect lsrSet
|
||||
Nothing -> False
|
||||
actorIsMember (LocalActorProject shr prj) lrSet = fromMaybe False $ do
|
||||
lsrSet <- lookup shr lrSet
|
||||
lprSet <- lookup prj $ localRecipProjectRelated lsrSet
|
||||
return $ localRecipProject $ localRecipProjectDirect $ lprSet
|
||||
actorIsMember (LocalActorRepo shr rp) lrSet = fromMaybe False $ do
|
||||
lsrSet <- lookup shr lrSet
|
||||
lrrSet <- lookup rp $ localRecipRepoRelated lsrSet
|
||||
return $ localRecipRepo $ localRecipRepoDirect $ lrrSet
|
||||
|
||||
actorRecips :: LocalActor -> LocalRecipientSet
|
||||
actorRecips = groupLocalRecipients . (: []) . groupedRecipientFromActor
|
||||
|
|
|
|||
|
|
@ -398,7 +398,8 @@ projectOfferTicketF
|
|||
(objUriAuthority $ remoteAuthorURI author)
|
||||
luOffer
|
||||
, acceptResult =
|
||||
encodeRouteLocal $ TicketR shrRecip prjRecip num
|
||||
Just $ encodeRouteLocal $
|
||||
TicketR shrRecip prjRecip num
|
||||
}
|
||||
}
|
||||
obiid <- insert OutboxItem
|
||||
|
|
|
|||
|
|
@ -100,6 +100,7 @@ editRepoAForm sid (Entity rid repo) = Repo
|
|||
<*> aopt selectRole "User role" (Just $ repoCollabUser repo)
|
||||
<*> aopt selectRole "Guest role" (Just $ repoCollabAnon repo)
|
||||
<*> pure (repoInbox repo)
|
||||
<*> pure (repoOutbox repo)
|
||||
<*> pure (repoFollowers repo)
|
||||
where
|
||||
selectProject' = selectProjectForExisting (repoSharer repo) rid
|
||||
|
|
|
|||
|
|
@ -793,6 +793,10 @@ instance YesodBreadcrumbs App where
|
|||
ReposR shar -> ("Repos", Just $ SharerR shar)
|
||||
RepoNewR shar -> ("New", Just $ ReposR shar)
|
||||
RepoR shar repo -> (rp2text repo, Just $ ReposR shar)
|
||||
RepoOutboxR shr rp -> ("Outbox", Just $ RepoR shr rp)
|
||||
RepoOutboxItemR shr rp hid -> ( "#" <> keyHashidText hid
|
||||
, Just $ RepoOutboxR shr rp
|
||||
)
|
||||
RepoEditR shr rp -> ("Edit", Just $ RepoR shr rp)
|
||||
RepoSourceR shar repo [] -> ("Files", Just $ RepoR shar repo)
|
||||
RepoSourceR shar repo refdir -> ( last refdir
|
||||
|
|
|
|||
|
|
@ -27,6 +27,8 @@ module Vervis.Handler.Inbox
|
|||
, postSharerOutboxR
|
||||
, getProjectOutboxR
|
||||
, getProjectOutboxItemR
|
||||
, getRepoOutboxR
|
||||
, getRepoOutboxItemR
|
||||
, getActorKey1R
|
||||
, getActorKey2R
|
||||
, getNotificationsR
|
||||
|
|
@ -39,24 +41,15 @@ import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
|
|||
import Control.Exception hiding (Handler)
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.Logger.CallStack
|
||||
import Control.Monad.STM (atomically)
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Maybe
|
||||
import Crypto.Error (CryptoFailable (..))
|
||||
import Crypto.PubKey.Ed25519 (publicKey, signature, verify)
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Encode.Pretty
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.Foldable (for_)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.List
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Maybe
|
||||
import Data.PEM (PEM (..))
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8')
|
||||
import Data.Text.Lazy.Encoding (decodeUtf8)
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Interval (TimeInterval, toTimeUnit)
|
||||
|
|
@ -64,18 +57,12 @@ import Data.Time.Units (Second)
|
|||
import Data.Traversable
|
||||
import Database.Persist
|
||||
import Database.Persist.Sql
|
||||
import Network.HTTP.Client (Manager, HttpException, requestFromURI)
|
||||
import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
|
||||
import Network.HTTP.Types.Header (hDate, hHost)
|
||||
import Network.HTTP.Types.Status
|
||||
import Text.Blaze.Html (Html, preEscapedToHtml)
|
||||
import Text.Blaze.Html.Renderer.Text
|
||||
import Text.HTML.SanitizeXSS
|
||||
import Text.Shakespeare.I18N (RenderMessage)
|
||||
import UnliftIO.Exception (try)
|
||||
import Yesod.Auth (requireAuth)
|
||||
import Yesod.Core
|
||||
import Yesod.Core.Json (requireJsonBody)
|
||||
import Yesod.Core.Handler
|
||||
import Yesod.Form.Fields
|
||||
import Yesod.Form.Functions
|
||||
|
|
@ -83,20 +70,11 @@ import Yesod.Form.Types
|
|||
import Yesod.Persist.Core
|
||||
|
||||
import qualified Data.ByteString.Char8 as BC (unpack)
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import qualified Data.CaseInsensitive as CI (mk)
|
||||
import qualified Data.HashMap.Strict as M (lookup, insert, adjust, fromList)
|
||||
import qualified Data.HashMap.Strict as M
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL (toStrict)
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
import qualified Data.Vector as V
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Network.Wai as W (requestMethod, rawPathInfo, requestHeaders)
|
||||
|
||||
import Network.HTTP.Signature hiding (Algorithm (..))
|
||||
import Yesod.HttpSignature (verifyRequestSignature)
|
||||
|
||||
import qualified Network.HTTP.Signature as S (Algorithm (..))
|
||||
|
||||
import Database.Persist.JSON
|
||||
import Network.FedURI
|
||||
|
|
@ -107,8 +85,6 @@ import Yesod.FedURI
|
|||
import Yesod.Hashids
|
||||
import Yesod.RenderSource
|
||||
|
||||
import qualified Data.Aeson.Encode.Pretty.ToEncoding as AEP
|
||||
|
||||
import Data.Aeson.Local
|
||||
import Data.Either.Local
|
||||
import Data.EventTime.Local
|
||||
|
|
@ -127,8 +103,6 @@ import Vervis.Foundation
|
|||
import Vervis.Model hiding (Ticket)
|
||||
import Vervis.Model.Ident
|
||||
import Vervis.Paginate
|
||||
import Vervis.RemoteActorStore
|
||||
import Yesod.RenderSource
|
||||
import Vervis.Settings
|
||||
|
||||
getShowTime = showTime <$> liftIO getCurrentTime
|
||||
|
|
@ -433,8 +407,20 @@ openTicketForm html = do
|
|||
deft = "Time slows down when tasting coconut ice-cream"
|
||||
defd = "Is that slow-motion effect intentional? :)"
|
||||
|
||||
activityWidget :: ShrIdent -> Widget -> Enctype -> Widget -> Enctype -> Widget
|
||||
activityWidget shr widget1 enctype1 widget2 enctype2 =
|
||||
followForm :: Form (FedURI, FedURI)
|
||||
followForm = renderDivs $ (,)
|
||||
<$> areq fedUriField "Target" (Just deft)
|
||||
<*> areq fedUriField "Recipient" (Just deft)
|
||||
where
|
||||
deft = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33"
|
||||
|
||||
activityWidget
|
||||
:: ShrIdent
|
||||
-> Widget -> Enctype
|
||||
-> Widget -> Enctype
|
||||
-> Widget -> Enctype
|
||||
-> Widget
|
||||
activityWidget shr widget1 enctype1 widget2 enctype2 widget3 enctype3 =
|
||||
[whamlet|
|
||||
<h1>Publish a ticket comment
|
||||
<form method=POST action=@{SharerOutboxR shr} enctype=#{enctype1}>
|
||||
|
|
@ -445,6 +431,11 @@ activityWidget shr widget1 enctype1 widget2 enctype2 =
|
|||
<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
|
||||
|
|
@ -460,7 +451,10 @@ getPublishR = do
|
|||
runFormPost $ identifyForm "f1" publishCommentForm
|
||||
((_result2, widget2), enctype2) <-
|
||||
runFormPost $ identifyForm "f2" openTicketForm
|
||||
defaultLayout $ activityWidget shr widget1 enctype1 widget2 enctype2
|
||||
((_result3, widget3), enctype3) <-
|
||||
runFormPost $ identifyForm "f3" followForm
|
||||
defaultLayout $
|
||||
activityWidget shr widget1 enctype1 widget2 enctype2 widget3 enctype3
|
||||
|
||||
getOutbox :: Route App -> AppDB OutboxId -> Handler TypedContent
|
||||
getOutbox here getObid = do
|
||||
|
|
@ -553,7 +547,12 @@ postSharerOutboxR shrAuthor = do
|
|||
runFormPost $ identifyForm "f1" publishCommentForm
|
||||
((result2, widget2), enctype2) <-
|
||||
runFormPost $ identifyForm "f2" openTicketForm
|
||||
let result = Left <$> result1 <|> Right <$> result2
|
||||
((result3, widget3), enctype3) <-
|
||||
runFormPost $ identifyForm "f3" followForm
|
||||
let result
|
||||
= Left <$> result1
|
||||
<|> Right . Left <$> result2
|
||||
<|> Right . Right <$> result3
|
||||
|
||||
eid <- runExceptT $ do
|
||||
input <-
|
||||
|
|
@ -561,7 +560,7 @@ postSharerOutboxR shrAuthor = do
|
|||
FormMissing -> throwE "Field(s) missing"
|
||||
FormFailure _l -> throwE "Invalid input, see below"
|
||||
FormSuccess r -> return r
|
||||
bitraverse publishComment openTicket input
|
||||
bitraverse publishComment (bitraverse openTicket follow) input
|
||||
case eid of
|
||||
Left err -> setMessage $ toHtml err
|
||||
Right id_ ->
|
||||
|
|
@ -571,9 +570,16 @@ postSharerOutboxR shrAuthor = do
|
|||
renderUrl <- getUrlRender
|
||||
let u = renderUrl $ MessageR shrAuthor lmkhid
|
||||
setMessage $ toHtml $ "Message created! ID: " <> u
|
||||
Right _obiid ->
|
||||
Right (Left _obiid) ->
|
||||
setMessage "Ticket offer published!"
|
||||
defaultLayout $ activityWidget shrAuthor widget1 enctype1 widget2 enctype2
|
||||
Right (Right _obiid) ->
|
||||
setMessage "Follow request published!"
|
||||
defaultLayout $
|
||||
activityWidget
|
||||
shrAuthor
|
||||
widget1 enctype1
|
||||
widget2 enctype2
|
||||
widget3 enctype3
|
||||
where
|
||||
publishComment ((hTicket, shrTicket, prj, num), muParent, msg) = do
|
||||
encodeRouteFed <- getEncodeRouteHome
|
||||
|
|
@ -656,6 +662,25 @@ postSharerOutboxR shrAuthor = do
|
|||
, audienceNonActors = map (encodeRouteFed h) recipsC
|
||||
}
|
||||
ExceptT $ offerTicketC shrAuthor summary audience offer
|
||||
follow (uObject@(ObjURI hObject luObject), uRecip) = do
|
||||
summary <-
|
||||
TextHtml . TL.toStrict . renderHtml <$>
|
||||
withUrlRenderer
|
||||
[hamlet|
|
||||
<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
|
||||
|
|
@ -676,6 +701,25 @@ getProjectOutboxItemR shr prj obikhid = getOutboxItem here getObid obikhid
|
|||
j <- getValBy404 $ UniqueProject prj sid
|
||||
return $ projectOutbox j
|
||||
|
||||
getRepoOutboxR :: ShrIdent -> RpIdent -> Handler TypedContent
|
||||
getRepoOutboxR shr rp = getOutbox here getObid
|
||||
where
|
||||
here = RepoOutboxR shr rp
|
||||
getObid = do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
r <- getValBy404 $ UniqueRepo rp sid
|
||||
return $ repoOutbox r
|
||||
|
||||
getRepoOutboxItemR
|
||||
:: ShrIdent -> RpIdent -> KeyHashid OutboxItem -> Handler TypedContent
|
||||
getRepoOutboxItemR shr rp obikhid = getOutboxItem here getObid obikhid
|
||||
where
|
||||
here = RepoOutboxItemR shr rp obikhid
|
||||
getObid = do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
r <- getValBy404 $ UniqueRepo rp sid
|
||||
return $ repoOutbox r
|
||||
|
||||
getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
|
||||
getActorKey choose route = do
|
||||
actorKey <-
|
||||
|
|
|
|||
|
|
@ -159,6 +159,7 @@ postReposR user = do
|
|||
pid <- requireAuthId
|
||||
runDB $ do
|
||||
ibid <- insert Inbox
|
||||
obid <- insert Outbox
|
||||
fsid <- insert FollowerSet
|
||||
let repo = Repo
|
||||
{ repoIdent = nrpIdent nrp
|
||||
|
|
@ -170,6 +171,7 @@ postReposR user = do
|
|||
, repoCollabUser = Nothing
|
||||
, repoCollabAnon = Nothing
|
||||
, repoInbox = ibid
|
||||
, repoOutbox = obid
|
||||
, repoFollowers = fsid
|
||||
}
|
||||
rid <- insert repo
|
||||
|
|
@ -213,10 +215,14 @@ getRepoR shr rp = do
|
|||
, actorName = Just $ rp2text rp
|
||||
, actorSummary = repoDesc repo
|
||||
, actorInbox = encodeRouteLocal $ RepoInboxR shr rp
|
||||
, actorOutbox = Nothing
|
||||
, actorOutbox =
|
||||
Just $ encodeRouteLocal $ RepoOutboxR shr rp
|
||||
, actorFollowers =
|
||||
Just $ encodeRouteLocal $ RepoFollowersR shr rp
|
||||
, actorPublicKeys = []
|
||||
, actorPublicKeys =
|
||||
[ Left $ encodeRouteLocal ActorKey1R
|
||||
, Left $ encodeRouteLocal ActorKey2R
|
||||
]
|
||||
}
|
||||
, AP.repoTeam = encodeRouteLocal $ RepoTeamR shr rp
|
||||
}
|
||||
|
|
|
|||
|
|
@ -941,7 +941,8 @@ changes hLocal ctx =
|
|||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = encodeRouteHome offerR
|
||||
, acceptResult =
|
||||
encodeRouteLocal $ TicketR shrProject prj num
|
||||
Just $ encodeRouteLocal $
|
||||
TicketR shrProject prj num
|
||||
}
|
||||
}
|
||||
obiidNew <- insert OutboxItem20190624
|
||||
|
|
@ -1054,6 +1055,20 @@ changes hLocal ctx =
|
|||
, addFieldPrimRequired "Follow" True "public"
|
||||
-- 137
|
||||
, addFieldPrimRequired "RemoteFollow" True "public"
|
||||
-- 138
|
||||
, addFieldRefRequired'
|
||||
"Repo"
|
||||
Outbox138
|
||||
(Just $ do
|
||||
rids <- selectKeysList ([] :: [Filter Repo138]) []
|
||||
for_ rids $ \ rid -> do
|
||||
obid <- insert Outbox138
|
||||
update rid [Repo138Outbox =. obid]
|
||||
)
|
||||
"outbox"
|
||||
"Outbox"
|
||||
-- 139
|
||||
, addUnique "Repo" $ Unique "UniqueRepoOutbox" ["outbox"]
|
||||
]
|
||||
|
||||
migrateDB
|
||||
|
|
|
|||
|
|
@ -122,6 +122,8 @@ module Vervis.Migration.Model
|
|||
, FollowerSet130Generic (..)
|
||||
, Repo130
|
||||
, Person130
|
||||
, Outbox138Generic (..)
|
||||
, Repo138
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -246,3 +248,6 @@ makeEntitiesMigration "127"
|
|||
|
||||
makeEntitiesMigration "130"
|
||||
$(modelFile "migrations/2019_09_06.model")
|
||||
|
||||
makeEntitiesMigration "138"
|
||||
$(modelFile "migrations/2019_09_10.model")
|
||||
|
|
|
|||
|
|
@ -975,19 +975,19 @@ instance ActivityPub Branch where
|
|||
|
||||
data Accept u = Accept
|
||||
{ acceptObject :: ObjURI u
|
||||
, acceptResult :: LocalURI
|
||||
, acceptResult :: Maybe LocalURI
|
||||
}
|
||||
|
||||
parseAccept :: UriMode u => Authority u -> Object -> Parser (Accept u)
|
||||
parseAccept a o =
|
||||
Accept
|
||||
<$> o .: "object"
|
||||
<*> withAuthorityO a (o .: "result")
|
||||
<*> withAuthorityMaybeO a (o .:? "result")
|
||||
|
||||
encodeAccept :: UriMode u => Authority u -> Accept u -> Series
|
||||
encodeAccept authority (Accept obj result)
|
||||
= "object" .= obj
|
||||
<> "result" .= ObjURI authority result
|
||||
encodeAccept authority (Accept obj mresult)
|
||||
= "object" .= obj
|
||||
<> "result" .=? (ObjURI authority <$> mresult)
|
||||
|
||||
data Create u = Create
|
||||
{ createObject :: Note u
|
||||
|
|
|
|||
Loading…
Reference in a new issue