diff options
Diffstat (limited to '')
-rw-r--r-- | lib/LintConfig.hs | 163 |
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 = |