Implement remote following, disable automatic following
This patch contains migrations that require that there are no follow records. If you have any, the migration will (hopefully) fail and you'll need to manually delete any follow records you have. In the next patch I'll try to add automatic following on the pseudo-client side by running both e.g. createNoteC and followC in the same POST request handler.
This commit is contained in:
parent
1673851db0
commit
5a7700ffe4
17 changed files with 860 additions and 560 deletions
|
@ -149,6 +149,28 @@ RemoteCollection
|
||||||
|
|
||||||
UniqueRemoteCollection instance ident
|
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
|
FollowerSet
|
||||||
|
|
||||||
Follow
|
Follow
|
||||||
|
@ -156,16 +178,24 @@ Follow
|
||||||
target FollowerSetId
|
target FollowerSetId
|
||||||
manual Bool
|
manual Bool
|
||||||
public Bool
|
public Bool
|
||||||
|
follow OutboxItemId
|
||||||
|
accept OutboxItemId
|
||||||
|
|
||||||
UniqueFollow person target
|
UniqueFollow person target
|
||||||
|
UniqueFollowFollow follow
|
||||||
|
UniqueFollowAccept accept
|
||||||
|
|
||||||
RemoteFollow
|
RemoteFollow
|
||||||
actor RemoteActorId
|
actor RemoteActorId
|
||||||
target FollowerSetId
|
target FollowerSetId
|
||||||
manual Bool
|
manual Bool
|
||||||
public Bool
|
public Bool
|
||||||
|
follow RemoteActivityId
|
||||||
|
accept OutboxItemId
|
||||||
|
|
||||||
UniqueRemoteFollow actor target
|
UniqueRemoteFollow actor target
|
||||||
|
UniqueRemoteFollowFollow follow
|
||||||
|
UniqueRemoteFollowAccept accept
|
||||||
|
|
||||||
SshKey
|
SshKey
|
||||||
ident KyIdent
|
ident KyIdent
|
||||||
|
|
|
@ -63,6 +63,7 @@
|
||||||
/s/#ShrIdent/outbox SharerOutboxR GET POST
|
/s/#ShrIdent/outbox SharerOutboxR GET POST
|
||||||
/s/#ShrIdent/outbox/#OutboxItemKeyHashid SharerOutboxItemR GET
|
/s/#ShrIdent/outbox/#OutboxItemKeyHashid SharerOutboxItemR GET
|
||||||
/s/#ShrIdent/followers SharerFollowersR GET
|
/s/#ShrIdent/followers SharerFollowersR GET
|
||||||
|
/s/#ShrIdent/follow SharerFollowR POST
|
||||||
|
|
||||||
/p PeopleR GET
|
/p PeopleR GET
|
||||||
|
|
||||||
|
@ -91,6 +92,7 @@
|
||||||
/s/#ShrIdent/r/#RpIdent/team RepoTeamR GET
|
/s/#ShrIdent/r/#RpIdent/team RepoTeamR GET
|
||||||
/s/#ShrIdent/r/#RpIdent/followers RepoFollowersR GET
|
/s/#ShrIdent/r/#RpIdent/followers RepoFollowersR GET
|
||||||
/s/#ShrIdent/r/#RpIdent/edit RepoEditR 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/s/+Texts RepoSourceR GET
|
||||||
/s/#ShrIdent/r/#RpIdent/c RepoHeadChangesR GET
|
/s/#ShrIdent/r/#RpIdent/c RepoHeadChangesR GET
|
||||||
/s/#ShrIdent/r/#RpIdent/b/#Text RepoBranchR GET
|
/s/#ShrIdent/r/#RpIdent/b/#Text RepoBranchR GET
|
||||||
|
@ -114,6 +116,7 @@
|
||||||
/s/#ShrIdent/p/#PrjIdent/team ProjectTeamR GET
|
/s/#ShrIdent/p/#PrjIdent/team ProjectTeamR GET
|
||||||
/s/#ShrIdent/p/#PrjIdent/followers ProjectFollowersR GET
|
/s/#ShrIdent/p/#PrjIdent/followers ProjectFollowersR GET
|
||||||
/s/#ShrIdent/p/#PrjIdent/edit ProjectEditR 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 ProjectDevsR GET POST
|
||||||
/s/#ShrIdent/p/#PrjIdent/d/!new ProjectDevNewR GET
|
/s/#ShrIdent/p/#PrjIdent/d/!new ProjectDevNewR GET
|
||||||
/s/#ShrIdent/p/#PrjIdent/d/#ShrIdent ProjectDevR GET DELETE POST
|
/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/unclaim TicketUnclaimR POST
|
||||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/assign TicketAssignR GET 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/unassign TicketUnassignR POST
|
||||||
|
/s/#ShrIdent/p/#PrjIdent/t/#Int/follow TicketFollowR POST
|
||||||
/s/#ShrIdent/p/#PrjIdent/tcr ClaimRequestsProjectR GET
|
/s/#ShrIdent/p/#PrjIdent/tcr ClaimRequestsProjectR GET
|
||||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/cr ClaimRequestsTicketR GET POST
|
/s/#ShrIdent/p/#PrjIdent/t/#Int/cr ClaimRequestsTicketR GET POST
|
||||||
/s/#ShrIdent/p/#PrjIdent/t/#Int/cr/new ClaimRequestNewR GET
|
/s/#ShrIdent/p/#PrjIdent/t/#Int/cr/new ClaimRequestNewR GET
|
||||||
|
|
21
migrations/2019_09_25.model
Normal file
21
migrations/2019_09_25.model
Normal 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
|
|
@ -182,7 +182,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
|
||||||
unless (messageRoot m == did) $
|
unless (messageRoot m == did) $
|
||||||
throwE "Remote parent belongs to a different discussion"
|
throwE "Remote parent belongs to a different discussion"
|
||||||
return mid
|
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))
|
return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject, fsidProject))
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
(rd, rdnew) <- lift $ do
|
(rd, rdnew) <- lift $ do
|
||||||
|
@ -452,7 +452,7 @@ followC
|
||||||
-> Audience URIMode
|
-> Audience URIMode
|
||||||
-> AP.Follow URIMode
|
-> AP.Follow URIMode
|
||||||
-> Handler (Either Text OutboxItemId)
|
-> 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
|
(localRecips, remoteRecips) <- do
|
||||||
mrecips <- parseAudience audience
|
mrecips <- parseAudience audience
|
||||||
fromMaybeE mrecips "Follow with no recipients"
|
fromMaybeE mrecips "Follow with no recipients"
|
||||||
|
@ -490,11 +490,13 @@ followC shrUser summary audience follow@(AP.Follow uObject hide) = runExceptT $
|
||||||
let ibidAuthor = personInbox personAuthor
|
let ibidAuthor = personInbox personAuthor
|
||||||
obidAuthor = personOutbox personAuthor
|
obidAuthor = personOutbox personAuthor
|
||||||
(obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox obidAuthor
|
(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
|
(fsid, ibidRecip, unread, obidRecip) <- getFollowee followee
|
||||||
lift $ do
|
lift $ do
|
||||||
deliverFollowLocal pidAuthor fsid unread obiidFollow ibidRecip
|
|
||||||
obiidAccept <- insertAcceptToOutbox luFollow actorRecip obidRecip
|
obiidAccept <- insertAcceptToOutbox luFollow actorRecip obidRecip
|
||||||
|
deliverFollowLocal pidAuthor fsid unread obiidFollow obiidAccept ibidRecip
|
||||||
deliverAcceptLocal obiidAccept ibidAuthor
|
deliverAcceptLocal obiidAccept ibidAuthor
|
||||||
remotesHttp <- lift $ deliverRemoteDB' dont obiidFollow remoteRecips []
|
remotesHttp <- lift $ deliverRemoteDB' dont obiidFollow remoteRecips []
|
||||||
return (obiidFollow, doc, remotesHttp)
|
return (obiidFollow, doc, remotesHttp)
|
||||||
|
@ -572,10 +574,10 @@ followC shrUser summary audience follow@(AP.Follow uObject hide) = runExceptT $
|
||||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||||
return (obiid, doc, luAct)
|
return (obiid, doc, luAct)
|
||||||
|
|
||||||
deliverFollowLocal pidAuthor fsid unread obiid ibidRecip = do
|
deliverFollowLocal pidAuthor fsid unread obiidF obiidA ibidRecip = do
|
||||||
insert_ $ Follow pidAuthor fsid True (not hide)
|
insert_ $ Follow pidAuthor fsid True (not hide) obiidF obiidA
|
||||||
ibiid <- insert $ InboxItem unread
|
ibiid <- insert $ InboxItem unread
|
||||||
insert_ $ InboxItemLocal ibidRecip obiid ibiid
|
insert_ $ InboxItemLocal ibidRecip obiidF ibiid
|
||||||
|
|
||||||
insertAcceptToOutbox luFollow actorRecip obidRecip = do
|
insertAcceptToOutbox luFollow actorRecip obidRecip = do
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
|
@ -854,13 +856,13 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
|
||||||
, ticketFollowers = fsid
|
, ticketFollowers = fsid
|
||||||
, ticketAccept = obiidAccept
|
, ticketAccept = obiidAccept
|
||||||
}
|
}
|
||||||
insert TicketAuthorLocal
|
insert_ TicketAuthorLocal
|
||||||
{ ticketAuthorLocalTicket = tid
|
{ ticketAuthorLocalTicket = tid
|
||||||
, ticketAuthorLocalAuthor = pidAuthor
|
, ticketAuthorLocalAuthor = pidAuthor
|
||||||
, ticketAuthorLocalOffer = obiid
|
, ticketAuthorLocalOffer = obiid
|
||||||
}
|
}
|
||||||
--insertMany_ $ map (TicketDependency tid) tidsDeps
|
--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
|
publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
let dont = Authority "dont-do.any-forwarding" Nothing
|
let dont = Authority "dont-do.any-forwarding" Nothing
|
||||||
|
|
|
@ -83,6 +83,7 @@ import Vervis.RemoteActorStore
|
||||||
|
|
||||||
-- Import all relevant handler modules here.
|
-- Import all relevant handler modules here.
|
||||||
-- Don't forget to add new modules to your cabal file!
|
-- Don't forget to add new modules to your cabal file!
|
||||||
|
import Vervis.Handler.Client
|
||||||
import Vervis.Handler.Common
|
import Vervis.Handler.Common
|
||||||
import Vervis.Handler.Git
|
import Vervis.Handler.Git
|
||||||
import Vervis.Handler.Group
|
import Vervis.Handler.Group
|
||||||
|
|
99
src/Vervis/Client.hs
Normal file
99
src/Vervis/Client.hs
Normal 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
|
|
@ -318,7 +318,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
|
||||||
delete mid
|
delete mid
|
||||||
return Nothing
|
return Nothing
|
||||||
Just _ -> do
|
Just _ -> do
|
||||||
insertUnique_ $ RemoteFollow raidAuthor fsid False True
|
-- insertUnique_ $ RemoteFollow raidAuthor fsid False True
|
||||||
ibiid <- insert $ InboxItem False
|
ibiid <- insert $ InboxItem False
|
||||||
insert_ $ InboxItemRemote ibid ractid ibiid
|
insert_ $ InboxItemRemote ibid ractid ibiid
|
||||||
return $ Just (ractid, mid)
|
return $ Just (ractid, mid)
|
||||||
|
|
|
@ -29,6 +29,7 @@ import Control.Monad
|
||||||
import Control.Monad.Logger.CallStack
|
import Control.Monad.Logger.CallStack
|
||||||
import Control.Monad.Trans.Class
|
import Control.Monad.Trans.Class
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
import Data.Bifunctor
|
import Data.Bifunctor
|
||||||
import Data.Foldable
|
import Data.Foldable
|
||||||
|
@ -75,20 +76,32 @@ import Vervis.Model
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
import Vervis.Model.Ticket
|
import Vervis.Model.Ticket
|
||||||
|
|
||||||
acceptF
|
sharerAcceptF
|
||||||
:: AppDB InboxId
|
:: ShrIdent
|
||||||
-> Route App
|
|
||||||
-> UTCTime
|
-> UTCTime
|
||||||
-> RemoteAuthor
|
-> RemoteAuthor
|
||||||
-> ActivityBody
|
-> ActivityBody
|
||||||
-> Accept URIMode
|
-> Accept URIMode
|
||||||
-> ExceptT Text Handler Text
|
-> 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 <-
|
luAccept <-
|
||||||
fromMaybeE (activityId $ actbActivity body) "Accept without 'id'"
|
fromMaybeE (activityId $ actbActivity body) "Accept without 'id'"
|
||||||
lift $ runDB $ do
|
lift $ runDB $ do
|
||||||
ibidRecip <- getIbid
|
Entity pidRecip recip <- do
|
||||||
insertToInbox luAccept ibidRecip
|
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
|
where
|
||||||
insertToInbox luAccept ibidRecip = do
|
insertToInbox luAccept ibidRecip = do
|
||||||
let iidAuthor = remoteAuthorInstance author
|
let iidAuthor = remoteAuthorInstance author
|
||||||
|
@ -98,76 +111,64 @@ acceptF getIbid route now author body (Accept _uOffer _luTicket) = do
|
||||||
ibiid <- insert $ InboxItem True
|
ibiid <- insert $ InboxItem True
|
||||||
mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
|
mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
let recip = localUriPath $ encodeRouteLocal route
|
|
||||||
case mibrid of
|
case mibrid of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
delete ibiid
|
delete ibiid
|
||||||
return $ "Activity already exists in inbox of " <> recip
|
return Nothing
|
||||||
Just _ -> return $ "Activity inserted to inbox of " <> recip
|
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
|
:: ShrIdent
|
||||||
-> UTCTime
|
-> UTCTime
|
||||||
-> RemoteAuthor
|
-> RemoteAuthor
|
||||||
-> ActivityBody
|
-> 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
|
-> Reject URIMode
|
||||||
-> ExceptT Text Handler Text
|
-> ExceptT Text Handler Text
|
||||||
rejectF getIbid route now author body (Reject _uOffer) = do
|
sharerRejectF shr now author body (Reject (ObjURI hOffer luOffer)) = do
|
||||||
luReject <-
|
luReject <-
|
||||||
fromMaybeE (activityId $ actbActivity body) "Reject without 'id'"
|
fromMaybeE (activityId $ actbActivity body) "Reject without 'id'"
|
||||||
lift $ runDB $ do
|
lift $ runDB $ do
|
||||||
ibidRecip <- getIbid
|
Entity pidRecip recip <- do
|
||||||
insertToInbox luReject ibidRecip
|
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
|
where
|
||||||
insertToInbox luReject ibidRecip = do
|
insertToInbox luReject ibidRecip = do
|
||||||
let iidAuthor = remoteAuthorInstance author
|
let iidAuthor = remoteAuthorInstance author
|
||||||
|
@ -177,61 +178,29 @@ rejectF getIbid route now author body (Reject _uOffer) = do
|
||||||
ibiid <- insert $ InboxItem True
|
ibiid <- insert $ InboxItem True
|
||||||
mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
|
mibrid <- insertUnique $ InboxItemRemote ibidRecip ractid ibiid
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
let recip = localUriPath $ encodeRouteLocal route
|
|
||||||
case mibrid of
|
case mibrid of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
delete ibiid
|
delete ibiid
|
||||||
return $ "Activity already exists in inbox of " <> recip
|
return Nothing
|
||||||
Just _ -> return $ "Activity inserted to inbox of " <> recip
|
Just _ -> return $ Just ractid
|
||||||
|
deleteFollow pidRecip obidRecip = runMaybeT $ do
|
||||||
sharerRejectF
|
guard =<< hostIsLocal hOffer
|
||||||
:: ShrIdent
|
route <- MaybeT . pure $ decodeRouteLocal luOffer
|
||||||
-> UTCTime
|
obiid <-
|
||||||
-> RemoteAuthor
|
case route of
|
||||||
-> ActivityBody
|
SharerOutboxItemR shr' obikhid
|
||||||
-> Reject URIMode
|
| shr == shr' -> decodeKeyHashidM obikhid
|
||||||
-> ExceptT Text Handler Text
|
_ -> MaybeT $ pure Nothing
|
||||||
sharerRejectF shr = rejectF getIbid route
|
obi <- MaybeT $ get obiid
|
||||||
where
|
guard $ outboxItemOutbox obi == obidRecip
|
||||||
route = SharerR shr
|
Entity frrid frr <- MaybeT $ getBy $ UniqueFollowRemoteRequestActivity obiid
|
||||||
getIbid = do
|
guard $ followRemoteRequestPerson frr == pidRecip
|
||||||
sid <- getKeyBy404 $ UniqueSharer shr
|
let originalRecip =
|
||||||
p <- getValBy404 $ UniquePersonIdent sid
|
case followRemoteRequestRecip frr of
|
||||||
return $ personInbox p
|
Nothing -> followRemoteRequestTarget frr
|
||||||
|
Just u -> u
|
||||||
{-
|
guard $ originalRecip == remoteAuthorURI author
|
||||||
projectRejectF
|
lift $ delete frrid
|
||||||
:: 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
|
|
||||||
-}
|
|
||||||
|
|
||||||
followF
|
followF
|
||||||
:: (Route App -> Maybe a)
|
:: (Route App -> Maybe a)
|
||||||
|
@ -248,7 +217,7 @@ followF
|
||||||
-> ExceptT Text Handler Text
|
-> ExceptT Text Handler Text
|
||||||
followF
|
followF
|
||||||
objRoute recipRoute getRecip recipInbox recipOutbox recipFollowers outboxItemRoute
|
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
|
mobj <- do
|
||||||
local <- hostIsLocal hObj
|
local <- hostIsLocal hObj
|
||||||
return $
|
return $
|
||||||
|
@ -265,15 +234,16 @@ followF
|
||||||
emsg <- lift $ runDB $ do
|
emsg <- lift $ runDB $ do
|
||||||
recip <- getRecip obj
|
recip <- getRecip obj
|
||||||
newItem <- insertToInbox luFollow $ recipInbox recip
|
newItem <- insertToInbox luFollow $ recipInbox recip
|
||||||
if newItem
|
case newItem of
|
||||||
then do
|
Nothing -> return $ Left "Activity already exists in inbox, not using"
|
||||||
newFollow <- insertFollow $ recipFollowers recip
|
Just ractid -> do
|
||||||
if newFollow
|
|
||||||
then Right <$> do
|
|
||||||
(obiid, doc) <-
|
(obiid, doc) <-
|
||||||
insertAcceptToOutbox
|
insertAcceptToOutbox
|
||||||
luFollow
|
luFollow
|
||||||
(recipOutbox recip)
|
(recipOutbox recip)
|
||||||
|
newFollow <- insertFollow ractid obiid $ recipFollowers recip
|
||||||
|
if newFollow
|
||||||
|
then Right <$> do
|
||||||
let raidAuthor = remoteAuthorId author
|
let raidAuthor = remoteAuthorId author
|
||||||
ra <- getJust raidAuthor
|
ra <- getJust raidAuthor
|
||||||
let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra)
|
let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra)
|
||||||
|
@ -281,8 +251,9 @@ followF
|
||||||
hAuthor = objUriAuthority $ remoteAuthorURI author
|
hAuthor = objUriAuthority $ remoteAuthorURI author
|
||||||
hostSection = ((iidAuthor, hAuthor), raInfo :| [])
|
hostSection = ((iidAuthor, hAuthor), raInfo :| [])
|
||||||
(obiid, doc,) <$> deliverRemoteDB' dont obiid [] [hostSection]
|
(obiid, doc,) <$> deliverRemoteDB' dont obiid [] [hostSection]
|
||||||
else return $ Left "You're already a follower of me"
|
else do
|
||||||
else return $ Left "Activity already exists in inbox, not using"
|
delete obiid
|
||||||
|
return $ Left "You're already a follower of me"
|
||||||
case emsg of
|
case emsg of
|
||||||
Left msg -> return msg
|
Left msg -> return msg
|
||||||
Right (obiid, doc, remotesHttp) -> do
|
Right (obiid, doc, remotesHttp) -> do
|
||||||
|
@ -302,12 +273,12 @@ followF
|
||||||
case mibrid of
|
case mibrid of
|
||||||
Nothing -> do
|
Nothing -> do
|
||||||
delete ibiid
|
delete ibiid
|
||||||
return False
|
return Nothing
|
||||||
Just _ -> return True
|
Just _ -> return $ Just ractid
|
||||||
|
|
||||||
insertFollow fsid = do
|
insertFollow ractid obiidA fsid = do
|
||||||
let raid = remoteAuthorId author
|
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
|
return $ isJust mrfid
|
||||||
|
|
||||||
insertAcceptToOutbox luFollow obidRecip = do
|
insertAcceptToOutbox luFollow obidRecip = do
|
||||||
|
|
|
@ -262,7 +262,7 @@ projectOfferTicketF
|
||||||
, ticketAuthorRemoteOffer = ractid
|
, ticketAuthorRemoteOffer = ractid
|
||||||
}
|
}
|
||||||
-- insertMany_ $ map (TicketDependency tid) deps
|
-- insertMany_ $ map (TicketDependency tid) deps
|
||||||
insert_ $ RemoteFollow raidAuthor fsid False True
|
--insert_ $ RemoteFollow raidAuthor fsid False True
|
||||||
return $ Just (ractid, next, obiidAccept, docAccept)
|
return $ Just (ractid, next, obiidAccept, docAccept)
|
||||||
|
|
||||||
deliverLocal
|
deliverLocal
|
||||||
|
|
|
@ -299,6 +299,7 @@ instance Yesod App where
|
||||||
(SharerInboxR shr , False) -> person shr
|
(SharerInboxR shr , False) -> person shr
|
||||||
(NotificationsR shr , _ ) -> person shr
|
(NotificationsR shr , _ ) -> person shr
|
||||||
(SharerOutboxR shr , True) -> person shr
|
(SharerOutboxR shr , True) -> person shr
|
||||||
|
(SharerFollowR shr , True) -> personAny
|
||||||
|
|
||||||
(GroupsR , True) -> personAny
|
(GroupsR , True) -> personAny
|
||||||
(GroupNewR , _ ) -> personAny
|
(GroupNewR , _ ) -> personAny
|
||||||
|
@ -322,6 +323,7 @@ instance Yesod App where
|
||||||
(RepoNewR shr , _ ) -> personOrGroupAdmin shr
|
(RepoNewR shr , _ ) -> personOrGroupAdmin shr
|
||||||
(RepoR shar _ , True) -> person shar
|
(RepoR shar _ , True) -> person shar
|
||||||
(RepoEditR shr _rp , _ ) -> person shr
|
(RepoEditR shr _rp , _ ) -> person shr
|
||||||
|
(RepoFollowR _shr _rp , True) -> personAny
|
||||||
(RepoDevsR shr _rp , _ ) -> person shr
|
(RepoDevsR shr _rp , _ ) -> person shr
|
||||||
(RepoDevNewR shr _rp , _ ) -> person shr
|
(RepoDevNewR shr _rp , _ ) -> person shr
|
||||||
(RepoDevR shr _rp _dev , _ ) -> person shr
|
(RepoDevR shr _rp _dev , _ ) -> person shr
|
||||||
|
@ -330,6 +332,7 @@ instance Yesod App where
|
||||||
(ProjectNewR shr , _ ) -> personOrGroupAdmin shr
|
(ProjectNewR shr , _ ) -> personOrGroupAdmin shr
|
||||||
(ProjectR shr _prj , True) -> person shr
|
(ProjectR shr _prj , True) -> person shr
|
||||||
(ProjectEditR shr _prj , _ ) -> person shr
|
(ProjectEditR shr _prj , _ ) -> person shr
|
||||||
|
(ProjectFollowR _shr _prj , _ ) -> personAny
|
||||||
(ProjectDevsR shr _prj , _ ) -> person shr
|
(ProjectDevsR shr _prj , _ ) -> person shr
|
||||||
(ProjectDevNewR shr _prj , _ ) -> person shr
|
(ProjectDevNewR shr _prj , _ ) -> person shr
|
||||||
(ProjectDevR shr _prj _dev , _ ) -> person shr
|
(ProjectDevR shr _prj _dev , _ ) -> person shr
|
||||||
|
@ -362,6 +365,7 @@ instance Yesod App where
|
||||||
(TicketUnclaimR s j _ , _ ) -> projOp ProjOpUnclaimTicket s j
|
(TicketUnclaimR s j _ , _ ) -> projOp ProjOpUnclaimTicket s j
|
||||||
(TicketAssignR s j _ , _ ) -> projOp ProjOpAssignTicket s j
|
(TicketAssignR s j _ , _ ) -> projOp ProjOpAssignTicket s j
|
||||||
(TicketUnassignR s j _ , _ ) -> projOp ProjOpUnassignTicket s j
|
(TicketUnassignR s j _ , _ ) -> projOp ProjOpUnassignTicket s j
|
||||||
|
(TicketFollowR _ _ _ , True) -> personAny
|
||||||
(ClaimRequestsTicketR s j _, True) -> projOp ProjOpRequestTicket s j
|
(ClaimRequestsTicketR s j _, True) -> projOp ProjOpRequestTicket s j
|
||||||
(ClaimRequestNewR s j _ , _ ) -> projOp ProjOpRequestTicket s j
|
(ClaimRequestNewR s j _ , _ ) -> projOp ProjOpRequestTicket s j
|
||||||
(TicketDiscussionR _ _ _ , True) -> personAny
|
(TicketDiscussionR _ _ _ , True) -> personAny
|
||||||
|
|
528
src/Vervis/Handler/Client.hs
Normal file
528
src/Vervis/Handler/Client.hs
Normal 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
|
|
@ -21,18 +21,14 @@ module Vervis.Handler.Inbox
|
||||||
, postSharerInboxR
|
, postSharerInboxR
|
||||||
, postProjectInboxR
|
, postProjectInboxR
|
||||||
, postRepoInboxR
|
, postRepoInboxR
|
||||||
, getPublishR
|
|
||||||
, getSharerOutboxR
|
, getSharerOutboxR
|
||||||
, getSharerOutboxItemR
|
, getSharerOutboxItemR
|
||||||
, postSharerOutboxR
|
|
||||||
, getProjectOutboxR
|
, getProjectOutboxR
|
||||||
, getProjectOutboxItemR
|
, getProjectOutboxItemR
|
||||||
, getRepoOutboxR
|
, getRepoOutboxR
|
||||||
, getRepoOutboxItemR
|
, getRepoOutboxItemR
|
||||||
, getActorKey1R
|
, getActorKey1R
|
||||||
, getActorKey2R
|
, getActorKey2R
|
||||||
, getNotificationsR
|
|
||||||
, postNotificationsR
|
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -105,6 +101,8 @@ import Vervis.Model.Ident
|
||||||
import Vervis.Paginate
|
import Vervis.Paginate
|
||||||
import Vervis.Settings
|
import Vervis.Settings
|
||||||
|
|
||||||
|
import qualified Vervis.Client as C
|
||||||
|
|
||||||
getShowTime = showTime <$> liftIO getCurrentTime
|
getShowTime = showTime <$> liftIO getCurrentTime
|
||||||
where
|
where
|
||||||
showTime now =
|
showTime now =
|
||||||
|
@ -334,127 +332,6 @@ jsonField = checkMMap fromTextarea toTextarea textareaField
|
||||||
fromTextarea = return . first T.pack . eitherDecodeStrict' . encodeUtf8 . unTextarea
|
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 :: Route App -> AppDB OutboxId -> Handler TypedContent
|
||||||
getOutbox here getObid = do
|
getOutbox here getObid = do
|
||||||
|
@ -538,150 +415,6 @@ getSharerOutboxItemR shr obikhid = getOutboxItem here getObid obikhid
|
||||||
p <- getValBy404 $ UniquePersonIdent sid
|
p <- getValBy404 $ UniquePersonIdent sid
|
||||||
return $ personOutbox p
|
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 :: ShrIdent -> PrjIdent -> Handler TypedContent
|
||||||
getProjectOutboxR shr prj = getOutbox here getObid
|
getProjectOutboxR shr prj = getOutbox here getObid
|
||||||
where
|
where
|
||||||
|
@ -739,143 +472,3 @@ getActorKey1R = getActorKey (\ (k1, _, _) -> k1) ActorKey1R
|
||||||
|
|
||||||
getActorKey2R :: Handler TypedContent
|
getActorKey2R :: Handler TypedContent
|
||||||
getActorKey2R = getActorKey (\ (_, k2, _) -> k2) ActorKey2R
|
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
|
|
||||||
|
|
|
@ -1069,6 +1069,24 @@ changes hLocal ctx =
|
||||||
"Outbox"
|
"Outbox"
|
||||||
-- 139
|
-- 139
|
||||||
, addUnique "Repo" $ Unique "UniqueRepoOutbox" ["outbox"]
|
, 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
|
migrateDB
|
||||||
|
|
|
@ -124,6 +124,7 @@ module Vervis.Migration.Model
|
||||||
, Person130
|
, Person130
|
||||||
, Outbox138Generic (..)
|
, Outbox138Generic (..)
|
||||||
, Repo138
|
, Repo138
|
||||||
|
, model_2019_09_25
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -251,3 +252,6 @@ makeEntitiesMigration "130"
|
||||||
|
|
||||||
makeEntitiesMigration "138"
|
makeEntitiesMigration "138"
|
||||||
$(modelFile "migrations/2019_09_10.model")
|
$(modelFile "migrations/2019_09_10.model")
|
||||||
|
|
||||||
|
model_2019_09_25 :: [Entity SqlBackend]
|
||||||
|
model_2019_09_25 = $(schema "2019_09_25")
|
||||||
|
|
|
@ -58,6 +58,7 @@ module Web.ActivityPub
|
||||||
, Offer (..)
|
, Offer (..)
|
||||||
, Push (..)
|
, Push (..)
|
||||||
, Reject (..)
|
, Reject (..)
|
||||||
|
, Undo (..)
|
||||||
, Audience (..)
|
, Audience (..)
|
||||||
, SpecificActivity (..)
|
, SpecificActivity (..)
|
||||||
, Activity (..)
|
, Activity (..)
|
||||||
|
@ -1005,6 +1006,7 @@ encodeCreate authority actor (Create obj) =
|
||||||
|
|
||||||
data Follow u = Follow
|
data Follow u = Follow
|
||||||
{ followObject :: ObjURI u
|
{ followObject :: ObjURI u
|
||||||
|
, followContext :: Maybe (ObjURI u)
|
||||||
, followHide :: Bool
|
, followHide :: Bool
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -1012,11 +1014,13 @@ parseFollow :: UriMode u => Object -> Parser (Follow u)
|
||||||
parseFollow o =
|
parseFollow o =
|
||||||
Follow
|
Follow
|
||||||
<$> o .: "object"
|
<$> o .: "object"
|
||||||
|
<*> o .:? "context"
|
||||||
<*> o .: "hide"
|
<*> o .: "hide"
|
||||||
|
|
||||||
encodeFollow :: UriMode u => Follow u -> Series
|
encodeFollow :: UriMode u => Follow u -> Series
|
||||||
encodeFollow (Follow obj hide)
|
encodeFollow (Follow obj mcontext hide)
|
||||||
= "object" .= obj
|
= "object" .= obj
|
||||||
|
<> "context" .=? mcontext
|
||||||
<> "hide" .= hide
|
<> "hide" .= hide
|
||||||
|
|
||||||
data Offer u = Offer
|
data Offer u = Offer
|
||||||
|
@ -1086,6 +1090,16 @@ parseReject o = Reject <$> o .: "object"
|
||||||
encodeReject :: UriMode u => Reject u -> Series
|
encodeReject :: UriMode u => Reject u -> Series
|
||||||
encodeReject (Reject obj) = "object" .= obj
|
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
|
data SpecificActivity u
|
||||||
= AcceptActivity (Accept u)
|
= AcceptActivity (Accept u)
|
||||||
| CreateActivity (Create u)
|
| CreateActivity (Create u)
|
||||||
|
@ -1093,6 +1107,7 @@ data SpecificActivity u
|
||||||
| OfferActivity (Offer u)
|
| OfferActivity (Offer u)
|
||||||
| PushActivity (Push u)
|
| PushActivity (Push u)
|
||||||
| RejectActivity (Reject u)
|
| RejectActivity (Reject u)
|
||||||
|
| UndoActivity (Undo u)
|
||||||
|
|
||||||
data Activity u = Activity
|
data Activity u = Activity
|
||||||
{ activityId :: Maybe LocalURI
|
{ activityId :: Maybe LocalURI
|
||||||
|
@ -1121,6 +1136,7 @@ instance ActivityPub Activity where
|
||||||
"Offer" -> OfferActivity <$> parseOffer o a actor
|
"Offer" -> OfferActivity <$> parseOffer o a actor
|
||||||
"Push" -> PushActivity <$> parsePush a o
|
"Push" -> PushActivity <$> parsePush a o
|
||||||
"Reject" -> RejectActivity <$> parseReject o
|
"Reject" -> RejectActivity <$> parseReject o
|
||||||
|
"Undo" -> UndoActivity <$> parseUndo a o
|
||||||
_ ->
|
_ ->
|
||||||
fail $
|
fail $
|
||||||
"Unrecognized activity type: " ++ T.unpack typ
|
"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 u (OfferActivity a) = encodeOffer h u a
|
||||||
encodeSpecific h _ (PushActivity a) = encodePush h a
|
encodeSpecific h _ (PushActivity a) = encodePush h a
|
||||||
encodeSpecific _ _ (RejectActivity a) = encodeReject a
|
encodeSpecific _ _ (RejectActivity a) = encodeReject a
|
||||||
|
encodeSpecific h _ (UndoActivity a) = encodeUndo h a
|
||||||
|
|
||||||
typeActivityStreams2 :: ContentType
|
typeActivityStreams2 :: ContentType
|
||||||
typeActivityStreams2 = "application/activity+json"
|
typeActivityStreams2 = "application/activity+json"
|
||||||
|
|
|
@ -38,6 +38,7 @@ import Control.Monad.IO.Unlift
|
||||||
import Control.Monad.Logger.CallStack
|
import Control.Monad.Logger.CallStack
|
||||||
import Control.Monad.Trans.Class
|
import Control.Monad.Trans.Class
|
||||||
import Control.Monad.Trans.Except
|
import Control.Monad.Trans.Except
|
||||||
|
import Control.Monad.Trans.Maybe
|
||||||
import Control.Monad.Trans.Reader
|
import Control.Monad.Trans.Reader
|
||||||
import Data.Functor
|
import Data.Functor
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
|
@ -77,6 +78,11 @@ instance MonadSite m => MonadSite (ReaderT r m) where
|
||||||
askSite = lift askSite
|
askSite = lift askSite
|
||||||
askUrlRenderParams = lift askUrlRenderParams
|
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
|
instance MonadSite m => MonadSite (ExceptT e m) where
|
||||||
type SiteEnv (ExceptT e m) = SiteEnv m
|
type SiteEnv (ExceptT e m) = SiteEnv m
|
||||||
askSite = lift askSite
|
askSite = lift askSite
|
||||||
|
|
|
@ -123,6 +123,7 @@ library
|
||||||
Vervis.BinaryBody
|
Vervis.BinaryBody
|
||||||
Vervis.Changes
|
Vervis.Changes
|
||||||
Vervis.ChangeFeed
|
Vervis.ChangeFeed
|
||||||
|
Vervis.Client
|
||||||
Vervis.Colour
|
Vervis.Colour
|
||||||
Vervis.Content
|
Vervis.Content
|
||||||
Vervis.Darcs
|
Vervis.Darcs
|
||||||
|
@ -153,6 +154,7 @@ library
|
||||||
Vervis.Foundation
|
Vervis.Foundation
|
||||||
Vervis.Git
|
Vervis.Git
|
||||||
Vervis.GraphProxy
|
Vervis.GraphProxy
|
||||||
|
Vervis.Handler.Client
|
||||||
Vervis.Handler.Common
|
Vervis.Handler.Common
|
||||||
Vervis.Handler.Discussion
|
Vervis.Handler.Discussion
|
||||||
Vervis.Handler.Git
|
Vervis.Handler.Git
|
||||||
|
|
Loading…
Reference in a new issue