From 7506ec06addde1f93a49d47cdd202cf7baaf9fa0 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sun, 1 Oct 2023 17:31:02 +0200 Subject: [PATCH 1/8] Add Workspace name validation (#834) --- monocle.cabal | 1 + src/CLI.hs | 8 +- src/Macroscope/Main.hs | 2 +- src/Macroscope/Test.hs | 2 +- src/Monocle/Api/Jwt.hs | 3 +- src/Monocle/Api/Server.hs | 4 +- src/Monocle/Api/ServerHTMX.hs | 3 +- src/Monocle/Backend/Provisioner.hs | 35 ++++--- src/Monocle/Backend/Test.hs | 16 +-- src/Monocle/Config.hs | 158 +++++++++++++---------------- src/Monocle/Config/Generated.hs | 137 +++++++++++++++++++++++++ src/Monocle/Effects.hs | 11 +- src/Monocle/Env.hs | 6 +- src/Monocle/Servant/HTMX.hs | 3 +- src/Tests.hs | 14 +-- 15 files changed, 269 insertions(+), 134 deletions(-) create mode 100644 src/Monocle/Config/Generated.hs diff --git a/monocle.cabal b/monocle.cabal index aa039bb98..4a666f89d 100644 --- a/monocle.cabal +++ b/monocle.cabal @@ -208,6 +208,7 @@ library , Monocle.Logging , Monocle.Version , Monocle.Config + , Monocle.Config.Generated , Monocle.Effects , Monocle.Effects.Compat , CLI diff --git a/src/CLI.hs b/src/CLI.hs index d6e6c8625..a65049353 100644 --- a/src/CLI.hs +++ b/src/CLI.hs @@ -6,6 +6,7 @@ module CLI (main) where import Control.Concurrent.CGroup qualified +import Data.Text qualified as T import Env hiding (Parser, auto, footer) import Env qualified import Lentille @@ -146,10 +147,13 @@ usageJanitor = where configOption = strOption (long "config" <> O.help "Path to configuration file" <> metavar "MONOCLE_CONFIG") elasticOption = strOption (long "elastic" <> O.help "The Elastic endpoint url" <> metavar "MONOCLE_ELASTIC_URL") - workspaceOption = strOption (long "workspace" <> O.help "Workspace name" <> metavar "WORKSPACE") + workspaceOption = + option + (eitherReader $ (first T.unpack . Config.mkIndexName) . T.pack) + (long "workspace" <> O.help "Workspace name" <> metavar "WORKSPACE") crawlerNameOption = strOption (long "crawler-name" <> O.help "The crawler name" <> metavar "CRAWLER_NAME") runOnWorkspace env action' workspace = runEff $ runLoggerEffect $ runElasticEffect env $ runEmptyQueryM workspace action' - noWorkspace workspaceName = "Unable to find the workspace " <> workspaceName <> " in the Monocle config" + noWorkspace workspaceName = "Unable to find the workspace " <> Config.getIndexName workspaceName <> " in the Monocle config" janitorUpdateIdent = io <$> parser where parser = (,,) <$> configOption <*> elasticOption <*> optional workspaceOption diff --git a/src/Macroscope/Main.hs b/src/Macroscope/Main.hs index 1937c032f..96be866af 100644 --- a/src/Macroscope/Main.hs +++ b/src/Macroscope/Main.hs @@ -53,7 +53,7 @@ import Monocle.Effects -- | A structure to carry a single crawler information. data InfoCrawler = InfoCrawler - { infoWorkspaceName :: Text + { infoWorkspaceName :: Config.IndexName , infoCrawlerKey :: Text , infoCrawler :: Config.Crawler , infoIdents :: [Config.Ident] diff --git a/src/Macroscope/Test.hs b/src/Macroscope/Test.hs index d8c8d07b7..17f9abd16 100644 --- a/src/Macroscope/Test.hs +++ b/src/Macroscope/Test.hs @@ -186,7 +186,7 @@ testGetStream = do assertEqual' "Stream group named" expected (map fst $ Macroscope.mkStreamsActions (catMaybes streams)) where conf = - [ (Config.mkTenant "test-stream") + [ (Config.mkTenant $ hardcodedIndexName "test-stream") { Config.crawlers = [gl "org1" "GITLAB_TOKEN", gl "org2" "GITLAB_TOKEN", gl "org3" "OTHER_TOKEN"] , Config.crawlers_api_key = Just "CRAWLERS_API_KEY" } diff --git a/src/Monocle/Api/Jwt.hs b/src/Monocle/Api/Jwt.hs index d25edaf34..e774b09c7 100644 --- a/src/Monocle/Api/Jwt.hs +++ b/src/Monocle/Api/Jwt.hs @@ -22,6 +22,7 @@ import Data.ByteString.Lazy qualified as BSL import Data.Map.Strict qualified as HM import Monocle.Config (OIDCProviderConfig (..)) import Monocle.Prelude hiding (Error) +import qualified Monocle.Config as Config import Network.HTTP.Client (Manager) import Servant.Auth.Server ( FromJWT, @@ -41,7 +42,7 @@ doGenJwk keyM = case keyM of randomJWK = keyFromBS <$> genRandom keyFromBS = fromOctets . take 64 . BSL.unpack . from -type MUidMap = Map Text Text +type MUidMap = Map Config.IndexName Text -- Will be added as the 'dat' unregistered claim data AuthenticatedUser = AUser diff --git a/src/Monocle/Api/Server.hs b/src/Monocle/Api/Server.hs index 9cbc55594..a834366be 100644 --- a/src/Monocle/Api/Server.hs +++ b/src/Monocle/Api/Server.hs @@ -517,7 +517,7 @@ searchAuthor auth request = checkAuth auth . const $ do pure . SearchPB.AuthorResponse $ V.fromList authors -getMuidByIndexName :: Text -> AuthenticatedUser -> Maybe Text +getMuidByIndexName :: Config.IndexName -> AuthenticatedUser -> Maybe Text getMuidByIndexName index = Map.lookup index . aMuidMap -- | /search/check endpoint @@ -1058,7 +1058,7 @@ handleLoggedIn cookieSettings err codeM stateM = do defaultUserId = sub idToken -- Given a Claim, get a mapping of index (workspace) name to Monocle UID (mUid) - getIdents :: Config -> Text -> Map.Map Text Text + getIdents :: Config -> Text -> Map.Map Config.IndexName Text getIdents config auid = foldr go Map.empty $ Config.getWorkspaces config where go index acc = case Config.getIdentByAlias index auid of diff --git a/src/Monocle/Api/ServerHTMX.hs b/src/Monocle/Api/ServerHTMX.hs index 41984663b..318544a2f 100644 --- a/src/Monocle/Api/ServerHTMX.hs +++ b/src/Monocle/Api/ServerHTMX.hs @@ -9,6 +9,7 @@ import Monocle.Api.Jwt (AuthenticatedUser) import Monocle.Api.Server (searchAuthor) import Monocle.Backend.Documents (EDocType (ECachedAuthor)) import Monocle.Backend.Queries (documentType) +import Monocle.Config qualified as Config import Monocle.Effects (ApiEffects, esCountByIndex) import Monocle.Env (tenantIndexName) import Monocle.Prelude @@ -22,7 +23,7 @@ hxTrigger = makeAttribute "hx-trigger" hxTarget = makeAttribute "hx-target" hxVals = makeAttribute "hx-vals" -searchAuthorsHandler :: ApiEffects es => AuthResult AuthenticatedUser -> Maybe Text -> Maybe Text -> Eff es (Html ()) +searchAuthorsHandler :: ApiEffects es => AuthResult AuthenticatedUser -> Maybe Config.IndexName -> Maybe Text -> Eff es (Html ()) searchAuthorsHandler _ Nothing _ = pure $ pure () searchAuthorsHandler auth (Just index) queryM = do case queryM of diff --git a/src/Monocle/Backend/Provisioner.hs b/src/Monocle/Backend/Provisioner.hs index f254450da..a66abfe87 100644 --- a/src/Monocle/Backend/Provisioner.hs +++ b/src/Monocle/Backend/Provisioner.hs @@ -30,7 +30,7 @@ import Faker.TvShow.TheExpanse qualified import Google.Protobuf.Timestamp qualified (fromUTCTime) import Monocle.Backend.Documents import Monocle.Backend.Test qualified as T -import Monocle.Config (csConfig, getWorkspaces, lookupTenant) +import Monocle.Config (csConfig, getWorkspaces, lookupTenant, mkIndexName) import Monocle.Effects (getReloadConfig, runElasticEffect, runEmptyQueryM, runMonoConfig) import Monocle.Env (mkEnv) import Monocle.Prelude @@ -38,20 +38,25 @@ import Monocle.Protob.Search (TaskData (..)) -- | Provision fakedata for a tenant runProvisioner :: FilePath -> Text -> Text -> Int -> IO () -runProvisioner configPath elasticUrl tenantName docCount = runEff . runMonoConfig configPath . runLoggerEffect $ do - conf <- csConfig <$> getReloadConfig - let tenantM = lookupTenant (getWorkspaces conf) tenantName - case tenantM of - Just tenant -> do - bhEnv <- mkEnv elasticUrl - r <- runRetry $ runFail $ runElasticEffect bhEnv $ do - events <- liftIO $ createFakeEvents docCount - runEmptyQueryM tenant $ T.indexScenario events - logInfo "Provisionned" ["index" .= tenantName, "doc count" .= length events] - case r of - Left err -> logInfo "Unable to perform the provisionning" ["error" .= err] - Right _ -> pure () - Nothing -> pure () +runProvisioner configPath elasticUrl tenantName docCount = do + indexName <- + either + (\e -> fail $ "Invalid tenantName " <> show tenantName <> " (" <> show e <> ")") return + $ mkIndexName tenantName + runEff . runMonoConfig configPath . runLoggerEffect $ do + conf <- csConfig <$> getReloadConfig + let tenantM = lookupTenant (getWorkspaces conf) indexName + case tenantM of + Just tenant -> do + bhEnv <- mkEnv elasticUrl + r <- runRetry $ runFail $ runElasticEffect bhEnv $ do + events <- liftIO $ createFakeEvents docCount + runEmptyQueryM tenant $ T.indexScenario events + logInfo "Provisionned" ["index" .= indexName, "doc count" .= length events] + case r of + Left err -> logInfo "Unable to perform the provisionning" ["error" .= err] + Right _ -> pure () + Nothing -> pure () -- | Ensure changes have a unique ID setChangeID :: [EChange] -> IO [EChange] diff --git a/src/Monocle/Backend/Test.hs b/src/Monocle/Backend/Test.hs index 68b79f91c..4910f7c07 100644 --- a/src/Monocle/Backend/Test.hs +++ b/src/Monocle/Backend/Test.hs @@ -126,7 +126,7 @@ withTenant :: Eff [MonoQuery, ElasticEffect, LoggerEffect, IOE] () -> IO () withTenant = withTenantConfig index where -- todo: generate random name - index = Config.mkTenant "test-tenant" + index = Config.mkTenant $ hardcodedIndexName "test-tenant" testQueryM' :: Config.Index -> Eff [MonoQuery, ElasticEffect, LoggerEffect, E.Fail, IOE] a -> IO a testQueryM' config action = do @@ -400,7 +400,7 @@ testEnsureConfig = withTenantConfig tenantConfig $ localQueryTarget target $ run (currentVersion, _) <- I.getConfigVersion assertEqual' "Check expected Config Index" I.configVersion currentVersion where - tenantConfig = Config.mkTenant "test-index" + tenantConfig = Config.mkTenant $ hardcodedIndexName "test-index" target = QueryConfig $ Config.Config Nothing Nothing Nothing [tenantConfig] testUpgradeConfigV3 :: Assertion @@ -512,7 +512,7 @@ testUpgradeConfigV1 = do tenantConfig :: Config.Index tenantConfig = Config.Index - { name = "test-tenant" + { name = hardcodedIndexName "test-tenant" , crawlers = [crawlerGH, crawlerGL] , crawlers_api_key = Nothing , projects = Nothing @@ -545,7 +545,7 @@ testJanitorWipeCrawler = withTenant $ localQueryTarget updateEnv doTest where tenant = Config.Index - { name = "test-tenant" + { name = hardcodedIndexName "test-tenant" , crawlers = [workerGerrit] , crawlers_api_key = Nothing , projects = Nothing @@ -587,7 +587,7 @@ testJanitorUpdateIdents = do tenantConfig :: Config.Index tenantConfig = Config.Index - { name = "test-tenant" + { name = hardcodedIndexName "test-tenant" , crawlers = [] , crawlers_api_key = Nothing , projects = Nothing @@ -689,7 +689,7 @@ testAchievements = withTenant doTest assertEqual' "event found" (Q.epbType agg) "Change" assertEqual' "event count match" (Q.epbCount agg) 1 where - conf = mkConfig "test" + conf = mkConfig $ hardcodedIndexName "test" query now = case (Q.queryGet $ Q.load now mempty conf "state:merged") id (Just defaultQueryFlavor) of [x] -> x _ -> error "Could not compile query" @@ -714,7 +714,7 @@ testGetInfoMetric = withTenantConfig tenant do (Just "time_to_merge") (getMetricName resp) where - tenant = Config.mkTenant "demo" + tenant = Config.mkTenant $ hardcodedIndexName "demo" env = Monocle.Api.Test.mkAppEnv tenant getMetricName :: MetricPB.InfoResponse -> Maybe Text getMetricName resp = case resp of @@ -752,7 +752,7 @@ testGetMetrics = withTenantConfig tenant do , MetricPB.getRequestOptions = Nothing } env = Monocle.Api.Test.mkAppEnv tenant - tenantName = "test-metric-tenant" + tenantName = hardcodedIndexName "test-metric-tenant" tenant = Config.mkTenant tenantName testReposSummary :: Assertion diff --git a/src/Monocle/Config.hs b/src/Monocle/Config.hs index 0b27707c4..10c66d99b 100644 --- a/src/Monocle/Config.hs +++ b/src/Monocle/Config.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -- | -- Module : Monocle.Api.Config @@ -17,6 +17,7 @@ module Monocle.Config ( Config (..), Workspace, Index (..), + IndexName, Project (..), Ident (..), SearchAlias (..), @@ -80,115 +81,81 @@ module Monocle.Config ( mkTenant, getIdentByAliasFromIdents, links, + getIndexName, + mkIndexName, ) where +import Data.Aeson qualified as Aeson import Data.ByteString qualified as BS +import Data.Char (isLowerCase) import Data.Either.Validation (Validation (Failure, Success)) import Data.Map qualified as Map -import Data.Text qualified as T (dropWhileEnd, isPrefixOf, null, replace, toUpper) +import Data.Text qualified as T (all, dropWhileEnd, isPrefixOf, null, replace, toUpper, uncons, unpack) +import Data.Text.Encoding qualified as T +import Data.Text.Lazy qualified as TL import Dhall qualified import Dhall.Core qualified -import Dhall.Src qualified -import Dhall.TH qualified import Dhall.YamlToDhall qualified as Dhall import Effectful.Env +import Monocle.Config.Generated import Monocle.Prelude +import Servant.API (FromHttpApiData(..)) import System.Directory (getModificationTime) +import Witch qualified --- | Generate Haskell Type from Dhall Type --- See: https://hackage.haskell.org/package/dhall-1.38.0/docs/Dhall-TH.html -Dhall.TH.makeHaskellTypes - ( let providerPath name = "./schemas/monocle/config/Provider/" <> name <> "/Type.dhall" - authProviderPath name = "./schemas/monocle/config/AuthProvider/" <> name <> "/Type.dhall" - provider name = Dhall.TH.SingleConstructor name name $ providerPath name - authProvider name = Dhall.TH.SingleConstructor name name $ authProviderPath name - mainPath name = "./schemas/monocle/config/" <> name <> "/Type.dhall" - main name = Dhall.TH.SingleConstructor name name $ mainPath name - in [ main "Project" - , main "Ident" - , main "SearchAlias" - , main "Crawler" - , main "Crawlers" - , main "Auth" - , main "Config" - , main "About" - , main "Link" - , provider "Gerrit" - , provider "Gitlab" - , provider "Github" - , provider "GithubUser" - , provider "GithubApplication" - , provider "Bugzilla" - , authProvider "OIDC" - , authProvider "GithubAuth" - , Dhall.TH.MultipleConstructors - "Provider" - "./schemas/monocle/config/Crawler/Provider.dhall" - , Dhall.TH.MultipleConstructors - "AuthProvider" - "./schemas/monocle/config/Auth/Provider.dhall" - , -- To support backward compatible schema, we replace Index and Crawler schemas - Dhall.TH.SingleConstructor "Index" "Index" $ mainPath "Workspace" - ] - ) +data Config = Config + { about :: Maybe About + , auth :: Maybe Auth + , crawlers :: Maybe Crawlers + , workspaces :: [Workspace] + } + deriving stock (Eq, Show, Generic) + deriving anyclass (Dhall.FromDhall, Dhall.ToDhall) -- | Workspace are not index name. type Workspace = Index --- | Embed the expected configuration schema -configurationSchema :: Dhall.Core.Expr Dhall.Src.Src Void -configurationSchema = $(Dhall.TH.staticDhallExpression "./schemas/monocle/config/Config/Type.dhall") - -deriving instance Eq OIDC -deriving instance Show OIDC - -deriving instance Eq GithubAuth -deriving instance Show GithubAuth - -deriving instance Eq Auth -deriving instance Show Auth - -deriving instance Eq AuthProvider -deriving instance Show AuthProvider - -deriving instance Eq Gerrit -deriving instance Show Gerrit - -deriving instance Eq Github -deriving instance Show Github - -deriving instance Eq GithubUser -deriving instance Show GithubUser - -deriving instance Eq GithubApplication -deriving instance Show GithubApplication - -deriving instance Eq Gitlab -deriving instance Show Gitlab +data Index = Index + { name :: IndexName + , crawlers_api_key :: Maybe Text + , crawlers :: [Crawler] + , projects :: Maybe [Project] + , idents :: Maybe [Ident] + , search_aliases :: Maybe [SearchAlias] + } + deriving stock (Eq, Show, Generic) + deriving anyclass (Dhall.FromDhall, Dhall.ToDhall) -deriving instance Eq Bugzilla -deriving instance Show Bugzilla +newtype IndexName + = IndexName { getIndexName :: Text } + deriving stock (Eq, Ord, Show) + deriving newtype (Semigroup, Dhall.ToDhall, Aeson.ToJSON, Aeson.ToJSONKey, Aeson.FromJSONKey) -deriving instance Eq Project -deriving instance Show Project +instance Aeson.FromJSON IndexName where + parseJSON x = + parseJSON x >>= either (fail . T.unpack) return . mkIndexName -deriving instance Eq Provider -deriving instance Show Provider +instance Dhall.FromDhall IndexName where + autoWith _ = Dhall.Decoder {..} + where + expected = pure Dhall.Core.Text + extract = + \case + Dhall.Core.TextLit (Dhall.Core.Chunks [] t) -> either Dhall.extractError pure $ mkIndexName t + expr -> Dhall.typeError expected expr -deriving instance Eq Crawlers -deriving instance Show Crawlers +deriving anyclass instance Witch.From Text IndexName -deriving instance Eq Crawler -deriving instance Show Crawler +deriving instance Witch.From IndexName Text -deriving instance Eq Ident -deriving instance Show Ident +instance Witch.From TL.Text IndexName where + from = IndexName . TL.toStrict -deriving instance Eq SearchAlias -deriving instance Show SearchAlias +instance Witch.From IndexName TL.Text where + from = TL.fromStrict . getIndexName -deriving instance Eq Index -deriving instance Show Index +instance FromHttpApiData IndexName where + parseUrlPiece = mkIndexName -- End - Loading of Types from the dhall-monocle @@ -231,7 +198,7 @@ loadConfig configPath = do -- | A Type to express if a 'Workspace' needs refresh data Status = NeedRefresh | Ready -type WorkspaceName = Text +type WorkspaceName = IndexName type WorkspaceStatus = Map WorkspaceName Status @@ -361,11 +328,11 @@ getAuthProvider publicUrl Config {auth} = case auth of --------------------------------------- -- | Get the 'Index' name -getWorkspaceName :: Index -> Text +getWorkspaceName :: Index -> IndexName getWorkspaceName Index {..} = name -- | Find an 'Index' by name -lookupTenant :: [Index] -> Text -> Maybe Index +lookupTenant :: [Index] -> IndexName -> Maybe Index lookupTenant xs tenantName = find isTenant xs where isTenant Index {..} = name == tenantName @@ -493,7 +460,7 @@ getCrawlerProjectIssue crawler@Crawler {..} = case provider of --------------------------------- -- | Create an empty 'Index' -mkTenant :: Text -> Index +mkTenant :: IndexName -> Index mkTenant name = Index { name @@ -513,4 +480,15 @@ getIdentByAliasFromIdents alias idents' = case find isMatched idents' of isMatched :: Ident -> Bool isMatched Ident {..} = alias `elem` aliases +mkIndexName :: Text -> Either Text IndexName +mkIndexName x = do + let check name p = if p then Right () else Left name + check "Is empty" $ not $ T.null x + check "Is longer than 255 bytes" $ BS.length (T.encodeUtf8 x) < 256 + check "Contains uppercase letter(s)" $ T.all isLowerCase x + check "Includes [\\/*?\"<>| ,#:]" $ T.all (flip @_ @String notElem "\\/*?\"<>| ,#:") x + check "Starts with [-_+.]" $ maybe False (flip @_ @String notElem "-_+." . fst) $ T.uncons x + check "Is (.|..)" $ notElem x [".", ".."] + return $ IndexName x + -- End - Some utility functions diff --git a/src/Monocle/Config/Generated.hs b/src/Monocle/Config/Generated.hs new file mode 100644 index 000000000..81d7bceae --- /dev/null +++ b/src/Monocle/Config/Generated.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Monocle.Api.Config.Generated +-- Description : Handle the Monocle configuration file +-- Copyright : Monocle authors +-- License : AGPL-3 +-- +-- The module contains defintion of data types according to the +-- Monocle dhall schemas found in the schemas/monocle/config directory. It also +-- provides some functions to handle configuration data. +module Monocle.Config.Generated ( + -- * Data types imported from dhall + Project (..), + Ident (..), + SearchAlias (..), + About (..), + Crawlers (..), + Crawler (..), + Provider (..), + Gitlab (..), + Gerrit (..), + Github (..), + GithubUser (..), + Bugzilla (..), + GithubApplication (..), + Link (..), + Auth (..), + AuthProvider (..), + OIDC (..), + GithubAuth (..), + + -- * Extra Generated + configurationSchema, +) where + +import Dhall.Core qualified +import Dhall.Src qualified +import Dhall.TH qualified +import Monocle.Prelude + +-- | Generate Haskell Type from Dhall Type +-- See: https://hackage.haskell.org/package/dhall-1.38.0/docs/Dhall-TH.html +Dhall.TH.makeHaskellTypes + ( let providerPath name = "./schemas/monocle/config/Provider/" <> name <> "/Type.dhall" + authProviderPath name = "./schemas/monocle/config/AuthProvider/" <> name <> "/Type.dhall" + provider name = Dhall.TH.SingleConstructor name name $ providerPath name + authProvider name = Dhall.TH.SingleConstructor name name $ authProviderPath name + mainPath name = "./schemas/monocle/config/" <> name <> "/Type.dhall" + main name = Dhall.TH.SingleConstructor name name $ mainPath name + in [ main "Project" + , main "Ident" + , main "SearchAlias" + , main "Crawler" + , main "Crawlers" + , main "Auth" + , main "About" + , main "Link" + , provider "Gerrit" + , provider "Gitlab" + , provider "Github" + , provider "GithubUser" + , provider "GithubApplication" + , provider "Bugzilla" + , authProvider "OIDC" + , authProvider "GithubAuth" + , Dhall.TH.MultipleConstructors + "Provider" + "./schemas/monocle/config/Crawler/Provider.dhall" + , Dhall.TH.MultipleConstructors + "AuthProvider" + "./schemas/monocle/config/Auth/Provider.dhall" + ] + ) + +-- | Embed the expected configuration schema +configurationSchema :: Dhall.Core.Expr Dhall.Src.Src Void +configurationSchema = $(Dhall.TH.staticDhallExpression "./schemas/monocle/config/Config/Type.dhall") + +deriving instance Eq OIDC +deriving instance Show OIDC + +deriving instance Eq GithubAuth +deriving instance Show GithubAuth + +deriving instance Eq Auth +deriving instance Show Auth + +deriving instance Eq AuthProvider +deriving instance Show AuthProvider + +deriving instance Eq Gerrit +deriving instance Show Gerrit + +deriving instance Eq Github +deriving instance Show Github + +deriving instance Eq GithubUser +deriving instance Show GithubUser + +deriving instance Eq GithubApplication +deriving instance Show GithubApplication + +deriving instance Eq Gitlab +deriving instance Show Gitlab + +deriving instance Eq Bugzilla +deriving instance Show Bugzilla + +deriving instance Eq Project +deriving instance Show Project + +deriving instance Eq Provider +deriving instance Show Provider + +deriving instance Eq Crawlers +deriving instance Show Crawlers + +deriving instance Eq Crawler +deriving instance Show Crawler + +deriving instance Eq Ident +deriving instance Show Ident + +deriving instance Eq SearchAlias +deriving instance Show SearchAlias + +deriving instance Eq Link +deriving instance Show Link + +deriving instance Eq About +deriving instance Show About + +-- End - Loading of Types from the dhall-monocle diff --git a/src/Monocle/Effects.hs b/src/Monocle/Effects.hs index 55510ffae..a047378c4 100644 --- a/src/Monocle/Effects.hs +++ b/src/Monocle/Effects.hs @@ -99,6 +99,7 @@ import Effectful.Reader.Static qualified as E import Effectful.Retry as Retry import Monocle.Client (MonocleClient) import Monocle.Client.Api (crawlerAddDoc, crawlerCommit, crawlerCommitInfo) +import Monocle.Config (IndexName, mkIndexName) import Monocle.Protob.Crawler qualified as CrawlerPB @@ -156,7 +157,7 @@ testTree = liftIO do writeFile fp "workspaces:\n- name: test\n crawlers: []" config <- getReloadConfig Monocle.Config.csReloaded config `testEff` True - getNames config `testEff` ["test"] + getNames config `testEff` [hardcodedIndexName "test"] -- make sure reload is avoided when the file doesn't change do @@ -243,7 +244,7 @@ runMonoQuery :: MonoQueryEnv -> Eff (MonoQuery : es) a -> Eff es a runMonoQuery env = evalStaticRep (MonoQuery env) runMonoQueryConfig :: SearchQuery.Query -> Eff (MonoQuery : es) a -> Eff es a -runMonoQueryConfig q = evalStaticRep (MonoQuery $ MonoQueryEnv (Monocle.Env.QueryWorkspace $ Monocle.Config.mkTenant "test-tenant") q) +runMonoQueryConfig q = evalStaticRep (MonoQuery $ MonoQueryEnv (Monocle.Env.QueryWorkspace $ Monocle.Config.mkTenant $ hardcodedIndexName "test-tenant") q) runQueryM :: Monocle.Config.Index -> SearchQuery.Query -> Eff (MonoQuery : es) a -> Eff es a runQueryM ws query = evalStaticRep (MonoQuery $ MonoQueryEnv target query) @@ -589,3 +590,9 @@ loggerDemo = logInfo "Hello effectful" [] subDemo :: E.Fail :> es => Eff es () subDemo = fail "Toto" + +hardcodedIndexName :: Text -> IndexName +hardcodedIndexName x = + either + (\e -> error $ "hardcodedIndexName: cannot make IndexName from " <> show x <> " (" <> show e <> ")") id + $ mkIndexName x diff --git a/src/Monocle/Env.hs b/src/Monocle/Env.hs index 3b1d602d9..54e3f0a36 100644 --- a/src/Monocle/Env.hs +++ b/src/Monocle/Env.hs @@ -47,7 +47,7 @@ mkEnv' = do mkEnv (from url) -- | Re-export utility function to create a config for testQueryM -mkConfig :: Text -> Config.Index +mkConfig :: Config.IndexName -> Config.Index mkConfig = Config.mkTenant indexNamePrefix :: Text @@ -62,8 +62,8 @@ envToIndexName target = do indexName :: Config.Index -> BH.IndexName indexName Config.Index {..} = tenantIndexName name -tenantIndexName :: Text -> BH.IndexName -tenantIndexName indexName = BH.IndexName $ indexNamePrefix <> indexName +tenantIndexName :: Config.IndexName -> BH.IndexName +tenantIndexName indexName = BH.IndexName $ indexNamePrefix <> Config.getIndexName indexName -- | 'mkQuery' creates a Q.Query from a BH.Query mkQuery :: [BH.Query] -> Q.Query diff --git a/src/Monocle/Servant/HTMX.hs b/src/Monocle/Servant/HTMX.hs index b764fb744..c26b42163 100644 --- a/src/Monocle/Servant/HTMX.hs +++ b/src/Monocle/Servant/HTMX.hs @@ -3,6 +3,7 @@ module Monocle.Servant.HTMX where import Data.Text import Lucid (Html) import Monocle.Api.Jwt (AuthenticatedUser) +import Monocle.Config qualified as Config import Servant import Servant.Auth.Server import Servant.HTML.Lucid (HTML) @@ -11,6 +12,6 @@ type HtmxAPI = "htmx" :> "authors_search" :> Auth '[JWT, Cookie] AuthenticatedUser - :> QueryParam "index" Text + :> QueryParam "index" Config.IndexName :> QueryParam "search" Text :> Get '[HTML] (Html ()) diff --git a/src/Tests.hs b/src/Tests.hs index 0cc913edb..3d749b6c5 100644 --- a/src/Tests.hs +++ b/src/Tests.hs @@ -126,7 +126,7 @@ monocleApiTests = where testAuthMagicTokenEndpoint :: Assertion testAuthMagicTokenEndpoint = do - let appEnv = mkAppEnv $ Config.mkTenant "ws" + let appEnv = mkAppEnv $ Config.mkTenant $ hardcodedIndexName "ws" let adminToken = "test" setEnv "MONOCLE_ADMIN_TOKEN" adminToken withTestApi appEnv $ \client -> do @@ -148,7 +148,7 @@ monocleApiTests = testGetGroups = do let appEnv = mkAppEnv - $ (Config.mkTenant "ws") + $ (Config.mkTenant $ hardcodedIndexName "ws") { Config.idents = Just [ Config.Ident [] (Just ["grp1", "grp2"]) "John" @@ -244,8 +244,8 @@ monocleApiTests = in Config.Crawler {..} ] } - wsName1 = "ws1" - wsName2 = "ws2" + wsName1 = hardcodedIndexName "ws1" + wsName2 = hardcodedIndexName "ws2" crawlerName = "testy" monocleBackendQueriesTests :: TestTree @@ -608,7 +608,7 @@ monocleSearchLanguage = queryMatchBound = queryDoMatch Q.queryBounds testTenant = Config.Index - { Config.name = "test" + { Config.name = hardcodedIndexName "test" , Config.projects = Just [testProjects] , Config.search_aliases = Just @@ -646,7 +646,7 @@ monocleConfig = testGetTenantGroups = testCase "Validate getTenantGroups" do let identA = createIdent "alice" [] ["core", "ptl"] identB = createIdent "bob" [] ["core"] - tenant = (Config.mkTenant "test") {Config.idents = Just [identA, identB]} + tenant = (Config.mkTenant $ hardcodedIndexName "test") {Config.idents = Just [identA, identB]} assertEqual "Ensure groups and members" [("core", ["bob", "alice"]), ("ptl", ["alice"])] @@ -655,7 +655,7 @@ monocleConfig = testGetIdentByAlias = testCase "Validate getIdentByAliases" do let identA = createIdent "alice" ["opendev.org/Alice Doe/12345", "github.com/alice89"] [] identB = createIdent "bob" [] [] - tenant = (Config.mkTenant "test") {Config.idents = Just [identA, identB]} + tenant = (Config.mkTenant $ hardcodedIndexName "test") {Config.idents = Just [identA, identB]} assertEqual "Ensure found alice as ident" (Just "alice") From 2c140244f8d2c3a3285ba0737aa718e18cdb117e Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Sun, 1 Oct 2023 19:16:41 +0200 Subject: [PATCH 2/8] fixup! Add Workspace name validation (#834) --- src/Monocle/Config.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Monocle/Config.hs b/src/Monocle/Config.hs index 10c66d99b..f0e058253 100644 --- a/src/Monocle/Config.hs +++ b/src/Monocle/Config.hs @@ -87,7 +87,7 @@ module Monocle.Config ( import Data.Aeson qualified as Aeson import Data.ByteString qualified as BS -import Data.Char (isLowerCase) +import Data.Char (isLetter, isLowerCase) import Data.Either.Validation (Validation (Failure, Success)) import Data.Map qualified as Map import Data.Text qualified as T (all, dropWhileEnd, isPrefixOf, null, replace, toUpper, uncons, unpack) @@ -485,7 +485,7 @@ mkIndexName x = do let check name p = if p then Right () else Left name check "Is empty" $ not $ T.null x check "Is longer than 255 bytes" $ BS.length (T.encodeUtf8 x) < 256 - check "Contains uppercase letter(s)" $ T.all isLowerCase x + check "Contains uppercase letter(s)" $ T.all (\x -> not (isLetter x) || isLowerCase x) x check "Includes [\\/*?\"<>| ,#:]" $ T.all (flip @_ @String notElem "\\/*?\"<>| ,#:") x check "Starts with [-_+.]" $ maybe False (flip @_ @String notElem "-_+." . fst) $ T.uncons x check "Is (.|..)" $ notElem x [".", ".."] From e581f8f0f0a23f17056222d398151b565c15c4af Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 2 Oct 2023 00:25:06 +0200 Subject: [PATCH 3/8] fixup! Add Workspace name validation (#834) --- src/Monocle/Config.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Monocle/Config.hs b/src/Monocle/Config.hs index f0e058253..b417d99d1 100644 --- a/src/Monocle/Config.hs +++ b/src/Monocle/Config.hs @@ -481,14 +481,14 @@ getIdentByAliasFromIdents alias idents' = case find isMatched idents' of isMatched Ident {..} = alias `elem` aliases mkIndexName :: Text -> Either Text IndexName -mkIndexName x = do +mkIndexName name = do let check name p = if p then Right () else Left name - check "Is empty" $ not $ T.null x - check "Is longer than 255 bytes" $ BS.length (T.encodeUtf8 x) < 256 - check "Contains uppercase letter(s)" $ T.all (\x -> not (isLetter x) || isLowerCase x) x - check "Includes [\\/*?\"<>| ,#:]" $ T.all (flip @_ @String notElem "\\/*?\"<>| ,#:") x - check "Starts with [-_+.]" $ maybe False (flip @_ @String notElem "-_+." . fst) $ T.uncons x - check "Is (.|..)" $ notElem x [".", ".."] - return $ IndexName x + check "Is empty" $ not $ T.null name + check "Is longer than 255 bytes" $ BS.length (T.encodeUtf8 name) < 256 + check "Contains uppercase letter(s)" $ T.all (\x -> not (isLetter x) || isLowerCase x) name + check "Includes [\\/*?\"<>| ,#:]" $ T.all (flip @_ @String notElem "\\/*?\"<>| ,#:") name + check "Starts with [-_+.]" $ maybe False (flip @_ @String notElem "-_+." . fst) $ T.uncons name + check "Is (.|..)" $ notElem name [".", ".."] + return $ IndexName name -- End - Some utility functions From 9a4991f2e392dddfaed6df31b86ac27b3ecb5e25 Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 2 Oct 2023 00:31:35 +0200 Subject: [PATCH 4/8] fixup! Add Workspace name validation (#834) --- src/Monocle/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Monocle/Config.hs b/src/Monocle/Config.hs index b417d99d1..dcc93cbf9 100644 --- a/src/Monocle/Config.hs +++ b/src/Monocle/Config.hs @@ -482,7 +482,7 @@ getIdentByAliasFromIdents alias idents' = case find isMatched idents' of mkIndexName :: Text -> Either Text IndexName mkIndexName name = do - let check name p = if p then Right () else Left name + let check explanation p = if p then Right () else Left explanation check "Is empty" $ not $ T.null name check "Is longer than 255 bytes" $ BS.length (T.encodeUtf8 name) < 256 check "Contains uppercase letter(s)" $ T.all (\x -> not (isLetter x) || isLowerCase x) name From d50e61655a607dd55c5b1fe60852757910b407ae Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 2 Oct 2023 18:33:39 +0200 Subject: [PATCH 5/8] fixup! Add Workspace name validation (#834) --- CHANGELOG.md | 2 ++ src/Monocle/Config.hs | 20 +++++++++++++++++++- src/Monocle/Effects.hs | 3 +-- 3 files changed, 22 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 602df2011..6c6f98474 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,8 @@ All notable changes to this project will be documented in this file. ### Changed +- `workspaceName` is typed as `IndexName`, which respect ElasticSearch constraints + ### Removed ### Fixed diff --git a/src/Monocle/Config.hs b/src/Monocle/Config.hs index dcc93cbf9..b9354ed59 100644 --- a/src/Monocle/Config.hs +++ b/src/Monocle/Config.hs @@ -90,7 +90,7 @@ import Data.ByteString qualified as BS import Data.Char (isLetter, isLowerCase) import Data.Either.Validation (Validation (Failure, Success)) import Data.Map qualified as Map -import Data.Text qualified as T (all, dropWhileEnd, isPrefixOf, null, replace, toUpper, uncons, unpack) +import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Text.Lazy qualified as TL import Dhall qualified @@ -480,6 +480,24 @@ getIdentByAliasFromIdents alias idents' = case find isMatched idents' of isMatched :: Ident -> Bool isMatched Ident {..} = alias `elem` aliases +-- | Create an IndexName with checked constraints +-- +-- >>> mkIndexName "" +-- Left "Is empty" +-- >>> mkIndexName $ T.replicate 256 "x" +-- Left "Is longer than 255 bytes" +-- >>> mkIndexName "azerTY" +-- Left "Contains uppercase letter(s)" +-- >>> mkIndexName "hello#world" +-- Left "Includes [\\/*?\"<>| ,#:]" +-- >>> mkIndexName "-test" +-- Left "Starts with [-_+.]" +-- >>> mkIndexName "." +-- Left "Is (.|..)" +-- >>> mkIndexName ".." +-- Left "Is (.|..)" +-- >>> mkIndexName "hello-world_42" +-- Right (IndexName "hello-world_42") mkIndexName :: Text -> Either Text IndexName mkIndexName name = do let check explanation p = if p then Right () else Left explanation diff --git a/src/Monocle/Effects.hs b/src/Monocle/Effects.hs index a047378c4..7253b2452 100644 --- a/src/Monocle/Effects.hs +++ b/src/Monocle/Effects.hs @@ -70,7 +70,7 @@ import Effectful.Dispatch.Static.Primitive qualified as EffStatic import Monocle.Effects.Compat () import GHC.IO.Handle (hClose) -import Monocle.Config (ConfigStatus) +import Monocle.Config (ConfigStatus, IndexName, mkIndexName) import System.Directory import System.Posix.Temp (mkstemp) import Test.Tasty @@ -99,7 +99,6 @@ import Effectful.Reader.Static qualified as E import Effectful.Retry as Retry import Monocle.Client (MonocleClient) import Monocle.Client.Api (crawlerAddDoc, crawlerCommit, crawlerCommitInfo) -import Monocle.Config (IndexName, mkIndexName) import Monocle.Protob.Crawler qualified as CrawlerPB From a63c6a022f6c68c7cb26adab722dbbad417879fd Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 2 Oct 2023 19:06:59 +0200 Subject: [PATCH 6/8] fixup! Add Workspace name validation (#834) --- src/Monocle/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Monocle/Config.hs b/src/Monocle/Config.hs index b9354ed59..e0f8ebc67 100644 --- a/src/Monocle/Config.hs +++ b/src/Monocle/Config.hs @@ -505,8 +505,8 @@ mkIndexName name = do check "Is longer than 255 bytes" $ BS.length (T.encodeUtf8 name) < 256 check "Contains uppercase letter(s)" $ T.all (\x -> not (isLetter x) || isLowerCase x) name check "Includes [\\/*?\"<>| ,#:]" $ T.all (flip @_ @String notElem "\\/*?\"<>| ,#:") name - check "Starts with [-_+.]" $ maybe False (flip @_ @String notElem "-_+." . fst) $ T.uncons name check "Is (.|..)" $ notElem name [".", ".."] + check "Starts with [-_+.]" $ maybe False (flip @_ @String notElem "-_+." . fst) $ T.uncons name return $ IndexName name -- End - Some utility functions From 52e4289221033ac1389841b475eb18e5af6bd37b Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 2 Oct 2023 19:26:15 +0200 Subject: [PATCH 7/8] fixup! Add Workspace name validation (#834) --- src/Monocle/Config.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Monocle/Config.hs b/src/Monocle/Config.hs index e0f8ebc67..f85ee998c 100644 --- a/src/Monocle/Config.hs +++ b/src/Monocle/Config.hs @@ -497,7 +497,7 @@ getIdentByAliasFromIdents alias idents' = case find isMatched idents' of -- >>> mkIndexName ".." -- Left "Is (.|..)" -- >>> mkIndexName "hello-world_42" --- Right (IndexName "hello-world_42") +-- Right (IndexName {getIndexName = "hello-world_42"}) mkIndexName :: Text -> Either Text IndexName mkIndexName name = do let check explanation p = if p then Right () else Left explanation From b5cc53a2055bc549626ec7c10fe47c9ab098fc1b Mon Sep 17 00:00:00 2001 From: Gautier DI FOLCO Date: Mon, 2 Oct 2023 19:44:38 +0200 Subject: [PATCH 8/8] fixup! Add Workspace name validation (#834) --- src/Monocle/Api/Jwt.hs | 2 +- src/Monocle/Backend/Provisioner.hs | 3 ++- src/Monocle/Config.hs | 17 ++++++++--------- src/Monocle/Effects.hs | 3 ++- test/JsonDecode.hs | 4 ++-- 5 files changed, 15 insertions(+), 14 deletions(-) diff --git a/src/Monocle/Api/Jwt.hs b/src/Monocle/Api/Jwt.hs index e774b09c7..f46bbd23e 100644 --- a/src/Monocle/Api/Jwt.hs +++ b/src/Monocle/Api/Jwt.hs @@ -21,8 +21,8 @@ import Data.ByteString.Base64 qualified as B64 import Data.ByteString.Lazy qualified as BSL import Data.Map.Strict qualified as HM import Monocle.Config (OIDCProviderConfig (..)) +import Monocle.Config qualified as Config import Monocle.Prelude hiding (Error) -import qualified Monocle.Config as Config import Network.HTTP.Client (Manager) import Servant.Auth.Server ( FromJWT, diff --git a/src/Monocle/Backend/Provisioner.hs b/src/Monocle/Backend/Provisioner.hs index a66abfe87..f91d08c11 100644 --- a/src/Monocle/Backend/Provisioner.hs +++ b/src/Monocle/Backend/Provisioner.hs @@ -41,7 +41,8 @@ runProvisioner :: FilePath -> Text -> Text -> Int -> IO () runProvisioner configPath elasticUrl tenantName docCount = do indexName <- either - (\e -> fail $ "Invalid tenantName " <> show tenantName <> " (" <> show e <> ")") return + (\e -> fail $ "Invalid tenantName " <> show tenantName <> " (" <> show e <> ")") + return $ mkIndexName tenantName runEff . runMonoConfig configPath . runLoggerEffect $ do conf <- csConfig <$> getReloadConfig diff --git a/src/Monocle/Config.hs b/src/Monocle/Config.hs index f85ee998c..9fc668361 100644 --- a/src/Monocle/Config.hs +++ b/src/Monocle/Config.hs @@ -99,7 +99,7 @@ import Dhall.YamlToDhall qualified as Dhall import Effectful.Env import Monocle.Config.Generated import Monocle.Prelude -import Servant.API (FromHttpApiData(..)) +import Servant.API (FromHttpApiData (..)) import System.Directory (getModificationTime) import Witch qualified @@ -126,8 +126,7 @@ data Index = Index deriving stock (Eq, Show, Generic) deriving anyclass (Dhall.FromDhall, Dhall.ToDhall) -newtype IndexName - = IndexName { getIndexName :: Text } +newtype IndexName = IndexName {getIndexName :: Text} deriving stock (Eq, Ord, Show) deriving newtype (Semigroup, Dhall.ToDhall, Aeson.ToJSON, Aeson.ToJSONKey, Aeson.FromJSONKey) @@ -137,12 +136,12 @@ instance Aeson.FromJSON IndexName where instance Dhall.FromDhall IndexName where autoWith _ = Dhall.Decoder {..} - where - expected = pure Dhall.Core.Text - extract = - \case - Dhall.Core.TextLit (Dhall.Core.Chunks [] t) -> either Dhall.extractError pure $ mkIndexName t - expr -> Dhall.typeError expected expr + where + expected = pure Dhall.Core.Text + extract = + \case + Dhall.Core.TextLit (Dhall.Core.Chunks [] t) -> either Dhall.extractError pure $ mkIndexName t + expr -> Dhall.typeError expected expr deriving anyclass instance Witch.From Text IndexName diff --git a/src/Monocle/Effects.hs b/src/Monocle/Effects.hs index 7253b2452..7f5f43ffb 100644 --- a/src/Monocle/Effects.hs +++ b/src/Monocle/Effects.hs @@ -593,5 +593,6 @@ subDemo = fail "Toto" hardcodedIndexName :: Text -> IndexName hardcodedIndexName x = either - (\e -> error $ "hardcodedIndexName: cannot make IndexName from " <> show x <> " (" <> show e <> ")") id + (\e -> error $ "hardcodedIndexName: cannot make IndexName from " <> show x <> " (" <> show e <> ")") + id $ mkIndexName x diff --git a/test/JsonDecode.hs b/test/JsonDecode.hs index 9a3b9fdc2..3dc5dde82 100644 --- a/test/JsonDecode.hs +++ b/test/JsonDecode.hs @@ -80,8 +80,8 @@ aesonDecodeData dat = getJsonData :: IO LBS.ByteString getJsonData = do xs <- - Faker.generateWithSettings (Faker.setRandomGen stdGen $ Faker.setNonDeterministic Faker.defaultFakerSettings) $ - Faker.Combinators.listOf total (fakeChangeEvent minDate maxDate) + Faker.generateWithSettings (Faker.setRandomGen stdGen $ Faker.setNonDeterministic Faker.defaultFakerSettings) + $ Faker.Combinators.listOf total (fakeChangeEvent minDate maxDate) pure $ Aeson.encode $ mkObj xs where minDate = [utctime|1970-01-01 00:00:00|]