diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 976ac0c..0ba7b09 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -148,6 +148,12 @@ import Vervis.Settings import Vervis.Ssh (runSsh) import Vervis.Web.Delivery +-- Only for fillPermitRecords, so remove soon +import qualified Web.ActivityPub as AP +import Vervis.Persist.Collab +import Data.Either.Local +import Database.Persist.Local + -- This line actually creates our YesodDispatch instance. It is the second half -- of the call to mkYesodData which occurs in Foundation.hs. Please see the -- comments there for more details. @@ -466,6 +472,54 @@ mailer foundation = (loggingFunction foundation) (readChan queue) +fillPermitRecords :: Worker () +fillPermitRecords = do + extendIDs <- runSiteDB $ selectKeysList [] [Asc PermitTopicExtendId] + for_ extendIDs $ \ extendID -> do + lr <- runSiteDB $ (,) + <$> getBy (UniquePermitTopicExtendResourceLocal extendID) + <*> getBy (UniquePermitTopicExtendResourceRemote extendID) + case lr of + (Just _, Nothing) -> pure () + (Nothing, Just _) -> pure () + (Just _, Just _) -> error "PTER both" + (Nothing, Nothing) -> do + uResource <- runSiteDB $ do + pte <- + requireEitherAlt + (getValBy $ UniquePermitTopicExtendLocal extendID) + (getValBy $ UniquePermitTopicExtendRemote extendID) + "PTE none" + "PTE both" + let ext = bimap permitTopicExtendLocalGrant permitTopicExtendRemoteGrant pte + (_doc, g) <- getGrantActivityBody ext + return $ AP.grantContext g + result <- runExceptT $ do + a <- parseActorURI uResource + case a of + Left la -> runSiteDBExcept $ do + actorID <- + localActorID <$> + getLocalActorEntityE la "Extension-Grant resource not found in DB" + lift $ insert_ $ PermitTopicExtendResourceLocal extendID actorID + Right (ObjURI h lu) -> do + actorID <- do + manager <- asksSite appHttpManager + instanceID <- + lift $ runSiteDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . displayException) <$> + fetchRemoteActor instanceID h lu + case result of + Left Nothing -> throwE "Resource @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Resource isn't an actor" + Right (Just actor) -> return $ entityKey actor + lift $ runSiteDB $ insert_ $ PermitTopicExtendResourceRemote extendID actorID + case result of + Left e -> error $ "fillPermitRecords: " ++ show extendID ++ T.unpack e + Right () -> $logInfo $ T.pack $ "fillPermitRecords: " ++ show extendID ++ " success" + -- | The @main@ function for an executable running this site. appMain :: IO () appMain = do @@ -495,6 +549,9 @@ appMain = do -- have a key and insert to DB runWorker fillPerActorKeys foundation + -- Temporary setup - fill PermitTopicExtendResource* records + runWorker fillPermitRecords foundation + -- Run periodic activity delivery retry runner -- Disabled because we're using the DeliveryTheater now {-