diff options
Diffstat (limited to 'lib/LintConfig.hs')
| -rw-r--r-- | lib/LintConfig.hs | 193 |
1 files changed, 0 insertions, 193 deletions
diff --git a/lib/LintConfig.hs b/lib/LintConfig.hs deleted file mode 100644 index b0fa3b0..0000000 --- a/lib/LintConfig.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# 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', ConfigKind (..), patchConfig,stuffConfig,feedConfig) where - -import Universum - -import Data.Aeson (FromJSON (parseJSON), Options (..), - defaultOptions, eitherDecode) -import Data.Aeson.Types (genericParseJSON) -import qualified Data.ByteString.Char8 as C8 -import qualified Data.ByteString.Lazy as LB -import qualified Data.Map.Strict as M -import GHC.Generics (Generic (Rep, from, to), K1 (..), - M1 (..), (:*:) (..)) -import Types (Level) -import Uris (SchemaSet, - Substitution (DomainSubstitution)) -import WithCli.Pure (Argument (argumentType, parseArgument)) - - - -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 :: WorldField f Text - -- ^ Assembly name (used for jitsiRoomAdminTag) - , configAssemblies :: StandaloneField f [Text] - -- ^ list of all assembly slugs (used to lint e.g. world:// links) - , 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 :: ConfigField f Bool - -- ^ Don't copy map assets (mostly useful for development) - , configAllowScripts :: ConfigField f Bool - -- ^ Allow defining custom scripts in maps - , configUriSchemas :: ConfigField f SchemaSet - } deriving (Generic) - -type LintConfig' = LintConfig Complete - -deriving instance Show (LintConfig Complete) -deriving instance Show (LintConfig Skeleton) -deriving instance Show (LintConfig Patch) -instance NFData (LintConfig Basic) - -aesonOptions :: Options -aesonOptions = defaultOptions - { omitNothingFields = True - , rejectUnknownFields = True - , fieldLabelModifier = drop 6 - } - -instance FromJSON (LintConfig Complete) where - parseJSON = genericParseJSON aesonOptions - -instance FromJSON (LintConfig Patch) where - parseJSON = genericParseJSON aesonOptions - -instance FromJSON (LintConfig Basic) where - parseJSON = genericParseJSON aesonOptions - - - --- | generic typeclass for things that are "patchable" -class GPatch i m where - gappend :: i p -> m p -> i p - --- generic instances. It's category theory, but with confusing names! -instance GPatch (K1 a k) (K1 a (Maybe k)) where - gappend _ (K1 (Just k')) = K1 k' - gappend (K1 k) (K1 Nothing) = K1 k - {-# INLINE gappend #-} - -instance (GPatch i o, GPatch i' o') - => GPatch (i :*: i') (o :*: o') where - gappend (l :*: r) (l' :*: r') = gappend l l' :*: gappend r r' - {-# INLINE gappend #-} - -instance GPatch i o - => GPatch (M1 _a _b i) (M1 _a' _b' o) where - gappend (M1 x) (M1 y) = M1 (gappend x y) - {-# INLINE gappend #-} - - --- | A patch function. For (almost) and a :: * -> *, --- take an a Identity and an a Maybe, then replace all appropriate --- values in the former with those in the latter. --- --- There isn't actually any useful reason for this function to be this --- abstract, I just wanted to play around with higher kinded types for --- a bit. -patch :: - ( Generic (f Patch) - , Generic (f Complete) - , GPatch (Rep (f Complete)) - (Rep (f Patch)) - ) - => f Complete - -> f Patch - -> f Complete -patch x y = to (gappend (from x) (from y)) - -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 = - case eitherDecode (LB.fromStrict $ C8.pack str) of - Left _ -> Nothing - Right res -> Just res - - argumentType Proxy = "LintConfig" |