forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Rename RemoteSharer entity to RemoteActor

Browse source
This commit is contained in:
fr33domlover 2019-04-12 00:56:27 +00:00
parent 7621c0280a
commit 3f9364e4aa
8 changed files with 65 additions and 61 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
config/models
View file

@ -59,22 +59,22 @@ VerifKey
instance InstanceId instance InstanceId
expires UTCTime Maybe expires UTCTime Maybe
public PublicVerifKey public PublicVerifKey
sharer RemoteSharerId Maybe sharer RemoteActorId Maybe
UniqueVerifKey instance ident UniqueVerifKey instance ident
VerifKeySharedUsage VerifKeySharedUsage
key VerifKeyId key VerifKeyId
user RemoteSharerId user RemoteActorId
UniqueVerifKeySharedUsage key user UniqueVerifKeySharedUsage key user
RemoteSharer RemoteActor
ident LocalURI ident LocalURI
instance InstanceId instance InstanceId
inbox LocalURI inbox LocalURI
UniqueRemoteSharer instance ident UniqueRemoteActor instance ident
Instance Instance
host Text host Text
@ -90,7 +90,7 @@ Follow
UniqueFollow person target UniqueFollow person target
RemoteFollow RemoteFollow
actor RemoteSharerId actor RemoteActorId
target FollowerSetId target FollowerSetId
UniqueRemoteFollow actor target UniqueRemoteFollow actor target
@ -273,7 +273,7 @@ LocalMessage
UniqueLocalMessage rest UniqueLocalMessage rest
RemoteMessage RemoteMessage
author RemoteSharerId author RemoteActorId
instance InstanceId instance InstanceId
ident LocalURI ident LocalURI
rest MessageId rest MessageId

6
src/Vervis/Discussion.hs
View file

@ -59,11 +59,11 @@ getMessages getdid = runDB $ do
where_ $ m ^. MessageRoot ==. val did where_ $ m ^. MessageRoot ==. val did
return (m, lm ^. LocalMessageId, s) return (m, lm ^. LocalMessageId, s)
r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` rs `InnerJoin` i) -> do r <- select $ from $ \ (rm `InnerJoin` m `InnerJoin` rs `InnerJoin` i) -> do
on $ rs ^. RemoteSharerInstance ==. i ^. InstanceId on $ rs ^. RemoteActorInstance ==. i ^. InstanceId
on $ rm ^. RemoteMessageAuthor ==. rs ^. RemoteSharerId on $ rm ^. RemoteMessageAuthor ==. rs ^. RemoteActorId
on $ rm ^. RemoteMessageRest ==. m ^. MessageId on $ rm ^. RemoteMessageRest ==. m ^. MessageId
where_ $ m ^. MessageRoot ==. val did where_ $ m ^. MessageRoot ==. val did
return (m, i ^. InstanceHost, rs ^. RemoteSharerIdent) return (m, i ^. InstanceHost, rs ^. RemoteActorIdent)
return $ map mklocal l ++ map mkremote r return $ map mklocal l ++ map mkremote r
where where
mklocal (Entity mid m, Value lmid, Entity _ s) = mklocal (Entity mid m, Value lmid, Entity _ s) =

44
src/Vervis/Federation.hs
View file

@ -162,7 +162,7 @@ getLocalParentMessageId did shr lmid = do
-- | Handle an activity that came to our inbox. Return a description of what we -- | Handle an activity that came to our inbox. Return a description of what we
-- did, and whether we stored the activity or not (so that we can decide -- did, and whether we stored the activity or not (so that we can decide
-- whether to log it for debugging). -- whether to log it for debugging).
handleInboxActivity :: Object -> Text -> InstanceId -> RemoteSharerId -> Activity -> Handler (Text, Bool) handleInboxActivity :: Object -> Text -> InstanceId -> RemoteActorId -> Activity -> Handler (Text, Bool)
handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audience specific) = handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audience specific) =
case specific of case specific of
CreateActivity (Create note) -> do CreateActivity (Create note) -> do
@ -372,8 +372,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
Right (luRecip, rdid) -> do Right (luRecip, rdid) -> do
mluInbox <- runDB $ runMaybeT $ do mluInbox <- runDB $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip
rs <- MaybeT $ getValBy $ UniqueRemoteSharer iid luRecip rs <- MaybeT $ getValBy $ UniqueRemoteActor iid luRecip
return $ remoteSharerInbox rs return $ remoteActorInbox rs
case mluInbox of case mluInbox of
Just luInbox -> return $ l2f hRecip luInbox Just luInbox -> return $ l2f hRecip luInbox
Nothing -> do Nothing -> do
@ -384,7 +384,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
Right actor -> withHostLock hRecip $ runDB $ do Right actor -> withHostLock hRecip $ runDB $ do
iid <- either entityKey id <$> insertBy (Instance hRecip) iid <- either entityKey id <$> insertBy (Instance hRecip)
let luInbox = actorInbox actor let luInbox = actorInbox actor
rsid <- either entityKey id <$> insertBy (RemoteSharer luRecip iid luInbox) rsid <- either entityKey id <$> insertBy (RemoteActor luRecip iid luInbox)
update rdid [RemoteDiscussionActor =. Just rsid, RemoteDiscussionUnlinkedActor =. Nothing] update rdid [RemoteDiscussionActor =. Just rsid, RemoteDiscussionUnlinkedActor =. Nothing]
return $ l2f hRecip luInbox return $ l2f hRecip luInbox
-- TODO based on the httpPostAP usage in postOutboxR -- TODO based on the httpPostAP usage in postOutboxR
@ -460,7 +460,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
{- {-
mrs <- lift $ runDB $ runMaybeT $ do mrs <- lift $ runDB $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip
MaybeT $ getBy $ UniqueRemoteSharer iid luRecip MaybeT $ getBy $ UniqueRemoteActor iid luRecip
erecip <- erecip <-
case mrs of case mrs of
Just ers -> return $ Left ers Just ers -> return $ Left ers
@ -503,9 +503,9 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
minb <- case eactor of minb <- case eactor of
Left rsid -> do Left rsid -> do
rs <- lift $ getJust rsid rs <- lift $ getJust rsid
unless (remoteSharerInstance rs == iid && remoteSharerIdent rs == luRecip) $ unless (remoteActorInstance rs == iid && remoteActorIdent rs == luRecip) $
throwE "Known remote context, but its actor doesn't match the new Note's recipient" throwE "Known remote context, but its actor doesn't match the new Note's recipient"
return $ Just $ remoteSharerInbox rs return $ Just $ remoteActorInbox rs
Right uActor -> do Right uActor -> do
unless (uActor == l2f hRecip luRecip) $ unless (uActor == l2f hRecip luRecip) $
throwE "Known remote context, but its unlinked actor doesn't match the new Note's recipient" throwE "Known remote context, but its unlinked actor doesn't match the new Note's recipient"
@ -523,7 +523,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
mrs <- mrs <-
if inew if inew
then return Nothing then return Nothing
else getBy $ UniqueRemoteSharer iid luRecip else getBy $ UniqueRemoteActor iid luRecip
did <- insert Discussion did <- insert Discussion
rdid <- insert RemoteDiscussion rdid <- insert RemoteDiscussion
{ remoteDiscussionActor = entityKey <$> mrs { remoteDiscussionActor = entityKey <$> mrs
@ -535,7 +535,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
Nothing -> Just $ l2f hRecip luRecip Nothing -> Just $ l2f hRecip luRecip
Just _ -> Nothing Just _ -> Nothing
} }
return (did, rdid, remoteSharerInbox . entityVal <$> mrs) return (did, rdid, remoteActorInbox . entityVal <$> mrs)
storeRemoteDiscussion storeRemoteDiscussion
:: Maybe InstanceId :: Maybe InstanceId
@ -750,7 +750,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
-- --
-- doc :: Doc Activity -- doc :: Doc Activity
-- remoteRecips :: [FedURI] -- remoteRecips :: [FedURI]
-- moreRemotes :: [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))] -- moreRemotes :: [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI))]
return lmid return lmid
where where
verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m () verifyNothing :: Monad m => Maybe a -> e -> ExceptT e m ()
@ -999,7 +999,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
:: OutboxItemId :: OutboxItemId
-> [ShrIdent] -> [ShrIdent]
-> Maybe (SharerId, FollowerSetId) -> Maybe (SharerId, FollowerSetId)
-> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))] -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI))]
deliverLocal obid recips mticket = do deliverLocal obid recips mticket = do
recipPids <- traverse getPersonId $ nub recips recipPids <- traverse getPersonId $ nub recips
(morePids, remotes) <- (morePids, remotes) <-
@ -1068,11 +1068,11 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
case id_ of case id_ of
Left pid -> return pid Left pid -> return pid
Right _gid -> throwE "Local Note addresses a local group" Right _gid -> throwE "Local Note addresses a local group"
groupRemotes :: [(InstanceId, Text, RemoteSharerId, LocalURI)] -> [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))] groupRemotes :: [(InstanceId, Text, RemoteActorId, LocalURI)] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI))]
groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toPairs groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toPairs
where where
toPairs (iid, h, rsid, lu) = ((iid, h), (rsid, lu)) toPairs (iid, h, rsid, lu) = ((iid, h), (rsid, lu))
getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))]) getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI))])
getTicketTeam sid = do getTicketTeam sid = do
id_ <- getPersonOrGroupId sid id_ <- getPersonOrGroupId sid
(,[]) <$> case id_ of (,[]) <$> case id_ of
@ -1080,19 +1080,19 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
Right gid -> Right gid ->
map (groupMemberPerson . entityVal) <$> map (groupMemberPerson . entityVal) <$>
selectList [GroupMemberGroup ==. gid] [] selectList [GroupMemberGroup ==. gid] []
getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))]) getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI))])
getFollowers fsid = do getFollowers fsid = do
local <- selectList [FollowTarget ==. fsid] [] local <- selectList [FollowTarget ==. fsid] []
remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do
E.on $ rs E.^. RemoteSharerInstance E.==. i E.^. InstanceId E.on $ rs E.^. RemoteActorInstance E.==. i E.^. InstanceId
E.on $ rf E.^. RemoteFollowActor E.==. rs E.^. RemoteSharerId E.on $ rf E.^. RemoteFollowActor E.==. rs E.^. RemoteActorId
E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid E.where_ $ rf E.^. RemoteFollowTarget E.==. E.val fsid
E.orderBy [E.asc $ i E.^. InstanceId] E.orderBy [E.asc $ i E.^. InstanceId]
return return
( i E.^. InstanceId ( i E.^. InstanceId
, i E.^. InstanceHost , i E.^. InstanceHost
, rs E.^. RemoteSharerId , rs E.^. RemoteActorId
, rs E.^. RemoteSharerInbox , rs E.^. RemoteActorInbox
) )
return return
( map (followPerson . entityVal) local ( map (followPerson . entityVal) local
@ -1137,7 +1137,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
-- (3) Insert/update reachability records for actors we suddenly succeed -- (3) Insert/update reachability records for actors we suddenly succeed
-- to reach -- to reach
-- --
-- So, for each RemoteSharer, we're going to add a field 'errorSince'. -- So, for each RemoteActor, we're going to add a field 'errorSince'.
-- Its type will be Maybe UTCTime, and the meaning is: -- Its type will be Maybe UTCTime, and the meaning is:
-- --
-- - Nothing: We haven't observed the inbox being down -- - Nothing: We haven't observed the inbox being down
@ -1145,7 +1145,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
-- since that time all our following attempts failed too -- since that time all our following attempts failed too
-- --
-- In this context, inbox error means any result that isn't a 2xx status. -- In this context, inbox error means any result that isn't a 2xx status.
deliverRemote :: Doc Activity -> [FedURI] -> [((InstanceId, Text), NonEmpty (RemoteSharerId, LocalURI))] -> Handler () deliverRemote :: Doc Activity -> [FedURI] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI))] -> Handler ()
deliverRemote doc recips known = runDB $ do deliverRemote doc recips known = runDB $ do
recips' <- for (groupByHost recips) $ \ (h, lus) -> do recips' <- for (groupByHost recips) $ \ (h, lus) -> do
let lus' = NE.nub lus let lus' = NE.nub lus
@ -1154,10 +1154,10 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
then return ((iid, h), (Nothing, Just lus')) then return ((iid, h), (Nothing, Just lus'))
else do else do
es <- for lus' $ \ lu -> do es <- for lus' $ \ lu -> do
mers <- getBy $ UniqueRemoteSharer iid lu mers <- getBy $ UniqueRemoteActor iid lu
return $ return $
case mers of case mers of
Just (Entity rsid rs) -> Left (rsid, remoteSharerInbox rs) Just (Entity rsid rs) -> Left (rsid, remoteActorInbox rs)
Nothing -> Right lu Nothing -> Right lu
let (newKnown, unknown) = partitionEithers $ NE.toList es let (newKnown, unknown) = partitionEithers $ NE.toList es
return ((iid, h), (nonEmpty newKnown, nonEmpty unknown)) return ((iid, h), (nonEmpty newKnown, nonEmpty unknown))

4
src/Vervis/Foundation.hs
View file

@ -629,7 +629,7 @@ instance YesodRemoteActorStore App where
data ActorDetail = ActorDetail data ActorDetail = ActorDetail
{ actorDetailId :: FedURI { actorDetailId :: FedURI
, actorDetailInstance :: InstanceId , actorDetailInstance :: InstanceId
, actorDetailSharer :: RemoteSharerId , actorDetailSharer :: RemoteActorId
} }
instance YesodHttpSig App where instance YesodHttpSig App where
@ -660,7 +660,7 @@ instance YesodHttpSig App where
(ua, s, rsid) <- (ua, s, rsid) <-
case mremote of case mremote of
Just (rsid, rs) -> do Just (rsid, rs) -> do
let sharer = remoteSharerIdent rs let sharer = remoteActorIdent rs
for_ mluActorHeader $ \ u -> for_ mluActorHeader $ \ u ->
if sharer == u if sharer == u
then return () then return ()

8
src/Vervis/Handler/Discussion.hs
View file

@ -80,9 +80,9 @@ getNode getdid mid = do
return $ MessageTreeNodeLocal lmid s return $ MessageTreeNodeLocal lmid s
(Nothing, Just (Entity _rmid rm)) -> do (Nothing, Just (Entity _rmid rm)) -> do
rs <- getJust $ remoteMessageAuthor rm rs <- getJust $ remoteMessageAuthor rm
i <- getJust $ remoteSharerInstance rs i <- getJust $ remoteActorInstance rs
return $ MessageTreeNodeRemote $ return $ MessageTreeNodeRemote $
l2f (instanceHost i) (remoteSharerIdent rs) l2f (instanceHost i) (remoteActorIdent rs)
return $ MessageTreeNode mid m author return $ MessageTreeNode mid m author
{- {-
@ -135,8 +135,8 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
return $ route2fed $ MessageR (sharerIdent s) lmhidParent return $ route2fed $ MessageR (sharerIdent s) lmhidParent
(Nothing, Just rmParent) -> do (Nothing, Just rmParent) -> do
rs <- getJust $ remoteMessageAuthor rmParent rs <- getJust $ remoteMessageAuthor rmParent
i <- getJust $ remoteSharerInstance rs i <- getJust $ remoteActorInstance rs
return $ l2f (instanceHost i) (remoteSharerIdent rs) return $ l2f (instanceHost i) (remoteActorIdent rs)
host <- getsYesod $ appInstanceHost . appSettings host <- getsYesod $ appInstanceHost . appSettings
route2local <- getEncodeRouteLocal route2local <- getEncodeRouteLocal

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

@ -161,7 +161,7 @@ postInboxR = do
recordUsed now msg = recordActivity now $ ActivityReportUsed msg recordUsed now msg = recordActivity now $ ActivityReportUsed msg
recordUnused now ct d msg = recordActivity now $ ActivityReportUnused ct (encodePretty d) msg recordUnused now ct d msg = recordActivity now $ ActivityReportUnused ct (encodePretty d) msg
recordError now e = recordActivity now $ ActivityReportHandlerError e recordError now e = recordActivity now $ ActivityReportHandlerError e
getActivity :: UTCTime -> ExceptT String Handler (ContentType, (WithValue (Doc Activity), (InstanceId, RemoteSharerId))) getActivity :: UTCTime -> ExceptT String Handler (ContentType, (WithValue (Doc Activity), (InstanceId, RemoteActorId)))
getActivity now = do getActivity now = do
contentType <- do contentType <- do
ctypes <- lookupHeaders "Content-Type" ctypes <- lookupHeaders "Content-Type"
@ -299,7 +299,7 @@ postOutboxR shr = do
Nothing -> return $ Left Nothing Nothing -> return $ Left Nothing
Just (Entity iid _) -> Just (Entity iid _) ->
maybe (Left $ Just iid) Right <$> maybe (Left $ Just iid) Right <$>
getBy (UniqueRemoteSharer iid lto) getBy (UniqueRemoteActor iid lto)
case mrs of case mrs of
Left miid -> do Left miid -> do
eres <- fetchAPID manager actorId h lto eres <- fetchAPID manager actorId h lto
@ -319,12 +319,12 @@ postOutboxR shr = do
case miid of case miid of
Just iid -> return (iid, False) Just iid -> return (iid, False)
Nothing -> idAndNew <$> insertBy (Instance h) Nothing -> idAndNew <$> insertBy (Instance h)
let rs = RemoteSharer lto iid inbox let rs = RemoteActor lto iid inbox
if inew if inew
then insert_ rs then insert_ rs
else insertUnique_ rs else insertUnique_ rs
return $ Just inbox return $ Just inbox
Right (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs Right (Entity _rsid rs) -> return $ Just $ remoteActorInbox rs
getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
getActorKey choose route = selectRep $ provideAP $ do getActorKey choose route = selectRep $ provideAP $ do

4
src/Vervis/Migration.hs
View file

@ -234,6 +234,10 @@ changes =
"unlinkedParent" "unlinkedParent"
-- 55 -- 55
, addEntities model_2019_04_11 , addEntities model_2019_04_11
-- 56
, renameEntity "RemoteSharer" "RemoteActor"
-- 57
, renameUnique "RemoteActor" "UniqueRemoteSharer" "UniqueRemoteActor"
] ]
migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int)) migrateDB :: MonadIO m => ReaderT SqlBackend m (Either Text (Int, Int))

40
src/Vervis/RemoteActorStore.hs
View file

@ -78,7 +78,7 @@ class Yesod site => YesodRemoteActorStore site where
siteActorRoomMode :: site -> Maybe Int siteActorRoomMode :: site -> Maybe Int
siteRejectOnMaxKeys :: site -> Bool siteRejectOnMaxKeys :: site -> Bool
siteActorFetchShare :: site -> ResultShare (HandlerFor site) FedURI (Either String (Entity RemoteSharer)) InstanceId siteActorFetchShare :: site -> ResultShare (HandlerFor site) FedURI (Either String (Entity RemoteActor)) InstanceId
-- TODO this is copied from stm-2.5, remove when we upgrade LTS -- TODO this is copied from stm-2.5, remove when we upgrade LTS
stateTVar :: TVar s -> (s -> (a, s)) -> STM a stateTVar :: TVar s -> (s -> (a, s)) -> STM a
@ -132,10 +132,10 @@ instanceAndActor
=> Text => Text
-> LocalURI -> LocalURI
-> LocalURI -> LocalURI
-> YesodDB site (InstanceId, RemoteSharerId, Maybe Bool) -> YesodDB site (InstanceId, RemoteActorId, Maybe Bool)
instanceAndActor host luActor luInbox = do instanceAndActor host luActor luInbox = do
(iid, inew) <- idAndNew <$> insertBy (Instance host) (iid, inew) <- idAndNew <$> insertBy (Instance host)
let rs = RemoteSharer luActor iid luInbox let rs = RemoteActor luActor iid luInbox
if inew if inew
then do then do
rsid <- insert rs rsid <- insert rs
@ -149,7 +149,7 @@ actorRoom
, BaseBackend (YesodPersistBackend site) ~ SqlBackend , BaseBackend (YesodPersistBackend site) ~ SqlBackend
) )
=> Int => Int
-> RemoteSharerId -> RemoteActorId
-> YesodDB site Bool -> YesodDB site Bool
actorRoom limit rsid = do actorRoom limit rsid = do
sumUpTo limit sumUpTo limit
@ -160,7 +160,7 @@ getOldUsageId
:: ( PersistQueryRead (YesodPersistBackend site) :: ( PersistQueryRead (YesodPersistBackend site)
, BaseBackend (YesodPersistBackend site) ~ SqlBackend , BaseBackend (YesodPersistBackend site) ~ SqlBackend
) )
=> RemoteSharerId => RemoteActorId
-> YesodDB site (Maybe VerifKeySharedUsageId) -> YesodDB site (Maybe VerifKeySharedUsageId)
getOldUsageId rsid = fmap entityKey . listToMaybe <$> selectList [VerifKeySharedUsageUser ==. rsid] [Asc VerifKeySharedUsageId, LimitTo 1] getOldUsageId rsid = fmap entityKey . listToMaybe <$> selectList [VerifKeySharedUsageUser ==. rsid] [Asc VerifKeySharedUsageId, LimitTo 1]
@ -168,7 +168,7 @@ getOldPersonalKeyId
:: ( PersistQueryRead (YesodPersistBackend site) :: ( PersistQueryRead (YesodPersistBackend site)
, BaseBackend (YesodPersistBackend site) ~ SqlBackend , BaseBackend (YesodPersistBackend site) ~ SqlBackend
) )
=> RemoteSharerId => RemoteActorId
-> YesodDB site (Maybe VerifKeyId) -> YesodDB site (Maybe VerifKeyId)
getOldPersonalKeyId rsid = fmap entityKey . listToMaybe <$> selectList [VerifKeySharer ==. Just rsid] [Asc VerifKeyExpires, Asc VerifKeyId, LimitTo 1] getOldPersonalKeyId rsid = fmap entityKey . listToMaybe <$> selectList [VerifKeySharer ==. Just rsid] [Asc VerifKeyExpires, Asc VerifKeyId, LimitTo 1]
@ -178,7 +178,7 @@ makeActorRoomByPersonal
, BaseBackend (YesodPersistBackend site) ~ SqlBackend , BaseBackend (YesodPersistBackend site) ~ SqlBackend
) )
=> Int => Int
-> RemoteSharerId -> RemoteActorId
-> VerifKeyId -> VerifKeyId
-> YesodDB site () -> YesodDB site ()
makeActorRoomByPersonal limit rsid vkid = do makeActorRoomByPersonal limit rsid vkid = do
@ -194,7 +194,7 @@ makeActorRoomByUsage
, BaseBackend (YesodPersistBackend site) ~ SqlBackend , BaseBackend (YesodPersistBackend site) ~ SqlBackend
) )
=> Int => Int
-> RemoteSharerId -> RemoteActorId
-> VerifKeySharedUsageId -> VerifKeySharedUsageId
-> YesodDB site () -> YesodDB site ()
makeActorRoomByUsage limit rsid suid = do makeActorRoomByUsage limit rsid suid = do
@ -219,7 +219,7 @@ makeActorRoomForUsage
, BaseBackend (YesodPersistBackend site) ~ SqlBackend , BaseBackend (YesodPersistBackend site) ~ SqlBackend
) )
=> Int => Int
-> RemoteSharerId -> RemoteActorId
-> YesodDB site () -> YesodDB site ()
makeActorRoomForUsage limit rsid = do makeActorRoomForUsage limit rsid = do
msuid <- getOldUsageId rsid msuid <- getOldUsageId rsid
@ -243,7 +243,7 @@ makeActorRoomForPersonalKey
, BaseBackend (YesodPersistBackend site) ~ SqlBackend , BaseBackend (YesodPersistBackend site) ~ SqlBackend
) )
=> Int => Int
-> RemoteSharerId -> RemoteActorId
-> YesodDB site () -> YesodDB site ()
makeActorRoomForPersonalKey limit rsid = do makeActorRoomForPersonalKey limit rsid = do
mvkid <- getOldPersonalKeyId rsid mvkid <- getOldPersonalKeyId rsid
@ -320,7 +320,7 @@ keyListedByActorShared
-> Text -> Text
-> LocalURI -> LocalURI
-> LocalURI -> LocalURI
-> ExceptT String (HandlerFor site) RemoteSharerId -> ExceptT String (HandlerFor site) RemoteActorId
keyListedByActorShared iid vkid host luKey luActor = do keyListedByActorShared iid vkid host luKey luActor = do
manager <- getsYesod getHttpManager manager <- getsYesod getHttpManager
reject <- getsYesod siteRejectOnMaxKeys reject <- getsYesod siteRejectOnMaxKeys
@ -329,11 +329,11 @@ keyListedByActorShared iid vkid host luKey luActor = do
RoomModeInstant -> do RoomModeInstant -> do
when reject $ throwE "Actor key storage limit is 0 and set to reject" when reject $ throwE "Actor key storage limit is 0 and set to reject"
luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor) luInbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
lift $ runDB $ either entityKey id <$> insertBy (RemoteSharer luActor iid luInbox) lift $ runDB $ either entityKey id <$> insertBy (RemoteActor luActor iid luInbox)
RoomModeCached m -> do RoomModeCached m -> do
eresult <- do eresult <- do
ments <- lift $ runDB $ do ments <- lift $ runDB $ do
mrs <- getBy $ UniqueRemoteSharer iid luActor mrs <- getBy $ UniqueRemoteActor iid luActor
for mrs $ \ (Entity rsid _) -> for mrs $ \ (Entity rsid _) ->
(rsid,) . isJust <$> (rsid,) . isJust <$>
getBy (UniqueVerifKeySharedUsage vkid rsid) getBy (UniqueVerifKeySharedUsage vkid rsid)
@ -352,7 +352,7 @@ keyListedByActorShared iid vkid host luKey luActor = do
vkExists <- isJust <$> get vkid vkExists <- isJust <$> get vkid
case mrsid of case mrsid of
Nothing -> do Nothing -> do
rsid <- insert $ RemoteSharer luActor iid luInbox rsid <- insert $ RemoteActor luActor iid luInbox
when vkExists $ insert_ $ VerifKeySharedUsage vkid rsid when vkExists $ insert_ $ VerifKeySharedUsage vkid rsid
return $ Right rsid return $ Right rsid
Just rsid -> runExceptT $ do Just rsid -> runExceptT $ do
@ -385,7 +385,7 @@ addVerifKey
=> Text => Text
-> LocalURI -> LocalURI
-> VerifKeyDetail -> VerifKeyDetail
-> ExceptT String (YesodDB site) (InstanceId, RemoteSharerId) -> ExceptT String (YesodDB site) (InstanceId, RemoteActorId)
addVerifKey h uinb vkd = addVerifKey h uinb vkd =
if vkdShared vkd if vkdShared vkd
then addSharedKey h uinb vkd then addSharedKey h uinb vkd
@ -452,19 +452,19 @@ actorFetchShareSettings
, BaseBackend (YesodPersistBackend site) ~ SqlBackend , BaseBackend (YesodPersistBackend site) ~ SqlBackend
, HasHttpManager site , HasHttpManager site
) )
=> ResultShareSettings (HandlerFor site) FedURI (Either String (Entity RemoteSharer)) InstanceId => ResultShareSettings (HandlerFor site) FedURI (Either String (Entity RemoteActor)) InstanceId
actorFetchShareSettings = ResultShareSettings actorFetchShareSettings = ResultShareSettings
{ resultShareFork = forkHandler $ \ e -> logError $ "ActorFetchShare action failed! " <> T.pack (displayException e) { resultShareFork = forkHandler $ \ e -> logError $ "ActorFetchShare action failed! " <> T.pack (displayException e)
, resultShareAction = \ u iid -> do , resultShareAction = \ u iid -> do
let (h, lu) = f2l u let (h, lu) = f2l u
mers <- runDB $ getBy $ UniqueRemoteSharer iid lu mers <- runDB $ getBy $ UniqueRemoteActor iid lu
case mers of case mers of
Just ers -> return $ Right ers Just ers -> return $ Right ers
Nothing -> do Nothing -> do
manager <- getsYesod getHttpManager manager <- getsYesod getHttpManager
eactor <- fetchAPID manager actorId h lu eactor <- fetchAPID manager actorId h lu
for eactor $ \ actor -> runDB $ for eactor $ \ actor -> runDB $
insertEntity $ RemoteSharer lu iid (actorInbox actor) insertEntity $ RemoteActor lu iid (actorInbox actor)
} }
fetchRemoteActor fetchRemoteActor
@ -473,9 +473,9 @@ fetchRemoteActor
, BaseBackend (YesodPersistBackend site) ~ SqlBackend , BaseBackend (YesodPersistBackend site) ~ SqlBackend
, YesodRemoteActorStore site , YesodRemoteActorStore site
) )
=> InstanceId -> Text -> LocalURI -> HandlerFor site (Either String (Entity RemoteSharer)) => InstanceId -> Text -> LocalURI -> HandlerFor site (Either String (Entity RemoteActor))
fetchRemoteActor iid host luActor = do fetchRemoteActor iid host luActor = do
mers <- runDB $ getBy $ UniqueRemoteSharer iid luActor mers <- runDB $ getBy $ UniqueRemoteActor iid luActor
case mers of case mers of
Just ers -> return $ Right ers Just ers -> return $ Right ers
Nothing -> do Nothing -> do