1 files changed, 187 insertions, 0 deletions
diff --git a/walint/LintConfig.hs b/walint/LintConfig.hs
new file mode 100644
index 0000000..8db46dd
--- /dev/null
+++ b/walint/LintConfig.hs
@@ -0,0 +1,187 @@
+{-# LANGUAGE DataKinds            #-}
+{-# LANGUAGE DeriveAnyClass       #-}
+{-# LANGUAGE LambdaCase           #-}
+{-# LANGUAGE OverloadedStrings    #-}
+{-# LANGUAGE RecordWildCards      #-}
+{-# LANGUAGE TypeFamilies         #-}
+{-# 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"