diff --git a/config/models b/config/models index 2b4c450..7f736ae 100644 --- a/config/models +++ b/config/models @@ -48,6 +48,12 @@ VerifKey UniqueVerifKey ident +VerifKeySharedUsage + key VerifKeyId + user RemoteSharerId + + UniqueVerifKeySharedUsage key user + RemoteSharer ident FedURI instance InstanceId diff --git a/migrations/2019_02_03_verifkey.model b/migrations/2019_02_03_verifkey.model index 4070d79..6a688d6 100644 --- a/migrations/2019_02_03_verifkey.model +++ b/migrations/2019_02_03_verifkey.model @@ -7,6 +7,12 @@ VerifKey UniqueVerifKey ident +VerifKeySharedUsage + key VerifKeyId + user RemoteSharerId + + UniqueVerifKeySharedUsage key user + RemoteSharer ident Text instance InstanceId diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index a5dda38..caca7a3 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -564,53 +564,114 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger -- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding -data AddVerifKey = AddVerifKey - { addvkHost :: Text - , addvkKeyId :: FedURI - , addvkExpires :: Maybe UTCTime - , addvkKey :: PublicKey - } - -addSharedKey :: AddVerifKey -> AppDB (Maybe String) -addSharedKey (AddVerifKey host uKey mexpires key) = do - (iid, new) <- idAndNew <$> insertBy (Instance host) - room <- - if new - then pure True - else - (< 2) <$> - count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing] - if room +sumUpTo :: Int -> AppDB Int -> AppDB Int -> AppDB Bool +sumUpTo limit action1 action2 = do + n <- action1 + if n <= limit then do - insert_ $ VerifKey uKey iid mexpires key Nothing - return Nothing - else return $ Just "We already store 2 keys" + m <- action2 + return $ n + m <= limit + else return False + +instanceAndActor + :: Text + -> FedURI + -> FedURI + -> AppDB (InstanceId, RemoteSharerId, Maybe Bool) +instanceAndActor host uActor uInbox = do + mrs <- getBy $ UniqueRemoteSharer uActor + case mrs of + Nothing -> do + (iid, inew) <- idAndNew <$> insertBy (Instance host) + rsid <- insert $ RemoteSharer uActor iid uInbox + return (iid, rsid, if inew then Nothing else Just True) + Just (Entity rsid rs) -> + return (remoteSharerInstance rs, rsid, Just False) where idAndNew (Left (Entity iid _)) = (iid, False) idAndNew (Right iid) = (iid, True) -data AddPersonalKey = AddPersonalKey - { addpkKey :: AddVerifKey - , addpkActorId :: FedURI - , addpkActorInbox :: FedURI +actorRoom :: RemoteSharerId -> AppDB Bool +actorRoom rsid = + sumUpTo 2 + (count [VerifKeySharedUsageUser ==. rsid]) + (count [VerifKeySharer ==. Just rsid]) + +keyListedByActor' + :: Manager + -> InstanceId + -> VerifKeyId + -> FedURI + -> FedURI + -> Handler (Either String ()) +keyListedByActor' manager iid vkid uKey uActor = do + mresult <- do + ments <- runDB $ do + mrs <- getBy $ UniqueRemoteSharer uActor + for mrs $ \ (Entity rsid _) -> + (rsid,) . isJust <$> + getBy (UniqueVerifKeySharedUsage vkid rsid) + return $ + case ments of + Nothing -> Just Nothing + Just (rsid, used) -> + if used + then Nothing + else Just $ Just rsid + runExceptT $ for_ mresult $ \ mrsid -> do + uInbox <- actorInbox <$> ExceptT (keyListedByActor manager uKey uActor) + ExceptT $ runDB $ case mrsid of + Nothing -> do + rsid <- insert $ RemoteSharer uActor iid uInbox + insert_ $ VerifKeySharedUsage vkid rsid + return $ Right () + Just rsid -> do + room <- actorRoom rsid + if room + then do + insert_ $ VerifKeySharedUsage vkid rsid + return $ Right () + else return $ Left "Actor already has at least 2 keys" + +data AddVerifKey = AddVerifKey + { addvkHost :: Text + , addvkKeyId :: FedURI + , addvkExpires :: Maybe UTCTime + , addvkKey :: PublicKey + , addvkActorId :: FedURI + , addvkActorInbox :: FedURI } -addPersonalKey :: AddPersonalKey -> AppDB (Maybe String) -addPersonalKey (AddPersonalKey avk uActor uInbox) = do - let AddVerifKey host uKey mexpires key = avk - (iid, rsid, new) <- do - mrs <- getBy $ UniqueRemoteSharer uActor - case mrs of - Nothing -> do - iid <- either entityKey id <$> insertBy (Instance host) - rsid <- insert $ RemoteSharer uActor iid uInbox - return (iid, rsid, True) - Just (Entity rsid rs) -> - return (remoteSharerInstance rs, rsid, False) +addSharedKey :: AddVerifKey -> AppDB (Maybe String) +addSharedKey (AddVerifKey host uKey mexpires key uActor uInbox) = do + (iid, rsid, inew) <- instanceAndActor host uActor uInbox room <- - if new - then pure True - else (< 2) <$> count [VerifKeySharer ==. Just rsid] + case inew of + Nothing -> pure True + Just rsnew -> do + iRoom <- instanceRoom iid + if iRoom + then if rsnew + then pure True + else actorRoom rsid + else return False + if room + then do + vkid <- insert $ VerifKey uKey iid mexpires key Nothing + insert_ $ VerifKeySharedUsage vkid rsid + return Nothing + else return $ Just "We already store 2 keys" + where + instanceRoom iid = + (< 2) <$> count [VerifKeyInstance ==. iid, VerifKeySharer ==. Nothing] + +addPersonalKey :: AddVerifKey -> AppDB (Maybe String) +addPersonalKey (AddVerifKey host uKey mexpires key uActor uInbox) = do + (iid, rsid, inew) <- instanceAndActor host uActor uInbox + room <- + if inew == Just False + then actorRoom rsid + else pure True if room then do insert_ $ VerifKey uKey iid mexpires key (Just rsid) @@ -630,12 +691,12 @@ updateVerifKey (UpdateVerifKey vkid mexpires key) = do data VerifKeyUpdate = VKUAddSharedKey AddVerifKey - | VKUAddPersonalKey AddPersonalKey + | VKUAddPersonalKey AddVerifKey | VKUUpdateKey UpdateVerifKey updateVerifKeyInDB :: VerifKeyUpdate -> AppDB (Maybe String) updateVerifKeyInDB (VKUAddSharedKey avk) = addSharedKey avk -updateVerifKeyInDB (VKUAddPersonalKey apk) = addPersonalKey apk +updateVerifKeyInDB (VKUAddPersonalKey avk) = addPersonalKey avk updateVerifKeyInDB (VKUUpdateKey uvk) = updateVerifKey uvk data VerifKeyDetail = VerifKeyDetail @@ -652,10 +713,10 @@ makeVerifKeyUpdate :: VerifKeyDetail -> VerifKeyUpdate makeVerifKeyUpdate (VerifKeyDetail uKey iori key mexpires uActor host shared) = case iori of Left uInbox -> - let avk = AddVerifKey host uKey mexpires key + let avk = AddVerifKey host uKey mexpires key uActor uInbox in if shared then VKUAddSharedKey avk - else VKUAddPersonalKey $ AddPersonalKey avk uActor uInbox + else VKUAddPersonalKey avk Right vkid -> VKUUpdateKey $ UpdateVerifKey vkid mexpires key instance YesodHttpSig App where @@ -686,7 +747,11 @@ instance YesodHttpSig App where [] -> return Nothing [b] -> fmap Just . ExceptT . pure $ do t <- first displayException $ decodeUtf8' b - parseFedURI t + u <- parseFedURI t + if furiHost u == furiHost uKey + then Right () + else Left "Key and actor have different hosts" + Right u _ -> throwE "Multiple ActivityPub-Actor headers" vkd <- do ments <- lift $ runDB $ do @@ -709,9 +774,10 @@ instance YesodHttpSig App where ua <- case muActorHeader of Nothing -> throwE "Got a sig with an instance key, but actor header not specified!" Just u -> return u - _ <- do - manager <- getsYesod appHttpManager - ExceptT $ keyListedByActor manager uKey ua + manager <- getsYesod appHttpManager + let iid = verifKeyInstance vk + ExceptT $ + keyListedByActor' manager iid vkid uKey ua return (ua, True) return VerifKeyDetail { vkdKeyId = uKey