summaryrefslogtreecommitdiff
path: root/lib/LintConfig.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/LintConfig.hs')
-rw-r--r--lib/LintConfig.hs163
1 files changed, 102 insertions, 61 deletions
diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs
index 11a8122..b0fa3b0 100644
--- a/lib/LintConfig.hs
+++ b/lib/LintConfig.hs
@@ -1,19 +1,21 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Module that deals with handling config options
-module LintConfig (LintConfig(..), LintConfig', patchConfig) where
+module LintConfig (LintConfig(..), LintConfig', ConfigKind (..), patchConfig,stuffConfig,feedConfig) where
import Universum
-import qualified Universum.Unsafe as Unsafe
import Data.Aeson (FromJSON (parseJSON), Options (..),
defaultOptions, eitherDecode)
@@ -28,38 +30,51 @@ import Uris (SchemaSet,
Substitution (DomainSubstitution))
import WithCli.Pure (Argument (argumentType, parseArgument))
-type family HKD f a where
- HKD Identity a = a
- HKD f a = f a
-data LintConfig f = LintConfig
- { configScriptInject :: HKD f (Maybe Text)
+
+data ConfigKind = Complete | Basic | Skeleton | Patch
+
+-- | a field that must be given in configs for both server & standalone linter
+type family ConfigField (f::ConfigKind) a where
+ ConfigField Patch a = Maybe a
+ ConfigField _ a = a
+
+-- | a field that must be given for the standalone linter, but not the server
+-- (usually because the server will infer them from its own config)
+type family StandaloneField (f :: ConfigKind) a where
+ StandaloneField Complete a = a
+ StandaloneField Skeleton a = a
+ StandaloneField _ a = Maybe a
+
+-- | a field specific to a single world / assembly
+type family WorldField (f :: ConfigKind) a where
+ WorldField Complete a = a
+ WorldField _ a = Maybe a
+
+data LintConfig (f :: ConfigKind) = LintConfig
+ { configScriptInject :: ConfigField f (Maybe Text)
-- ^ Link to Script that should be injected
- , configAssemblyTag :: HKD f Text
+ , configAssemblyTag :: WorldField f Text
-- ^ Assembly name (used for jitsiRoomAdminTag)
- , configAssemblies :: HKD f [Text]
+ , configAssemblies :: StandaloneField f [Text]
-- ^ list of all assembly slugs (used to lint e.g. world:// links)
- , configMaxLintLevel :: HKD f Level
+ , configEventSlug :: StandaloneField f Text
+ -- ^ slug of this event (used e.g. to resolve world:// links)
+ , configMaxLintLevel :: ConfigField f Level
-- ^ Maximum warn level allowed before the lint fails
- , configDontCopyAssets :: HKD f Bool
+ , configDontCopyAssets :: ConfigField f Bool
-- ^ Don't copy map assets (mostly useful for development)
- , configAllowScripts :: HKD f Bool
+ , configAllowScripts :: ConfigField f Bool
-- ^ Allow defining custom scripts in maps
- , configUriSchemas :: HKD f SchemaSet
+ , configUriSchemas :: ConfigField f SchemaSet
} deriving (Generic)
-type LintConfig' = LintConfig Identity
+type LintConfig' = LintConfig Complete
--- TODO: should probably find a way to write these constraints nicer ...
-deriving instance
- ( Show (HKD a (Maybe Text))
- , Show (HKD a Text)
- , Show (HKD a Level)
- , Show (HKD a [Text])
- , Show (HKD a Bool)
- , Show (HKD a SchemaSet)
- )
- => Show (LintConfig a)
+deriving instance Show (LintConfig Complete)
+deriving instance Show (LintConfig Skeleton)
+deriving instance Show (LintConfig Patch)
+instance NFData (LintConfig Basic)
aesonOptions :: Options
aesonOptions = defaultOptions
@@ -68,23 +83,13 @@ aesonOptions = defaultOptions
, fieldLabelModifier = drop 6
}
-instance
- ( FromJSON (HKD a (Maybe Text))
- , FromJSON (HKD a [Text])
- , FromJSON (HKD a Text)
- , FromJSON (HKD a Level)
- , FromJSON (HKD a Bool)
- , FromJSON (HKD a SchemaSet)
- )
- => FromJSON (LintConfig a)
- where
- parseJSON = genericParseJSON aesonOptions
+instance FromJSON (LintConfig Complete) where
+ parseJSON = genericParseJSON aesonOptions
--- need to define this one extra, since Aeson will not make
--- Maybe fields optional if the type isn't given explicitly.
---
--- Whoever said instances had confusing semantics?
-instance {-# Overlapping #-} FromJSON (LintConfig Maybe) where
+instance FromJSON (LintConfig Patch) where
+ parseJSON = genericParseJSON aesonOptions
+
+instance FromJSON (LintConfig Basic) where
parseJSON = genericParseJSON aesonOptions
@@ -118,30 +123,66 @@ instance GPatch i o
-- abstract, I just wanted to play around with higher kinded types for
-- a bit.
patch ::
- ( Generic (f Maybe)
- , Generic (f Identity)
- , GPatch (Rep (f Identity))
- (Rep (f Maybe))
+ ( Generic (f Patch)
+ , Generic (f Complete)
+ , GPatch (Rep (f Complete))
+ (Rep (f Patch))
)
- => f Identity
- -> f Maybe
- -> f Identity
+ => f Complete
+ -> f Patch
+ -> f Complete
patch x y = to (gappend (from x) (from y))
-patchConfig :: LintConfig Identity -> Maybe (LintConfig Maybe) -> LintConfig Identity
-patchConfig config p = config'
- { configUriSchemas = ("world", assemblysubsts) : configUriSchemas config'}
- where config' = case p of
- Just p -> patch config p
- Nothing -> config
- assemblysubsts =
- DomainSubstitution (M.fromList generated) scope
- where generated = (\slug -> (slug, "/@/rc3_21/"<>slug)) <$> configAssemblies config'
- scope = (\(DomainSubstitution _ s) -> s)
- . snd . Unsafe.head
- . filter ((==) "world" . fst)
- $ configUriSchemas config'
-
+patchConfig
+ :: LintConfig Complete
+ -> Maybe (LintConfig Patch)
+ -> LintConfig Complete
+patchConfig config p = expandWorlds config'
+ where
+ config' = case p of
+ Just p -> patch config p
+ Nothing -> config
+
+
+-- | feed a basic server config
+feedConfig
+ :: LintConfig Basic
+ -> [Text]
+ -> Text
+ -> LintConfig Skeleton
+feedConfig LintConfig{..} worlds eventslug = expandWorlds $
+ LintConfig
+ { configAssemblies = worlds
+ , configEventSlug = eventslug
+ , .. }
+
+-- | stuff a
+stuffConfig :: LintConfig Skeleton -> Text -> LintConfig Complete
+stuffConfig LintConfig{..} assemblyslug =
+ LintConfig
+ { configAssemblyTag = assemblyslug
+ , ..}
+
+class HasWorldList (a :: ConfigKind)
+instance HasWorldList 'Complete
+instance HasWorldList 'Skeleton
+
+-- kinda sad that ghc can't solve these contraints automatically,
+-- though i guess it also makes sense …
+expandWorlds
+ :: ( ConfigField a SchemaSet ~ SchemaSet
+ , StandaloneField a [Text] ~ [Text]
+ , StandaloneField a Text ~ Text
+ , HasWorldList a)
+ => LintConfig a -> LintConfig a
+expandWorlds config = config { configUriSchemas = configUriSchemas' }
+ where
+ configUriSchemas' =
+ M.insert "world:" [assemblysubsts] (configUriSchemas config)
+ assemblysubsts =
+ DomainSubstitution (M.fromList generated) ["map"]
+ where generated = configAssemblies config
+ <&> \slug -> (slug, "/@/"<>configEventSlug config<>"/"<>slug)
instance (FromJSON (LintConfig a)) => Argument (LintConfig a) where
parseArgument str =
generated by cgit v1.2.3 (git 2.25.1) at 2024-05-22 02:09:03 +0000